From d7837cf5b7a132ac0433283639351ac7c457f3c0 Mon Sep 17 00:00:00 2001
From: Scott Owens <sowens@cs.utah.edu>
Date: Fri, 25 Jan 2002 06:52:52 +0000
Subject: [PATCH] *** empty log message ***

original commit: 90f5b4a6b959e3279d12afa521b01b5b7075ee71
---
 collects/parser-tools/examples/read.ss        |  2 +-
 .../private-yacc/input-file-parser.ss         | 40 ++++++++++---------
 .../private-yacc/parser-builder.ss            | 11 +++--
 3 files changed, 30 insertions(+), 23 deletions(-)

diff --git a/collects/parser-tools/examples/read.ss b/collects/parser-tools/examples/read.ss
index 00d58bd..4cfb4bd 100644
--- a/collects/parser-tools/examples/read.ss
+++ b/collects/parser-tools/examples/read.ss
@@ -1,6 +1,6 @@
 ;; This implements the equivalent of mzscheme's read-syntax for R5RS scheme.
 ;; It has not been thoroughly tested.  Also it will read an entire file into a 
-;; list of syntax objects
+;; list of syntax objects, instead of returning one syntax object at a time
 
  ;; Everything in this module will be read with case sensitivity.
 #cs
diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss
index 36c90f8..ea23bc2 100644
--- a/collects/parser-tools/private-yacc/input-file-parser.ss
+++ b/collects/parser-tools/private-yacc/input-file-parser.ss
@@ -8,19 +8,23 @@
 
   (provide parse-input get-term-list)
 
-  ;; get-args: num * syntax-object -> syntax-object list
-  (define (get-args x act src-pos)
-    (let loop ((i 1))
-      (cond
-        ((> i x) null)
-        (src-pos
-         `(,(datum->syntax-object act (string->symbol (format "$~a" i)))
-           ,(datum->syntax-object act (string->symbol (format "$~a-start-pos" i)))
-           ,(datum->syntax-object act (string->symbol (format "$~a-end-pos" i)))
-           ,@(loop (add1 i))))
-        (else
-         `(,(datum->syntax-object act (string->symbol (format "$~a" i)))
-           ,@(loop (add1 i)))))))
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+
+  ;; get-args: int * syntax-object list * syntax-object -> syntax-object list
+  (define (get-args i rhs act src-pos)
+    (cond
+      ((null? rhs) null)
+      (else
+       (let ((b (syntax-local-introduce (car rhs))))
+         (cond
+           (src-pos
+            `(,(datum->syntax-object act (string->symbol (format "$~a" i)) b stx-for-original-property)
+              ,(datum->syntax-object act (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)
+              ,(datum->syntax-object act (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)
+              ,@(get-args (add1 i) (cdr rhs) act src-pos)))
+           (else
+            `(,(datum->syntax-object act (string->symbol (format "$~a" i)) b stx-for-original-property)
+              ,@(get-args (add1 i) (cdr rhs) act src-pos))))))))
     
   ;; nullable: production list * int -> non-term set
   ;; determines which non-terminals can derive epsilon
@@ -297,12 +301,12 @@
                     "production right-hand-side must have form (symbol ...)"
                     prod-so)))))
 	     
-             ;; parse-action: gram-sym vector * syntax-object -> syntax-object
+             ;; parse-action: syntax-object * syntax-object -> syntax-object
              (parse-action 
-              (lambda (prod act)
+              (lambda (rhs act)
                 (datum->syntax-object
                  runtime
-                 `(lambda ,(get-args (vector-length prod) act src-pos)
+                 `(lambda ,(get-args 1 (syntax->list rhs) act src-pos)
                     ,act)
                  act)))
              
@@ -326,7 +330,7 @@
                                   (term-prec gs)
                                   (loop (sub1 i))))
                             #f))
-                      (parse-action p (syntax action)))))
+                      (parse-action (syntax prod-rhs) (syntax action)))))
                   ((prod-rhs (prec term) action)
                    (identifier? (syntax term))
                    (let ((p (parse-prod (syntax prod-rhs))))
@@ -346,7 +350,7 @@
                             "unrecognized terminal ~a in precedence declaration"
                             (syntax-object->datum (syntax term)))
                            (syntax term)))))
-                      (parse-action p (syntax action)))))
+                      (parse-action (syntax prod-rhs) (syntax action)))))
                   (_
                    (raise-syntax-error
                     'parser-production-rhs
diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss
index f668511..0201979 100644
--- a/collects/parser-tools/private-yacc/parser-builder.ss
+++ b/collects/parser-tools/private-yacc/parser-builder.ss
@@ -16,7 +16,7 @@
       so
       so)))
   
-  (define (fix-check-syntax start terms prods)
+  (define (fix-check-syntax start terms prods precs ends)
     (syntax-case prods ()
       ((_ (bind ((bound ...) x ...) ...) ...)
        (let ((binds (syntax->list (syntax (bind ...))))
@@ -28,11 +28,14 @@
                                   append 
                                   (map syntax->list 
                                        (syntax->list (syntax (((bound ...) ...) ...)))))))))
-             (terms (get-term-list terms)))
+             (terms (get-term-list terms))
+             (precs (syntax-case precs ()
+                      ((_ (__ term ...) ...)
+                       (apply append (map syntax->list (syntax->list (syntax ((term ...) ...)))))))))
          `(if #f (let ,(map (lambda (bind)
                               `(,(strip bind) void))
                             (append terms binds))
-                   (void ,@(map strip bounds))))))))
+                   (void ,@(append ends precs (map strip bounds)))))))))
   
   (define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src)
     (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
@@ -235,5 +238,5 @@
                                #f #f #f #f #f)))))))))))
       (datum->syntax-object
        runtime
-       `(begin ,(fix-check-syntax start input-terms prods) ,parser-code)
+       `(begin ,(fix-check-syntax start input-terms prods assocs end) ,parser-code)
        src))))