diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss index 4203d4c..3163dba 100644 --- a/collects/parser-tools/private-yacc/lalr.ss +++ b/collects/parser-tools/private-yacc/lalr.ss @@ -6,6 +6,7 @@ (require "lr0.ss" "grammar.ss" "array2d.ss" + "graph.ss" (lib "list.ss") (lib "class.ss")) @@ -41,25 +42,12 @@ (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) + (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)))))) - - ;; 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 dot-pos start num-states) @@ -123,40 +111,6 @@ 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) (define (compute-lookback a g) @@ -175,7 +129,7 @@ (send a get-num-states) (send g get-num-terms) (send g get-num-non-terms)))) - + ;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set) ;; output term set is represented in bit-vector form (define (compute-LA a g) diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 4b9bc3d..00d80b1 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -171,8 +171,8 @@ (letrec ( (terms (list->vector (send grammar get-terms))) (non-terms (list->vector (send grammar get-non-terms))) - (num-non-terms (vector-length non-terms)) - (num-gram-syms (+ num-non-terms (vector-length terms))) + (num-non-terms (send grammar get-num-non-terms)) + (num-gram-syms (+ num-non-terms (send grammar get-num-terms))) (epsilons (make-hash-table 'equal)) ;; first-non-term: non-term -> non-term list @@ -191,7 +191,7 @@ (lambda (nt) (list nt)) (union non-term LR1-item list ;; Creates a set of items containing i s.t. if A -> n.Xm is in it, ;; X -> .o is in it too. @@ -218,7 +218,6 @@ (cons (car i) (LR0-closure (cdr i)))))))))) - ;; maps trans-keys to kernels (automaton-term (make-hash-table 'equal)) (automaton-non-term (make-hash-table 'equal)) @@ -274,7 +273,6 @@ (for-each (lambda (item) (add-item! table item)) (LR0-closure (kernel-items kernel))) - ;; each group is a new kernel, with the dot advanced. ;; sorts the items in a kernel so kernels can be compared @@ -333,8 +331,7 @@ (loop (add1 i))))))) (else null)))))))) - - (start (list (make-item (send grammar get-init-prod) 0))) + (start (list (make-item (send grammar get-init-prod) 0))) (startk (make-kernel start 0)) (new-kernels (make-queue))) diff --git a/collects/parser-tools/private-yacc/parser-actions.ss b/collects/parser-tools/private-yacc/parser-actions.ss index bbf40c8..825a18f 100644 --- a/collects/parser-tools/private-yacc/parser-actions.ss +++ b/collects/parser-tools/private-yacc/parser-actions.ss @@ -10,10 +10,21 @@ ;; action = (shift int) ;; | (reduce int int int) ;; | (accept) - ;; | int + ;; | int>=0 ;; | #f - (define-struct shift (state) (make-inspector)) - (define-struct reduce (prod-num lhs-num rhs-length) (make-inspector)) - (define-struct accept () (make-inspector)) + (define (shift? x) (and (integer? x) (< x 0))) + (define (make-shift x) (- (+ x 1))) + (define (shift-state x) (- (+ x 1))) + (define reduce? vector?) + (define make-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)) + (define (make-accept) 'accept) + + ;(define-struct shift (state) (make-inspector)) + ;(define-struct reduce (prod-num lhs-num rhs-length) (make-inspector)) + ;(define-struct accept () (make-inspector)) ) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 971d520..41f14ca 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -2,7 +2,6 @@ (module parser-builder mzscheme (require "input-file-parser.ss" - "parser-actions.ss" "grammar.ss" "table.ss" (lib "class.ss")) @@ -55,17 +54,6 @@ ht))) (actions-code `(vector ,@(map prod-action (send grammar get-prods))))) - (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 diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index b9d7443..7928caf 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -216,13 +216,11 @@ ;; buile-table: grammar * string -> action array2d (define (build-table g file suppress) (let* ((a (build-lr0-automaton g)) - (terms (send g get-terms)) - (non-terms (send g get-non-terms)) - (get-term (list->vector terms)) - (get-non-term (list->vector non-terms)) + (num-terms (send g get-num-terms)) + (num-non-terms (send g get-num-non-terms)) + (get-term (list->vector (send g get-terms))) + (get-non-term (list->vector (send g get-non-terms))) (get-prod (list->vector (send g get-prods))) - (num-terms (vector-length get-term)) - (num-non-terms (vector-length get-non-term)) (end-term-indexes (map (lambda (term) @@ -240,7 +238,7 @@ (else (if (not (equal? a old)) (array2d-set! v i1 i2 (list a old)))))))) (get-lookahead (compute-LA a g))) - + (send a for-each-state (lambda (state) (let loop ((i 0)) @@ -264,7 +262,6 @@ (make-shift (kernel-index goto))))))) (loop (add1 i))))) - (for-each (lambda (item) (let ((item-prod (item-prod item))) @@ -285,26 +282,27 @@ (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 94a93be..ac3b079 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -5,6 +5,7 @@ "private-yacc/yacc-helper.ss") (require "private-yacc/array2d.ss" "private-lex/token.ss" + "private-yacc/parser-actions.ss" (lib "readerr.ss" "syntax")) (provide parser) @@ -153,14 +154,6 @@ (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