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

*** empty log message ***

Browse Source 
original commit: bab7ce1c4c49987bd1e7e40abc7403e5d3541313
tokens
Scott Owens 23 years ago
parent 036a5f5104
commit d315d5a52e
6 changed files with 102 additions and 61 deletions
Show Stats Download Patch File Download Diff File

9
collects/parser-tools/private-yacc/grammar.ss
Unescape Escape View File

@ -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-term<? term<?
non-term? term? nullable? non-term<? term<?
term-list->bit-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

33
collects/parser-tools/private-yacc/graph.ss
Unescape Escape View File

@ -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)

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

@ -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<?)
null)))
bitwise-ior
(lambda () 0))))
;; comput-includes-and-lookback:
@ -60,7 +56,6 @@
(lookback (make-array2d num-states
(grammar-num-prods g)
null)))
(for-each-state
(lambda (state)
(for-each
@ -70,26 +65,21 @@
(let loop ((i (make-item prod 0))
(p state))
(if (and p i)
(begin
(if (and (non-term? (sym-at-dot i))
(nullable-after-dot? (move-dot-right i)
g))
(let ((new-i (move-dot-right i))
(next-sym (sym-at-dot i)))
(if (and (non-term? next-sym)
(nullable-after-dot? new-i g))
(array2d-add! includes
(kernel-index p)
(gram-sym-index
(sym-at-dot i))
(make-trans-key
state
non-term)))
(if (not (move-dot-right i))
(gram-sym-index next-sym)
(make-trans-key state non-term)))
(if (not new-i)
(array2d-add! lookback
(kernel-index p)
(prod-index prod)
(make-trans-key
state
non-term)))
(loop (move-dot-right i)
(run-automaton p (sym-at-dot i) a))))))
(make-trans-key state non-term)))
(loop new-i
(run-automaton p next-sym a))))))
(get-nt-prods g non-term)))
non-terms))
a)
@ -106,21 +96,20 @@
;; compute-follow: LR0-automaton * grammar -> (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<?)
null)))
bitwise-ior
(lambda () 0))))
;; compute-LA: LR0-automaton * grammar -> (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)

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

@ -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<?)
@ -34,8 +34,9 @@
;; trans-key = (make-trans-key kernel gram-sym)
(define-struct kernel (items index) (make-inspector))
(define-struct trans-key (st gs) (make-inspector))
(define-struct lr0 (transitions states epsilon-trans) (make-inspector))
(define-struct lr0 (term-transitions non-term-transitions states epsilon-trans) (make-inspector))
;; Iteration over the states in an automaton
(define (for-each-state f a)
(let* ((states (lr0-states a))
@ -54,13 +55,27 @@
(kernel-items k))
"}")))
(define (false-thunk) #f)
;; run-automaton: kernel * gram-sym * LR0-automaton -> 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<?)
null))
(lambda () null)))
;; closure: LR1-item list -> 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

2
collects/parser-tools/private-yacc/parser-builder.ss
Unescape Escape View File

@ -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)))

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

@ -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

Write Preview
Loading…
Cancel
Save