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 ;; Things that operate on grammar symbols
gram-sym-symbol gram-sym-index term-prec gram-sym->string 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 ;; Things that work on precs
prec-num prec-assoc prec-num prec-assoc
@ -142,6 +143,12 @@
(define (gram-sym->string gs) (define (gram-sym->string gs)
(symbol->string (gram-sym-symbol 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 --------------------------- ;; ------------------------- Precedences ---------------------------
;; a precedence declaration. the sym should be 'left 'right or 'nonassoc ;; 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) (provide digraph)
(define (zero-thunk) 0)
;; digraph: ;; 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) ;; -> ('a -> 'b)
;; 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)}
@ -14,18 +16,33 @@
(letrec ( (letrec (
;; Will map elements of 'a to 'b sets ;; Will map elements of 'a to 'b sets
(results (make-hash-table 'equal)) (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. ;; Maps elements of 'a to integers.
(N (make-hash-table 'equal)) (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))) (set-N (lambda (x d) (hash-table-put! N x d)))
(stack null) ; (stack null)
(push (lambda (x) (set! stack (cons x stack)))) ; (push (lambda (x)
(pop (lambda () (begin0 (car stack) (set! stack (cdr stack))))) ; (set! stack (cons x stack))))
(depth (lambda () (length 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: 'a ->
(traverse (traverse
(lambda (x) (lambda (x)

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

@ -11,20 +11,17 @@
(provide compute-LA) (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) ;; compute-DR: LR0-automaton * grammar -> (trans-key -> term list)
;; computes for each state, non-term transition pair, the terminals ;; computes for each state, non-term transition pair, the terminals
;; which can transition out of the resulting state ;; which can transition out of the resulting state
(define (compute-DR a g) (define (compute-DR a g)
(lambda (tk) (lambda (tk)
(let ((r (run-automaton (trans-key-st tk) (trans-key-gs tk) a))) (let ((r (run-automaton (trans-key-st tk) (trans-key-gs tk) a)))
(filter (term-list->bit-vector
(lambda (term) (filter
(run-automaton r term a)) (lambda (term)
(grammar-terms g))))) (run-automaton r term a))
(grammar-terms g))))))
;; compute-reads: ;; compute-reads:
;; LR0-automaton * grammar -> (trans-key -> trans-key list) ;; LR0-automaton * grammar -> (trans-key -> trans-key list)
@ -41,12 +38,11 @@
(define (compute-read a g) (define (compute-read a g)
(let* ((dr (compute-DR a g)) (let* ((dr (compute-DR a g))
(reads (compute-reads a g))) (reads (compute-reads a g)))
(digraph (filter (lambda (x) (non-term? (trans-key-gs x))) (digraph (get-mapped-lr0-non-term-keys a)
(hash-table-map (lr0-transitions a) (lambda (k v) k)))
reads reads
dr dr
(union term<?) bitwise-ior
null))) (lambda () 0))))
;; comput-includes-and-lookback: ;; comput-includes-and-lookback:
@ -60,7 +56,6 @@
(lookback (make-array2d num-states (lookback (make-array2d num-states
(grammar-num-prods g) (grammar-num-prods g)
null))) null)))
(for-each-state (for-each-state
(lambda (state) (lambda (state)
(for-each (for-each
@ -70,26 +65,21 @@
(let loop ((i (make-item prod 0)) (let loop ((i (make-item prod 0))
(p state)) (p state))
(if (and p i) (if (and p i)
(begin (let ((new-i (move-dot-right i))
(if (and (non-term? (sym-at-dot i)) (next-sym (sym-at-dot i)))
(nullable-after-dot? (move-dot-right i) (if (and (non-term? next-sym)
g)) (nullable-after-dot? new-i g))
(array2d-add! includes (array2d-add! includes
(kernel-index p) (kernel-index p)
(gram-sym-index (gram-sym-index next-sym)
(sym-at-dot i)) (make-trans-key state non-term)))
(make-trans-key (if (not new-i)
state
non-term)))
(if (not (move-dot-right i))
(array2d-add! lookback (array2d-add! lookback
(kernel-index p) (kernel-index p)
(prod-index prod) (prod-index prod)
(make-trans-key (make-trans-key state non-term)))
state (loop new-i
non-term))) (run-automaton p next-sym a))))))
(loop (move-dot-right i)
(run-automaton p (sym-at-dot i) a))))))
(get-nt-prods g non-term))) (get-nt-prods g non-term)))
non-terms)) non-terms))
a) a)
@ -106,21 +96,20 @@
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term list) ;; compute-follow: LR0-automaton * grammar -> (trans-key -> term list)
(define (compute-follow a g includes) (define (compute-follow a g includes)
(let ((read (compute-read a g))) (let ((read (compute-read a g)))
(digraph (filter (lambda (x) (non-term? (trans-key-gs x))) (digraph (get-mapped-lr0-non-term-keys a)
(hash-table-map (lr0-transitions a) (lambda (k v) k)))
includes includes
read read
(union term<?) bitwise-ior
null))) (lambda () 0))))
;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term list) ;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term list)
(define (compute-LA a g) (define (compute-LA a g)
(let-values (((includes lookback) (compute-includes-and-lookback a g))) (let-values (((includes lookback) (time (compute-includes-and-lookback a g))))
(let ((follow (compute-follow a g includes))) (let ((follow (time (compute-follow a g includes))))
(lambda (k p) (lambda (k p)
(let* ((l (lookback k p)) (let* ((l (lookback k p))
(f (map follow l))) (f (map follow l)))
(apply append f)))))) (apply bitwise-ior (cons 0 f)))))))
(define (print-DR dr a g) (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")) (lib "list.ss"))
(provide union build-lr0-automaton run-automaton (struct trans-key (st gs)) (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) kernel-items kernel-index for-each-state)
(define (union comp<?) (define (union comp<?)
@ -34,8 +34,9 @@
;; trans-key = (make-trans-key kernel gram-sym) ;; trans-key = (make-trans-key kernel gram-sym)
(define-struct kernel (items index) (make-inspector)) (define-struct kernel (items index) (make-inspector))
(define-struct trans-key (st gs) (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 ;; Iteration over the states in an automaton
(define (for-each-state f a) (define (for-each-state f a)
(let* ((states (lr0-states a)) (let* ((states (lr0-states a))
@ -54,13 +55,27 @@
(kernel-items k)) (kernel-items k))
"}"))) "}")))
(define (false-thunk) #f)
;; run-automaton: kernel * gram-sym * LR0-automaton -> kernel | #f ;; run-automaton: kernel * gram-sym * LR0-automaton -> kernel | #f
;; returns the state that the transition trans-key provides or #f ;; returns the state that the transition trans-key provides or #f
;; if there is no such state ;; if there is no such state
(define (run-automaton k s a) (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 ;; 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)
@ -87,7 +102,7 @@
(get-nt-prods grammar nt)))) (get-nt-prods grammar nt))))
(lambda (nt) (list nt)) (lambda (nt) (list nt))
(union non-term<?) (union non-term<?)
null)) (lambda () null)))
;; closure: LR1-item list -> LR1-item list ;; closure: LR1-item list -> LR1-item list
;; Creates a set of items containing i s.t. if A -> n.Xm is in it, ;; 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 ;; 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 ;; keeps the kernels we have seen, so we can have a unique
;; list for each kernel ;; list for each kernel
@ -200,9 +216,9 @@
new-kernel new-kernel
k) k)
k))))) k)))))
(hash-table-put! automaton (add-lr0-transition! automaton-term automaton-non-term
(make-trans-key kernel gs) (make-trans-key kernel gs)
unique-kernel) unique-kernel)
; (printf "~a -> ~a on ~a~n" ; (printf "~a -> ~a on ~a~n"
; (kernel->string kernel) ; (kernel->string kernel)
; (kernel->string unique-kernel) ; (kernel->string unique-kernel)
@ -239,7 +255,7 @@
(seen-kernels null)) (seen-kernels null))
(cond (cond
((and (empty-queue? new-kernels) (null? old-kernels)) ((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) ((null? old-kernels)
(loop (deq! new-kernels) seen-kernels)) (loop (deq! new-kernels) seen-kernels))
(else (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) (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)) (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 (table-code
`((lambda (table-list) `((lambda (table-list)
(let ((v (list->vector 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) (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 -> ;; print-entry: symbol * action * output-port ->
;; prints the action a for lookahead sym to port ;; prints the action a for lookahead sym to port
(define (print-entry sym a port) (define (print-entry sym a port)
@ -204,7 +217,7 @@
;; term/non-term index (with the non-terms coming first) ;; term/non-term index (with the non-terms coming first)
;; buile-table: grammar * string -> action2d-array ;; buile-table: grammar * string -> action2d-array
(define (build-table g file suppress) (define (build-table g file suppress)
(let* ((a (build-lr0-automaton g)) (let* ((a (time (build-lr0-automaton g)))
(terms (grammar-terms g)) (terms (grammar-terms g))
(non-terms (grammar-non-terms g)) (non-terms (grammar-non-terms g))
(get-term (list->vector terms)) (get-term (list->vector terms))
@ -229,7 +242,6 @@
(else (if (not (equal? a old)) (else (if (not (equal? a old))
(array2d-set! v i1 i2 (list a old)))))))) (array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (compute-LA a g))) (get-lookahead (compute-LA a g)))
(for-each-state (for-each-state
(lambda (state) (lambda (state)
(let loop ((i 0)) (let loop ((i 0))
@ -256,11 +268,11 @@
(for-each (for-each
(lambda (item) (lambda (item)
(for-each (bit-vector-for-each
(lambda (t) (lambda (term-index)
(array2d-add! table (array2d-add! table
(kernel-index state) (kernel-index state)
(+ num-non-terms (gram-sym-index t)) (+ num-non-terms term-index)
(cond (cond
((not (start-item? item)) ((not (start-item? item))
(make-reduce (make-reduce

Write Preview
Loading…
Cancel
Save