Anonymous committed 107eb49

Converted to using typed items & productions

Comments (0)

Files changed (1)

 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; LALR(1) parser construction
+;; Classes + types
+(defclass production ()
+  ((rule-name :initarg :rule)
+   (rhs :initarg :rhs)))
+(defmethod print-object ((obj production) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (with-slots (rule-name rhs) obj
+      (format stream "Rule=~a RHS=~s" rule-name rhs))))
+(defclass lr0-item ()
+  ((position :initarg :position)
+   (production :initarg :production)))
+(defmethod print-object ((obj lr0-item) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (with-slots (position production) obj
+      (format stream "Position=~a Production=~s" position production))))
+(defclass lr1-item ()
+  ((position :initarg :position)
+   (lookahead :initarg :lookahead)
+   (production :initarg :production)))
+(defgeneric equal-items (left right)
+  (:method ((left production) (right production))
+    (with-slots ((left-rule-name rule-name) (left-rhs rhs)) left
+      (with-slots ((right-rule-name rule-name) (right-rhs rhs)) right
+	(and (equal left-rule-name right-rule-name)
+	     (equal left-rhs right-rhs)))))
+  (:method ((left lr0-item) (right lr0-item))
+    (with-slots ((left-position position) (left-production production)) left
+      (with-slots ((right-position position) (right-production production)) right
+	(and (= left-position right-position)
+	     (equal-items left-production right-production)))))
+  (:method ((left list) (right list))
+    (loop for left-item in left
+       for right-item in right
+       with same = t
+       do (setf same (and same (equal-items left-item right-item)))
+       while same
+       finally (return same)))
+  (:method ((left t) (right t))
+    (equal left right)))
+(defmethod print-object ((obj lr1-item) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (with-slots (position lookahead production) obj
+      (format stream "Position=~a Lookahead=~s Production=~s" position lookahead production))))
 (defun rule-productions (rule)
   (destructuring-bind (rule-name &rest rhss) rule
     (loop for rhs in rhss
-       collect (list rule-name rhs))))
+       collect (make-instance 'production :rule rule-name :rhs rhs))))
 (defun productions-in-grammar (grammar)
   "Given a grammar, return as rule-name -> rhs pairs (actually, just short lists);
 (defun symbols-in-grammar (grammar)
   (let ((symbols ()))
     (loop for production in (productions-in-grammar grammar)
-	 do (destructuring-bind (rule-name rhs) production
+	 do (with-slots (rule-name rhs) production
 	      (pushnew rule-name symbols)
 	      (loop for term in rhs
 		 do (unless (equal term :nil) 
 		      (pushnew term symbols)))))
-(defun initial-item-for-production (production)
-  (list 0 production))
+(defun initial-lr0-item-for-production (production)
+  (make-instance 'lr0-item :position 0 :production production))
-(defun initial-items-for-grammar (grammar start-rule-name)
+(defun initial-lr0-items-for-grammar (grammar start-rule-name)
   "Start rule should have  single production of the form: rule-name (:bof some-other-rule-name :eof);
   an item's position is an index into the production's rhs of the *next* unread term.  Thus,
   the starting position is 1, implying the beginning of the file (:bof) has been read,
   (loop for rule in grammar
      if (eql (car rule) start-rule-name)
      return (loop for production in (rule-productions rule)
-	       collect (list 1 production))))
+	       collect (initial-lr0-item-for-production production))))
 (defun rule-productions-in-grammar (grammar rule-name)
   (loop for rule in grammar
      return (rule-productions rule)))
 (defun item-finished-p (item)
-  (destructuring-bind (position (rule-name rhs)) item
-    (>= position (length rhs))))
+  (with-slots (position production) item
+    (with-slots (rule-name rhs) production
+      (>= position (length rhs)))))
 (defun next-term-for-item (item)
   (unless (item-finished-p item) 
-    (destructuring-bind (position (rule-name rhs)) item
-      (elt rhs position))))
+    (with-slots (position production) item
+      (with-slots ( rule-name rhs) production
+	(elt rhs position)))))
 (defun increment-item-position (item)
-  (destructuring-bind (position production) item
-    (list (1+ position) production)))
+  (with-slots (position production) item
+    (make-instance 'lr0-item :position (1+ position) :production production)))
 (defun item< (left right)
   (labels ((symbol< (left right)
 	     (string< (symbol-name left) (symbol-name right)))
 	   (production< (left right)
-	     (destructuring-bind (left-rule-name left-rhs) left
-	       (destructuring-bind (right-rule-name right-rhs) right
+	     (with-slots ((left-rule-name rule-name) ( left-rhs rhs)) left
+	       (with-slots (( right-rule-name rule-name) ( right-rhs rhs)) right
 		 (cond ((symbol< left-rule-name right-rule-name) t)
 		       ((equal left-rule-name right-rule-name)
 			(and (<= (length left-rhs) (length right-rhs))
 				do (setf result (and result (symbol< left-term right-term)))
 				finally (return result))))
 		       (t nil))))))
-    (destructuring-bind (left-position left-production) left
-      (destructuring-bind (right-position right-production) right
+    (with-slots (( left-position position) ( left-production production)) left
+      (with-slots (( right-position position) ( right-production production)) right
 	(cond ((< left-position right-position) t)
 	      ((> left-position right-position) nil)
 	      (t (production< left-production right-production)))))))
 	;; non-terminal
 	(let ((firsts ())) 
 	  (loop for production in productions
-	     do (destructuring-bind (rule-name rhs) production
+	     do (with-slots (rule-name rhs) production
 		  (declare (ignore rule-name))
 		  (loop for first in (first-of-symbol grammar (car rhs))
 		     do (pushnew first firsts))))
 	;; terminal -- no productions
 	(list symbol))))
-(defun closure-of-items (grammar items)
+(defun closure-of-lr0-items (grammar items)
   (let ((closure items))
     (loop for done = t
        do (loop for item in closure
 	     for productions = (rule-productions-in-grammar grammar (next-term-for-item item))
 	     when productions
 	     do (loop for production in productions
-		   do (let ((initial-item (initial-item-for-production production)))
-			(unless (member initial-item closure :test #'equal)
+		   do (let ((initial-item (initial-lr0-item-for-production production)))
+			(unless (member initial-item closure :test #'equal-items)
 			  (setf done nil)
 			  (push initial-item closure)))))
        until done
        ;; test of uniqueness (and set membership, too)
        finally (return (sort closure #'item<)))))
-(defun goto-for-symbol (grammar items symbol)
-  (closure-of-items grammar 
+(defun lr0-goto-for-symbol (grammar items symbol)
+  (closure-of-lr0-items grammar 
 		    (loop for item in items
 		       if (equal symbol (next-term-for-item item))
 		       unless (item-finished-p item)
 		       collect (increment-item-position item))))
 (defun lr0-items-for-grammar (grammar start-rule-name)
-  (let ((states (list (closure-of-items grammar (initial-items-for-grammar grammar start-rule-name))))
+  (let ((states (list (closure-of-lr0-items grammar (initial-lr0-items-for-grammar grammar start-rule-name))))
 	(symbols (symbols-in-grammar grammar)))
     (loop for done = t
        do (loop for state in states
 	     ;; do (format *standard-output* "State: ~a~%" state)
 	     do (loop for symbol in symbols
-		   do (let ((goto (goto-for-symbol grammar state symbol)))
-			(when (and goto (not (member goto states :test #'equal)))
+		   do (let ((goto (lr0-goto-for-symbol grammar state symbol)))
+			(when (and goto (not (member goto states :test #'equal-items)))
 			  (setf done nil)
 			  (push goto states)))))
        until done