Commits

Anonymous committed b8a24cd

Okay, now we create abstract syntax nodes for rules in a grammar, although we do not yet do that for tokens

Comments (0)

Files changed (7)

+(in-package :hh-parse)
+
+;; printing
+
+(defmethod print-object ((obj ast-node) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (with-slots (children) obj
+      (when children
+	(format stream "Children=~s" children)))))
+
+(defgeneric ast-node-type (node)
+  (:documentation "Return the symbolic name for the node's type (corresponds to a rule name in 
+   the original grammar")
+  (:method ((node ast-node))
+    (class-name (class-of node))))
 ;; Grammar specifications
 
 (defvar *new-rules* nil "New rules under construction")
+(defvar *next-rule-number* 0 "Used for creating unique rule names")
+
+(defun genrulesym (name &optional (*package* *package*))
+  (intern (format nil "~a~a" name (incf *next-rule-number*)) *package*))
 
 (defun rule-spec-rule-name (rule)
   (destructuring-bind (rule-name options &rest rhss) rule
 	 (let ((term-type (car term)))
 	   (cond ((eq term-type '+)
 		  (let* ((repeat-body (transform-term (cdr term)))
-			 (repeat-rule-name (gensym "REPEAT-")))
+			 (repeat-rule-name (genrulesym "REPEAT-")))
 		    (make-new-named-rule repeat-rule-name () `( (,repeat-rule-name ,@repeat-body)
 							     (,@repeat-body)) )))
 		 ((eq term-type '*)
 		  (transform-term `(? (+ ,@(transform-term (cdr term))))) )
 		 ((eq term-type '^)
 		  (let* ((alternate-body (transform-term (cdr term))) 
-			 (alternate-rule-name (gensym "ALTERNATE-")))
+			 (alternate-rule-name (genrulesym "ALTERNATE-")))
 		    (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-")))
+			 (optional-rule-name (genrulesym "OPTIONAL-")))
 		    (make-new-named-rule optional-rule-name () `( ( ,@optional-body)
 							       ( :nil)) )))
 		 (t ;; ordinary list, term list, or group--take your pick of language
 ;; Reductions
 
 (defun list-terms (rule-name &rest args)
-  (declare (ignorable rule-name))
-  args)
+  (make-instance rule-name :children args))
 
 (defun ignore-terms (rule-name &rest args)
   (declare (ignorable args))
-  rule-name)
+  (make-instance rule-name))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;;
   * 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))
-	  (grammar (make-grammar specification)))
-     (defun ,name ()
-       grammar)))
+  (let* ((specification (transform-extended-grammar-to-fundamental start-rule-name rules))
+	 (ast-classes (loop for rule in (non-terminals-in-grammar specification)
+			   collect `(defclass ,rule (ast-node) ()))))
+    `(progn
+       ,@ast-classes
+       (let ((grammar (make-grammar ',specification)))
+	 (defun ,name ()
+	   grammar)))))
   :components (
                (:file "package-hh-parse")
 	       (:file "types")
+	       (:file "ast")
 	       (:file "lexer")
 	       (:file "grammar")
 	       (:file "parser")

package-hh-parse.lisp

    #:current-line-position
    #:current-column-position
 
+   ;; AST nodes
+   #:ast-node-type
+
    ;; grammars
    ;; #:+ from CL
    ;; #:* from CL
 								     (reverse (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 (token-name token-value) stack-token
+											     (declare (ignorable token-name))
+											     token-value)))))))
 			       (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))) 
 
 (defgrammar numbers-grammar number  
   ;; literals are digits, decimal, plus, minus
-  (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)))
 
 (defgrammar html-grammar document
   ( tag-name ()  (identifier) )
   
   ( attribute-name ()  (identifier) )
 
-  (integer () 
+  (integer-term () 
 	   (digit)
-	   (integer digit))
-  (numeric-value () ( (? (^ plus minus)) integer (? decimal integer)))
-  (number () (numeric-value))
+	   (integer-term digit))
+  (numeric-value () ( (? (^ plus minus)) integer-term (? decimal integer-term)))
+  (number-term () (numeric-value))
 
   (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
 			string-value))
 
 ;; Grammar
 
+(defclass ast-node ()
+  ((children :initform () :initarg :children :accessor children)))
+
 (defclass production ()
   ((rule-name :initarg :rule :accessor rule-name)
    (reduction :initform #'list-terms :initarg :reduction :accessor reduction)