From a015a446e03114866feab14cce50afe17602aabb Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Wed, 1 May 2002 10:20:09 +0000 Subject: [PATCH] *** empty log message *** original commit: a4ff3b193e6908036453cf5bfcea9a9abc7ef77a --- collects/parser-tools/private-yacc/grammar.ss | 8 ++--- collects/parser-tools/private-yacc/lalr.ss | 5 +-- collects/parser-tools/private-yacc/lr0.ss | 32 +++++++++++++------ collects/parser-tools/private-yacc/table.ss | 30 +++++++++-------- 4 files changed, 45 insertions(+), 30 deletions(-) diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss index 8ec52de..dc3c992 100644 --- a/collects/parser-tools/private-yacc/grammar.ss +++ b/collects/parser-tools/private-yacc/grammar.ss @@ -14,13 +14,13 @@ (rename make-gram make-grammar) ;; Things that work on items - start-item? item-prod item-prod-index item->string + start-item? item-prod item->string sym-at-dot move-dot-right itemstring non-term? term? nullable? non-termbit-vector + term-list->bit-vector term-index non-term-index ;; Things that work on precs prec-num prec-assoc @@ -46,9 +46,7 @@ (define (export-make-item a b) (make-item a b #f)) - - (define (item-prod-index x) - (prod-index (item-prod x))) + ;; item bool ;; Lexicographic comparison on two items. diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss index c7c7849..876f8c7 100644 --- a/collects/parser-tools/private-yacc/lalr.ss +++ b/collects/parser-tools/private-yacc/lalr.ss @@ -78,8 +78,9 @@ (kernel-index p) (prod-index prod) (make-trans-key state non-term))) - (loop new-i - (run-automaton p next-sym a)))))) + (if next-sym + (loop new-i + (run-automaton p next-sym a))))))) (get-nt-prods g non-term))) non-terms)) a) diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 422add9..ea2b233 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -5,9 +5,10 @@ (require "grammar.ss" "graph.ss" + "array2d.ss" (lib "list.ss")) - (provide union build-lr0-automaton run-automaton (struct trans-key (st gs)) + (provide build-lr0-automaton run-automaton (struct trans-key (st gs)) get-mapped-lr0-non-term-keys lr0-states lr0-epsilon-trans kernel-items kernel-index for-each-state) @@ -30,11 +31,11 @@ ;; kernel = (make-kernel (LR1-item list) index) ;; the list must be kept sorted according to item 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) (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))) + (array2d-ref (lr0-term-transitions a) (kernel-index k) (term-index s)) + (array2d-ref (lr0-non-term-transitions a) (kernel-index k) (non-term-index s)))) - (define (get-mapped-lr0-non-term-keys a) - (hash-table-map (lr0-non-term-transitions a) (lambda (k v) k))) + (define get-mapped-lr0-non-term-keys lr0-mapped-non-terms) (define (add-lr0-transition! ttable nttable key value) (hash-table-put! @@ -74,6 +73,16 @@ nttable) key value)) + + (define (make-lr0-table auto-hash states syms) + (let ((t (make-array2d states syms #f))) + (hash-table-map auto-hash + (lambda (k v) + (array2d-set! t + (kernel-index (trans-key-st k)) + (gram-sym-index (trans-key-gs k)) + v))) + t)) ;; build-LR0-automaton: grammar -> LR0-automaton @@ -151,7 +160,6 @@ ;; maps each gram-syms to a list of items (table (make-vector num-gram-syms null)) - (epsilons (make-hash-table 'equal)) ;; add-item!: ;; (item list) vector * item -> @@ -255,7 +263,11 @@ (seen-kernels null)) (cond ((and (empty-queue? new-kernels) (null? old-kernels)) - (make-lr0 automaton-term automaton-non-term (list->vector (reverse! seen-kernels)) epsilons)) + (make-lr0 (make-lr0-table automaton-term (length seen-kernels) (vector-length terms)) + (make-lr0-table automaton-non-term (length seen-kernels) (vector-length non-terms)) + (hash-table-map automaton-non-term (lambda (k v) k)) + (list->vector (reverse! seen-kernels)) + epsilons)) ((null? old-kernels) (loop (deq! new-kernels) seen-kernels)) (else diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index be176c5..1dd0200 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -242,6 +242,7 @@ (else (if (not (equal? a old)) (array2d-set! v i1 i2 (list a old)))))))) (get-lookahead (compute-LA a g))) + (time (for-each-state (lambda (state) (let loop ((i 0)) @@ -268,26 +269,29 @@ (for-each (lambda (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 - (item-prod-index item) - (gram-sym-index (prod-lhs (item-prod item))) - (vector-length (prod-rhs (item-prod item)))))))) - (get-lookahead state (item-prod 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 (lr0-epsilon-trans a) state (lambda () null)) (filter (lambda (item) (not (move-dot-right item))) (kernel-items state))))) - a) + a)) + (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)