prediction.lisp

   1
   2 (in-package :lalr-parser-generator)
   3
   4 ;;;; FIRST and FOLLOW
   5
   6 (defun compute-prediction-sets (grammar)
   7   "Computes and returns the first, follow, and nullable sets for
   8 GRAMMAR."
   9   (let ((nullable (make-hash-table))
  10         (follow (make-hash-table))
  11         (first (make-hash-table)))
  12     (flet ((nullable-p (x) (gethash x nullable)))
  13       (do-for-each-terminal (z grammar)
  14         (setf (gethash z first) (list z)))
  15       (do-until-unchanged (first follow nullable)
  16         (do-for-each-production (x ys grammar)
  17           (when (every #'nullable-p ys)
  18             (setf (gethash x nullable) t))
  19           (loop with k = (length ys)
  20                 for i below k
  21                 ;; Note - subseq 0 0 is NIL, the intended effect here.
  22                 when (every #'nullable-p (subseq ys 0 i))
  23                 do (unionf (gethash x first) (gethash (nth i ys) first))
  24                 when (every #'nullable-p (subseq ys (1+ i) k))
  25                 do (unionf (gethash (nth i ys) follow) (gethash x follow))
  26                 do (loop for j from (1+ i) to k
  27                          when (every #'nullable-p (subseq ys (1+ i) j))
  28                          do (unionf (gethash (nth i ys) follow)
  29                                     (gethash (nth j ys) first))))))
  30       (values first follow nullable))))
  31
  32 ;;; The following three functions are just for testing.  Combined,
  33 ;;; they perform the same functions as COMPUTE-PREDICTION-SETS
  34
  35 (defun list-nullable (grammar)
  36   (let ((nullable nil))
  37     (do-until-unchanged (nullable)
  38       (do-for-each-production (lhs rhs grammar)
  39         (when (or (null rhs)
  40                   (every #'(lambda (x) (member x nullable)) rhs))
  41           (pushnew lhs nullable))))
  42     nullable))
  43
  44 (defun list-first-set (grammar nullable)
  45   (let ((first-set (make-hash-table)))
  46     (do-for-each-terminal (x grammar)
  47       (setf (gethash x first-set) (list x)))
  48     (do-until-unchanged (first-set)
  49       (do-for-each-production (lhs rhs grammar)
  50         (do ((r-> rhs (cdr r->))
  51              (done-p nil))
  52             ((or done-p (null r->)))
  53           (when (not (member (car r->) nullable))
  54             (unionf (gethash lhs first-set)
  55                     (gethash (car r->) first-set))
  56             (setf done-p t))))
  57
  58       (do-for-each-production (lhs rhs grammar)
  59         (do ((r-> rhs (cdr r->))
  60              (done-p nil))
  61             ((or done-p (null r->)))
  62           (when (not (member (car r->) nullable))
  63             (unionf (gethash lhs first-set)
  64                     (gethash (car r->) first-set))
  65             (setf done-p t)))))
  66     first-set))
  67
  68 (defun list-follow-set (grammar nullable first-set)
  69   (let ((follow-set (make-hash-table)))
  70     (do-until-unchanged (follow-set)
  71       (do-for-each-production (lhs rhs grammar)
  72         (do ((r-> rhs (cdr r->))
  73              (done-p nil))
  74             ((or done-p (null r->)))
  75           (when (every (lambda (x) (member x nullable)) (cdr r->))
  76             (unionf (gethash (car r->) follow-set)
  77                     (gethash lhs follow-set)))
  78
  79           (loop for j from 1 to (length r->)
  80                 do (progn
  81                      (when (every (lambda (x) (member x nullable))
  82                                   (and (> j 1) (subseq r-> 1 (1- j))))
  83                        (unionf (gethash (car r->) follow-set)
  84                                (gethash (nth j r->) first-set))))))))
  85     follow-set))
  86