From d40da544f77f6e459d0b9d3b4ac1be31325c0d3e Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Thu, 9 Sep 2004 23:29:26 +0000 Subject: [PATCH] *** empty log message *** original commit: 5180d0d5a689a1dd57248e8631fe24995b642d8a --- collects/parser-tools/private-lex/token.ss | 82 ++++++++--------- .../private-yacc/input-file-parser.ss | 71 ++++++--------- .../private-yacc/parser-builder.ss | 90 ++++++++++++------- collects/parser-tools/yacc.ss | 71 +++++++++------ 4 files changed, 172 insertions(+), 142 deletions(-) diff --git a/collects/parser-tools/private-lex/token.ss b/collects/parser-tools/private-lex/token.ss index ee917e4..6a3e456 100644 --- a/collects/parser-tools/private-lex/token.ss +++ b/collects/parser-tools/private-lex/token.ss @@ -40,46 +40,48 @@ 0 t)))) - (define-syntaxes (define-tokens define-empty-tokens) - (let ((define-tokens-helper - (lambda (stx empty?) - (syntax-case stx () - ((_ name (terms ...)) - (andmap identifier? (syntax->list (syntax (terms ...)))) - (datum->syntax-object - #'here - `(begin - (define-syntax ,(syntax name) - ,(if empty? - `(make-e-terminals-def (quote-syntax ,(syntax (terms ...)))) - `(make-terminals-def (quote-syntax ,(syntax (terms ...)))))) - ,@(map - (lambda (n) - (if (eq? (syntax-object->datum n) 'error) - (raise-syntax-error - #f - "Cannot define a token named error." - stx)) - `(define (,(datum->syntax-object - n - (string->symbol - (format "token-~a" (syntax-object->datum n))) - n - n) - ,@(if empty? '() '(x))) - ,(if empty? - `',n - `(make-token ',n x)))) - (syntax->list (syntax (terms ...))))) - stx)) - ((_ ...) - (raise-syntax-error - #f - "must have the form (define-tokens name (symbol ...)) or (define-empty-tokens name (symbol ...))" - stx)))))) - (values - (lambda (stx) (define-tokens-helper stx #f)) - (lambda (stx) (define-tokens-helper stx #t))))) + (define-for-syntax (make-ctor-name n) + (datum->syntax-object n + (string->symbol (format "token-~a" (syntax-e n))) + n + n)) + + (define-for-syntax (make-define-tokens empty?) + (lambda (stx) + (syntax-case stx () + ((_ name (token ...)) + (andmap identifier? (syntax->list (syntax (token ...)))) + (with-syntax (((marked-token ...) + (map (make-syntax-introducer) + (syntax->list (syntax (token ...)))))) + (quasisyntax/loc stx + (begin + (define-syntax name + #,(if empty? + #'(make-e-terminals-def (quote-syntax (marked-token ...))) + #'(make-terminals-def (quote-syntax (marked-token ...))))) + #,@(map + (lambda (n) + (when (eq? (syntax-e n) 'error) + (raise-syntax-error + #f + "Cannot define a token named error." + stx)) + (if empty? + #`(define (#,(make-ctor-name n)) + '#,n) + #`(define (#,(make-ctor-name n) x) + (make-token '#,n x)))) + (syntax->list (syntax (token ...)))) + (define-syntax marked-token #f) ...)))) + ((_ ...) + (raise-syntax-error + #f + "must have the form (define-tokens name (identifier ...)) or (define-empty-tokens name (identifier ...))" + stx))))) + + (define-syntax define-tokens (make-define-tokens #f)) + (define-syntax define-empty-tokens (make-define-tokens #t)) (define-struct position (offset line col)) (define-struct position-token (token start-pos end-pos)) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 157f7d3..388ac62 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -12,12 +12,13 @@ (provide/contract - (parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? any? . -> . (is-a?/c grammar%))) - (get-term-list (syntax? . -> . (listof syntax?)))) + (parse-input ((listof identifier?) (listof identifier?) (listof identifier?) + (union false? syntax?) syntax? any? . -> . (is-a?/c grammar%))) + (get-term-list ((listof identifier?) . -> . (listof identifier?)))) (define stx-for-original-property (read-syntax #f (open-input-string "original"))) - ;; get-args: int * syntax-object list * syntax-object -> syntax-object list + ;; get-args: ??? (define (get-args i rhs src-pos term-defs) (let ((empty-table (make-hash-table))) (hash-table-put! empty-table 'error #t) @@ -27,7 +28,7 @@ (for-each (lambda (s) (hash-table-put! empty-table (syntax-object->datum s) #t)) (syntax->list (e-terminals-def-t v)))))) - (cdr (syntax->list term-defs))) + term-defs) (let get-args ((i i) (rhs rhs)) (cond @@ -79,7 +80,7 @@ term-list))) ;; Retrieves the terminal symbols from a terminals-def (See terminal-syntax.ss) - ;; get-terms-from-def: syntax-object -> symbol list + ;; get-terms-from-def: identifier? -> (listof identifier?) (define (get-terms-from-def term-syn) (let ((t (syntax-local-value term-syn (lambda () #f)))) (cond @@ -91,48 +92,34 @@ "undefined token group" term-syn))))) - ;; get-term-list: syntax-object -> syntax-object list - (define (get-term-list so) - (syntax-case* so (tokens) - (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) - ((tokens term-def ...) - (andmap identifier? (syntax->list (syntax (term-def ...)))) - (remove-duplicates - (cons (datum->syntax-object #f 'error) - (apply append - (map get-terms-from-def - (syntax->list (syntax (term-def ...)))))))) - (_ - (raise-syntax-error - 'parser-tokens - "Token declaration must be (tokens symbol ...)" - so)))) + (define (get-term-list term-group-names) + (remove-duplicates + (cons (datum->syntax-object #f 'error) + (apply append + (map get-terms-from-def term-group-names))))) - (define (parse-input start ends term-defs prec-decls prods src-pos) - (let* ((start-syms (map syntax-object->datum start)) + (define (parse-input term-defs start ends prec-decls prods src-pos) + (let* ((start-syms (map syntax-e start)) - (list-of-terms (map syntax-object->datum (get-term-list term-defs))) + (list-of-terms (map syntax-e (get-term-list term-defs))) (end-terms (map (lambda (end) - (if (not (memq (syntax-object->datum end) list-of-terms)) - (raise-syntax-error - 'parser-end-tokens - (format "End token ~a not defined as a token" - (syntax-object->datum end)) - end) - (syntax-object->datum end))) + (unless (memq (syntax-e end) list-of-terms) + (raise-syntax-error + 'parser-end-tokens + (format "End token ~a not defined as a token" + (syntax-e end)) + end)) + (syntax-e end)) ends)) ;; Get the list of terminals out of input-terms (list-of-non-terms - (syntax-case* prods (grammar) - (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) - ((grammar (non-term production ...) ...) + (syntax-case prods () + (((non-term production ...) ...) (begin (for-each (lambda (nts) @@ -162,10 +149,8 @@ ;; Check the precedence declarations for errors and turn them into data (precs - (syntax-case* prec-decls (precs) - (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) - ((precs (type term ...) ...) + (syntax-case prec-decls () + (((type term ...) ...) (let ((p-terms (apply append (syntax-object->datum (syntax ((term ...) ...)))))) @@ -273,9 +258,7 @@ ;; parse-prod+action: non-term * syntax-object -> production (parse-prod+action (lambda (nt prod-so) - (syntax-case* prod-so (prec) - (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) + (syntax-case prod-so () ((prod-rhs action) (let ((p (parse-prod (syntax prod-rhs)))) (make-prod @@ -342,7 +325,7 @@ (let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms)) (end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms)) - (parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods)))) + (parsed-prods (map parse-prods-for-nt (syntax->list prods))) (start-prods (map (lambda (start end-non-term) (list (make-prod start (vector end-non-term) #f #f diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 520bc2e..e3b4c18 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -5,10 +5,12 @@ "table.ss" (lib "class.ss") (lib "contract.ss")) + (require-for-template mzscheme) (provide/contract - (build-parser ((string? any? any? syntax? (listof syntax?) (listof syntax?) - (union syntax? false?) syntax?) . ->* . (any? any? any? any?)))) + (build-parser ((string? any? any? (listof identifier?) (listof identifier?) + (listof identifier?) (union syntax? false?) syntax?) . ->* . + (any? any? any? any?)))) (define (strip so) (syntax-local-introduce @@ -18,38 +20,60 @@ so so))) - (define (fix-check-syntax start term-groups prods precs ends) - (syntax-case prods () - ((_ (bind ((bound ...) x ...) ...) ...) - (let ((binds (syntax->list (syntax (bind ...)))) - (bounds (append start - (apply - append - (map syntax->list - (apply - append - (map syntax->list - (syntax->list (syntax (((bound ...) ...) ...))))))))) - (terms (get-term-list term-groups)) - (term-group-stx - (map (lambda (tg) - (syntax-property - (datum->syntax-object tg #f) - 'disappeared-use - tg)) - (syntax->list term-groups))) - (precs (if precs - (syntax-case precs () - ((_ (__ term ...) ...) - (apply append (map syntax->list (syntax->list (syntax ((term ...) ...))))))) - null))) - `(if #f (let ,(map (lambda (bind) - `(,(strip bind) void)) - (append terms binds)) - (void ,@(append ends precs term-group-stx (map strip bounds))))))))) + ;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?) + ;; (union syntax? false?) syntax?) -> syntax? + (define (fix-check-syntax input-terms start end assocs prods) + (let* ((term-binders (get-term-list input-terms)) + (get-term-binder + (let ((t (make-hash-table))) + (for-each + (lambda (term) + (hash-table-put! t (syntax-e term) term)) + term-binders) + (lambda (x) + (hash-table-get t (syntax-e x) (lambda () x))))) + (rhs-list + (syntax-case prods () + (((_ rhs ...) ...) + (syntax->list (syntax (rhs ... ...))))))) + (with-syntax (((tmp ...) term-binders) + ((term-group ...) + (map (lambda (tg) + (syntax-property + (datum->syntax-object tg #f) + 'disappeared-use + tg)) + input-terms)) + ((end ...) + (map get-term-binder end)) + ((bind ...) + (syntax-case prods () + (((bind _ ...) ...) (syntax->list (syntax (bind ...)))))) + (((bound ...) ...) + (map + (lambda (rhs) + (syntax-case rhs () + (((bound ...) (_ pbound) __) + (map get-term-binder + (cons (syntax pbound) + (syntax->list (syntax (bound ...)))))) + (((bound ...) _) + (map get-term-binder + (syntax->list (syntax (bound ...))))))) + rhs-list)) + ((prec ...) + (if assocs + (map get-term-binder + (syntax-case assocs () + ((_ (__ term ...) ...) + (syntax->list (syntax (term ... ...)))))) + null))) + #`(when #f + (let ((bind void) ... (tmp void) ...) + (void bound ... ... term-group ... end ... prec ...)))))) (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)) + (let* ((grammar (parse-input input-terms start end assocs prods src-pos)) (table (build-table grammar filename suppress)) (num-non-terms (send grammar get-num-non-terms)) (token-code @@ -66,6 +90,6 @@ (values table token-code actions-code - (fix-check-syntax start input-terms prods assocs end)))) + (fix-check-syntax input-terms start end assocs prods)))) ) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 6079e1f..1d7f0e5 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -27,20 +27,22 @@ (yacc-output #f)) (for-each (lambda (arg) - (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos yacc-output) + (syntax-case* arg (debug error tokens start end precs grammar + suppress src-pos yacc-output) (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) + (eq? (syntax-e a) (syntax-e b))) ((debug filename) (cond - ((not (string? (syntax-object->datum (syntax filename)))) + ((not (string? (syntax-e (syntax filename)))) (raise-syntax-error - 'parser-debug + #f "Debugging filename must be a string" + stx (syntax filename))) (debug (raise-syntax-error #f "Multiple debug declarations" stx)) (else - (set! debug (syntax-object->datum (syntax filename)))))) + (set! debug (syntax-e (syntax filename)))))) ((suppress) (set! suppress #t)) ((src-pos) @@ -50,65 +52,84 @@ (raise-syntax-error #f "Multiple error declarations" stx) (set! error (syntax expression)))) ((tokens def ...) - (if tokens - (raise-syntax-error #f "Multiple tokens declarations" stx) - (set! tokens arg))) + (begin + (when tokens + (raise-syntax-error #f "Multiple tokens declarations" stx)) + (let ((defs (syntax->list (syntax (def ...))))) + (for-each + (lambda (d) + (unless (identifier? d) + (raise-syntax-error + #f + "Token-group name must be an identifier" + stx + d))) + defs) + (set! tokens defs)))) ((start symbol ...) (let ((symbols (syntax->list (syntax (symbol ...))))) (for-each (lambda (sym) (unless (identifier? sym) - (raise-syntax-error 'parser-start + (raise-syntax-error #f "Start symbol must be a symbol" + stx sym))) symbols) (when start (raise-syntax-error #f "Multiple start declarations" stx)) (when (null? symbols) - (raise-syntax-error 'parser-start + (raise-syntax-error #f "Missing start symbol" - stx)) + stx + arg)) (set! start symbols))) ((end symbols ...) (let ((symbols (syntax->list (syntax (symbols ...))))) (for-each (lambda (sym) (unless (identifier? sym) - (raise-syntax-error 'parser-end + (raise-syntax-error #f "End token must be a symbol" + stx sym))) symbols) - (let ((d (duplicate-list? (map syntax-object->datum symbols)))) + (let ((d (duplicate-list? (map syntax-e symbols)))) (when d - (raise-syntax-error 'parser-end - (format "Duplicate end token definition for ~a" d) - arg)) + (raise-syntax-error + #f + (format "Duplicate end token definition for ~a" d) + stx + arg)) (when (null? symbols) - (raise-syntax-error 'parser-end - "end declaration must contain at least 1 token" - arg)) + (raise-syntax-error + #f + "end declaration must contain at least 1 token" + stx + arg)) (when end (raise-syntax-error #f "Multiple end declarations" stx)) (set! end symbols)))) ((precs decls ...) (if precs (raise-syntax-error #f "Multiple precs declarations" stx) - (set! precs arg))) + (set! precs (syntax/loc arg (decls ...))))) ((grammar prods ...) (if grammar (raise-syntax-error #f "Multiple grammar declarations" stx) - (set! grammar arg))) + (set! grammar (syntax/loc arg (prods ...))))) ((yacc-output filename) (cond - ((not (string? (syntax-object->datum (syntax filename)))) - (raise-syntax-error 'parser-yacc-output + ((not (string? (syntax-e (syntax filename)))) + (raise-syntax-error #f "Yacc-output filename must be a string" + stx (syntax filename))) (yacc-output (raise-syntax-error #f "Multiple yacc-output declarations" stx)) (else - (set! yacc-output (syntax-object->datum (syntax filename)))))) - (_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg)))) + (set! yacc-output (syntax-e (syntax filename)))))) + (_ (raise-syntax-error #f "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" stx arg)))) (syntax->list (syntax (args ...)))) (unless tokens (raise-syntax-error #f "missing tokens declaration" stx))