Commits

Anonymous committed e0ac2c0

Added grammar object, distinct from parser, and distinct from the grammar's specification

Comments (0)

Files changed (1)

 	    (loop for k being the hash-keys of (entries obj)
 		 collect (list k (gethash k (entries obj)))))))
 
+(defclass lalr1-grammar ()
+  ((specification :initarg :specification :accessor specification)
+   (states :initarg :states :accessor states)
+   (actions :initarg :actions :accessor actions)
+   (gotos :initarg :gotos :accessor gotos)))
+
 (defclass lalr1-parser ()
   ((grammar :initarg :grammar :accessor grammar)
-   (states :initarg :states :accessor states)
-   (actions :initarg :actions :accessor actions)
-   (gotos :initarg :gotos :accessor gotos)
+   (lexer :initarg :lexer :accessor lexer)
    (stack :initform () :accessor stack)))
 
 (defgeneric equal-items (left right)
     (loop for rhs in rhss
        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 productions-in-grammar (specification)
+  "Given a specification, return as rule-name -> rhs pairs (actually, just short lists);
   because of the way its constructed rule names and rhss are reused, but space for 
   the each production itself is extra"
-  (loop for rule in grammar;; (transform-extended-grammar-to-fundamental grammar)
+  (loop for rule in specification;; (transform-extended-grammar-to-fundamental specification)
        append (rule-productions rule)))
 
-(defun symbols-in-grammar (grammar)
+(defun symbols-in-grammar (specification)
   (let ((symbols ()))
-    (loop for production in (productions-in-grammar grammar)
+    (loop for production in (productions-in-grammar specification)
 	 do (with-slots (rule-name rhs) production
 	      (pushnew rule-name symbols)
 	      (loop for term in rhs
 		      (pushnew term symbols)))))
     symbols))
 
-(defun non-terminals-in-grammar (grammar)
-  "Given a grammar, find all of the non-terminals (that is, symbols with a rule) in the grammar"
-  (loop for rule in grammar
+(defun non-terminals-in-grammar (specification)
+  "Given a specification, find all of the non-terminals (that is, symbols with a rule) in the specification"
+  (loop for rule in specification
        collect (car rule)))
 
 (defun initial-lr0-item-for-production (production)
   (make-instance 'lr0-item :position 0 :production production))
 
-(defun initial-lr0-items-for-grammar (grammar start-rule-name)
+(defun initial-lr0-items-for-grammar (specification 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."
-  (loop for rule in grammar
+  (loop for rule in specification
      if (eql (car rule) start-rule-name)
      return (loop for production in (rule-productions rule)
 	       collect (initial-lr0-item-for-production production))))
 (defun initial-lr1-item-for-production (production lookahead)
   (make-instance 'lr1-item :position 0 :production production :lookahead lookahead))
 
-(defun initial-lr1-items-for-grammar (grammar start-rule-name)
-  (loop for rule in grammar
+(defun initial-lr1-items-for-grammar (specification start-rule-name)
+  (loop for rule in specification
      if (eql (car rule) start-rule-name)
      return (loop for production in (rule-productions rule)
 	       collect (initial-lr1-item-for-production production :eof))))
 
-(defun rule-productions-in-grammar (grammar rule-name)
-  (loop for rule in grammar
+(defun rule-productions-in-grammar (specification rule-name)
+  (loop for rule in specification
      if (eql (car rule) rule-name)
      return (rule-productions rule)))
 
 	      ((> left-position right-position) nil)
 	      (t (production< left-production right-production)))))))
 
-(defun first-of-symbol (grammar symbol)
-  "Given a symbol of a grammar, return it's FIRST(); if the symbol is a terminal,
+(defun first-of-symbol (specification symbol)
+  "Given a symbol of a specification, return it's FIRST(); if the symbol is a terminal,
   then the FIRST is just a list containing the symbol itself.  If it's a 
   non-terminal, then it's the union of the FIRSTs for the first symbol on
   the rhs of each of the non-terminals productions"
   ;; TODO consider whether we need to include non-terminals in our list of firsts,
   ;; as that may help later when we consider supporting incremental parsing
-  (let ((productions (rule-productions-in-grammar grammar symbol)))
+  (let ((productions (rule-productions-in-grammar specification symbol)))
     (if productions
 	;; non-terminal
 	(let ((firsts ())) 
 		  (declare (ignore rule-name))
 		  (let ((new-first (car rhs)))
 		    (unless (or (equal symbol new-first) (member new-first firsts))
-		      (loop for first in (first-of-symbol grammar new-first)
+		      (loop for first in (first-of-symbol specification new-first)
 			 do (pushnew first firsts))))))
 	  firsts)
 	;; terminal -- no productions
 	(list symbol))))
 
-(defun closure-of-lr0-items (grammar items)
+(defun closure-of-lr0-items (specification 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))
+	     for productions = (rule-productions-in-grammar specification (next-term-for-item item))
 	     when productions
 	     do (loop for production in productions
 		   do (let ((initial-item (initial-lr0-item-for-production production)))
        ;; test of uniqueness (and set membership, too)
        finally (return (sort closure #'item<)))))
 
-(defun closure-of-lr1-items (grammar items)
+(defun closure-of-lr1-items (specification items)
   (let ((closure items))
     (loop for done = t
        do (loop for item in closure
 	     for (next-term lookahead) = (multiple-value-list (next-term-and-lookahead-for-item item (slot-value item 'lookahead)))
-	     for productions = (rule-productions-in-grammar grammar next-term)
+	     for productions = (rule-productions-in-grammar specification next-term)
 	     when productions
 	     do (loop for production in productions
-		   do (loop for first in (first-of-symbol grammar lookahead) 
+		   do (loop for first in (first-of-symbol specification lookahead) 
 			 do (let ((initial-item (initial-lr1-item-for-production production first)))
 			      (unless (member initial-item closure :test #'equal-items)
 				(setf done nil)
   (:method ((left t) (right t))
     (equal left right)))
 
-(defun lr0-goto-for-symbol (grammar items symbol)
-  (closure-of-lr0-items grammar 
+(defun lr0-goto-for-symbol (specification items symbol)
+  (closure-of-lr0-items specification 
 		    (loop for item in items
 		       if (equal symbol (next-term-for-item item))
 		       unless (item-finished-p item)
 		       collect (increment-lr0-item-position item))))
 
-(defun lr1-goto-for-symbol (grammar items symbol)
-  (closure-of-lr1-items grammar 
+(defun lr1-goto-for-symbol (specification items symbol)
+  (closure-of-lr1-items specification 
 		    (loop for item in items
 		       if (equal symbol (next-term-and-lookahead-for-item item (slot-value item 'lookahead)))
 		       unless (item-finished-p item)
 		       collect (increment-lr1-item-position item))))
 
-(defun lr1-goto-index-for-symbol ( grammar states symbol)
-  (let ((goto (lr1-goto-for-symbol grammar states symbol)))
+(defun lr1-goto-index-for-symbol ( specification states symbol)
+  (let ((goto (lr1-goto-for-symbol specification states symbol)))
     (position goto states :test #'equal-items)))
 
-(defun lr0-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)))
+(defun lr0-items-for-grammar (specification start-rule-name)
+  (let ((states (list (closure-of-lr0-items specification (initial-lr0-items-for-grammar specification start-rule-name))))
+	(symbols (symbols-in-grammar specification)))
     (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 (lr0-goto-for-symbol grammar state symbol)))
+		   do (let ((goto (lr0-goto-for-symbol specification state symbol)))
 			(when (and goto (not (member goto states :test #'equal-items)))
 			  (setf done nil)
 			  (push goto states)))))
        until done
        finally (return (reverse states)))))
 
-(defun lr1-items-for-grammar (grammar start-rule-name)
-  (let ((states (list (closure-of-lr1-items grammar (initial-lr1-items-for-grammar grammar start-rule-name))))
-	(symbols (symbols-in-grammar grammar)))
+(defun lr1-items-for-grammar (specification start-rule-name)
+  (let ((states (list (closure-of-lr1-items specification (initial-lr1-items-for-grammar specification start-rule-name))))
+	(symbols (symbols-in-grammar specification)))
     (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 (lr1-goto-for-symbol grammar state symbol)))
+		   do (let ((goto (lr1-goto-for-symbol specification state symbol)))
 			(when (and goto (not (member goto states :test #'equal-items)))
 			  (setf done nil)
 			  (push goto states)))))
        until done
        finally (return (reverse states)))))
 
-(defun lr1-parse-tables-for-grammar (grammar start-rule-name)
-  (let* ((states (lr1-items-for-grammar grammar start-rule-name))
-	 (non-terminals (non-terminals-in-grammar grammar))
+(defun lr1-parse-tables-for-grammar (specification start-rule-name)
+  (let* ((states (lr1-items-for-grammar specification start-rule-name))
+	 (non-terminals (non-terminals-in-grammar specification))
 	 (action-table (make-instance 'lr-parse-table :states (length states)))
 	 (goto-table (make-instance 'lr-parse-table :states (length states))))
 
 
 	     (record-shift (statei next-symbol)
 	       (setf (gethash (list statei next-symbol) action-table)
-		     (list :shift (index-of-goto (lr1-goto-for-symbol grammar states next-symbol)))))
+		     (list :shift (index-of-goto (lr1-goto-for-symbol specification states next-symbol)))))
 
 	     (record-reduce (statei next-symbol production)
 	       (setf (gethash (list statei next-symbol) action-table)
 	       (setf (gethash (list statei next-symbol) action-table) :accept))
 
 	     (record-goto (statei non-terminal)
-	       (let ((goto (index-of-goto (lr1-goto-for-symbol grammar states non-terminal))))
+	       (let ((goto (index-of-goto (lr1-goto-for-symbol specification states non-terminal))))
 		 (when goto
 		   (setf (gethash (list statei non-terminal) goto-table) goto)))))
 
       )
     (values action-table goto-table)))
 
-(defun parse1 (parser token)
-  (destructuring-bind (token-symbol token-value) token
-    (declare (ignorable token-value))
-    (loop with continue = t
-       with result = nil
-       while continue
-       do (destructuring-bind (stack-state stack-token) (car (stack parser))
-	    (declare (ignorable stack-token))
-	    (let ((action (gethash (list stack-state token-symbol) (actions parser))))
-	      (destructuring-bind (op next-state) action
+(defun parse-token (parser token)
+  "Advance the state of the parser by parsing a single token; does not assume token came from lexer"
+  (let ((grammar (grammar parser)))
+    (destructuring-bind (token-symbol token-value) token
+      (declare (ignorable token-value))
+      (loop with continue = t
+	 with result = nil
+	 while continue
+	 do (destructuring-bind (stack-state stack-token) (car (stack parser))
+	      (declare (ignorable stack-token))
+	      (let ((action (gethash (list stack-state token-symbol) (actions grammar))))
+		(destructuring-bind (op next-state) action
 
-		(cond ((equal :shift op)
-		       (push (list next-state token) (stack parser))
-		       (setf continue nil)
-		       (setf result :continue))
+		  (cond ((equal :shift op)
+			 (push (list next-state token) (stack parser))
+			 (setf continue nil)
+			 (setf result :continue))
 
-		      ((equal :reduce op)
-		       ;; NOTE : if there is a semantic action, after the reduction is a good time to call it
-		       (let ((production next-state)) ;; for reduce, the next-state value is used to capture the production
-			 (loop for i from 1 to (length (slot-value production 'rhs))
+			((equal :reduce op)
+			 ;; NOTE : if there is a semantic action, after the reduction is a good time to call it
+			 (let ((production next-state)) ;; for reduce, the next-state value is used to capture the production
+			   (loop for i from 1 to (length (slot-value production 'rhs))
 			      do (pop (stack parser)))
-			 (destructuring-bind (new-stack-state new-stack-token) (car (stack parser))
-			   (declare (ignorable new-stack-token))
-			   (push (list (gethash (list new-stack-state (slot-value production 'rule-name )) (gotos parser)) 
-				       (slot-value production 'rule-name))
-				 (stack parser)))))
+			   (destructuring-bind (new-stack-state new-stack-token) (car (stack parser))
+			     (declare (ignorable new-stack-token))
+			     (push (list (gethash (list new-stack-state (slot-value production 'rule-name )) (gotos grammar)) 
+					 (slot-value production 'rule-name))
+				   (stack parser)))))
 
-		      ((equal :accept op)
-		       (setf continue nil)
-		       (setf result :succeeded))
-		      (t (setf continue nil)
-			 (setf result :failed)))))))))
+			((equal :accept op)
+			 (setf continue nil)
+			 (setf result :succeeded))
+			(t (setf continue nil)
+			   (setf result :failed))))))))))
+
+(defun parse-result (parser)
+  (when (stack parser)
+    (destructuring-bind (stack-state stack-token) (car (stack parser))
+      stack-token)))
+
+(defun parse-input (parser input)
+  (let ((lexer (lexer parser)))
+    (loop for token = (funcall lexer input)
+	 while token
+	 do (parse-token parser token)
+       finally (return (parse-result parser)))))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.