*** empty log message ***

original commit: abf74d9040aa14a62d261a93e4cde5bca6f96f7e

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

@@ -9,12 +9,18 @@
   (provide parse-input)
 
   ;; get-args: num * syntax-object -> syntax-object list
-  (define (get-args x act)
+  (define (get-args x act src-pos)
     (let loop ((i 1))
       (cond
         ((> i x) null)
-        (else (cons (datum->syntax-object act (string->symbol (format "$~a" i)))
-                    (loop (add1 i)))))))
+        (else 
+         (if 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)))
+             `(,(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
@@ -111,8 +117,8 @@
          "undefined token group"
          term-syn)))))
   
-  ;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar
-  (define (parse-input start ends term-defs prec-decls prods runtime)
+  ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar
+  (define (parse-input start ends term-defs prec-decls prods runtime src-pos)
     (let* ((counter 0)
            
            (start-sym (syntax-object->datum start))
@@ -285,7 +291,7 @@
               (lambda (prod act)
                 (datum->syntax-object
                  runtime
-                 `(lambda ,(get-args (vector-length prod) act)
+                 `(lambda ,(get-args (vector-length prod) act src-pos)
                     ,act)
                  act)))
              

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

@@ -8,8 +8,8 @@
   
   (provide build-parser)
   
-  (define (build-parser filename suppress error-expr input-terms start end assocs prods runtime src)
-    (let* ((grammar (parse-input start end input-terms assocs prods runtime))
+  (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))
            (table (build-table grammar filename suppress))
            (table-code 
             `((lambda (table-list)
@@ -67,7 +67,9 @@
                       (reduce-stack
                        (lambda (s n v)
                          (if (> n 0)
-                             (reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))
+                             ,(if src-pos
+                                  `(reduce-stack (cddr s) (sub1 n) `(,(cadr s) ,(caddr s) ,(cadddr s) ,@v))
+                                  `(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v)))
                              (values s v))))
                       (fix-error
                        (lambda (stack ip get-token)
@@ -119,18 +121,22 @@
                (lambda (get-token)
                  (let parsing-loop ((stack (list 0))
 				    (ip (get-token)))
+                                             
                    ;;(display stack)
                    ;;(newline)
                    ;;(display (if (token? ip) (token-name ip) ip))
                    ;;(newline)
-                   (let ((action (find-action stack ip)))
+                   (let* ((tok ,(if src-pos `(car ip) `ip))
+                          (action (find-action stack tok)))
                      (cond
                        ((shift? action)
                         ;; (printf "shift:~a~n" (shift-state action))
-                        (let ((val (if (token? ip)
-                                       (token-value ip)
+                        (let ((val (if (token? tok)
+                                       (token-value tok)
                                        #f)))
-                          (parsing-loop (cons (shift-state action) (cons val stack))
+                          (parsing-loop ,(if src-pos
+                                             ``(,(shift-state action) ,val ,(cadr ip) ,(caddr ip) ,@stack)
+                                             ``(,(shift-state action) ,val ,@stack))
                                         (get-token))))
                        ((reduce? action)
                         ;; (printf "reduce:~a~n" (reduce-prod-num action))
@@ -152,7 +158,7 @@
                         (cadr stack))
                        (else 
                         (err ip)
-                        (let ((new-stack (fix-error stack ip get-token)))
+                        (let ((new-stack (fix-error stack tok get-token)))
                           (if new-stack
                               (parsing-loop new-stack (get-token))
                               (void)))))))))))

collects/parser-tools/yacc.ss

@@ -9,11 +9,11 @@
   
   (provide parser)
   
-  (define-syntax parser
-    (lambda (stx)
+  (define-syntax (parser stx)
     (syntax-case stx ()
       ((_ args ...)
        (let ((arg-list (syntax->list (syntax (args ...))))
+             (src-pos #f)
              (debug #f)
              (error #f)
              (tokens #f)
@@ -24,7 +24,7 @@
              (grammar #f))
          (for-each
           (lambda (arg)
-              (syntax-case* arg (debug error tokens start end precs grammar suppress)
+            (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos)
               (lambda (a b)
                 (eq? (syntax-object->datum a) (syntax-object->datum b)))
               ((debug filename)
@@ -40,6 +40,8 @@
                   (set! debug (syntax-object->datum (syntax filename))))))
               ((suppress)
                (set! suppress #t))
+              ((src-pos)
+               (set! src-pos #t))
               ((error expression)
                (if error
                    (raise-syntax-error #f "Multiple error declarations" stx)
@@ -105,6 +107,7 @@
          (if (not start)
              (raise-syntax-error #f "missing start declaration" stx))
          (build-parser (if debug debug "")
+                       src-pos
                        suppress
                        error
                        tokens
@@ -118,7 +121,7 @@
        (raise-syntax-error
         #f
         "parser must have the form (parser args ...)"
-          stx)))))
+        stx))))
 
 
 )