diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss index 9e09ff5..780027f 100644 --- a/collects/parser-tools/private-yacc/grammar.ss +++ b/collects/parser-tools/private-yacc/grammar.ss @@ -1,20 +1,41 @@ +;; Constructs to create and access grammars, the internal +;; representation of the input to the parser generator. + #cs (module grammar mzscheme (require (lib "class.ss") (lib "list.ss") - "yacc-helper.ss") + "yacc-helper.ss" + (lib "contracts.ss")) + + ;; Each production has a unique index 0 <= index <= number of productions + (define-struct prod (lhs rhs index prec action) (make-inspector)) + + ;; The dot-pos field is the index of the element in the rhs + ;; of prod that the dot immediately preceeds. + ;; Thus 0 <= dot-pos <= (vector-length rhs). + (define-struct item (prod dot-pos) (make-inspector)) + + ;; gram-sym = (or/f term? non-term?) + ;; Each term has a unique index 0 <= index < number of terms + ;; Each non-term has a unique index 0 <= index < number of non-terms + (define-struct term (sym index prec) (make-inspector)) + (define-struct non-term (sym index) (make-inspector)) + + ;; a precedence declaration. + (define-struct prec (num assoc) (make-inspector)) + + (provide/contract + (make-item (prod? (or/f false? natural-number?) . -> . item?)) + (make-term (symbol? (or/f false? natural-number?) (or/f prec? false?) . -> . term?)) + (make-non-term (symbol? (or/f false? natural-number?) . -> . non-term?)) + (make-prec (natural-number? (symbols 'left 'right 'nonassoc) . -> . prec?)) + (make-prod (non-term? (vectorof (or/f non-term? term?)) + (or/f false? natural-number?) (or/f false? prec?) syntax? . -> . prod?))) - ;; Constructs to create and access grammars, the internal - ;; representation of the input to the parser generator. - (provide - make-item - make-term - make-non-term - make-prec - make-prod ;; Things that work on items start-item? item-prod item->string @@ -36,12 +57,6 @@ ;;---------------------- LR items -------------------------- - ;; LR-item = (make-item production nat) - ;; The dot-pos field is the index of the element in the rhs - ;; of prod that the dot immediately preceeds. - ;; Thus 0 <= dot-pos <= (vector-length rhs). - (define-struct item (prod dot-pos) (make-inspector)) - ;; item bool ;; Lexicographic comparison on two items. (define (itembit-vector (cdr terms)))))) - ;; ------------------------- Precedences --------------------------- - - ;; a precedence declaration. the sym should be 'left 'right or 'nonassoc - ;; prec = (make-prec int sym) - ;; | #f - (define-struct prec (num assoc) (make-inspector)) ;; ------------------------- Grammar ------------------------------ @@ -147,10 +149,12 @@ (class object% (super-instantiate ()) ;; prods: production list list - ;; where the nth element in the outermost list is the list of productions with the nth non-term as lhs + ;; where there is one production list per non-term (init prods) + ;; init-prods: production list + ;; The productions parsing can start from ;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable - (init-field terms non-terms end-terms) + (init-field init-prods terms non-terms end-terms) ;; list of all productions (define all-prods (apply append prods)) @@ -196,8 +200,7 @@ (define/public (get-prods-for-non-term nt) (vector-ref nt->prods (non-term-index nt))) (define/public (get-prods) all-prods) - (define/public (get-init-prod) - (car (vector-ref nt->prods 0))) + (define/public (get-init-prods) init-prods) (define/public (get-terms) terms) (define/public (get-non-terms) non-terms) @@ -275,9 +278,4 @@ nullable))))))) - ;; ------------------------ Productions --------------------------- - - ;; production = (make-prod non-term (gram-sym vector) int prec syntax-object) - ;; Each production has a unique index 0 <= index <= number of productions - (define-struct prod (lhs rhs index prec action) (make-inspector)) ) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 9c28848..02fa108 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -345,10 +345,13 @@ (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)))) + (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))))) + starts end-non-terms)) (prods - `(,@(map (lambda (start end-non-term) - (list (make-prod start (vector end-non-term) #f #f #f))) - starts end-non-terms) + `(,@start-prods ,@(map (lambda (end-nt start-sym) (map @@ -368,6 +371,7 @@ (make-object grammar% prods + (map car start-prods) terms (append starts (append end-non-terms non-terms)) (map (lambda (term-name) diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 00d80b1..7bb4580 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -226,7 +226,7 @@ ;; list for each kernel (kernels (make-hash-table 'equal)) - (counter 1) + (counter 0) ;; goto: LR1-item list -> LR1-item list list ;; creates new kernels by moving the dot in each item in the @@ -331,12 +331,19 @@ (loop (add1 i))))))) (else null)))))))) - (start (list (make-item (send grammar get-init-prod) 0))) - (startk (make-kernel start 0)) + (starts + (map (lambda (init-prod) (list (make-item init-prod 0))) + (send grammar get-init-prods))) + (startk + (map (lambda (start) + (let ((k (make-kernel start counter))) + (hash-table-put! kernels start k) + (set! counter (add1 counter)) + k)) + starts)) (new-kernels (make-queue))) - (hash-table-put! kernels start startk) - (let loop ((old-kernels (list startk)) + (let loop ((old-kernels startk) (seen-kernels null)) (cond ((and (empty-queue? new-kernels) (null? old-kernels)) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index e65ebe4..7f01663 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -150,6 +150,7 @@ (with-syntax ((check-syntax-fix check-syntax-fix) (err error) (ends end) + (starts start) (debug debug) (table table) (term-sym->index term-sym->index) @@ -158,7 +159,7 @@ (syntax (begin check-syntax-fix - (parser-body debug err (quote ends) table term-sym->index actions src-pos))))))) + (parser-body debug err (quote starts) (quote ends) table term-sym->index actions src-pos))))))) (_ (raise-syntax-error #f "parser must have the form (parser args ...)" @@ -188,7 +189,7 @@ ;; an accept, shift or reduce structure - or a #f. Except that we will encode ;; by changing (make-accept) -> 'accept, (make-shift i) -> i and ;; (make-reduce i1 i2 i3) -> #(i1 i2 i3) - (define (parser-body debug err ends table term-sym->index actions src-pos) + (define (parser-body debug err starts ends table term-sym->index actions src-pos) (letrec ((input->token (if src-pos (lambda (ip) @@ -341,5 +342,12 @@ (err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip)) (err #t (token-name tok) (token-value tok))) (parsing-loop (fix-error stack tok ip get-token) (get-token)))))))))) - (make-parser 0))) + (cond + ((null? (cdr starts)) (make-parser 0)) + (else + (let loop ((l starts) + (i 0)) + (cond + ((null? l) null) + (else (cons (make-parser i) (loop (cdr l) (add1 i)))))))))) ) \ No newline at end of file