diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 327fa6f..5ddc4f8 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -10,7 +10,7 @@ (provide lex define-lex-abbrev define-lex-abbrevs make-lex-buf get-position position-offset position-line position-col position? - define-tokens define-empty-tokens token-value token-name token?) + define-tokens define-empty-tokens) (define-syntax lex @@ -27,9 +27,9 @@ (lambda () end-pos) (lambda () - (list->string (reverse (filter (lambda (x) - (char? x)) - match)))) + (if (char? (car match)) + (list->string (reverse match)) + (list->string (reverse (cdr match))))) lb))))) (lambda (lb) (unless (lex-buffer? lb) @@ -37,21 +37,22 @@ (format "Lexer expects argument of type lex-buf; given ~a" lb))) (let ((first-pos (get-position lb))) - (let loop ( - ;; current-state - (state start-state) - ;; the character to transition on - (char (next-char lb)) - ;; action for the longest match seen thus far - ;; including a match at the current state - (longest-match-action - (vector-ref actions start-state)) - ;; how many characters have been read - ;; including the one just read - (length 1) - ;; how many characters are in the longest match - (longest-match-length 0) - (end-pos first-pos)) + (let lexer-loop ( + ;; current-state + (state start-state) + ;; the character to transition on + (char (next-char lb)) + ;; action for the longest match seen thus far + ;; including a match at the current state + (longest-match-action + (vector-ref actions start-state)) + ;; how many characters have been read + ;; including the one just read + (length 1) + ;; how many characters are in the longest match + (longest-match-length 0) + ;;(end-pos first-pos)) + (end-pos first-pos)) (let ((next-state (cond ((eof-object? char) @@ -70,16 +71,17 @@ longest-match-action length)) (else - (loop next-state - (next-char lb) - (if (vector-ref actions next-state) - (vector-ref actions next-state) - longest-match-action) - (add1 length) - (if (vector-ref actions next-state) - length - longest-match-length) - pos)))))))))) + (let ((act (vector-ref actions next-state))) + (lexer-loop next-state + (next-char lb) + (if act + act + longest-match-action) + (add1 length) + (if act + length + longest-match-length) + pos))))))))))) (lambda (stx) (syntax-case stx () ((_ (re act) ...) @@ -224,8 +226,3 @@ ) - - - - - diff --git a/collects/parser-tools/private-lex/token.ss b/collects/parser-tools/private-lex/token.ss index d7a9ec7..14f8e7f 100644 --- a/collects/parser-tools/private-lex/token.ss +++ b/collects/parser-tools/private-lex/token.ss @@ -7,7 +7,7 @@ (provide define-tokens define-empty-tokens token-name token-value token?) - (define-struct token (name value)) + (define-struct token (name value) (make-inspector)) (define-syntax define-tokens (lambda (stx) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 454835b..058a33d 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -14,7 +14,7 @@ (table-code `((lambda (table-list) (let ((v (list->vector table-list))) - (let loop ((i 0)) + (let build-table-loop ((i 0)) (cond ((< i (vector-length v)) (let ((vi (vector-ref v i))) @@ -27,7 +27,7 @@ ((eq? 'r (car vi)) (make-reduce (cadr vi) (caddr vi) (cadddr vi))) ((eq? 'a (car vi)) (make-accept))))))) - (loop (add1 i))) + (build-table-loop (add1 i))) (else v))))) (quote ,(map (lambda (action) @@ -71,37 +71,41 @@ (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))))))) + (letrec ((remove-input + (lambda () + (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)))))) + (remove-states + (lambda () + (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))) + (remove-input)) + (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))))))))) + (remove-states)))) (find-action (lambda (stack tok) @@ -113,8 +117,8 @@ tok) err))))) (lambda (get-token) - (let loop ((stack (list 0)) - (ip (get-token))) + (let parsing-loop ((stack (list 0)) + (ip (get-token))) ;;(display stack) ;;(newline) ;;(display (if (token? ip) (token-name ip) ip)) @@ -126,8 +130,8 @@ (let ((val (if (token? ip) (token-value ip) #f))) - (loop (cons (shift-state action) (cons val stack)) - (get-token)))) + (parsing-loop (cons (shift-state action) (cons val stack)) + (get-token)))) ((reduce? action) ;; (printf "reduce:~a~n" (reduce-prod-num action)) (let-values (((new-stack args) @@ -136,13 +140,13 @@ null))) (let* ((A (reduce-lhs-num action)) (goto (array2d-ref table (car new-stack) A))) - (loop (cons goto - (cons (apply - (vector-ref actions - (reduce-prod-num action)) - args) - new-stack)) - ip)))) + (parsing-loop (cons goto + (cons (apply + (vector-ref actions + (reduce-prod-num action)) + args) + new-stack)) + ip)))) ((accept? action) ;; (printf "accept~n") (cadr stack)) @@ -150,10 +154,9 @@ (err) (let ((new-stack (fix-error stack ip get-token))) (if new-stack - (loop new-stack (get-token)) + (parsing-loop new-stack (get-token)) (void))))))))))) (datum->syntax-object runtime parser-code src)))) - \ No newline at end of file