mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 8a774b04bc0a1d916fa10955d608b77ea10e001d
tokens
Scott Owens 20 years ago
parent 75ba3a3f22
commit b5dd2db7e8
3 changed files with 182 additions and 188 deletions
Show Stats Download Patch File Download Diff File

80
collects/parser-tools/private-yacc/lalr.ss
Unescape Escape View File

@ -4,8 +4,6 @@
(require "lr0.ss" (require "lr0.ss"
"grammar.ss" "grammar.ss"
"array2d.ss"
"graph.ss"
(lib "list.ss") (lib "list.ss")
(lib "class.ss")) (lib "class.ss"))
@ -44,9 +42,7 @@
(digraph-tk->terml (send a get-mapped-non-term-keys) (digraph-tk->terml (send a get-mapped-non-term-keys)
reads reads
dr dr
(send a get-num-states) (send a get-num-states))))
(send g get-num-terms)
(send g get-num-non-terms))))
;; returns the list of all k such that state k transitions to state start on the ;; returns the list of all k such that state k transitions to state start on the
;; transitions in rhs (in order) ;; transitions in rhs (in order)
(define (run-lr0-backward a rhs dot-pos start num-states) (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) (digraph-tk->terml (send a get-mapped-non-term-keys)
includes includes
read read
(send a get-num-states) (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) ;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
;; output term set is represented in bit-vector form ;; output term set is represented in bit-vector form
(define (compute-LA a g) (define (compute-LA a g)
(let* ((includes (compute-includes a g)) (let* ((includes (compute-includes a g))
@ -202,43 +196,51 @@
(gram-sym-symbol (trans-key-gs p)))) (gram-sym-symbol (trans-key-gs p))))
r)) 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: ;; digraph-tk->terml:
;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int ;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
;; -> (trans-key -> term list) ;; -> (trans-key -> term list)
;; DeRemer and Pennello 1982 ;; DeRemer and Pennello 1982
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)} ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
;; A specialization of digraph in the file graph.ss ;; 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 ( (letrec (
;; Will map elements of trans-key to term sets represented as bit vectors ;; Will map elements of trans-key to term sets represented as bit vectors
(results-terms (make-array2d num-states num-terms 0)) (results (init-tk-map num-states))
(results-non-terms (make-array2d num-states num-non-terms 0))
;; Maps elements of trans-keys to integers. ;; Maps elements of trans-keys to integers.
(N-terms (make-array2d num-states num-terms 0)) (N (init-tk-map num-states))
(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))))))
(get-N (lookup-tk-map N-terms N-non-terms)) (get-N (lookup-tk-map N))
(set-N (add-tk-map N-terms N-non-terms)) (set-N (add-tk-map N))
(get-f (lookup-tk-map results-terms results-non-terms)) (get-f (lookup-tk-map results))
(set-f (add-tk-map results-terms results-non-terms)) (set-f (add-tk-map results))
(stack null) (stack null)
(push (lambda (x) (push (lambda (x)
@ -257,19 +259,19 @@
(set-N x d) (set-N x d)
(set-f x (f- x)) (set-f x (f- x))
(for-each (lambda (y) (for-each (lambda (y)
(if (= 0 (get-N y)) (when (= 0 (get-N y))
(traverse y)) (traverse y))
(set-f x (bitwise-ior (get-f x) (get-f y))) (set-f x (bitwise-ior (get-f x) (get-f y)))
(set-N x (min (get-N x) (get-N y)))) (set-N x (min (get-N x) (get-N y))))
(edges x)) (edges x))
(if (= d (get-N x)) (when (= d (get-N x))
(let loop ((p (pop))) (let loop ((p (pop)))
(set-N p +inf.0) (set-N p +inf.0)
(set-f p (get-f x)) (set-f p (get-f x))
(if (not (equal? x p)) (unless (equal? x p)
(loop (pop))))))))) (loop (pop)))))))))
(for-each (lambda (x) (for-each (lambda (x)
(if (= 0 (get-N x)) (when (= 0 (get-N x))
(traverse x))) (traverse x)))
nodes) nodes)
get-f)) get-f))

209
collects/parser-tools/private-yacc/lr0.ss
Unescape Escape View File

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

27
collects/parser-tools/private-yacc/table.ss
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save