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

Modernize cfg-parser from mzscheme to Racket libraries.

Browse Source 
original commit: 4ff4c677bd354cb1a26adf0c3e0e4de03a7a3939
tokens
Danny Yoo 12 years ago
parent f4d9e18360 d6f9d98289
commit 33ebcd7a78
5 changed files with 972 additions and 978 deletions
Show Stats Download Patch File Download Diff File

1435
collects/algol60/cfg-parser.rkt
View File

File diff suppressed because it is too large Load Diff

4
collects/parser-tools/private-lex/token.rkt
Unescape Escape View File

@ -83,7 +83,7 @@
(define-syntax define-tokens (make-define-tokens #f)) (define-syntax define-tokens (make-define-tokens #f))
(define-syntax define-empty-tokens (make-define-tokens #t)) (define-syntax define-empty-tokens (make-define-tokens #t))
(define-struct position (offset line col)) (define-struct position (offset line col) #f)
(define-struct position-token (token start-pos end-pos)) (define-struct position-token (token start-pos end-pos) #f)
) )

89
collects/parser-tools/private-yacc/graph.rkt
Unescape Escape View File

@ -12,55 +12,50 @@
;; We use a hash-table to represent the result function 'a -> 'b set, so ;; We use a hash-table to represent the result function 'a -> 'b set, so
;; the values of type 'a must be comparable with eq?. ;; the values of type 'a must be comparable with eq?.
(define (digraph nodes edges f- union fail) (define (digraph nodes edges f- union fail)
(letrec ( (letrec [
;; Will map elements of 'a to 'b sets ;; Will map elements of 'a to 'b sets
(results (make-hash-table)) (results (make-hash-table))
(f (lambda (x) (hash-table-get results x 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)) (N (make-hash-table))
(get-N (lambda (x) (hash-table-get N x zero-thunk))) (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) (push (lambda (x)
(set! stack (cons x stack)))) (set! stack (cons x stack))))
(pop (lambda () (pop (lambda ()
(begin0 (begin0
(car stack) (car stack)
(set! stack (cdr stack))))) (set! stack (cdr stack)))))
(depth (lambda () (length stack))) (depth (lambda () (length stack)))
;; traverse: 'a -> ;; traverse: 'a ->
(traverse (traverse
(lambda (x) (lambda (x)
(push x) (push x)
(let ((d (depth))) (let ((d (depth)))
(set-N x d) (set-N x d)
(hash-table-put! results x (f- x)) (hash-table-put! results x (f- x))
(for-each (lambda (y) (for-each (lambda (y)
(if (= 0 (get-N y)) (if (= 0 (get-N y))
(traverse y)) (traverse y))
(hash-table-put! results (hash-table-put! results
x x
(union (f x) (f y))) (union (f x) (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)) (if (= d (get-N x))
(let loop ((p (pop))) (let loop ((p (pop)))
(set-N p +inf.0) (set-N p +inf.0)
(hash-table-put! results p (f x)) (hash-table-put! results p (f x))
(if (not (eq? x p)) (if (not (eq? x p))
(loop (pop))))))))) (loop (pop))))))))]
(for-each (lambda (x) (for-each (lambda (x)
(if (= 0 (get-N x)) (if (= 0 (get-N x))
(traverse x))) (traverse x)))
nodes) nodes)
f)) f))
) )

84
collects/parser-tools/private-yacc/lalr.rkt
Unescape Escape View File

@ -38,7 +38,7 @@
;; output term set is represented in bit-vector form ;; output term set is represented in bit-vector form
(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-tk->terml (send a get-mapped-non-term-keys) (digraph-tk->terml (send a get-mapped-non-term-keys)
reads reads
dr dr
@ -127,13 +127,12 @@
;; 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))
(lookback (compute-lookback a g)) (lookback (compute-lookback a g))
(follow (compute-follow a g includes))) (follow (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 bitwise-ior (cons 0 f)))))) (apply bitwise-ior (cons 0 f))))))
(define (print-DR dr a g) (define (print-DR dr a g)
(print-input-st-sym dr "DR" a g print-output-terms)) (print-input-st-sym dr "DR" a g print-output-terms))
@ -192,8 +191,8 @@
(map (map
(lambda (p) (lambda (p)
(list (list
(kernel-index (trans-key-st p)) (kernel-index (trans-key-st p))
(gram-sym-symbol (trans-key-gs p)))) (gram-sym-symbol (trans-key-gs p))))
r)) r))
;; init-tk-map : int -> (vectorof hashtable?) ;; init-tk-map : int -> (vectorof hashtable?)
@ -230,52 +229,49 @@
;; 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.rkt ;; A specialization of digraph in the file graph.rkt
(define (digraph-tk->terml nodes edges f- num-states) (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 (init-tk-map num-states)) (results (init-tk-map num-states))
;; Maps elements of trans-keys to integers. ;; Maps elements of trans-keys to integers.
(N (init-tk-map num-states)) (N (init-tk-map num-states))
(get-N (lookup-tk-map N)) (get-N (lookup-tk-map N))
(set-N (add-tk-map N)) (set-N (add-tk-map N))
(get-f (lookup-tk-map results)) (get-f (lookup-tk-map results))
(set-f (add-tk-map results)) (set-f (add-tk-map results))
(stack null) (stack null)
(push (lambda (x) (push (lambda (x)
(set! stack (cons x stack)))) (set! stack (cons x stack))))
(pop (lambda () (pop (lambda ()
(begin0 (begin0
(car stack) (car stack)
(set! stack (cdr stack))))) (set! stack (cdr stack)))))
(depth (lambda () (length stack))) (depth (lambda () (length stack)))
;; traverse: 'a -> ;; traverse: 'a ->
(traverse (traverse
(lambda (x) (lambda (x)
(push x) (push x)
(let ((d (depth))) (let ((d (depth)))
(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)
(when (= 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))
(when (= 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))
(unless (equal? x p) (unless (equal? x p)
(loop (pop))))))))) (loop (pop))))))))]
(for-each (lambda (x) (for-each (lambda (x)
(when (= 0 (get-N x)) (when (= 0 (get-N x))
(traverse x))) (traverse x)))
nodes) nodes)
get-f)) get-f))
) )

338
collects/parser-tools/private-yacc/lr0.rkt
Unescape Escape View File

@ -62,9 +62,9 @@
;; (listof (cons/c trans-key? (listof kernel?))) ;; (listof (cons/c trans-key? (listof kernel?)))
(define (reverse-assoc assoc) (define (reverse-assoc assoc)
(let ((reverse-hash (make-hash-table 'equal)) (let ((reverse-hash (make-hash-table 'equal))
(hash-table-add! (hash-table-add!
(lambda (ht k v) (lambda (ht k v)
(hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null))))))) (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
(for-each (for-each
(lambda (trans-key/kernel) (lambda (trans-key/kernel)
(let ((tk (car trans-key/kernel))) (let ((tk (car trans-key/kernel)))
@ -99,13 +99,13 @@
(define mapped-non-terms (map car non-term-assoc)) (define mapped-non-terms (map car non-term-assoc))
(define/public (get-mapped-non-term-keys) (define/public (get-mapped-non-term-keys)
mapped-non-terms) mapped-non-terms)
(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) (define/public (get-transitions)
(append term-assoc non-term-assoc)) (append term-assoc non-term-assoc))
@ -113,12 +113,12 @@
;; for-each-state : (state ->) -> ;; 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)))
(let loop ((i 0)) (let loop ((i 0))
(if (< i num-states) (if (< i num-states)
(begin (begin
(f (vector-ref states i)) (f (vector-ref states i))
(loop (add1 i))))))) (loop (add1 i)))))))
;; run-automaton: kernel? gram-sym? -> (union kernel #f) ;; run-automaton: kernel? gram-sym? -> (union kernel #f)
;; returns the state reached from state k on input s, or #f when k ;; returns the state reached from state k on input s, or #f when k
@ -131,28 +131,28 @@
;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel) ;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel)
;; returns the list of states that can reach k by transitioning on s. ;; 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
(map (map
(lambda (k) (lambda (k)
(hash-table-get (vector-ref reverse-transitions (kernel-index k)) (hash-table-get (vector-ref reverse-transitions (kernel-index k))
(gram-sym-symbol s) (gram-sym-symbol s)
(lambda () null))) (lambda () null)))
k))))) k)))))
(define (union comp<?) (define (union comp<?)
(letrec ((union (letrec ((union
(lambda (l1 l2) (lambda (l1 l2)
(cond (cond
((null? l1) l2) ((null? l1) l2)
((null? l2) l1) ((null? l2) l1)
(else (let ((c1 (car l1)) (else (let ((c1 (car l1))
(c2 (car l2))) (c2 (car l2)))
(cond (cond
((comp<? c1 c2) ((comp<? c1 c2)
(cons c1 (union (cdr l1) l2))) (cons c1 (union (cdr l1) l2)))
((comp<? c2 c1) ((comp<? c2 c1)
(cons c2 (union l1 (cdr l2)))) (cons c2 (union l1 (cdr l2))))
(else (union (cdr l1) l2))))))))) (else (union (cdr l1) l2)))))))))
union)) union))
@ -160,141 +160,141 @@
;; That is (equal? a b) <=> (eq? a b) ;; That is (equal? a b) <=> (eq? a b)
(define (kernel->string k) (define (kernel->string k)
(apply string-append (apply string-append
`("{" ,@(map (lambda (i) (string-append (item->string i) ", ")) `("{" ,@(map (lambda (i) (string-append (item->string i) ", "))
(kernel-items k)) (kernel-items k))
"}"))) "}")))
;; 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 (
(epsilons (make-hash-table 'equal)) (epsilons (make-hash-table 'equal))
(grammar-symbols (append (send grammar get-non-terms) (grammar-symbols (append (send grammar get-non-terms)
(send grammar get-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
;; non-terminals n where -> means a rightmost derivation in many ;; non-terminals n where -> means a rightmost derivation in many
;; steps. Assumes that each non-term can be reduced to a string ;; steps. Assumes that each non-term can be reduced to a string
;; of terms. ;; of terms.
(first-non-term (first-non-term
(digraph (send grammar get-non-terms) (digraph (send grammar get-non-terms)
(lambda (nt) (lambda (nt)
(filter non-term? (filter non-term?
(map (lambda (prod) (map (lambda (prod)
(sym-at-dot (make-item prod 0))) (sym-at-dot (make-item prod 0)))
(send grammar get-prods-for-non-term nt)))) (send grammar get-prods-for-non-term nt))))
(lambda (nt) (list nt)) (lambda (nt) (list nt))
(union non-term<?) (union non-term<?)
(lambda () 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,
;; X -> .o is in it too. ;; X -> .o is in it too.
(LR0-closure (LR0-closure
(lambda (i) (lambda (i)
(cond (cond
((null? i) null) ((null? i) null)
(else (else
(let ((next-gsym (sym-at-dot (car i)))) (let ((next-gsym (sym-at-dot (car i))))
(cond (cond
((non-term? next-gsym) ((non-term? next-gsym)
(cons (car i) (cons (car i)
(append (append
(apply append (apply append
(map (lambda (non-term) (map (lambda (non-term)
(map (lambda (x) (map (lambda (x)
(make-item x 0)) (make-item x 0))
(send grammar (send grammar
get-prods-for-non-term get-prods-for-non-term
non-term))) non-term)))
(first-non-term next-gsym))) (first-non-term next-gsym)))
(LR0-closure (cdr i))))) (LR0-closure (cdr i)))))
(else (else
(cons (car i) (LR0-closure (cdr i)))))))))) (cons (car i) (LR0-closure (cdr i))))))))))
;; maps trans-keys to kernels ;; maps trans-keys to kernels
(automaton-term null) (automaton-term null)
(automaton-non-term null) (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
(kernels (make-hash-table 'equal)) (kernels (make-hash-table 'equal))
(counter 0) (counter 0)
;; goto: LR1-item list -> LR1-item list list ;; goto: LR1-item list -> LR1-item list list
;; creates new kernels by moving the dot in each item in the ;; creates new kernels by moving the dot in each item in the
;; LR0-closure of kernel to the right, and grouping them by ;; LR0-closure of kernel to the right, and grouping them by
;; the term/non-term moved over. Returns the kernels not ;; the term/non-term moved over. Returns the kernels not
;; yet seen, and places the trans-keys into automaton ;; yet seen, and places the trans-keys into automaton
(goto (goto
(lambda (kernel) (lambda (kernel)
(let ( (let (
;; maps a gram-syms to a list of items ;; maps a gram-syms to a list of items
(table (make-hash-table)) (table (make-hash-table))
;; add-item!: ;; add-item!:
;; (symbol (listof item) hashtable) 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!
(lambda (table i) (lambda (table i)
(let ((gs (sym-at-dot i))) (let ((gs (sym-at-dot i)))
(cond (cond
(gs (gs
(let ((already (let ((already
(hash-table-get table (hash-table-get table
(gram-sym-symbol gs) (gram-sym-symbol gs)
(lambda () null)))) (lambda () null))))
(unless (member i already) (unless (member i already)
(hash-table-put! table (hash-table-put! table
(gram-sym-symbol gs) (gram-sym-symbol 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
kernel kernel
(lambda () null)))) (lambda () null))))
(hash-table-put! epsilons (hash-table-put! epsilons
kernel kernel
(cons i current))))))))) (cons i current)))))))))
;; Group the items of the LR0 closure of the kernel ;; Group the items of the LR0 closure of the kernel
;; by the character after the dot ;; by the character after the dot
(for-each (lambda (item) (for-each (lambda (item)
(add-item! table item)) (add-item! table item))
(LR0-closure (kernel-items kernel))) (LR0-closure (kernel-items kernel)))
;; each group is a new kernel, with the dot advanced. ;; each group is a new kernel, with the dot advanced.
;; sorts the items in a kernel so kernels can be compared ;; sorts the items in a kernel so kernels can be compared
;; with equal? for using the table kernels to make sure ;; with equal? for using the table kernels to make sure
;; only one representitive of each kernel is created ;; only one representitive of each kernel is created
(filter (filter
(lambda (x) x) (lambda (x) x)
(map (map
(lambda (i) (lambda (i)
(let* ((gs (car i)) (let* ((gs (car i))
(items (cadr i)) (items (cadr i))
(new #f) (new #f)
(new-kernel (sort (new-kernel (sort
(filter (lambda (x) x) (filter (lambda (x) x)
(map move-dot-right items)) (map move-dot-right items))
item<?)) item<?))
(unique-kernel (hash-table-get (unique-kernel (hash-table-get
kernels kernels
new-kernel new-kernel
(lambda () (lambda ()
(let ((k (make-kernel (let ((k (make-kernel
new-kernel new-kernel
counter))) counter)))
(set! new #t) (set! new #t)
(set! counter (add1 counter)) (set! counter (add1 counter))
(hash-table-put! kernels (hash-table-put! kernels
new-kernel new-kernel
k) k)
k))))) k)))))
(cond (cond
((term? gs) ((term? gs)
(set! automaton-term (cons (cons (make-trans-key kernel gs) (set! automaton-term (cons (cons (make-trans-key kernel gs)
@ -305,14 +305,14 @@
unique-kernel) unique-kernel)
automaton-non-term)))) automaton-non-term))))
#;(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)
(gram-sym-symbol gs)) (gram-sym-symbol gs))
(if new (if new
unique-kernel unique-kernel
#f))) #f)))
(let loop ((gsyms grammar-symbols)) (let loop ((gsyms grammar-symbols))
(cond (cond
((null? gsyms) null) ((null? gsyms) null)
(else (else
(let ((items (hash-table-get table (let ((items (hash-table-get table
@ -323,33 +323,33 @@
(else (else
(cons (list (car gsyms) items) (cons (list (car gsyms) items)
(loop (cdr gsyms)))))))))))))) (loop (cdr gsyms))))))))))))))
(starts (starts
(map (lambda (init-prod) (list (make-item init-prod 0))) (map (lambda (init-prod) (list (make-item init-prod 0)))
(send grammar get-init-prods))) (send grammar get-init-prods)))
(startk (startk
(map (lambda (start) (map (lambda (start)
(let ((k (make-kernel start counter))) (let ((k (make-kernel start counter)))
(hash-table-put! kernels start k) (hash-table-put! kernels start k)
(set! counter (add1 counter)) (set! counter (add1 counter))
k)) k))
starts)) starts))
(new-kernels (make-queue))) (new-kernels (make-queue)))
(let loop ((old-kernels startk) (let loop ((old-kernels startk)
(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-object lr0% (make-object lr0%
automaton-term automaton-term
automaton-non-term automaton-non-term
(list->vector (reverse seen-kernels)) (list->vector (reverse seen-kernels))
epsilons)) epsilons))
((null? old-kernels) ((null? old-kernels)
(loop (deq! new-kernels) seen-kernels)) (loop (deq! new-kernels) seen-kernels))
(else (else
(enq! new-kernels (goto (car old-kernels))) (enq! new-kernels (goto (car old-kernels)))
(loop (cdr old-kernels) (cons (car old-kernels) seen-kernels))))))) (loop (cdr old-kernels) (cons (car old-kernels) seen-kernels)))))))
(define-struct q (f l) (make-inspector)) (define-struct q (f l) (make-inspector))
(define (empty-queue? q) (define (empty-queue? q)
@ -358,12 +358,12 @@
(make-q null null)) (make-q null null))
(define (enq! q i) (define (enq! q i)
(if (empty-queue? q) (if (empty-queue? q)
(let ((i (mcons i null))) (let ((i (mcons i null)))
(set-q-l! q i) (set-q-l! q i)
(set-q-f! q i)) (set-q-f! q i))
(begin (begin
(set-mcdr! (q-l q) (mcons i null)) (set-mcdr! (q-l q) (mcons i null))
(set-q-l! q (mcdr (q-l q)))))) (set-q-l! q (mcdr (q-l q))))))
(define (deq! q) (define (deq! q)
(begin0 (begin0
(mcar (q-f q)) (mcar (q-f q))

Write Preview
Loading…
Cancel
Save