diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 7206bd6..851a7a2 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -63,8 +63,8 @@ ;; c = char | eof ;; lex-buf = - ;; (make-lex-buffer input-port (c list) (c list) int int int (int list)) - (define-struct lex-buffer (ip from to offset line col line-lengths tab-skips)) + ;; (make-lex-buffer input-port (c list) (c list) int int int (int list) boolean) + (define-struct lex-buffer (ip from to offset line col line-lengths tab-skips has-seen-eof?)) ;; make-lex-buf: input-port -> lex-buf (define make-lex-buf @@ -74,7 +74,7 @@ ((not (input-port? ip)) (raise-type-error 'make-lex-buf "input-port" 0 ip)) (else - (make-lex-buffer ip null null 1 1 1 null null)))) + (make-lex-buffer ip null null 1 1 1 null null #f)))) ((ip offsets) (cond ((not (input-port? ip)) @@ -85,12 +85,19 @@ (not (andmap (lambda (x) (>= x 0)) offsets))) (raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets)) (else - (make-lex-buffer ip null null (caddr offsets) (car offsets) (cadr offsets) null null)))))) + (make-lex-buffer ip null null (caddr offsets) (car offsets) (cadr offsets) null null #f)))))) (define (get-next lb) (cond ((null? (lex-buffer-from lb)) - (read-char (lex-buffer-ip lb))) + (let ((res (read-char (lex-buffer-ip lb)))) + (if (eof-object? res) + (if (lex-buffer-has-seen-eof? lb) + (raise-read-error + (format "lex-buf: No characters left in input stream") + #f #f #f #f #f) + (set-lex-buffer-has-seen-eof?! lb #t))) + res)) (else (begin0 (car (lex-buffer-from lb)) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 0cb6bcd..8dbb607 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -90,6 +90,28 @@ (table ,table-code) (term-sym->index ,token-code) (actions ,actions-code) + (input->token + (lambda (ip) + ,(if src-pos + `(cond + ((and (list? ip) (= 3 (length ip))) + (let ((tok (car ip))) + (cond + ((symbol? tok) (make-token tok #f)) + ((token? tok) tok) + (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)))))) (reduce-stack (lambda (s n v) (if (> n 0) @@ -98,45 +120,53 @@ `(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))) (values s v)))) (fix-error - (lambda (stack ip get-token) + (lambda (stack tok ip get-token) (letrec ((remove-input (lambda () - (let ((a (find-action stack ip))) + (let ((a (find-action stack tok ip))) (cond ((shift? a) ;; (printf "shift:~a~n" (shift-state a)) - (cons (shift-state a) - (cons (if (token? ip) - (token-value ip) - #f) - stack))) + ,(if src-pos + ``(,(shift-state a) + ,(if (token? ip) (token-value ip) #f) + ,(cadr ip) + ,(caddr ip) + ,@stack) + ``(,(shift-state a) + ,(if (token? ip) (token-value ip) #f) + ,@stack))) (else - (printf "discard-input:~a~n" (if (token? ip) - (token-name ip) - ip)) + (printf "discard input:~a~n" tok) (set! ip (get-token)) + (set! tok (input->token ip)) (remove-input)))))) (remove-states (lambda () - (let ((a (find-action stack 'error))) + (let ((a (find-action stack 'error #f))) (cond ((shift? a) ;; (printf "shift:~a~n" (shift-state a)) - (set! stack (cons (shift-state a) (cons #f stack))) - (remove-input)) + (set! stack + ,(if src-pos + ``(,(shift-state a) ,#f ,(cadr ip) ,(caddr ip) ,@stack) + ``(,(shift-state a) ,#f ,@stack))) + (remove-input)) (else - ;; (printf "discard-state:~a~n" (car stack)) + ;; (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))))))))) + ((< (length stack) ,(if src-pos `5 `3)) + (printf "Unable to shift error token~n") + #f) + (else + ,(if src-pos + `(set! stack (cddddr stack)) + `(set! stack (cddr stack))) + (remove-states))))))))) (remove-states)))) (find-action - (lambda (stack tok ,@(if src-pos `(ip) `())) + (lambda (stack tok ip) (array2d-ref table (car stack) (hash-table-get term-sym->index @@ -150,26 +180,8 @@ (lambda (get-token) (let parsing-loop ((stack (list 0)) (ip (get-token))) - (let* ((tok ,(if src-pos `(cond - ((and (list? ip) (= 3 (length ip))) - (let ((tok (car ip))) - (cond - ((symbol? tok) (make-token tok #f)) - ((token? tok) tok) - (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) `())))) + (let* ((tok (input->token ip)) + (action (find-action stack tok ip))) (cond ((shift? action) ;; (printf "shift:~a~n" (shift-state action)) @@ -196,7 +208,7 @@ (cadr ip) (cadr args)) ,(if (null? args) - (cadr ip) + (caddr ip) (list-ref args (- (* (reduce-rhs-length action) 3) 1))) ,@new-stack) ``(,goto @@ -213,7 +225,7 @@ ,(if src-pos `(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))) + (let ((new-stack (fix-error stack tok ip get-token))) (if new-stack (parsing-loop new-stack (get-token)) (raise-read-error