*** empty log message ***

original commit: 8a774b04bc0a1d916fa10955d608b77ea10e001d
tokens
Scott Owens 20 years ago
parent 75ba3a3f22
commit b5dd2db7e8

@ -4,8 +4,6 @@
(require "lr0.ss"
"grammar.ss"
"array2d.ss"
"graph.ss"
(lib "list.ss")
(lib "class.ss"))
@ -42,11 +40,9 @@
(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))))
reads
dr
(send a get-num-states))))
;; 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)
@ -125,11 +121,9 @@
(digraph-tk->terml (send a get-mapped-non-term-keys)
includes
read
(send a get-num-states)
(send g get-num-terms)
(send g get-num-non-terms))))
(send a get-num-states))))
;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set)
;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
;; output term set is represented in bit-vector form
(define (compute-LA a g)
(let* ((includes (compute-includes a g))
@ -202,43 +196,51 @@
(gram-sym-symbol (trans-key-gs p))))
r))
;; init-tk-map : int -> (vectorof hashtable?)
(define (init-tk-map n)
(let ((v (make-vector n #f)))
(let loop ((i (sub1 (vector-length v))))
(when (>= i 0)
(vector-set! v i (make-hash-table))
(loop (sub1 i))))
v))
;; lookup-tk-map : (vectorof (symbol? int hashtable)) -> trans-key? -> int
(define (lookup-tk-map map)
(lambda (tk)
(let ((st (trans-key-st tk))
(gs (trans-key-gs tk)))
(hash-table-get (vector-ref map (kernel-index st))
(gram-sym-symbol gs)
(lambda () 0)))))
;; add-tk-map : (vectorof (symbol? int hashtable)) -> trans-key int ->
(define (add-tk-map map)
(lambda (tk v)
(let ((st (trans-key-st tk))
(gs (trans-key-gs tk)))
(hash-table-put! (vector-ref map (kernel-index st))
(gram-sym-symbol gs)
v))))
;; digraph-tk->terml:
;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
;; -> (trans-key -> term list)
;; DeRemer and Pennello 1982
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
;; A specialization of digraph in the file graph.ss
(define (digraph-tk->terml nodes edges f- num-states num-terms num-non-terms)
(define (digraph-tk->terml nodes edges f- num-states)
(letrec (
;; Will map elements of trans-key to term sets represented as bit vectors
(results-terms (make-array2d num-states num-terms 0))
(results-non-terms (make-array2d num-states num-non-terms 0))
(results (init-tk-map num-states))
;; Maps elements of trans-keys to integers.
(N-terms (make-array2d num-states num-terms 0))
(N-non-terms (make-array2d num-states num-non-terms 0))
(lookup-tk-map
(lambda (map-term map-non-term)
(lambda (tk)
(let ((st (trans-key-st tk))
(gs (trans-key-gs tk)))
(if (term? gs)
(array2d-ref map-term (kernel-index st) (term-index gs))
(array2d-ref map-non-term (kernel-index st) (non-term-index gs)))))))
(add-tk-map
(lambda (map-term map-non-term)
(lambda (tk v)
(let ((st (trans-key-st tk))
(gs (trans-key-gs tk)))
(if (term? gs)
(array2d-set! map-term (kernel-index st) (term-index gs) v)
(array2d-set! map-non-term (kernel-index st) (non-term-index gs) v))))))
(N (init-tk-map num-states))
(get-N (lookup-tk-map N-terms N-non-terms))
(set-N (add-tk-map N-terms N-non-terms))
(get-f (lookup-tk-map results-terms results-non-terms))
(set-f (add-tk-map results-terms results-non-terms))
(get-N (lookup-tk-map N))
(set-N (add-tk-map N))
(get-f (lookup-tk-map results))
(set-f (add-tk-map results))
(stack null)
(push (lambda (x)
@ -257,20 +259,20 @@
(set-N x d)
(set-f x (f- x))
(for-each (lambda (y)
(if (= 0 (get-N y))
(traverse y))
(when (= 0 (get-N y))
(traverse y))
(set-f x (bitwise-ior (get-f x) (get-f y)))
(set-N x (min (get-N x) (get-N y))))
(edges x))
(if (= d (get-N x))
(let loop ((p (pop)))
(set-N p +inf.0)
(set-f p (get-f x))
(if (not (equal? x p))
(loop (pop)))))))))
(when (= d (get-N x))
(let loop ((p (pop)))
(set-N p +inf.0)
(set-f p (get-f x))
(unless (equal? x p)
(loop (pop)))))))))
(for-each (lambda (x)
(if (= 0 (get-N x))
(traverse x)))
(when (= 0 (get-N x))
(traverse x)))
nodes)
get-f))
)

@ -4,7 +4,6 @@
(require "grammar.ss"
"graph.ss"
"array2d.ss"
(lib "list.ss")
(lib "class.ss"))
@ -43,41 +42,76 @@
;; build-transition-table : int (listof (cons/c trans-key X) ->
;; (vectorof (symbol X hashtable))
(define (build-transition-table num-states assoc)
(let ((transitions (make-vector num-states #f)))
(let loop ((i (sub1 (vector-length transitions))))
(when (>= i 0)
(vector-set! transitions i (make-hash-table))
(loop (sub1 i))))
(for-each
(lambda (trans-key/kernel)
(let ((tk (car trans-key/kernel)))
(hash-table-put! (vector-ref transitions (kernel-index (trans-key-st tk)))
(gram-sym-symbol (trans-key-gs tk))
(cdr trans-key/kernel))))
assoc)
transitions))
;; reverse-assoc : (listof (cons/c trans-key? kernel?)) ->
;; (listof (cons/c trans-key? (listof kernel?)))
(define (reverse-assoc assoc)
(let ((reverse-hash (make-hash-table 'equal))
(hash-table-add!
(lambda (ht k v)
(hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
(for-each
(lambda (trans-key/kernel)
(let ((tk (car trans-key/kernel)))
(hash-table-add! reverse-hash
(make-trans-key (cdr trans-key/kernel)
(trans-key-gs tk))
(trans-key-st tk))))
assoc)
(hash-table-map reverse-hash cons)))
;; kernel-list-remove-duplicates
;; LR0-automaton = object of class lr0%
(define lr0%
(class object%
(super-instantiate ())
;; Hash tables that map a trans-keys to a kernel
(init term-hash non-term-hash)
(init-field states epsilons num-terms num-non-terms)
(define term-transitions (make-lr0-table term-hash (vector-length states) num-terms #f))
(define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms #f))
;; term-assoc : (listof (cons/c trans-key? kernel?))
;; non-term-assoc : (listof (cons/c trans-key? kernel?))
;; states : (vectorof kernel?)
;; epsilons : ???
(init-field term-assoc non-term-assoc states epsilons)
(define reverse-term-hash (reverse-hash term-hash))
(define reverse-non-term-hash (reverse-hash non-term-hash))
(define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms null))
(define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms null))
(define transitions (build-transition-table (vector-length states)
(append term-assoc non-term-assoc)))
(define mapped-non-terms
(hash-table-map non-term-hash (lambda (k v) k)))
(define reverse-term-assoc (reverse-assoc term-assoc))
(define reverse-non-term-assoc (reverse-assoc non-term-assoc))
(define reverse-transitions
(build-transition-table (vector-length states)
(append reverse-term-assoc reverse-non-term-assoc)))
(define reverse-mapped-non-terms
(hash-table-map reverse-non-term-hash (lambda (k v) k)))
(define mapped-non-terms (map car non-term-assoc))
(define/public (get-mapped-non-term-keys)
mapped-non-terms)
(define/public (get-states)
states)
(define/public (get-num-states)
(vector-length states))
(define/public (get-epsilon-trans)
epsilons)
(define/public (get-transitions)
(append term-assoc non-term-assoc))
;; for-each-state : (state ->) ->
;; Iteration over the states in an automaton
(define/public (for-each-state f)
(let ((num-states (vector-length states)))
@ -87,46 +121,24 @@
(f (vector-ref states i))
(loop (add1 i)))))))
;; run-automaton: kernel * gram-sym -> kernel | #f
;; returns the state that the transition trans-key provides or #f
;; if there is no such state
;; run-automaton: kernel? gram-sym? -> (union kernel #f)
;; returns the state reached from state k on input s, or #f when k
;; has no transition on s
(define/public (run-automaton k s)
(if (term? s)
(array2d-ref term-transitions (kernel-index k) (term-index s))
(array2d-ref non-term-transitions (kernel-index k) (non-term-index s))))
(hash-table-get (vector-ref transitions (kernel-index k))
(gram-sym-symbol s)
(lambda () #f)))
;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel)
;; returns the list of states that can reach k by transitioning on s.
(define/public (run-automaton-back k s)
(apply append
(if (term? s)
(map (lambda (k)
(array2d-ref reverse-term-transitions (kernel-index k) (term-index s)))
k)
(map (lambda (k)
(array2d-ref reverse-non-term-transitions (kernel-index k) (non-term-index s)))
k))))))
(define (make-lr0-table auto-hash states syms def)
(let ((t (make-array2d states syms def)))
(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))
(define (reverse-hash hash)
(let ((reverse-hash (make-hash-table 'equal))
(hash-table-add!
(lambda (ht k v)
(hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
(hash-table-for-each hash
(lambda (k v)
(hash-table-add! reverse-hash
(make-trans-key v (trans-key-gs k))
(trans-key-st k))))
reverse-hash))
(map
(lambda (k)
(hash-table-get (vector-ref reverse-transitions (kernel-index k))
(gram-sym-symbol s)
(lambda () null)))
k)))))
(define (union comp<?)
(letrec ((union
@ -153,27 +165,14 @@
(kernel-items 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)
; (printf "LR(0) automaton:~n")
(letrec (
(terms (list->vector (send grammar get-terms)))
(non-terms (list->vector (send grammar get-non-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))
(grammar-symbols (append (send grammar get-non-terms)
(send grammar get-terms)))
;; first-non-term: non-term -> non-term list
;; given a non-terminal symbol C, return those non-terminal
;; symbols A s.t. C -> An for some string of terminals and
@ -218,8 +217,8 @@
;; maps trans-keys to kernels
(automaton-term (make-hash-table 'equal))
(automaton-non-term (make-hash-table 'equal))
(automaton-term null)
(automaton-non-term null)
;; keeps the kernels we have seen, so we can have a unique
;; list for each kernel
@ -235,12 +234,11 @@
(goto
(lambda (kernel)
(let (
;; maps each gram-syms to a list of items
(table (make-vector num-gram-syms null))
;; maps a gram-syms to a list of items
(table (make-hash-table))
;; add-item!:
;; (item list) vector * item ->
;; (symbol (listof item) hashtable) item? ->
;; adds i into the table grouped with the grammar
;; symbol following its dot
(add-item!
@ -248,17 +246,14 @@
(let ((gs (sym-at-dot i)))
(cond
(gs
(let* ((add (if (term? gs)
num-non-terms
0))
(already
(vector-ref table
(+ add
(gram-sym-index gs)))))
(if (not (member i already))
(vector-set! table
(+ add (gram-sym-index gs))
(cons i already)))))
(let ((already
(hash-table-get table
(gram-sym-symbol gs)
(lambda () null))))
(unless (member i already)
(hash-table-put! table
(gram-sym-symbol gs)
(cons i already)))))
((= 0 (vector-length (prod-rhs (item-prod i))))
(let ((current (hash-table-get epsilons
kernel
@ -301,34 +296,34 @@
new-kernel
k)
k)))))
(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)
; (gram-sym-symbol gs))
(cond
((term? gs)
(set! automaton-term (cons (cons (make-trans-key kernel gs)
unique-kernel)
automaton-term)))
(else
(set! automaton-non-term (cons (cons (make-trans-key kernel gs)
unique-kernel)
automaton-non-term))))
#;(printf "~a -> ~a on ~a~n"
(kernel->string kernel)
(kernel->string unique-kernel)
(gram-sym-symbol gs))
(if new
unique-kernel
#f)))
(let loop ((i 0))
(let loop ((gsyms grammar-symbols))
(cond
((< i num-non-terms)
(let ((items (vector-ref table i)))
(cond
((null? items) (loop (add1 i)))
(else
(cons (list (vector-ref non-terms i) items)
(loop (add1 i)))))))
((< i num-gram-syms)
(let ((items (vector-ref table i)))
(cond
((null? items) (loop (add1 i)))
(else
(cons (list (vector-ref terms (- i num-non-terms))
items)
(loop (add1 i)))))))
(else null))))))))
((null? gsyms) null)
(else
(let ((items (hash-table-get table
(gram-sym-symbol (car gsyms))
(lambda () null))))
(cond
((null? items) (loop (cdr gsyms)))
(else
(cons (list (car gsyms) items)
(loop (cdr gsyms))))))))))))))
(starts
(map (lambda (init-prod) (list (make-item init-prod 0)))
@ -350,9 +345,7 @@
automaton-term
automaton-non-term
(list->vector (reverse! seen-kernels))
epsilons
(vector-length terms)
num-non-terms))
epsilons))
((null? old-kernels)
(loop (deq! new-kernels) seen-kernels))
(else

@ -224,29 +224,29 @@
;; build-table: grammar string bool -> parse-table
(define (build-table g file suppress)
(let* ((a (build-lr0-automaton g))
(term-list (send g get-terms))
(term-vector (list->vector term-list))
(non-term-list (send g get-non-terms))
(term-vector (list->vector (send g get-terms)))
(end-terms (send g get-end-terms))
(table (make-parse-table (send a get-num-states)))
(get-lookahead (compute-LA a g)))
(get-lookahead (time (compute-LA a g))))
(for-each
(lambda (trans-key/state)
(let ((from-state-index (kernel-index (trans-key-st (car trans-key/state))))
(gs (trans-key-gs (car trans-key/state)))
(to-state (cdr trans-key/state)))
(table-add! table from-state-index gs
(cond
((non-term? gs)
(make-goto (kernel-index to-state)))
((member gs end-terms)
(make-accept))
(else
(make-shift
(kernel-index to-state)))))))
(send a get-transitions))
(send a for-each-state
(lambda (state)
(for-each
(lambda (gs)
(let ((goto (send a run-automaton state gs)))
(when goto
(table-add! table (kernel-index state) gs
(cond
((non-term? gs)
(make-goto (kernel-index goto)))
((member gs end-terms)
(make-accept))
(else
(make-shift
(kernel-index goto))))))))
(append non-term-list term-list))
(for-each
(lambda (item)
(let ((item-prod (item-prod item)))
@ -258,7 +258,6 @@
(vector-ref term-vector term-index)
(make-reduce 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)))

Loading…
Cancel
Save