From 6e3f0cd22715cd974572842bdb3a7d7ae2b8eb88 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Sat, 4 Sep 2004 03:15:28 +0000 Subject: [PATCH] *** empty log message *** original commit: 2be8fedb446fc5d6283d92da0e15ff49312d2759 --- .../private-yacc/input-file-parser.ss | 33 +++++++++---------- .../private-yacc/parser-builder.ss | 6 ++-- collects/parser-tools/yacc.ss | 3 +- 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 8c688f7..157f7d3 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -8,16 +8,17 @@ "grammar.ss" (lib "class.ss") (lib "contract.ss")) + (require-for-template mzscheme) (provide/contract - (parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? syntax? any? . -> . (is-a?/c grammar%))) + (parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? any? . -> . (is-a?/c grammar%))) (get-term-list (syntax? . -> . (listof syntax?)))) (define stx-for-original-property (read-syntax #f (open-input-string "original"))) ;; get-args: int * syntax-object list * syntax-object -> syntax-object list - (define (get-args i rhs act src-pos term-defs) + (define (get-args i rhs src-pos term-defs) (let ((empty-table (make-hash-table))) (hash-table-put! empty-table 'error #t) (for-each (lambda (td) @@ -32,18 +33,18 @@ (cond ((null? rhs) null) (else - (let ((b (syntax-local-introduce (car rhs))) + (let ((b (car rhs)) (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) (gensym) (string->symbol (format "$~a" i))))) (cond (src-pos - `(,(datum->syntax-object act name b stx-for-original-property) - ,(datum->syntax-object act (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property) - ,(datum->syntax-object act (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property) + `(,(datum->syntax-object b name b stx-for-original-property) + ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property) + ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property) ,@(get-args (add1 i) (cdr rhs)))) (else - `(,(datum->syntax-object act name b stx-for-original-property) + `(,(datum->syntax-object b name b stx-for-original-property) ,@(get-args (add1 i) (cdr rhs))))))))))) ;; Given the list of terminal symbols and the precedence/associativity definitions, @@ -108,7 +109,7 @@ "Token declaration must be (tokens symbol ...)" so)))) - (define (parse-input start ends term-defs prec-decls prods runtime src-pos) + (define (parse-input start ends term-defs prec-decls prods src-pos) (let* ((start-syms (map syntax-object->datum start)) (list-of-terms (map syntax-object->datum (get-term-list term-defs))) @@ -265,11 +266,9 @@ ;; parse-action: syntax-object * syntax-object -> syntax-object (parse-action (lambda (rhs act) - (datum->syntax-object - runtime - `(lambda ,(get-args 1 (syntax->list rhs) act src-pos term-defs) - ,act) - act))) + (quasisyntax/loc act + (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs) + #,act)))) ;; parse-prod+action: non-term * syntax-object -> production (parse-prod+action @@ -347,7 +346,7 @@ (start-prods (map (lambda (start end-non-term) (list (make-prod start (vector end-non-term) #f #f - (datum->syntax-object runtime `(lambda (x) x))))) + (syntax (lambda (x) x))))) starts end-non-terms)) (prods `(,@start-prods @@ -361,13 +360,11 @@ (hash-table-get term-table end)) #f #f - (datum->syntax-object - runtime - `(lambda (x) x)))) + (syntax (lambda (x) x)))) end-terms)) end-non-terms start-syms) ,@parsed-prods))) - + (make-object grammar% prods (map car start-prods) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index f80349e..520bc2e 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -8,7 +8,7 @@ (provide/contract (build-parser ((string? any? any? syntax? (listof syntax?) (listof syntax?) - (union syntax? false?) syntax? syntax?) . ->* . (any? any? any? any?)))) + (union syntax? false?) syntax?) . ->* . (any? any? any? any?)))) (define (strip so) (syntax-local-introduce @@ -48,8 +48,8 @@ (append terms binds)) (void ,@(append ends precs term-group-stx (map strip bounds))))))))) - (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)) + (define (build-parser filename src-pos suppress input-terms start end assocs prods) + (let* ((grammar (parse-input start end input-terms assocs prods src-pos)) (table (build-table grammar filename suppress)) (num-non-terms (send grammar get-num-non-terms)) (token-code diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index d36c0f8..6079e1f 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -128,8 +128,7 @@ start end precs - grammar - stx))) + grammar))) (when (and yacc-output (not (string=? yacc-output ""))) (with-handlers [(exn:fail:filesystem? (lambda (e)