diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss index b250afd..e3e61d6 100644 --- a/collects/parser-tools/private-yacc/grammar.ss +++ b/collects/parser-tools/private-yacc/grammar.ss @@ -30,6 +30,7 @@ (rename gram-terms grammar-terms) (rename gram-num-prods grammar-num-prods) (rename gram-prods grammar-prods) + (rename gram-end-terms grammar-end-terms) ;; Things that work on productions prod-index prod-prec prod-rhs prod-lhs prod-action) @@ -155,7 +156,8 @@ ;; (bool vector) ;; (non-term list) ;; (term list) - ;; int) + ;; int + ;; (term list)) ;; ;; The nt-prods field is indexed by the number assigned to the non-term and ;; contains the list of productions for that non-term @@ -163,7 +165,7 @@ ;; The nulls field is indexed by the index for a non-term and is trus iff ;; the non-term is nullable (define-struct gram - (nt-prods prods nulls non-terms terms num-prods)) + (nt-prods prods nulls non-terms terms num-prods end-terms)) ;; get-nt-prods: grammar * non-term -> production list diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 8e874b6..bcb43e9 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -111,31 +111,44 @@ "undefined token group" term-syn))))) - ;; parse-input: syntax-object^4 * string -> grammar - (define (parse-input start term-defs prec-decls prods runtime) + ;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar + (define (parse-input start ends term-defs prec-decls prods runtime) (let* ((counter 0) (start-sym (syntax-object->datum start)) - ;; Get the list of terminals out of input-terms (list-of-terms - (syntax-case term-defs () - ((term-def ...) - (andmap identifier? (syntax->list term-defs)) + (syntax-case term-defs (tokens) + ((tokens term-def ...) + (andmap identifier? (syntax->list (syntax (term-def ...)))) (remove-duplicates - (apply append - (map get-terms-from-def - (syntax->list term-defs))))) + (cons 'error + (apply append + (map get-terms-from-def + (syntax->list (syntax (term-def ...)))))))) (_ (raise-syntax-error 'parser-tokens - "Token list must be (symbol ...)" + "Token declaration must be (tokens symbol ...)" 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))) + ends)) + ;; Get the list of terminals out of input-terms (list-of-non-terms - (syntax-case prods () - (((non-term production ...) ...) + (syntax-case prods (grammar) + ((grammar (non-term production ...) ...) (begin (for-each (lambda (nts) @@ -167,14 +180,14 @@ (syntax-object->datum (syntax (non-term ...))))) (_ (raise-syntax-error - 'parser-productions - "Productions must be of the form ((non-terminal productions ...) ...)" + 'parser-grammar + "Grammar must be of the form (grammar (non-terminal productions ...) ...)" prods)))) ;; Check the precedence declarations for errors and turn them into data (precs - (syntax-case prec-decls () - (((type term ...) ...) + (syntax-case prec-decls (precs) + ((precs (type term ...) ...) (let ((p-terms (apply append (syntax-object->datum (syntax ((term ...) ...)))))) @@ -210,11 +223,11 @@ "Associativity must be left, right or nonassoc" type))) (syntax->list (syntax (type ...)))) - (syntax-object->datum prec-decls))))) + (cdr (syntax-object->datum prec-decls)))))) (_ (raise-syntax-error 'parser-precedences - "Precedence declaration must be of the form ((assoc term ...) ...) where assoc is left, right or nonassoc" + "Precedence declaration must be of the form (precs (assoc term ...) ...) where assoc is left, right or nonassoc" prec-decls)))) (terms (build-terms list-of-terms precs)) @@ -346,14 +359,14 @@ (prods (cons (list (make-prod start - (vector (hash-table-get non-term-table - start-sym)) + (vector (hash-table-get non-term-table start-sym) + (hash-table-get term-table (car end-terms))) 0 #f (datum->syntax-object runtime `(lambda (x) x)))) - (map parse-prods-for-nt (syntax->list prods)))) + (map parse-prods-for-nt (cdr (syntax->list prods))))) (nulls (nullable (apply append prods) (add1 (length non-terms))))) @@ -376,4 +389,5 @@ nulls (cons start non-terms) terms - counter)))))) + counter + end-terms)))))) diff --git a/collects/parser-tools/private-yacc/parser-actions.ss b/collects/parser-tools/private-yacc/parser-actions.ss index 1728145..dbc7faa 100644 --- a/collects/parser-tools/private-yacc/parser-actions.ss +++ b/collects/parser-tools/private-yacc/parser-actions.ss @@ -5,7 +5,7 @@ (provide shift? reduce? accept? shift-state reduce-prod-num reduce-lhs-num reduce-rhs-length - make-shift make-reduce) + make-shift make-reduce make-accept) ;; action = (shift int) ;; | (reduce int int int) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 344a124..4092ebc 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -8,8 +8,8 @@ (provide build-parser) - (define (build-parser start input-terms assocs prods filename runtime src) - (let* ((grammar (parse-input start input-terms assocs prods runtime)) + (define (build-parser filename error-expr input-terms start end assocs prods runtime src) + (let* ((grammar (parse-input start end input-terms assocs prods runtime)) (table (build-table grammar filename)) (table-code (cons 'vector @@ -42,7 +42,8 @@ `(vector ,@(map prod-action (grammar-prods grammar)))) (parser-code - `(letrec ((term-sym->index ,token-code) + `(letrec ((err ,error-expr) + (term-sym->index ,token-code) (table ,table-code) (actions ,actions-code) (reduce-stack @@ -61,7 +62,8 @@ (a (hash-table-get term-sym->index (if (token? ip) (token-name ip) - ip))) + ip) + err)) (action (array2d-ref table s a))) (cond ((shift? action) @@ -88,7 +90,7 @@ ip)))) ((accept? action) (printf "accept~n")) - (else (error 'parser))))))))) + (else (err))))))))) (datum->syntax-object runtime parser-code diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index b0e12ef..528a086 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -264,8 +264,7 @@ (vector-length (prod-rhs (item-prod item)))))))) (get-lookahead (vector-ref get-state state) (item-prod item)))) - items)) - + items)) (loop (add1 state))))) (resolve-prec-conflicts table get-term get-prod num-states num-terms num-non-terms) diff --git a/collects/parser-tools/private-yacc/terminal-syntax.ss b/collects/parser-tools/private-yacc/terminal-syntax.ss index fd97ab7..ca51f24 100644 --- a/collects/parser-tools/private-yacc/terminal-syntax.ss +++ b/collects/parser-tools/private-yacc/terminal-syntax.ss @@ -7,17 +7,22 @@ (define-struct terminals-def (t)) - (define (define-tokens-helper stx hack empty?) + (define (define-tokens-helper stx runtime empty?) (syntax-case stx () ((_ name (terms ...)) (andmap identifier? (syntax->list (syntax (terms ...)))) (datum->syntax-object - hack + runtime `(begin (define-syntax ,(syntax name) (make-terminals-def ',(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 diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 0742b2d..3fac187 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -1,40 +1,102 @@ #cs (module yacc mzscheme - (require-for-syntax "private-yacc/parser-builder.ss") + (require-for-syntax "private-yacc/parser-builder.ss" + "private-yacc/yacc-helper.ss") (require "private-yacc/terminal.ss" "private-yacc/parser-actions.ss" "private-yacc/array2d.ss") - (provide define-tokens define-empty-tokens parser parser-debug) + (provide define-tokens define-empty-tokens parser) (define-syntax parser (lambda (stx) (syntax-case stx () - ((_ start input-terms assocs prods) - (build-parser (syntax start) (syntax input-terms) - (syntax assocs) (syntax prods) - "" #'here stx)) + ((_ args ...) + (let ((arg-list (syntax->list (syntax (args ...)))) + (debug #f) + (error #f) + (tokens #f) + (start #f) + (end #f) + (precs #f) + (grammar #f)) + (for-each + (lambda (arg) + (syntax-case arg (debug error tokens start end precs grammar) + ((debug filename) + (cond + ((not (string? (syntax-object->datum (syntax filename)))) + (raise-syntax-error + 'parser-debug + "Debugging filename must be a string" + (syntax filename))) + (debug + (raise-syntax-error #f "Multiple debug declarations" stx)) + (else + (set! debug (syntax-object->datum (syntax filename)))))) + ((error expression) + (if error + (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))) + ((start symbol) + (cond + ((not (identifier? (syntax symbol))) + (raise-syntax-error + 'parser-start + "Start non-terminal must be a symbol" + (syntax symbol))) + (start + (raise-syntax-error #f "Multiple start declarations" stx)) + (else + (set! start (syntax symbol))))) + ((end symbols ...) + (begin + (for-each + (lambda (sym) + (if (not (identifier? sym)) + (raise-syntax-error + 'parser-end + "End token must be a symbol" + sym))) + (syntax->list (syntax (symbols ...)))) + (if end + (raise-syntax-error #f "Multiple end declarations" stx)) + (set! end (syntax->list (syntax (symbols ...)))))) + ((precs decls ...) + (if precs + (raise-syntax-error #f "Multiple precs declarations" stx) + (set! precs arg))) + ((grammar prods ...) + (if grammar + (raise-syntax-error #f "Multiple grammar declarations" stx) + (set! grammar arg))) + (_ (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)))) + (syntax->list (syntax (args ...)))) + (if (not tokens) + (raise-syntax-error #f "missing tokens declaration" stx)) + (if (not grammar) + (raise-syntax-error #f "missing error declaration" stx)) + (if (not end) + (raise-syntax-error #f "missing end declaration" stx)) + (build-parser (if debug debug "") + error + tokens + start + end + precs + grammar + #'here + stx))) (_ (raise-syntax-error #f - "parser must have the form (parser start-symbol tokens precedence/associativity productions)" + "parser must have the form (parser args ...)" stx))))) - + - (define-syntax parser-debug - (lambda (stx) - (syntax-case stx () - ((_ filename start input-terms assocs prods) - (string? (syntax-object->datum (syntax filename))) - (build-parser (syntax start) (syntax input-terms) - (syntax assocs) (syntax prods) - (syntax-object->datum (syntax filename)) - #'here stx)) - (_ - (raise-syntax-error - #f - "parser must have the form (parser-debug filename start-symbol tokens precedence/associativity productions) where filename is a string" - stx))))) - ) \ No newline at end of file