From bc38b81823da0b42ea22f535d2af865ee6f87bb7 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Tue, 30 Apr 2002 09:53:52 +0000 Subject: [PATCH] *** empty log message *** original commit: 743eeb59fcf962813ba85cb3bdc20eb65fe71732 --- .../private-yacc/parser-builder.ss | 164 +------------- collects/parser-tools/yacc.ss | 200 ++++++++++++++++-- 2 files changed, 195 insertions(+), 169 deletions(-) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index e411ec0..6e83215 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -39,7 +39,7 @@ (append terms binds)) (void ,@(append ends precs (map strip bounds))))))))) - (define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src) + (define (build-parser filename src-pos suppress input-terms start end assocs prods runtime) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos)) (table (build-table grammar filename suppress)) (table-code @@ -87,158 +87,10 @@ ht))) (actions-code - `(vector ,@(map prod-action (grammar-prods grammar)))) - - (parser-code - `(letrec ((err ,error-expr) - (ends ',end) - (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) - ,(if src-pos - `(reduce-stack (cddddr s) (sub1 n) `(,(cadr s) ,(caddr s) ,(cadddr s) ,@v)) - `(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))) - (values s v)))) - (fix-error - (lambda (stack tok ip get-token) - (letrec ((remove-input - (lambda () - (if (memq (token-name tok) ends) - #f - (let ((a (find-action stack tok ip))) - (cond - ((shift? a) - ;; (printf "shift:~a~n" (shift-state a)) - ,(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" tok) - (set! ip (get-token)) - (set! tok (input->token ip)) - (remove-input))))))) - (remove-states - (lambda () - (let ((a (find-action stack (make-token 'error #f) #f))) - (cond - ((shift? a) - ;; (printf "shift:~a~n" (shift-state a)) - (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)) - (cond - ((< (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 ip) - (array2d-ref table - (car stack) - (hash-table-get term-sym->index - (token-name tok) - (lambda () - ,(if src-pos - `(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip)) - `(err #t (token-name tok) (token-value tok))) - (raise-read-error (format "parser: got token of unknown type ~a" (token-name tok)) - #f #f #f #f #f))))))) - (lambda (get-token) - (let parsing-loop ((stack (list 0)) - (ip (get-token))) - (let* ((tok (input->token ip)) - (action (find-action stack tok ip))) - (cond - ((shift? action) - ;; (printf "shift:~a~n" (shift-state action)) - (let ((val (token-value tok))) - (parsing-loop ,(if src-pos - ``(,(shift-state action) ,val ,(cadr ip) ,(caddr ip) ,@stack) - ``(,(shift-state action) ,val ,@stack)) - (get-token)))) - ((reduce? action) - ;; (printf "reduce:~a~n" (reduce-prod-num action)) - (let-values (((new-stack args) - (reduce-stack stack - (reduce-rhs-length action) - null))) - (let* ((A (reduce-lhs-num action)) - (goto (array2d-ref table (car new-stack) A))) - (parsing-loop ,(if src-pos - ``(,goto - ,(apply - (vector-ref actions - (reduce-prod-num action)) - args) - ,(if (null? args) - (cadr ip) - (cadr args)) - ,(if (null? args) - (caddr ip) - (list-ref args (- (* (reduce-rhs-length action) 3) 1))) - ,@new-stack) - ``(,goto - ,(apply - (vector-ref actions - (reduce-prod-num action)) - args) - ,@new-stack)) - ip)))) - ((accept? action) - ;; (printf "accept~n") - (cadr stack)) - (else - ,(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 tok ip get-token))) - (if new-stack - (parsing-loop new-stack (get-token)) - (raise-read-error - "parser: Could not parse input" - #f #f #f #f #f))))))))))) - (datum->syntax-object - runtime - `(begin ,(fix-check-syntax start input-terms prods assocs end) ,parser-code) - src)))) + `(vector ,@(map prod-action (grammar-prods grammar))))) + (values table-code + token-code + actions-code + (fix-check-syntax start input-terms prods assocs end)))) + + ) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 31b15e6..05e64ca 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -9,7 +9,7 @@ (lib "readerr.ss" "syntax")) (provide parser) - + (define-syntax (parser stx) (syntax-case stx () ((_ args ...) @@ -107,22 +107,196 @@ (raise-syntax-error #f "missing end declaration" stx)) (if (not start) (raise-syntax-error #f "missing start declaration" stx)) - (build-parser (if debug debug "") - src-pos - suppress - error - tokens - start - end - precs - grammar - #'here - stx))) + (let-values (((table term-sym->index actions check-syntax-fix) + (build-parser (if debug debug "") + src-pos + suppress + tokens + start + end + precs + grammar + stx))) + (with-syntax ((check-syntax-fix check-syntax-fix) + (err error) + (ends end) + (table table) + (term-sym->index term-sym->index) + (actions actions) + (src-pos src-pos)) + (syntax + (begin + check-syntax-fix + (parser-body err (quote ends) table term-sym->index actions src-pos))))))) (_ (raise-syntax-error #f "parser must have the form (parser args ...)" stx)))) + (define (reduce-stack stack num ret-vals src-pos) + (cond + ((> num 0) + (let* ((top-frame (car stack)) + (ret-vals + (if src-pos + (cons (stack-frame-value top-frame) + (cons (stack-frame-start-pos top-frame) + (cons (stack-frame-end-pos top-frame) + ret-vals))) + (cons (stack-frame-value top-frame) ret-vals)))) + (reduce-stack (cdr stack) (sub1 num) ret-vals src-pos))) + (else (values stack ret-vals)))) -) \ No newline at end of file + (define-struct stack-frame (state value start-pos end-pos)) + + (define empty-stack (list (make-stack-frame 0 #f #f #f))) + + (define (parser-body err ends table term-sym->index actions src-pos) + (letrec ((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)))))) + + (fix-error + (lambda (stack tok ip get-token) + (letrec ((remove-input + (lambda () + (if (memq (token-name tok) ends) + #f + (let ((a (find-action stack tok ip))) + (cond + ((shift? a) + ;; (printf "shift:~a~n" (shift-state a)) + (cons (if src-pos + (make-stack-frame (shift-state a) + (if (token? ip) (token-value ip) #f) + (cadr ip) + (caddr ip)) + (make-stack-frame (shift-state a) + (if (token? ip) (token-value ip) #f) + #f + #f)) + stack)) + (else + ;; (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 (make-token 'error #f) #f))) + (cond + ((shift? a) + ;; (printf "shift:~a~n" (shift-state a)) + (set! stack + (cons + (if src-pos + (make-stack-frame (shift-state a) + #f + (cadr ip) + (caddr ip)) + (make-stack-frame (shift-state a) + #f + #f + #f)) + stack)) + (remove-input)) + (else + ;; (printf "discard state:~a~n" (car stack)) + (cond + ((< (length stack) 2) + (printf "Unable to shift error token~n") + #f) + (else + (set! stack (cdr stack)))))))))) + (remove-states)))) + + (find-action + (lambda (stack tok ip) + (array2d-ref table + (stack-frame-state (car stack)) + (hash-table-get term-sym->index + (token-name tok) + (lambda () + (if src-pos + (err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip)) + (err #t (token-name tok) (token-value tok))) + (raise-read-error (format "parser: got token of unknown type ~a" (token-name tok)) + #f #f #f #f #f))))))) + (lambda (get-token) + (let parsing-loop ((stack empty-stack) + (ip (get-token))) + (let* ((tok (input->token ip)) + (action (find-action stack tok ip))) + (cond + ((shift? action) + ;; (printf "shift:~a~n" (shift-state action)) + (let ((val (token-value tok))) + (parsing-loop (cons (if src-pos + (make-stack-frame (shift-state action) + val + (cadr ip) + (caddr ip)) + (make-stack-frame (shift-state action) + val + #f + #f)) + stack) + (get-token)))) + ((reduce? action) + ;; (printf "reduce:~a~n" (reduce-prod-num action)) + (let-values (((new-stack args) + (reduce-stack stack + (reduce-rhs-length action) + null + src-pos))) + (let* ((A (reduce-lhs-num action)) + (goto (array2d-ref table (stack-frame-state (car new-stack)) A))) + (parsing-loop (cons + (if src-pos + (make-stack-frame goto + (apply (vector-ref actions (reduce-prod-num action)) args) + (if (null? args) (cadr ip) (cadr args)) + (if (null? args) + (caddr ip) + (list-ref args (- (* (reduce-rhs-length action) 3) 1)))) + (make-stack-frame goto + (apply (vector-ref actions (reduce-prod-num action)) args) + #f + #f)) + new-stack) + ip)))) + ((accept? action) + ;; (printf "accept~n") + (stack-frame-value (car stack))) + (else + (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 tok ip get-token))) + (if new-stack + (parsing-loop new-stack (get-token)) + (raise-read-error + "parser: Could not parse input" + #f #f #f #f #f)))))))))) + + ) \ No newline at end of file