diff --git a/collects/parser-tools/private-lex/token-syntax.ss b/collects/parser-tools/private-lex/token-syntax.ss index f560de5..534e662 100644 --- a/collects/parser-tools/private-lex/token-syntax.ss +++ b/collects/parser-tools/private-lex/token-syntax.ss @@ -15,7 +15,7 @@ runtime `(begin (define-syntax ,(syntax name) - (make-terminals-def ',(syntax (terms ...)))) + (make-terminals-def (quote-syntax ,(syntax (terms ...))))) ,@(map (lambda (n) (if (eq? (syntax-object->datum n) 'error) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index bd7ae2b..067438a 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -6,7 +6,7 @@ (require "yacc-helper.ss" "../private-lex/token-syntax.ss" "grammar.ss" (lib "list.ss")) - (provide parse-input) + (provide parse-input get-term-list) ;; get-args: num * syntax-object -> syntax-object list (define (get-args x act src-pos) @@ -110,36 +110,38 @@ (define (get-terms-from-def term-syn) (let ((t (syntax-local-value term-syn (lambda () #f)))) (cond - ((terminals-def? t) (terminals-def-t t)) + ((terminals-def? t) (syntax->list (terminals-def-t t))) (else (raise-syntax-error 'parser-tokens "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)))) ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar (define (parse-input start ends term-defs prec-decls prods runtime src-pos) (let* ((counter 0) (start-sym (syntax-object->datum start)) - - - (list-of-terms - (syntax-case* term-defs (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 'error - (apply append - (map get-terms-from-def - (syntax->list (syntax (term-def ...)))))))) - (_ - (raise-syntax-error - 'parser-tokens - "Token declaration must be (tokens symbol ...)" - term-defs)))) + + (list-of-terms (map syntax-object->datum (get-term-list term-defs))) (end-terms (map diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 0e8e8e2..c5f31c5 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -8,6 +8,20 @@ (provide build-parser) + (define (fix-check-syntax start terms prods) + (syntax-case prods () + ((_ (bind ((bound ...) x ...) ...) ...) + (let ((binds (syntax->list (syntax (bind ...)))) + (bounds (cons start + (apply append (map syntax->list + (apply append (map syntax->list + (syntax->list (syntax (((bound ...) ...) ...))))))))) + (terms (get-term-list terms))) + `(if #f (let ,(map (lambda (bind) + `(,bind void)) + (append terms binds)) + (void ,@bounds))))))) + (define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos)) (table (build-table grammar filename suppress)) @@ -195,5 +209,5 @@ #f #f #f #f #f))))))))))) (datum->syntax-object runtime - parser-code + `(begin #|,(fix-check-syntax start input-terms prods)|# ,parser-code) src)))) diff --git a/collects/parser-tools/private-yacc/yacc-helper.ss b/collects/parser-tools/private-yacc/yacc-helper.ss index 60f90ee..f744b59 100644 --- a/collects/parser-tools/private-yacc/yacc-helper.ss +++ b/collects/parser-tools/private-yacc/yacc-helper.ss @@ -27,8 +27,10 @@ (hash-table-put! t (car l) (car l)) (dl? (cdr l))))))) (dl? l))) - - ;; remove-duplicates: symbol list -> symbol list + + (require (lib "pretty.ss")) + + ;; remove-duplicates: syntax-object list -> syntax-object list ;; removes the duplicates from the lists (define (remove-duplicates sl) (let ((t (make-hash-table))) @@ -36,10 +38,10 @@ (lambda (sl) (cond ((null? sl) sl) - ((hash-table-get t (car sl) (lambda () #f)) + ((hash-table-get t (syntax-object->datum (car sl)) (lambda () #f)) (x (cdr sl))) (else - (hash-table-put! t (car sl) #t) + (hash-table-put! t (syntax-object->datum (car sl)) #t) (cons (car sl) (x (cdr sl)))))))) (x sl))))