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