*** empty log message ***

original commit: 8d5d988ce3fa041013d10351e44003908781c5f6

collects/parser-tools/private-yacc/grammar.ss

@@ -4,9 +4,6 @@
   ;; Constructs to create and access grammars, the internal
   ;; representation of the input to the parser generator.
     
-  (require (lib "list.ss")
-           "yacc-helper.ss")
-
   (provide 
      
    (rename export-make-item make-item)
@@ -35,7 +32,7 @@
    (rename gram-prods grammar-prods)
 
    ;; Things that work on productions
-   prod-index prod-prec prod-rhs prod-lhs)
+   prod-index prod-prec prod-rhs prod-lhs prod-action)
 
 
   ;;---------------------- LR items --------------------------
@@ -188,6 +185,6 @@
 
   ;; ------------------------ Productions ---------------------------
   
-  ;; production = (make-prod non-term (gram-sym vector) int prec)
-  (define-struct prod (lhs rhs index prec))
+  ;; production = (make-prod non-term (gram-sym vector) int prec syntax-object)
+  (define-struct prod (lhs rhs index prec action))
 )

collects/parser-tools/private-yacc/input-file-parser.ss

@@ -8,6 +8,14 @@
 
   (provide parse-input)
 
+  ;; get-args: num * syntax-object -> syntax-object list
+  (define (get-args x act)
+    (let loop ((i 1))
+      (cond
+        ((> i x) null)
+        (else (cons (datum->syntax-object act (string->symbol (format "$~a" i)))
+                    (loop (add1 i)))))))
+    
   ;; nullable: production list * int -> non-term set
   ;; determines which non-terminals can derive epsilon
   (define (nullable prods num-nts)
@@ -104,7 +112,7 @@
          term-syn)))))
   
   ;; parse-input: syntax-object^4 * string -> grammar
-  (define (parse-input start term-defs prec-decls prods)
+  (define (parse-input start term-defs prec-decls prods runtime)
     (let* ((counter 0)
            
            (start-sym (syntax-object->datum start))
@@ -261,6 +269,15 @@
                     "production right-hand-side must have form (symbol ...)"
                     prod-so)))))
 	     
+             ;; parse-action: gram-sym vector * syntax-object -> syntax-object
+             (parse-action 
+              (lambda (prod act)
+                (datum->syntax-object
+                 runtime
+                 `(lambda ,(get-args (vector-length prod) act)
+                    ,act)
+                 act)))
+             
 	     ;; parse-prod+action: non-term * syntax-object -> production
 	     (parse-prod+action
 	      (lambda (nt prod-so)
@@ -278,27 +295,30 @@
                                 (if (term? gs)
                                     (term-prec gs)
                                     (loop (sub1 i))))
-                              #f)))
+                              #f))
+                        (parse-action p (syntax action)))
                        (set! counter (add1 counter)))))
                   ((prod-rhs (prec term) action)
                    (identifier? (syntax term))
-                   (begin0
-                     (make-prod 
-                      nt 
-                      (parse-prod (syntax prod-rhs))
-                      counter
-                      (term-prec
-                       (hash-table-get 
-                        term-table 
-                        (syntax-object->datum (syntax term))
-                        (lambda ()
-                          (raise-syntax-error
-                           'parser-production-rhs
-                           (format
-                            "unrecognized terminal ~a in precedence declaration"
-                            (syntax-object->datum (syntax term)))
-                           (syntax term)))))
-                      (set! counter (add1 counter)))))
+                   (let ((p (parse-prod (syntax prod-rhs))))
+                     (begin0
+                       (make-prod 
+                        nt 
+                        p
+                        counter
+                        (term-prec
+                         (hash-table-get 
+                          term-table 
+                          (syntax-object->datum (syntax term))
+                          (lambda ()
+                            (raise-syntax-error
+                             'parser-production-rhs
+                             (format
+                              "unrecognized terminal ~a in precedence declaration"
+                              (syntax-object->datum (syntax term)))
+                             (syntax term)))))
+                        (parse-action p (syntax action)))
+                       (set! counter (add1 counter)))))
                   (_
                    (raise-syntax-error
                     'parser-production-rhs
@@ -329,7 +349,10 @@
                                   (vector (hash-table-get non-term-table 
                                                           start-sym))
                                   0
-                                  #f))
+                                  #f
+                                  (datum->syntax-object
+                                   runtime
+                                   `(lambda (x) x))))
                  (map parse-prods-for-nt (syntax->list prods))))
                (nulls (nullable (apply append prods) 
                                 (add1 (length non-terms)))))

collects/parser-tools/private-yacc/parser-builder.ss

@@ -9,7 +9,7 @@
   (provide build-parser)
   
   (define (build-parser start input-terms assocs prods filename runtime src)
-    (let* ((grammar (parse-input start input-terms assocs prods))
+    (let* ((grammar (parse-input start input-terms assocs prods runtime))
            (table (build-table grammar filename))
            (table-code 
             (cons 'vector 
@@ -38,9 +38,13 @@
                         (grammar-terms grammar))
                  ht)))
            
+           (actions-code
+            `(vector ,@(map prod-action (grammar-prods grammar))))
+           
            (parser-code
             `(letrec ((term-sym->index ,token-code)
                       (table ,table-code)
+                      (actions ,actions-code)
                       (pop-x
                        (lambda (s n)
                          (if (> n 0)