*** empty log message ***

original commit: de0a1d7c61d0d21a75b134914b423e702ea2dcca

collects/parser-tools/private-lex/token.ss

@@ -5,7 +5,7 @@
   
   (require-for-syntax "token-syntax.ss")
 
-  (provide define-tokens define-empty-tokens token-name token-value token?)
+  (provide define-tokens define-empty-tokens make-token token-name token-value token?)
 
   (define-struct token (name value) (make-inspector))
 

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

@@ -69,7 +69,7 @@
                          (if (> n 0)
                              ,(if src-pos
                                   `(reduce-stack (cddddr s) (sub1 n) `(,(cadr s) ,(caddr s) ,(cadddr s) ,@v))
-                                  `(reduce-stack (cddddr s) (sub1 n) (cons (cadr s) v)))
+                                  `(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v)))
                              (values s v))))
                       (fix-error
                        (lambda (stack ip get-token)
@@ -110,32 +110,42 @@
 			   (remove-states))))
                       
                       (find-action
-                       (lambda (stack tok)
+                       (lambda (stack tok ,@(if src-pos `(ip) `()))
-                         ;; (display (if (token? tok) (token-name tok) tok))
-                         ;; (newline)
                          (array2d-ref table 
                                       (car stack)
                                       (hash-table-get term-sym->index
-                                                      (if (token? tok)
+                                                      (token-name tok)
-                                                          (token-name tok)
+                                                      (lambda ()
-                                                          tok)
+                                                        ,(if src-pos
-                                                      err)))))
+                                                             `(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
+                                                             `(err #t (token-name tok) (token-value tok)))))))))
                (lambda (get-token)
                  (let parsing-loop ((stack (list 0))
 				    (ip (get-token)))
-                                             
+                   (let* ((tok ,(if src-pos `(cond
-                   ;; (display stack)
+                                               ((and (list? ip) (= 3 (length ip)))
-                   ;; (newline)
+                                                (let ((tok (car ip)))
-                   (let* ((tok ,(if src-pos `(car ip) `ip))
+                                                  (cond
-                          (action (find-action stack tok)))
+                                                    ((symbol? tok) (make-token tok #f))
-                     ;; (display (if (token? tok) (token-name tok) tok))
+                                                    ((token? tok) tok)
-                     ;; (newline)
+                                                    (else (raise-type-error 'parser 
+                                                                            "(list (token or symbol) position position)"
+                                                                            0 
+                                                                            ip)))))
+                                               (else
+                                                (raise-type-error 'parser 
+                                                                  "(list (token or symbol) position position)"
+                                                                  0
+                                                                  ip)))
+                                                `(cond
+                                                   ((symbol? ip) (make-token ip #f))
+                                                   ((token? ip) ip)
+                                                   (else (raise-type-error 'parser "token or symbol" 0 ip)))))
+                          (action (find-action stack tok) ,@(if src-pos `(ip) `())))
                      (cond
                        ((shift? action)
                         ;; (printf "shift:~a~n" (shift-state action))
-                        (let ((val (if (token? tok)
+                        (let ((val (token-value tok)))
-                                       (token-value tok)
-                                       #f)))
                           (parsing-loop ,(if src-pos
                                              ``(,(shift-state action) ,val ,(cadr ip) ,(caddr ip) ,@stack)
                                              ``(,(shift-state action) ,val ,@stack))
@@ -172,11 +182,15 @@
                         ;; (printf "accept~n")
                         (cadr stack))
                        (else 
-                        (err ip)
+                        ,(if src-pos
-                        (let ((new-stack (fix-error stack tok get-token)))
+                             `(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
+                             `(err #t (token-name tok) (token-value tok)))
+                        (let ((new-stack (fix-error stack ip get-token)))
                           (if new-stack
                               (parsing-loop new-stack (get-token))
-                              (void)))))))))))
+                              (raise-read-error 
+                               "parser: Could not parse input"
+                               #f #f #f #f #f)))))))))))
       (datum->syntax-object
        runtime
        parser-code

collects/parser-tools/yacc.ss

@@ -5,7 +5,8 @@
                       "private-yacc/yacc-helper.ss")
   (require "private-yacc/parser-actions.ss"
            "private-yacc/array2d.ss"
-           "private-lex/token.ss")
+           "private-lex/token.ss"
+	   (lib "readerr.ss" "syntax"))
   
   (provide parser)