Phil Hargett  committed 7910e94

I believe I have added code that removes all occurrences of :nil from a grammar, after making proper substitutions first to expand the rules that remain. Visual inspection of HTML grammar looks correct, and the resulting expanded rule set is not significantly larger than the original.

  • Participants
  • Parent commits 53c49bb
  • Branches parsing

Comments (0)

Files changed (2)

File grammar.lisp

 			     collect (transform-term term))))))
     (if (listp new-rhs) new-rhs (list new-rhs)))) ;; make sure it's always a list
+(defun transform-for-nil (grammar)
+  "Transform the grammar as needed to remove all occurrences of nil"
+  (let ((nilable ())
+	(transforming nil)
+	(new-grammar grammar))
+    (labels ((term-expansions (term)
+	       "Return a list of term expansions (including :nil)"
+	       (let ((rule (assoc term grammar)))
+		 (cdr rule)))
+	     (expand-term (term-list position expansion)
+	       (loop for index from 0 below (length term-list)
+		  if (= position index) 
+		  collect expansion 
+		  else 
+		  collect (elt term-list index)))
+	     (flatten (term-list)
+	       (loop for term in term-list
+		    if (listp term)
+		    append term
+		    else append (list term)))
+	     (nilable-p (term grammar)
+	       "A term is nilable if we have already identified it as such, or if 
+                one of it's RHS is (:nil); we remember that a rule is nilable,
+                to simplify future checks"
+	       (if (member term nilable)
+		   t  ;; already known to be nilable
+		   (let ((rule (assoc term grammar)))
+		     (when rule ;; terminals are not nilable
+		       (destructuring-bind (rule-name &rest rhss) rule
+			 (declare (ignorable rule-name))
+			 (when (member `(:nil) rhss :test #'equal)
+			   (progn
+			     ;; (format *standard-output* "New nilable term: ~s~%" term)
+			     (push term nilable)
+			     ;; setting this, too, in case this changes
+			     ;; how we handle RHSs we have already seen--so
+			     ;; will have to go 'round again
+			     (setf transforming t)
+			     t)))))))
+	     (compute-nilable-terms (grammar)
+	       (loop for rule in grammar
+		  do (nilable-p (car rule) grammar)))
+	     (substitute-and-split-rhss (grammar)
+	       (for-each-rule grammar
+			      #'(lambda (rule)
+				  (destructuring-bind (rule-name &rest rhss) rule
+				    (let ((new-rhss ()))
+				      (loop for rhs in rhss
+					 with expanded = nil
+					 do (loop for position from 0 below (length rhs)
+					       for term = (elt rhs position)
+					       if (nilable-p term grammar)
+					       do (loop for expansion in (term-expansions term)
+						     for expanded-rhs = (flatten (expand-term rhs position expansion))
+						     do (progn 
+							  (setf expanded t)
+							  ;; (format *standard-output* "Expanded ~s:~s to ~s~%" rule-name rhs expanded-rhs)
+							  (setf transforming t)
+							  (push expanded-rhs new-rhss))))
+					 unless expanded do (push rhs new-rhss))
+				      (cons rule-name 
+					    ;; ensure uniques
+					    (loop for rhs in (reverse new-rhss)
+						 unless (member rhs unique-rhs :test #'equal)
+						 collect rhs into unique-rhs
+						 finally (return unique-rhs))))))))
+	     (collapse-nils (grammar)
+	       (for-each-rhs grammar
+			     #'(lambda (rhs)
+				 (or (loop for term in rhs
+					  unless (equal :nil term)
+					  collect term)
+				     `(:nil)))))
+	     (remove-unused-rules (grammar)
+	       "After all of the :nil substitutions have been made, it is reasonable that some rules
+                may no longer be used anywhere; let's just drop them, to simplify table development"
+	       (loop for rule in grammar
+		    if (loop for any-rule in grammar
+			    with used = nil
+			    do (loop for any-rhs in (cdr any-rule)
+				    if (member (car rule) any-rhs :test #'equal)
+				    do (setf used t))
+			    until used
+			    finally (return used))
+		    collect rule)))
+      (loop ;; for i from 1 to 10
+      	 do (setf transforming nil)
+      	 do (progn
+	      (setf new-grammar (substitute-and-split-rhss new-grammar))
+	      (setf new-grammar (collapse-nils new-grammar))
+	      (compute-nilable-terms new-grammar))
+      	 while transforming)
+      (setf new-grammar (remove-unused-rules new-grammar))
+      new-grammar)))
 (defun transform-extended-grammar-to-fundamental (grammar) 
-  (let ((*new-rules* nil))
-    (append (for-each-rhs grammar
-			  #'(lambda (rhs)		      
-			      (transform-rhs (if (listp rhs) rhs (list rhs)))))
-	    *new-rules*)))
+  (transform-for-nil
+   (let ((*new-rules* nil))
+     (append (for-each-rhs grammar
+			   #'(lambda (rhs)		      
+			       (transform-rhs (if (listp rhs) rhs (list rhs)))))
+	     *new-rules*))))
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; LALR(1) grammar construction
 		      (setf continue nil)
 		      (setf result :failed)))))
-	 finally (return result)))))
+	 finally (return (values result (car (stack parser))))))))
 (defun make-parser (lexer grammar)
   (let ((parser (make-instance 'lalr1-parser :lexer lexer :grammar grammar)))