Commits

Anonymous committed 25e173c

Now using a grammar-specific augmented start rule, since we otherwise would be limited to 1 grammar per package

Comments (0)

Files changed (4)

 	   else 
 	   collect (list captured-slot (list captured-value)))))
 
+(defun augment-grammar (start-rule-name grammar)
+  (let ((augmented-start-rule-name (genrulesym "START-")))
+    (values augmented-start-rule-name (cons `(,augmented-start-rule-name () (,start-rule-name)) grammar))))
+
 (defun transform-term (term)
   (cond ((null term) term)
 	((not (listp term)) term)
 		  (loop for item in term
 		     collect (transform-term item))))))))
 
-
 (defun transform-rhs (rhs)
   (let ((new-rhs (cond ((null rhs) rhs)
 		       ((compoundtermp rhs)
 (defun transform-extended-grammar-to-fundamental (start-rule-name grammar ) 
   ;; TODO this could be done in a pipeline model where different stages evolve the grammar
   ;; independently, but use (and depend upon) the input of the prior stage
-  (transform-for-nil 'start-rule
-		     (let ((*new-rules* nil)
-			   (augmented-grammar (cons `(start-rule () (,start-rule-name)) grammar)))
-		       (append (for-each-rhs (transform-for-captures augmented-grammar)
+  (transform-for-nil start-rule-name
+		     (let ((*new-rules* nil))
+		       (append (for-each-rhs (transform-for-captures grammar)
 					      #'(lambda (rhs)		      
 						  (transform-rhs (if (listp rhs) rhs (list rhs)))))
 			       *new-rules*))))
        until done
        finally (return  states))))
 
-(defun make-grammar (specification)
-  (let* ((states (lr1-states-for-grammar specification 'start-rule))
+(defun make-grammar (specification &key ((:augmented-start augmented-start-rule-name) nil) ((:start start-rule-name) nil))
+  (let* ((effective-start-rule-name (or augmented-start-rule-name 'start-rule)) 
+	 (states (lr1-states-for-grammar specification effective-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))))
       			;; reducing or accepting -- use lookahead to decide
 			(with-slots (lookahead production) item
 			  (if (and (equal :eof lookahead)
-				   (equal 'start-rule (slot-value production 'rule-name)))
+				   (equal effective-start-rule-name (slot-value production 'rule-name)))
 			      ;; accepting
 			      (record-accept i lookahead production)
 			      ;; reducing
       		 ;; goto table
       		 do (loop for non-terminal in non-terminals
       			 do (record-goto i non-terminal)))))
-    (make-instance 'lalr1-grammar :specification specification :states states :actions action-table :gotos goto-table)))
+    (make-instance 'lalr1-grammar 
+		   :augmented-start augmented-start-rule-name
+		   :start start-rule-name
+		   :specification specification 
+		   :states states 
+		   :actions action-table 
+		   :gotos goto-table)))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; Reductions
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;;
 
-(defmacro defgrammar (name start-rule-name &rest rules)
+(defmacro defgrammar (name start-rule-name &rest specification)
   "Defines a grammar, later accessible by calling a function named for the grammar, where the specification for
   the grammar consists of one or more rules of the form:
 
   * A production is a logical idea only: it's the pairing of a rule name with 1 rhs (so a rule is just a
     short-hand for a set of productions all with the same rule name)
 "
-  (let* ((specification (transform-extended-grammar-to-fundamental start-rule-name rules))
-	 (ast-classes (loop for rule-name in (non-terminals-in-grammar specification)
-			 for rule = (assoc rule-name specification)
-			 for rule-options = (rule-spec-rule-options rule)
-			 for rule-slots = (getf rule-options 'slots )
-			 collect `(progn 
-				    (defclass ,rule-name (rule-node) (,@rule-slots))
-				    (defmethod print-rule-slots ((rule ,rule-name) stream)
-				      ,@(loop for slot in rule-slots
-				    	   collect `(when (slot-boundp rule ',slot) 
-				    		      (format stream " ~s=~s" ',slot (slot-value rule ',slot)))))))))
-    `(progn
-       ,@ast-classes
-       (let ((grammar (make-grammar ',specification)))
-	 (defun ,name ()
-	   grammar)))))
+  (multiple-value-bind (augmented-start-rule-name augmented-specification) (augment-grammar start-rule-name specification)
+    (let* ((fundamental-specification (transform-extended-grammar-to-fundamental augmented-start-rule-name augmented-specification))
+	   (ast-classes (loop for rule-name in (non-terminals-in-grammar fundamental-specification)
+			   for rule = (assoc rule-name fundamental-specification)
+			   for rule-options = (rule-spec-rule-options rule)
+			   for rule-slots = (getf rule-options 'slots )
+			   collect `(progn 
+				      (defclass ,rule-name (rule-node) (,@rule-slots))
+				      (defmethod print-rule-slots ((rule ,rule-name) stream)
+					,@(loop for slot in rule-slots
+					     collect `(when (slot-boundp rule ',slot) 
+							(format stream " ~s=~s" ',slot (slot-value rule ',slot)))))))))
+      `(progn
+	 ,@ast-classes
+	 (let ((grammar (make-grammar ',fundamental-specification
+				      :augmented-start ',augmented-start-rule-name
+				      :start ',start-rule-name)))
+	   (defun ,name ()
+	     grammar))))))
 
 (defun make-parser (lexer grammar)
   (let ((parser (make-instance 'lalr1-parser :lexer lexer :grammar grammar)))
-    (push-parser-context parser 0 'start-rule)
+    (push-parser-context parser 0 (start grammar))
     parser))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 (defpackage :hh-parse-profile
-  (:use :cl :asdf :lisp-unit :hh-utils :hh-parse))
+  (:use :cl :asdf :hh-utils :hh-parse))
 
 (in-package :hh-parse-profile)
 
 ;; and that was the most expensive part of this code
 
 (defgrammar html-grammar document
-  ( tag-name  (identifier) )
+  ( tag-name ()   (= name identifier) )
   
-  ( attribute-name  (identifier) )
+  ( attribute-name ()  (identifier) )
 
-  (integer (digit)
-	   (integer digit))
-  (numeric-value ( (? (^ plus minus)) integer (? decimal integer)))
-  (number (numeric-value))
+  (integer-term () 
+	   (digit)
+	   (integer-term digit))
+  (numeric-value () ( (? (^ plus minus)) integer-term (? decimal integer-term)))
+  (number-term () (numeric-value))
 
-  (es (? ws))
+  (es () (? ws))
 
-  ( quantity-value  (^ number
-		       ( number pct-symbol)
-		       ( number pct)
-		       ( number px) ) )
+  ( quantity-value ()  (^ number-term
+		       ( number-term pct-symbol)
+		       ( number-term pct)
+		       ( number-term px) ) )
 
-  ( attribute-value  (^ quantity-value
+  ( attribute-value () (^ quantity-value
 			string-value))
 
-  ( attribute  (attribute-name es equal-sign es attribute-value))
+  ( attribute ()  (attribute-name es equal-sign es attribute-value))
 
-  ( attribute-list  ( attribute (* ws attribute)))
+  ( attribute-list ()  ( attribute (* ws attribute)))
 
-  ( start-tag  (lt es tag-name (? ws attribute-list) es gt))
+  ( start-tag ()  (lt es tag-name (? ws attribute-list) es gt))
 
-  ( end-tag  (lt es forward-slash es tag-name  gt))
+  ( end-tag (reduction #'ignore-terms)  (lt es forward-slash es tag-name  gt))
 
-  ( single-tag  (lt es tag-name (? ws attribute-list) es forward-slash es gt))
+  ( single-tag ()  (lt es tag-name (? ws attribute-list) es forward-slash es gt))
 
-  ( tag  (^ single-tag
+  ( tag ()  (^ single-tag
 	    (start-tag es (* (^ tag html-text)) es end-tag)))
-  (document (tag)))
+  (document () (tag)))
 
 (deflexer html-lexer (:text)
   (:tag #'digit-char-p digit)
    (entries :initform (make-hash-table :test #'equal) :accessor entries))) 
 
 (defclass lalr1-grammar ()
-  ((specification :initarg :specification :accessor specification)
+  ((augmented-start-rule-name :initarg :augmented-start :accessor augmented-start) 
+   (start-rule-name :initarg :start :accessor start)
+   (specification :initarg :specification :accessor specification)
    (states :initarg :states :accessor states)
    (actions :initarg :actions :accessor actions)
    (gotos :initarg :gotos :accessor gotos)))