From d315d5a52ea29776e5fe6acb1e98b4cfc50b46c1 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Wed, 1 May 2002 08:53:11 +0000 Subject: [PATCH] *** empty log message *** original commit: bab7ce1c4c49987bd1e7e40abc7403e5d3541313 --- collects/parser-tools/private-yacc/grammar.ss | 9 ++- collects/parser-tools/private-yacc/graph.ss | 33 +++++++--- collects/parser-tools/private-yacc/lalr.ss | 61 ++++++++----------- collects/parser-tools/private-yacc/lr0.ss | 36 ++++++++--- .../private-yacc/parser-builder.ss | 2 +- collects/parser-tools/private-yacc/table.ss | 22 +++++-- 6 files changed, 102 insertions(+), 61 deletions(-) diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss index 80307a4..8ec52de 100644 --- a/collects/parser-tools/private-yacc/grammar.ss +++ b/collects/parser-tools/private-yacc/grammar.ss @@ -19,7 +19,8 @@ ;; Things that operate on grammar symbols gram-sym-symbol gram-sym-index term-prec gram-sym->string - non-term? term? nullable? non-termbit-vector ;; Things that work on precs prec-num prec-assoc @@ -142,6 +143,12 @@ (define (gram-sym->string gs) (symbol->string (gram-sym-symbol gs))) + (define (term-list->bit-vector terms) + (cond + ((null? terms) 0) + (else + (bitwise-ior (arithmetic-shift 1 (term-index (car terms))) (term-list->bit-vector (cdr terms)))))) + ;; ------------------------- Precedences --------------------------- ;; a precedence declaration. the sym should be 'left 'right or 'nonassoc diff --git a/collects/parser-tools/private-yacc/graph.ss b/collects/parser-tools/private-yacc/graph.ss index 3252576..d42f8b0 100644 --- a/collects/parser-tools/private-yacc/graph.ss +++ b/collects/parser-tools/private-yacc/graph.ss @@ -3,8 +3,10 @@ (provide digraph) + (define (zero-thunk) 0) + ;; digraph: - ;; ('a list) * ('a -> 'a list) * ('a -> 'b) * ('b * 'b -> 'b) * 'b + ;; ('a list) * ('a -> 'a list) * ('a -> 'b) * ('b * 'b -> 'b) * (-> 'b) ;; -> ('a -> 'b) ;; DeRemer and Pennello 1982 ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)} @@ -14,18 +16,33 @@ (letrec ( ;; Will map elements of 'a to 'b sets (results (make-hash-table 'equal)) - (f (lambda (x) (hash-table-get results x (lambda () fail)))) + (f (lambda (x) (hash-table-get results x fail))) ;; Maps elements of 'a to integers. (N (make-hash-table 'equal)) - (get-N (lambda (x) (hash-table-get N x (lambda () 0)))) + (get-N (lambda (x) (hash-table-get N x zero-thunk))) (set-N (lambda (x d) (hash-table-put! N x d))) - (stack null) - (push (lambda (x) (set! stack (cons x stack)))) - (pop (lambda () (begin0 (car stack) (set! stack (cdr stack))))) - (depth (lambda () (length stack))) - +; (stack null) +; (push (lambda (x) +; (set! stack (cons x stack)))) +; (pop (lambda () +; (begin0 +; (car stack) +; (set! stack (cdr stack))))) +; (depth (lambda () (length stack))) + (stack (make-vector 1000 #f)) + (stack-pointer 0) + (push (lambda (x) + (vector-set! stack stack-pointer x) + (set! stack-pointer (add1 stack-pointer)))) + (pop (lambda () + (set! stack-pointer (sub1 stack-pointer)) + (vector-ref stack stack-pointer))) + (depth (lambda () stack-pointer)) + + + ;; traverse: 'a -> (traverse (lambda (x) diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss index 62d9d65..c7c7849 100644 --- a/collects/parser-tools/private-yacc/lalr.ss +++ b/collects/parser-tools/private-yacc/lalr.ss @@ -11,20 +11,17 @@ (provide compute-LA) - (define (array2d-add! a i1 i2 v) - (let ((old (array2d-ref a i1 i2))) - (array2d-set! a i1 i2 (cons v old)))) - ;; compute-DR: LR0-automaton * grammar -> (trans-key -> term list) ;; computes for each state, non-term transition pair, the terminals ;; which can transition out of the resulting state (define (compute-DR a g) (lambda (tk) (let ((r (run-automaton (trans-key-st tk) (trans-key-gs tk) a))) - (filter - (lambda (term) - (run-automaton r term a)) - (grammar-terms g))))) + (term-list->bit-vector + (filter + (lambda (term) + (run-automaton r term a)) + (grammar-terms g)))))) ;; compute-reads: ;; LR0-automaton * grammar -> (trans-key -> trans-key list) @@ -41,12 +38,11 @@ (define (compute-read a g) (let* ((dr (compute-DR a g)) (reads (compute-reads a g))) - (digraph (filter (lambda (x) (non-term? (trans-key-gs x))) - (hash-table-map (lr0-transitions a) (lambda (k v) k))) + (digraph (get-mapped-lr0-non-term-keys a) reads dr - (union term (trans-key -> term list) (define (compute-follow a g includes) (let ((read (compute-read a g))) - (digraph (filter (lambda (x) (non-term? (trans-key-gs x))) - (hash-table-map (lr0-transitions a) (lambda (k v) k))) + (digraph (get-mapped-lr0-non-term-keys a) includes read - (union term (kernel * prod -> term list) (define (compute-LA a g) - (let-values (((includes lookback) (compute-includes-and-lookback a g))) - (let ((follow (compute-follow a g includes))) + (let-values (((includes lookback) (time (compute-includes-and-lookback a g)))) + (let ((follow (time (compute-follow a g includes)))) (lambda (k p) (let* ((l (lookback k p)) - (f (map follow l))) - (apply append f)))))) + (f (map follow l))) + (apply bitwise-ior (cons 0 f))))))) (define (print-DR dr a g) diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 5bbf200..422add9 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -8,7 +8,7 @@ (lib "list.ss")) (provide union build-lr0-automaton run-automaton (struct trans-key (st gs)) - lr0-transitions lr0-states lr0-epsilon-trans + get-mapped-lr0-non-term-keys lr0-states lr0-epsilon-trans kernel-items kernel-index for-each-state) (define (union comp kernel | #f ;; returns the state that the transition trans-key provides or #f ;; if there is no such state (define (run-automaton k s a) - (hash-table-get (lr0-transitions a) (make-trans-key k s) (lambda () #f))) - + (if (term? s) + (hash-table-get (lr0-term-transitions a) (make-trans-key k s) false-thunk) + (hash-table-get (lr0-non-term-transitions a) (make-trans-key k s) false-thunk))) + (define (get-mapped-lr0-non-term-keys a) + (hash-table-map (lr0-non-term-transitions a) (lambda (k v) k))) + + (define (add-lr0-transition! ttable nttable key value) + (hash-table-put! + (if (term? (trans-key-gs key)) + ttable + nttable) + key + value)) + + ;; build-LR0-automaton: grammar -> LR0-automaton ;; Constructs the kernels of the sets of LR(0) items of g (define (build-lr0-automaton grammar) @@ -87,7 +102,7 @@ (get-nt-prods grammar nt)))) (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, @@ -116,7 +131,8 @@ ;; maps trans-keys to kernels - (automaton (make-hash-table 'equal)) + (automaton-term (make-hash-table 'equal)) + (automaton-non-term (make-hash-table 'equal)) ;; keeps the kernels we have seen, so we can have a unique ;; list for each kernel @@ -200,9 +216,9 @@ new-kernel k) k))))) - (hash-table-put! automaton - (make-trans-key kernel gs) - unique-kernel) + (add-lr0-transition! automaton-term automaton-non-term + (make-trans-key kernel gs) + unique-kernel) ; (printf "~a -> ~a on ~a~n" ; (kernel->string kernel) ; (kernel->string unique-kernel) @@ -239,7 +255,7 @@ (seen-kernels null)) (cond ((and (empty-queue? new-kernels) (null? old-kernels)) - (make-lr0 automaton (list->vector (reverse! seen-kernels)) epsilons)) + (make-lr0 automaton-term automaton-non-term (list->vector (reverse! seen-kernels)) epsilons)) ((null? old-kernels) (loop (deq! new-kernels) seen-kernels)) (else diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 6e83215..395650d 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -41,7 +41,7 @@ (define (build-parser filename src-pos suppress input-terms start end assocs prods runtime) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos)) - (table (build-table grammar filename suppress)) + (table (build-table grammar filename suppress)) (table-code `((lambda (table-list) (let ((v (list->vector table-list))) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index 61ca87a..be176c5 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -12,6 +12,19 @@ (provide build-table) + + (define (bit-vector-for-each f bv) + (letrec ((for-each + (lambda (bv number) + (cond + ((= 0 bv) (void)) + ((= 1 (bitwise-and 1 bv)) + (f number) + (for-each (arithmetic-shift bv -1) (add1 number))) + (else (for-each (arithmetic-shift bv -1) (add1 number))))))) + (for-each bv 0))) + + ;; print-entry: symbol * action * output-port -> ;; prints the action a for lookahead sym to port (define (print-entry sym a port) @@ -204,7 +217,7 @@ ;; term/non-term index (with the non-terms coming first) ;; buile-table: grammar * string -> action2d-array (define (build-table g file suppress) - (let* ((a (build-lr0-automaton g)) + (let* ((a (time (build-lr0-automaton g))) (terms (grammar-terms g)) (non-terms (grammar-non-terms g)) (get-term (list->vector terms)) @@ -229,7 +242,6 @@ (else (if (not (equal? a old)) (array2d-set! v i1 i2 (list a old)))))))) (get-lookahead (compute-LA a g))) - (for-each-state (lambda (state) (let loop ((i 0)) @@ -256,11 +268,11 @@ (for-each (lambda (item) - (for-each - (lambda (t) + (bit-vector-for-each + (lambda (term-index) (array2d-add! table (kernel-index state) - (+ num-non-terms (gram-sym-index t)) + (+ num-non-terms term-index) (cond ((not (start-item? item)) (make-reduce