Commits

Anonymous committed 3206a0c

Initial support for different reduction actions

Comments (0)

Files changed (5)

 (defun rule-productions (rule)
   (destructuring-bind (rule-name options &rest rhss) rule
     (loop for rhs in rhss
-       collect (make-instance 'production :rule rule-name :options options :rhs rhs))))
+       collect (let ((production (make-instance 'production :rule rule-name :rhs rhs)))
+		 (loop for (slot value) on options by #'cddr
+		    ;; TODO consider eval'ing the value first; depends on use cases for doing so
+		    do (setf (slot-value production slot) (eval value)))
+		 production))))
 
 (defun productions-in-grammar (specification)
   "Given a specification, return as rule-name -> rhs pairs (actually, just short lists);
     (make-instance 'lalr1-grammar :specification specification :states states :actions action-table :gotos goto-table)))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
+;; Reductions
+
+(defun ignore-terms (&rest args)
+  (declare (ignorable args))
+  nil)
+
+;; ---------------------------------------------------------------------------------------------------------------------
 ;;
 
 (defmacro defgrammar (name start-rule-name &rest rules)

package-hh-parse.lisp

    #:start-rule
    #:defgrammar
    #:specification
+   #:reduction
+   #:ignore-terms
 
    ;; lexers
    #:deflexer
 	 do (push expected-symbol expected))
     expected))
 
+(defun reduce-production (production symbol-values)
+  (apply (reduction production) symbol-values))
+
 (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)))
 			       (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 arg))
-			       (loop for i from 1 to (length (slot-value production 'rhs))
-				  do (pop (stack parser)))
+			     (let* ((production arg)
+				    (reduced-term (reduce-production production 
+								     (loop for i from 1 to (length (slot-value production 'rhs))
+									collect (destructuring-bind (stack-state stack-token) (pop (stack parser))
+										  (declare (ignorable stack-state))
+										  stack-token)))))
 			       (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 )) (entries (gotos grammar))) 
-					     (slot-value production 'rule-name))
+					     (list (slot-value production 'rule-name) reduced-term))
 				       (stack parser)))))
 
 			    ((equal :accept op)
 
   ( 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))
 
 	   (parser (make-parser lexer grammar)))
       (multiple-value-bind (result value) (parse-input parser)
 	(assert-equal :succeeded result)
-	(assert-equal 'document value)))
+	(assert-equal 'document (car value))))
 
     (let* ((grammar (html-grammar))
 	   (source (make-source "<foo bar=1>borp whaple<p>fwoomer</p>gamp</foo>"))
 	   (parser (make-parser lexer grammar)))
       (multiple-value-bind (result value) (parse-input parser)
 	(assert-equal :succeeded result)
-	(assert-equal 'document value)))
+	(assert-equal 'document (car value))))
 
     (let* ((grammar (html-grammar))
 	   (source (make-source "<foobar=1>borp whaple</foo>"))
 ;; Grammar
 
 (defclass production ()
-  ((rule-name :initarg :rule)
-   (options :initarg :options)
+  ((rule-name :initarg :rule :accessor rule-name)
+   (reduction :initform #'list :initarg :reduction :accessor reduction)
    (rhs :initarg :rhs)))
 
 (defclass lr1-item ()