diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss index 48898fa..3076714 100644 --- a/collects/parser-tools/private-yacc/grammar.ss +++ b/collects/parser-tools/private-yacc/grammar.ss @@ -185,7 +185,14 @@ (if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i))) (loop (add1 i)) #f)) - ((= i prod-length) #t))))))) + ((= i prod-length) #t))))) + + (define/public (nullable-non-term-thunk) + (lambda (nt) + (nullable-non-term? nt))) + (define/public (nullable-after-dot?-thunk) + (lambda (item) + (nullable-after-dot? item))))) ;; ------------------------ Productions --------------------------- diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss index 6f057eb..b4a975b 100644 --- a/collects/parser-tools/private-yacc/lalr.ss +++ b/collects/parser-tools/private-yacc/lalr.ss @@ -10,12 +10,6 @@ (lib "class.ss")) (provide compute-LA) - - (define (list-head l n) - (cond - ((= 0 n) null) - (else (cons (car l) (list-head (cdr l) (sub1 n)))))) - ;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set) ;; computes for each state, non-term transition pair, the terminals @@ -33,38 +27,49 @@ ;; compute-reads: ;; LR0-automaton * grammar -> (trans-key -> trans-key list) (define (compute-reads a g) - (lambda (tk) - (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))) - (map (lambda (x) (make-trans-key r x)) - (filter (lambda (non-term) - (and (send g nullable-non-term? non-term) - (send a run-automaton r non-term))) - (send g get-non-terms )))))) + (let ((nullable-non-terms + (filter (lambda (nt) (send g nullable-non-term? nt)) + (send g get-non-terms)))) + (lambda (tk) + (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))) + (map (lambda (x) (make-trans-key r x)) + (filter (lambda (non-term) (send a run-automaton r non-term)) + nullable-non-terms)))))) ;; compute-read: LR0-automaton * grammar -> (trans-key -> term set) ;; output term set is represented in bit-vector form (define (compute-read a g) (let* ((dr (compute-DR a g)) (reads (compute-reads a g))) - (digraph-tk->terml (send a get-mapped-non-term-keys) - reads - dr - (send a get-num-states) - (send g get-num-terms) - (send g get-num-non-terms)))) + (time + (digraph-tk->terml (send a get-mapped-non-term-keys) + reads + dr + (send a get-num-states) + (send g get-num-terms) + (send g get-num-non-terms)))) + ) +; ;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list +; ;; returns the list of all k such that state k transitions to state start on the +; ;; transitions in rhs (in order) +; (define (run-lr0-backward a rhs start num-states) +; (let loop ((states (list start)) +; (rhs (reverse rhs))) +; (cond +; ((null? rhs) states) +; (else (loop (send a run-automaton-back states (car rhs)) +; (cdr rhs)))))) - ;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list + ;; gram-sym list * kernel * int -> kernel list ;; returns the list of all k such that state k transitions to state start on the ;; transitions in rhs (in order) - (define (run-lr0-backward a rhs start num-states) + (define (run-lr0-backward a rhs dot-pos start num-states) (let loop ((states (list start)) - (rhs (reverse rhs))) + (i (sub1 dot-pos))) (cond - ((null? rhs) states) - (else (loop (kernel-list-remove-duplicates - (send a run-automaton-back states (car rhs)) - num-states) - (cdr rhs)))))) + ((< i 0) states) + (else (loop (send a run-automaton-back states (vector-ref rhs i)) + (sub1 i)))))) ;; prod->items-for-include: grammar * prod * non-term -> lr0-item list ;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma) @@ -91,74 +96,75 @@ ;; and gamma =>* epsilon (define (prod-list->items-for-include g prod-list nt) (apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list))) - + ;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list) (define (compute-includes a g) - (let ((non-terms (send g get-non-terms)) - (num-states (send a get-num-states))) + (let ((num-states (send a get-num-states)) + (items-for-input-nt (make-vector (send g get-num-non-terms) null))) + (for-each + (lambda (input-nt) + (vector-set! items-for-input-nt (non-term-index input-nt) + (prod-list->items-for-include g (send g get-prods) input-nt))) + (send g get-non-terms)) (lambda (tk) - (let ((goal-state (trans-key-st tk)) - (non-term (trans-key-gs tk))) - (apply append - (map (lambda (B) - (map (lambda (state) - (make-trans-key state B)) - (kernel-list-remove-duplicates - (let ((items (prod-list->items-for-include g (send g get-prods-for-non-term B) non-term))) - (apply append - (map (lambda (item) - (let ((rhs (prod-rhs (item-prod item)))) - (run-lr0-backward a - (list-head (vector->list rhs) - (- (vector-length rhs) - (item-dot-pos item))) - goal-state - num-states))) - items))) - num-states))) - non-terms)))))) - - - ;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list) -; (define (compute-includes a g) -; (let* ((non-terms (send g get-non-terms)) -; (num-states (vector-length (send a get-states))) -; (num-non-terms (length non-terms)) -; (includes (make-array2d num-states num-non-terms null))) -; (send a for-each-state -; (lambda (state) -; (for-each -; (lambda (non-term) -; (for-each -; (lambda (prod) -; (let loop ((i (make-item prod 0)) -; (p state)) -; (if (and p i) -; (let* ((next-sym (sym-at-dot i)) -; (new-i (move-dot-right i))) -; (if (and (non-term? next-sym) -; (send g nullable-after-dot? new-i)) -; (array2d-add! includes -; (kernel-index p) -; (gram-sym-index next-sym) -; (make-trans-key state non-term))) -; (if next-sym -; (loop new-i -; (send a run-automaton p next-sym))))))) -; (send g get-prods-for-non-term non-term))) -; non-terms))) + (let* ((goal-state (trans-key-st tk)) + (non-term (trans-key-gs tk)) + (items (vector-ref items-for-input-nt (non-term-index non-term)))) + (trans-key-list-remove-dups + (apply append + (map (lambda (item) + (let* ((prod (item-prod item)) + (rhs (prod-rhs prod)) + (lhs (prod-lhs prod))) + (map (lambda (state) + (make-trans-key state lhs)) + (run-lr0-backward a + rhs + (item-dot-pos item) + goal-state + num-states)))) + items))))))) + +; ;; compute-includes: lr0-automaton * grammar -> (trans-key -> trans-key list) +; (define (compute-includes a g) +; (let* ((non-terms (send g get-non-terms)) +; (num-states (vector-length (send a get-states))) +; (num-non-terms (length non-terms)) +; (includes (make-array2d num-states num-non-terms null))) +; (send a for-each-state +; (lambda (state) +; (for-each +; (lambda (non-term) +; (for-each +; (lambda (prod) +; (let loop ((i (make-item prod 0)) +; (p state)) +; (if (and p i) +; (let* ((next-sym (sym-at-dot i)) +; (new-i (move-dot-right i))) +; (if (and (non-term? next-sym) +; (send g nullable-after-dot? new-i)) +; (array2d-add! includes +; (kernel-index p) +; (gram-sym-index next-sym) +; (make-trans-key state non-term))) +; (if next-sym +; (loop new-i +; (send a run-automaton p next-sym))))))) +; (send g get-prods-for-non-term non-term))) +; non-terms))) ; -; (lambda (tk) -; (array2d-ref includes -; (kernel-index (trans-key-st tk)) -; (gram-sym-index (trans-key-gs tk)))))) -; - ; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list) +; (lambda (tk) +; (array2d-ref includes +; (kernel-index (trans-key-st tk)) +; (gram-sym-index (trans-key-gs tk)))))) + + ;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list) (define (compute-lookback a g) (let ((num-states (send a get-num-states))) (lambda (state prod) (map (lambda (k) (make-trans-key k (prod-lhs prod))) - (run-lr0-backward a (vector->list (prod-rhs prod)) state num-states))))) + (run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states))))) ;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set) ;; output term set is represented in bit-vector form @@ -176,7 +182,7 @@ (define (compute-LA a g) (let* ((includes (compute-includes a g)) (lookback (compute-lookback a g)) - (follow (compute-follow a g includes))) + (follow (compute-follow a g includes))) (lambda (k p) (let* ((l (lookback k p)) (f (map follow l))) diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 99bc050..4b9bc3d 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -10,8 +10,8 @@ (lib "class.ss")) (provide build-lr0-automaton lr0% - (struct trans-key (st gs)) - kernel-items kernel-index kernel-list-remove-duplicates) + (struct trans-key (st gs)) trans-key-list-remove-dups + kernel-items kernel-index) ;; kernel = (make-kernel (LR1-item list) index) ;; the list must be kept sorted according to item kernel list - (define (kernel-list-remove-duplicates k num-states) - (let ((v (make-vector num-states #f))) - (for-each - (lambda (k) - (vector-set! v (kernel-index k) k)) - k) - (let loop ((i 0)) - (cond - ((< i num-states) - (let ((k (vector-ref v i))) - (if k - (cons k (loop (add1 i))) - (loop (add1 i))))) - (else null))))) - - - + (define (trans-key-list-remove-dups tkl) + (let loop ((sorted (quicksort tkl trans-keyvector table-list))) - (let build-table-loop ((i 0)) - (cond - ((< i (vector-length v)) - (let ((vi (vector-ref v i))) - (cond - ((list? vi) - (vector-set! v i - (cond - ((eq? 's (car vi)) - (make-shift (cadr vi))) - ((eq? 'r (car vi)) - (make-reduce (cadr vi) (caddr vi) (cadddr vi))) - ((eq? 'a (car vi)) (make-accept))))))) - (build-table-loop (add1 i))) - (else v))))) - (quote - ,(map (lambda (action) - (cond - ((shift? action) - `(s ,(shift-state action))) - ((reduce? action) - `(r ,(reduce-prod-num action) - ,(reduce-lhs-num action) - ,(reduce-rhs-length action))) - ((accept? action) - `(a)) - (else action))) - (vector->list table))))) - + (table (build-table grammar filename suppress)) (num-non-terms (send grammar get-num-non-terms)) - (token-code `(let ((ht (make-hash-table))) (begin @@ -86,12 +53,22 @@ ,(+ num-non-terms (gram-sym-index term)))) (send grammar get-terms)) ht))) - (actions-code `(vector ,@(map prod-action (send grammar get-prods))))) - (values table-code - token-code - actions-code - (fix-check-syntax start input-terms prods assocs end)))) + (let loop ((i 1)) + (if (< i (vector-length table)) + (let ((a (vector-ref table i))) + (vector-set! table i (cond + ((accept? a) 'accept) + ((shift? a) (- (shift-state a))) + ((reduce? a) (vector (reduce-prod-num a) + (reduce-lhs-num a) + (reduce-rhs-length a))) + (else a))) + (loop (add1 i))))) + (values table + token-code + actions-code + (fix-check-syntax start input-terms prods assocs end)))) ) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index dd3ae70..111230c 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -213,9 +213,9 @@ ;; In the result table the first index is the state and the second is the ;; term/non-term index (with the non-terms coming first) - ;; buile-table: grammar * string -> action2d-array + ;; buile-table: grammar * string -> action array2d (define (build-table g file suppress) - (let* ((a (time (build-lr0-automaton g))) + (let* ((a (build-lr0-automaton g)) (terms (send g get-terms)) (non-terms (send g get-non-terms)) (get-term (list->vector terms)) @@ -229,7 +229,7 @@ (+ num-non-terms (gram-sym-index term))) (send g get-end-terms))) (num-gram-syms (+ num-terms num-non-terms)) - (table (make-array2d (vector-length (send a get-states)) num-gram-syms #f)) + (table (make-array2d (send a get-num-states) num-gram-syms #f)) (array2d-add! (lambda (v i1 i2 a) (let ((old (array2d-ref v i1 i2))) @@ -240,69 +240,71 @@ (else (if (not (equal? a old)) (array2d-set! v i1 i2 (list a old)))))))) (get-lookahead (time (compute-LA a g)))) - (time - (send a for-each-state - (lambda (state) - (let loop ((i 0)) - (if (< i num-gram-syms) - (begin - (let* ((s (if (< i num-non-terms) - (vector-ref get-non-term i) - (vector-ref get-term (- i num-non-terms)))) - (goto - (send a run-automaton state s))) - (if goto - (array2d-set! table - (kernel-index state) - i - (cond - ((< i num-non-terms) - (kernel-index goto)) - ((member i end-term-indexes) - (make-accept)) - (else - (make-shift - (kernel-index goto))))))) - (loop (add1 i))))) + + (send a for-each-state + (lambda (state) + (let loop ((i 0)) + (if (< i num-gram-syms) + (begin + (let* ((s (if (< i num-non-terms) + (vector-ref get-non-term i) + (vector-ref get-term (- i num-non-terms)))) + (goto + (send a run-automaton state s))) + (if goto + (array2d-set! table + (kernel-index state) + i + (cond + ((< i num-non-terms) + (kernel-index goto)) + ((member i end-term-indexes) + (make-accept)) + (else + (make-shift + (kernel-index goto))))))) + (loop (add1 i))))) + + (for-each + (lambda (item) + (let ((item-prod (item-prod item))) + (bit-vector-for-each + (lambda (term-index) + (array2d-add! table + (kernel-index state) + (+ num-non-terms term-index) + (cond + ((not (start-item? item)) + (make-reduce + (prod-index item-prod) + (gram-sym-index (prod-lhs item-prod)) + (vector-length (prod-rhs item-prod))))))) + (get-lookahead state item-prod)))) - (for-each - (lambda (item) - (let ((item-prod (item-prod item))) - (bit-vector-for-each - (lambda (term-index) - (array2d-add! table - (kernel-index state) - (+ num-non-terms term-index) - (cond - ((not (start-item? item)) - (make-reduce - (prod-index item-prod) - (gram-sym-index (prod-lhs item-prod)) - (vector-length (prod-rhs item-prod))))))) - (get-lookahead state item-prod)))) - - (append (hash-table-get (send a get-epsilon-trans) state (lambda () null)) - (filter (lambda (item) - (not (move-dot-right item))) - (kernel-items state))))))) - + (append (hash-table-get (send a get-epsilon-trans) state (lambda () null)) + (filter (lambda (item) + (not (move-dot-right item))) + (kernel-items state)))))) + (resolve-prec-conflicts a table get-term get-prod num-terms - num-non-terms) - - (if (not (string=? file "")) - (with-handlers [(exn:i/o:filesystem? - (lambda (e) - (fprintf - (current-error-port) - "Cannot write debug output to file \"~a\". ~a~n" - (exn:i/o:filesystem-pathname e) - (exn:i/o:filesystem-detail e))))] - (call-with-output-file file - (lambda (port) - (display-parser a table get-term get-non-term (send g get-prods) - port))))) - (resolve-conflicts a table num-terms num-non-terms suppress) - table)) -) - + num-non-terms) + + (if (not (string=? file "")) + (with-handlers [(exn:i/o:filesystem? + (lambda (e) + (fprintf + (current-error-port) + "Cannot write debug output to file \"~a\". ~a~n" + (exn:i/o:filesystem-pathname e) + (exn:i/o:filesystem-detail e))))] + (call-with-output-file file + (lambda (port) + (display-parser a table get-term get-non-term (send g get-prods) + port))))) + (resolve-conflicts a table num-terms num-non-terms suppress) + table)) + ) + + + \ No newline at end of file diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 3e54ed7..94a93be 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -3,8 +3,7 @@ (require-for-syntax "private-yacc/parser-builder.ss" "private-yacc/yacc-helper.ss") - (require "private-yacc/parser-actions.ss" - "private-yacc/array2d.ss" + (require "private-yacc/array2d.ss" "private-lex/token.ss" (lib "readerr.ss" "syntax")) @@ -154,6 +153,18 @@ (define (false-thunk) #f) + (define shift? integer?) + (define (shift-state x) (- x)) + (define reduce? vector?) + (define (reduce-prod-num x) (vector-ref x 0)) + (define (reduce-lhs-num x) (vector-ref x 1)) + (define (reduce-rhs-length x) (vector-ref x 2)) + (define (accept? x) (eq? x 'accept)) + + ;; The table format is an array2d that maps each state/term pair to either + ;; 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 err ends table term-sym->index actions src-pos) (letrec ((input->token (if src-pos