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
  16       (do-until-unchanged (first follow nullable)
  17         (do-for-each-production (x ys grammar)
  18           (when (every #'nullable-p ys)
  19             (setf (gethash x nullable) t))
  20
  21           (do ((i 0 (1+ i))
  22                (k (length ys)))
  23               ((>= i k))
  24
  25             ;; Note - subseq 0 0 is NIL, the intended effect here.
  26             (when (every #'nullable-p (subseq ys 0 i))
  27               (setf (gethash x first)
  28                     (union (gethash x first)
  29                            (gethash (nth i ys) first))))
  30
  31             (when (every #'nullable-p (subseq ys (1+ i) k))
  32               (setf (gethash (nth i ys) follow)
  33                     (union (gethash (nth i ys) follow)
  34                            (gethash x follow))))
  35
  36             (loop for j from (1+ i) to k
  37                   when (every #'nullable-p (subseq ys (1+ i) j))
  38                   do (setf (gethash (nth i ys) follow)
  39                            (union (gethash (nth i ys) follow)
  40                                   (gethash (nth j ys) first)))))))
  41
  42       (values first follow nullable))))
  43
  44 ;;; The following three functions are just for testing.  Combined,
  45 ;;; they perform the same functions as COMPUTE-PREDICTION-SETS
  46
  47 (defun list-nullable (grammar)
  48   (let ((nullable nil))
  49     (do-until-unchanged (nullable)
  50       (do-for-each-production (lhs rhs grammar)
  51         (when (or (null rhs)
  52                   (every #'(lambda (x) (member x nullable)) rhs))
  53           (pushnew lhs nullable))))
  54     nullable))
  55
  56 (defun list-first-set (grammar nullable)
  57   (let ((first-set (make-hash-table)))
  58     (do-for-each-terminal (x grammar)
  59       (setf (gethash x first-set) (list x)))
  60     (do-until-unchanged (first-set)
  61       (do-for-each-production (lhs rhs grammar)
  62         (do ((r-> rhs (cdr r->))
  63              (done-p nil))
  64             ((or done-p (null r->)))
  65           (when (not (member (car r->) nullable))
  66             (setf (gethash lhs first-set)
  67                   (union (gethash lhs first-set)
  68                          (gethash (car r->) first-set)))
  69             (setf done-p t))))
  70
  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 (not (member (car r->) nullable))
  76             (setf (gethash lhs first-set)
  77                   (union (gethash lhs first-set)
  78                          (gethash (car r->) first-set)))
  79             (setf done-p t)))))
  80     first-set))
  81
  82 (defun list-follow-set (grammar nullable first-set)
  83   (let ((follow-set (make-hash-table)))
  84     (do-until-unchanged (follow-set)
  85       (do-for-each-production (lhs rhs grammar)
  86         (do ((r-> rhs (cdr r->))
  87              (done-p nil))
  88             ((or done-p (null r->)))
  89           (when (every (lambda (x) (member x nullable)) (cdr r->))
  90             (setf (gethash (car r->) follow-set)
  91                   (union (gethash (car r->) follow-set)
  92                          (gethash lhs follow-set))))
  93
  94           (loop for j from 1 to (length r->)
  95                 do (progn
  96                      (when (every (lambda (x) (member x nullable))
  97                                   (and (> j 1) (subseq r-> 1 (1- j))))
  98                        (setf (gethash (car r->) follow-set)
  99                              (union (gethash (car r->) follow-set)
 100                                     (gethash (nth j r->) first-set)))))))))
 101     follow-set))
 102