Commits

Phil Hargett  committed 5766757

Added placeholder for options in rule definitions within grammar specifications

  • Participants
  • Parent commits 88787bd

Comments (0)

Files changed (4)

File grammar.lisp

 
 (defvar *new-rules* nil "New rules under construction")
 
+(defun rule-spec-rule-name (rule)
+  (destructuring-bind (rule-name options &rest rhss) rule
+    (declare (ignorable options rhss))
+    rule-name))
+
+(defun rule-spec-rule-options (rule)
+  (destructuring-bind (rule-name options &rest rhss) rule
+    (declare (ignorable rule-name rhss))
+    options))
+
+(defun rule-spec-rule-rhss (rule)
+  (destructuring-bind (rule-name options &rest rhss) rule
+    (declare (ignorable rule-name options))
+    rhss))
+
 (defun compoundtermp (term)
   (and (listp term) (member (car term) '(+ ? * ^))))
 
-(defun make-new-named-rule (rule-name rhss) 	       
-  (let ((rule (cons rule-name rhss)))
+(defun make-new-named-rule (rule-name options rhss) 	       
+  (let ((rule (cons rule-name (cons options rhss))))
     (setf *new-rules*
 	  (append *new-rules* (list rule)))
     rule-name))
 (defun for-each-rhs (grammar rhs-func)
   (for-each-rule grammar
 		 #'(lambda (rule)
-		     (destructuring-bind (rule-name &rest rhss) rule
-		       (cons rule-name (loop for rhs in rhss
-					  collect (or (funcall rhs-func rhs) rhs)))))))
+		     (destructuring-bind (rule-name options &rest rhss) rule
+		       (cons rule-name (cons options 
+					     (loop for rhs in rhss
+						collect (or (funcall rhs-func rhs) rhs))))))))
 
 (defun transform-term (term)
   (cond ((null term) term)
 	   (cond ((eq term-type '+)
 		  (let* ((repeat-body (transform-term (cdr term)))
 			 (repeat-rule-name (gensym "REPEAT-")))
-		    (make-new-named-rule repeat-rule-name `( (,repeat-rule-name ,@repeat-body)
+		    (make-new-named-rule repeat-rule-name () `( (,repeat-rule-name ,@repeat-body)
 							     (,@repeat-body)) )))
 		 ((eq term-type '*)
 		  ;; cheating here--reusing the ? and + transformations
 		 ((eq term-type '^)
 		  (let* ((alternate-body (transform-term (cdr term))) 
 			 (alternate-rule-name (gensym "ALTERNATE-")))
-		    (make-new-named-rule alternate-rule-name 
+		    (make-new-named-rule alternate-rule-name ()
 					 (loop for alternate in alternate-body
 					    collect (if (listp alternate) alternate (list alternate))))))
 		 ((eq term-type '?)
 		  (let* ((optional-body (transform-term (cdr term)))
 			 (optional-rule-name (gensym "OPTIONAL-")))
-		    (make-new-named-rule optional-rule-name `( ( ,@optional-body)
+		    (make-new-named-rule optional-rule-name () `( ( ,@optional-body)
 							       ( :nil)) )))
 		 (t ;; ordinary list, term list, or group--take your pick of language
 		  (loop for item in term
     (labels ((term-expansions (term)
 	       "Return a list of term expansions (including :nil)"
 	       (let ((rule (assoc term grammar)))
-		 (cdr rule)))
+		 (rule-spec-rule-rhss rule)))
 	     (expand-term (term-list position expansion)
 	       (loop for index from 0 below (length term-list)
 		  if (= position index) 
 		   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))
+		       (let ((rhss (rule-spec-rule-rhss rule)))
 			 (when (member `(:nil) rhss :test #'equal)
 			   (progn
 			     ;; (format *standard-output* "New nilable term: ~s~%" term)
 			     t)))))))
 	     (compute-nilable-terms (grammar)
 	       (loop for rule in grammar
-		  do (nilable-p (car rule) grammar)))
+		  do (nilable-p (rule-spec-rule-name rule) grammar)))
 	     (substitute-and-split-rhss (grammar)
 	       (for-each-rule grammar
 			      #'(lambda (rule)
-				  (destructuring-bind (rule-name &rest rhss) rule
+				  (destructuring-bind (rule-name options &rest rhss) rule
 				    (let ((new-rhss ()))
 				      (loop for rhs in rhss
 					 with expanded = nil
 							  (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))))))))
+					    (cons options
+						  ;; 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)
                 may no longer be used anywhere; let's just drop them, to simplify table development"
 	       ;; TODO gotta pass in the start rule, otherwise it gets removed also!
 	       (loop for rule in grammar
-		  if (or (equal (car rule) start-rule-name)
+		  for rule-name = (rule-spec-rule-name rule)
+		  if (or (equal rule-name start-rule-name)
 			 (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 (loop for any-rhs in (rule-spec-rule-rhss any-rule)
+				  if (member rule-name any-rhs :test #'equal)
 				  do (setf used t))
 			    until used
 			    finally (return used)))
 (defun transform-extended-grammar-to-fundamental (start-rule-name grammar ) 
   (transform-for-nil 'start-rule
 		     (let ((*new-rules* nil)
-			   (augmented-grammar (cons `(start-rule (,start-rule-name)) grammar)))
+			   (augmented-grammar (cons `(start-rule () (,start-rule-name)) grammar)))
 		       (append (for-each-rhs augmented-grammar
 					     #'(lambda (rhs)		      
 						 (transform-rhs (if (listp rhs) rhs (list 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=~s RHS=~s" rule-name rhs))))
+    (with-slots (rule-name options rhs) obj
+      (format stream "Rule=~s Options=~s RHS=~s" rule-name options rhs))))
 
 (defmethod print-object ((obj lr-parse-table) stream)
   (print-unreadable-object (obj stream :type t :identity t)
 ;; specifications
 
 (defun rule-productions (rule)
-  (destructuring-bind (rule-name &rest rhss) rule
+  (destructuring-bind (rule-name options &rest rhss) rule
     (loop for rhs in rhss
-       collect (make-instance 'production :rule rule-name :rhs rhs))))
+       collect (make-instance 'production :rule rule-name :options options :rhs rhs))))
 
 (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 specification;; (transform-extended-grammar-to-fundamental specification)
+  (loop for rule in specification
        append (rule-productions rule)))
 
 (defun symbols-in-grammar (specification)
 (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)))
+       collect (rule-spec-rule-name rule)))
 
 (defun terminals-in-grammar (specification)
   (let ((non-terminals (non-terminals-in-grammar specification)))
 
 (defun rule-productions-in-grammar (specification rule-name)
   (loop for rule in specification
-     if (eql (car rule) rule-name)
+     if (eql (rule-spec-rule-name rule) rule-name)
      return (rule-productions rule)))
 
 (defun item-finished-p (item)

File package-hh-parse.lisp

 
    #:start-rule
    #:defgrammar
+   #:specification
 
    ;; lexers
    #:deflexer
 ;; Sample grammars
 
 (defgrammar grammar-419 S
-  (S (^ (:i E :t S SP) :a))
-  (SP (:e (? S)))
-  (E (:b)))
+  (S () (^ (:i E :t S SP) :a))
+  (SP () (:e (? S)))
+  (E () (:b)))
 
 (defgrammar grammar-420 s
-  (s (l eq r)
+  (s () (l eq r)
      (r))
-  (l (star r)
+  (l () (star r)
      (id))
-  (r (l)))
+  (r () (l)))
 
 (defgrammar numbers-grammar number  
   ;; literals are digits, decimal, plus, minus
-  (integer (digit)
+  (integer () (digit)
 	   (integer digit))
-  (numeric-value ( (? (^ plus minus)) integer (? decimal integer)))
-  (number (numeric-value)))
+  (numeric-value () ( (? (^ plus minus)) integer (? decimal integer)))
+  (number () (numeric-value)))
 
 (defgrammar html-grammar document
-  ( tag-name  (identifier) )
+  ( tag-name ()  (identifier) )
   
-  ( attribute-name  (identifier) )
+  ( attribute-name ()  (identifier) )
 
-  (integer (digit)
+  (integer () 
+	   (digit)
 	   (integer digit))
-  (numeric-value ( (? (^ plus minus)) integer (? decimal integer)))
-  (number (numeric-value))
+  (numeric-value () ( (? (^ plus minus)) integer (? decimal integer)))
+  (number () (numeric-value))
 
-  (es (? ws))
+  (es () (? ws))
 
-  ( quantity-value  (^ number
+  ( quantity-value ()  (^ number
 		       ( number pct-symbol)
 		       ( number pct)
 		       ( number 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 ()  (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)
 	(assert-equal 'document value)))
 
     (let* ((grammar (html-grammar))
+	   (source (make-source "<foo bar=1>borp whaple<p>fwoomer</p>gamp</foo>"))
+	   (lexer (make-instance 'html-lexer :source source))
+	   (parser (make-parser lexer grammar)))
+      (multiple-value-bind (result value) (parse-input parser)
+	(assert-equal :succeeded result)
+	(assert-equal 'document value)))
+
+    (let* ((grammar (html-grammar))
 	   (source (make-source "<foobar=1>borp whaple</foo>"))
 	   (lexer (make-instance 'html-lexer :source source))
 	   (parser (make-parser lexer grammar)))
 
 (defclass production ()
   ((rule-name :initarg :rule)
+   (options :initarg :options)
    (rhs :initarg :rhs)))
 
 (defclass lr1-item ()