*** empty log message ***

original commit: ca20d2a89326943989e4ae31bdd9a121eced73fa

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

@@ -117,6 +117,7 @@
            
            (start-sym (syntax-object->datum start))
                           
+           
            (list-of-terms
             (syntax-case term-defs (tokens)
               ((tokens term-def ...)
@@ -224,6 +225,7 @@
                             type)))
                      (syntax->list (syntax (type ...))))
                     (cdr (syntax-object->datum prec-decls))))))
+              (#f null)
               (_
                (raise-syntax-error
                 'parser-precedences

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

@@ -43,14 +43,58 @@
            
            (parser-code
             `(letrec ((err ,error-expr)
-                      (term-sym->index ,token-code)
+                      (err-state 0)
                       (table ,table-code)
+                      (term-sym->index ,token-code)
                       (actions ,actions-code)
                       (reduce-stack
                        (lambda (s n v)
                          (if (> n 0)
-                             (reduce-stack (cdr (cdr s)) (sub1 n) (cons (cadr s) v))
-                             (values s v)))))
+                             (reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))
+                             (values s v))))
+                      (fix-error
+                       (lambda (stack ip get-token)
+                         (let remove-states ()
+                           (let ((a (find-action stack 'error)))
+                             (cond
+                               ((shift? a)
+                                (printf "shift:~a~n" (shift-state a))
+                                (set! stack (cons (shift-state a) (cons #f stack))))
+                               (else
+                                (printf "discard-state:~a~n" (car stack))
+                                (cond
+                                  ((< (length stack) 3)
+                                   (printf "Unable to shift error token~n")
+                                   #f)
+                                  (else
+                                   (set! stack (cddr stack))
+                                   (remove-states)))))))
+                         (let remove-input ()
+                           (let ((a (find-action stack ip)))
+                             (cond
+                               ((shift? a)
+                                (printf "shift:~a~n" (shift-state a))
+                                (cons (shift-state a)
+                                      (cons (if (token? ip)
+                                                (token-value ip)
+                                                #f)
+                                            stack)))
+                               (else
+                                (printf "discard-input:~a~n" (if (token? ip)
+                                                                 (token-name ip)
+                                                                 ip))
+                                (set! ip (get-token))
+                                (remove-input)))))))
+                      
+                      (find-action
+                       (lambda (stack tok)
+                         (array2d-ref table 
+                                      (car stack)
+                                      (hash-table-get term-sym->index
+                                                      (if (token? tok)
+                                                          (token-name tok)
+                                                          tok)
+                                                      err)))))
                (lambda (get-token)
                  (let loop ((stack (list 0))
                             (ip (get-token)))
@@ -58,13 +102,7 @@
                    (newline)
                    (display (if (token? ip) (token-name ip) ip))
                    (newline)
-                   (let* ((s (car stack))
-                          (a (hash-table-get term-sym->index 
-                                             (if (token? ip)
-                                                 (token-name ip)
-                                                 ip)
-                                             err))
-                          (action (array2d-ref table s a)))
+                   (let ((action (find-action stack ip)))
                      (cond
                        ((shift? action)
                         (printf "shift:~a~n" (shift-state action))
@@ -89,8 +127,14 @@
                                               new-stack))
                                   ip))))
                        ((accept? action)
-                        (printf "accept~n"))
-                       (else (err)))))))))
+                        (printf "accept~n")
+                        (cadr stack))
+                       (else 
+                        (err)
+                        (let ((new-stack (fix-error stack ip get-token)))
+                          (if new-stack
+                              (loop new-stack (get-token))
+                              (void)))))))))))
       (datum->syntax-object
        runtime
        parser-code

collects/parser-tools/yacc.ss

@@ -79,8 +79,10 @@
             (syntax->list (syntax (args ...))))
            (if (not tokens)
                (raise-syntax-error #f "missing tokens declaration" stx))
-           (if (not grammar)
+           (if (not error)
                (raise-syntax-error #f "missing error declaration" stx))
+           (if (not grammar)
+               (raise-syntax-error #f "missing grammar declaration" stx))
            (if (not end)
                (raise-syntax-error #f "missing end declaration" stx))
            (build-parser (if debug debug "")