*** empty log message ***

original commit: 5c5088e25177f4d087a86edf98568918e020e753

collects/parser-tools/yacc.ss

@@ -152,10 +152,12 @@
  
   (define empty-stack (list (make-stack-frame 0 #f #f #f)))
 
+  (define (false-thunk) #f) 
+
   (define (parser-body err ends table term-sym->index actions src-pos)
     (letrec ((input->token
-              (lambda (ip)
               (if src-pos
+                  (lambda (ip)
                     (cond
                       ((and (list? ip) (= 3 (length ip)))
                        (let ((tok (car ip)))
@@ -170,7 +172,8 @@
                        (raise-type-error 'parser 
                                          "(list (token or symbol) position position)"
                                          0
-                                         ip)))
+                                         ip))))
+                  (lambda (ip)
                     (cond
                       ((symbol? ip) (make-token ip #f))
                       ((token? ip) ip)
@@ -203,7 +206,7 @@
                                      (remove-input)))))))
                          (remove-states
                           (lambda ()
-                            (let ((a (find-action stack (make-token 'error #f) #f)))
+                            (let ((a (find-action stack (make-token 'error #f) ip)))
                               (cond
                                 ((shift? a)
                                  ;; (printf "shift:~a~n" (shift-state a))
@@ -232,11 +235,14 @@
              
              (find-action
               (lambda (stack tok ip)
+                (let ((token-index (hash-table-get term-sym->index
+                                                   (token-name tok)
+                                                   false-thunk)))
+                  (if token-index
                       (array2d-ref table 
                                    (stack-frame-state (car stack))
-                             (hash-table-get term-sym->index
-                                             (token-name tok)
-                                             (lambda ()
+                                   token-index)
+                      (begin
                         (if src-pos
                             (err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
                             (err #t (token-name tok) (token-value tok)))