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

*** empty log message ***

Browse Source 
original commit: a8b8b4c9f8aae2ca3af3f086048be6c115defe1d
tokens
Scott Owens 23 years ago
parent 9b439ae7a6
commit 95300ddd13
6 changed files with 260 additions and 194 deletions
Show Stats Download Patch File Download Diff File

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

@ -1,37 +1,32 @@
#cs #cs
(module grammar mzscheme (module grammar mzscheme
(require (lib "class.ss"))
;; Constructs to create and access grammars, the internal ;; Constructs to create and access grammars, the internal
;; representation of the input to the parser generator. ;; representation of the input to the parser generator.
(provide (provide
(rename export-make-item make-item) make-item
make-term make-term
make-non-term make-non-term
make-prec make-prec
make-prod make-prod
(rename make-gram make-grammar)
;; Things that work on items ;; Things that work on items
start-item? item-prod item->string start-item? item-prod item->string
sym-at-dot move-dot-right move-dot-right! item<? nullable-after-dot? sym-at-dot move-dot-right item<? item-dot-pos
;; 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? non-term<? term<?
term-list->bit-vector term-index non-term-index term-list->bit-vector term-index non-term-index
;; Things that work on precs ;; Things that work on precs
prec-num prec-assoc prec-num prec-assoc
;;Things that work on grammars grammar%
get-nt-prods get-init-prod
(rename gram-non-terms grammar-non-terms)
(rename gram-terms grammar-terms)
(rename gram-num-prods grammar-num-prods)
(rename gram-prods grammar-prods)
(rename gram-end-terms grammar-end-terms)
;; Things that work on productions ;; Things that work on productions
prod-index prod-prec prod-rhs prod-lhs prod-action) prod-index prod-prec prod-rhs prod-lhs prod-action)
@ -39,14 +34,11 @@
;;---------------------- LR items -------------------------- ;;---------------------- LR items --------------------------
;; LR-item = (make-item production nat (int | #f)) ;; LR-item = (make-item production nat)
;; The n field contains the least integer such the item is nullable ;; The dot-pos field is the index of the element in the rhs
;; after the dot if the dot is to the right of the nth position. ;; of prod that the dot immediately preceeds.
(define-struct item (prod dot-pos n) (make-inspector)) ;; Thus 0 <= dot-pos <= (vector-length rhs).
(define-struct item (prod dot-pos) (make-inspector))
(define (export-make-item a b)
(make-item a b #f))
;; item<?: LR-item * LR-item -> bool ;; item<?: LR-item * LR-item -> bool
;; Lexicographic comparison on two items. ;; Lexicographic comparison on two items.
@ -59,6 +51,8 @@
(d2 (item-dot-pos i2))) (d2 (item-dot-pos i2)))
(< d1 d2)))))) (< d1 d2))))))
;; start-item?: LR-item -> bool
;; The start production always has index 0
(define (start-item? i) (define (start-item? i)
(= 0 (non-term-index (prod-lhs (item-prod i))))) (= 0 (non-term-index (prod-lhs (item-prod i)))))
@ -70,41 +64,16 @@
(cond (cond
((= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f) ((= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f)
(else (make-item (item-prod i) (else (make-item (item-prod i)
(add1 (item-dot-pos i)) (add1 (item-dot-pos i))))))
(item-n i)))))
;; move-dot-right!: LR-item -> LR-item | #f
;; moves the dot to the right in the item, unless it is at its
;; rightmost, then it returns false
(define (move-dot-right! i)
(cond
((= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f)
(else (set-item-dot-pos! i (add1 (item-dot-pos i)))
i)))
;; sym-at-dot: LR-item -> gram-sym | #f ;; sym-at-dot: LR-item -> gram-sym | #f
;; returns the symbol after the dot in the item or #f if there is none ;; returns the symbol after the dot in the item or #f if there is none
(define (sym-at-dot i) (define (sym-at-dot i)
(let ((dp (item-dot-pos i))) (let ((dp (item-dot-pos i))
(rhs (prod-rhs (item-prod i))))
(cond (cond
((= dp (vector-length (prod-rhs (item-prod i)))) #f) ((= dp (vector-length rhs)) #f)
(else (vector-ref (prod-rhs (item-prod i)) dp))))) (else (vector-ref rhs dp)))))
;; nullable-after-dot?: LR1-iten * grammar -> bool
;; determines if the string after the dot is nullable
(define (nullable-after-dot? i g)
(let ((i-n (item-n i)))
(cond
(i-n (>= (item-dot-pos i) i-n))
(else
(let ((str (prod-rhs (item-prod i))))
(let loop ((c (sub1 (vector-length str))))
(cond
((= c -1) (set-item-n! i 0))
((term? (vector-ref str c)) (set-item-n! i (add1 c)))
((nullable? g (vector-ref str c)) (loop (sub1 c)))
(else (set-item-n! i (add1 c))))))
(>= (item-dot-pos i) (item-n i))))))
;; print-item: LR-item -> ;; print-item: LR-item ->
@ -130,6 +99,8 @@
;; gram-sym = (make-term symbol int prec) ;; gram-sym = (make-term symbol int prec)
;; | (make-non-term symbol int) ;; | (make-non-term symbol int)
;; Each term has a unique index 0 <= index < number of terms
;; Each non-term has a unique index 0 <= index < number of non-terms
(define-struct term (sym index prec) (make-inspector)) (define-struct term (sym index prec) (make-inspector))
(define-struct non-term (sym index) (make-inspector)) (define-struct non-term (sym index) (make-inspector))
@ -152,6 +123,9 @@
(define (gram-sym->string gs) (define (gram-sym->string gs)
(symbol->string (gram-sym-symbol gs))) (symbol->string (gram-sym-symbol gs)))
;; term-list->bit-vector: term list -> int
;; Creates a number where the nth bit is 1 if the term with index n is in
;; the list, and whose nth bit is 0 otherwise
(define (term-list->bit-vector terms) (define (term-list->bit-vector terms)
(cond (cond
((null? terms) 0) ((null? terms) 0)
@ -167,43 +141,56 @@
;; ------------------------- Grammar ------------------------------ ;; ------------------------- Grammar ------------------------------
;; grammar = (make-gram (production list vector) (define grammar%
;; (production list) (class object%
;; (bool vector) (super-instantiate ())
;; (non-term list) ;; prods: production list list
;; (term list) ;; where the nth element in the outermost list is the list of productions with the nth non-term as lhs
;; int (init prods)
;; (term list)) ;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable
;; (init-field terms non-terms nullable-non-terms end-terms)
;; The nt-prods field is indexed by the number assigned to the non-term and
;; contains the list of productions for that non-term ;; indexed by the index of the non-term - contains the list of productions for that non-term
;; The prods field contains a list of all productions (define nt->prods (list->vector prods))
;; The nulls field is indexed by the index for a non-term and is trus iff ;; list of all productions
;; the non-term is nullable (define all-prods (apply append prods))
(define-struct gram (define num-prods (length all-prods))
(nt-prods prods nulls non-terms terms num-prods end-terms) (define num-terms (length terms))
(make-inspector)) (define num-non-terms (length non-terms))
(define/public (get-num-terms) num-terms)
;; get-nt-prods: grammar * non-term -> production list (define/public (get-num-non-terms) num-non-terms)
;; returns the productions for the given non-term
(define (get-nt-prods g nt) (define/public (get-prods-for-non-term nt)
(vector-ref (gram-nt-prods g) (non-term-index nt))) (vector-ref nt->prods (non-term-index nt)))
(define/public (get-prods) all-prods)
(define/public (get-init-prod)
;; get-init-prod: grammar -> production (car (vector-ref nt->prods 0)))
;; gets the starting production
(define (get-init-prod g) (define/public (get-terms) terms)
(car (vector-ref (gram-nt-prods g) 0))) (define/public (get-non-terms) non-terms)
(define/public (get-num-prods) num-prods)
(define/public (get-end-terms) end-terms)
(define (nullable? g nt)
(vector-ref (gram-nulls g) (non-term-index nt))) (define/public (nullable-non-term? nt)
(vector-ref nullable-non-terms (non-term-index nt)))
(define/public (nullable-after-dot? item)
(let* ((rhs (prod-rhs (item-prod item)))
(prod-length (vector-length rhs)))
(let loop ((i (item-dot-pos item)))
(cond
((< i prod-length)
(if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i)))
(loop (add1 i))
#f))
((= i prod-length) #t)))))))
;; ------------------------ Productions --------------------------- ;; ------------------------ Productions ---------------------------
;; production = (make-prod non-term (gram-sym vector) int prec syntax-object) ;; production = (make-prod non-term (gram-sym vector) int prec syntax-object)
;; Each production has a unique index 0 <= index <= number of productions
(define-struct prod (lhs rhs index prec action) (make-inspector)) (define-struct prod (lhs rhs index prec action) (make-inspector))
) )

24
collects/parser-tools/private-yacc/input-file-parser.ss
Unescape Escape View File

@ -4,7 +4,11 @@
;; routines for parsing the input to the parser generator and producing a ;; routines for parsing the input to the parser generator and producing a
;; grammar (See grammar.ss) ;; grammar (See grammar.ss)
(require "yacc-helper.ss" "../private-lex/token-syntax.ss" "grammar.ss" (lib "list.ss")) (require "yacc-helper.ss"
"../private-lex/token-syntax.ss"
"grammar.ss"
(lib "list.ss")
(lib "class.ss"))
(provide parse-input get-term-list) (provide parse-input get-term-list)
@ -418,13 +422,11 @@
;; (list-ref (cons start (cons end-non-term non-terms)) i))) ;; (list-ref (cons start (cons end-non-term non-terms)) i)))
;; (loop (add1 i)))) ;; (loop (add1 i))))
;; (else (loop (add1 i))))))) ;; (else (loop (add1 i)))))))
(make-grammar (make-object grammar%
(list->vector prods) prods
(apply append prods) terms
nulls (cons start (cons end-non-term non-terms))
(cons start (cons end-non-term non-terms)) nulls
terms (map (lambda (term-name)
(add1 counter) (hash-table-get term-table term-name))
(map (lambda (term-name) end-terms)))))))
(hash-table-get term-table term-name))
end-terms)))))))

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

@ -5,16 +5,22 @@
(require "lr0.ss" (require "lr0.ss"
"grammar.ss" "grammar.ss"
"graph.ss"
"array2d.ss" "array2d.ss"
(lib "list.ss") (lib "list.ss")
(lib "class.ss")) (lib "class.ss"))
(provide compute-LA) (provide compute-LA)
;; compute-DR: LR0-automaton * grammar -> (trans-key -> term list) (define (list-head l n)
(cond
((= 0 n) null)
(else (cons (car l) (list-head (cdr l) (sub1 n))))))
;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
;; 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
;; output term set is represented in bit-vector form
(define (compute-DR a g) (define (compute-DR a g)
(lambda (tk) (lambda (tk)
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))) (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
@ -22,7 +28,7 @@
(filter (filter
(lambda (term) (lambda (term)
(send a run-automaton r term)) (send a run-automaton r term))
(grammar-terms g)))))) (send g get-terms))))))
;; compute-reads: ;; compute-reads:
;; LR0-automaton * grammar -> (trans-key -> trans-key list) ;; LR0-automaton * grammar -> (trans-key -> trans-key list)
@ -31,88 +37,150 @@
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))) (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
(map (lambda (x) (make-trans-key r x)) (map (lambda (x) (make-trans-key r x))
(filter (lambda (non-term) (filter (lambda (non-term)
(and (nullable? g non-term) (and (send g nullable-non-term? non-term)
(send a run-automaton r non-term))) (send a run-automaton r non-term)))
(grammar-non-terms g)))))) (send g get-non-terms ))))))
;; compute-read: LR0-automaton * grammar -> (trans-key -> term list) ;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
;; 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
(vector-length (send a get-states)) (send a get-num-states)
(length (grammar-terms g)) (send g get-num-terms)
(length (grammar-non-terms g))))) (send g get-num-non-terms))))
;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list
;; comput-includes-and-lookback: ;; returns the list of all k such that state k transitions to state start on the
;; lr0-automaton * grammar -> (value (trans-key -> trans-key list) ;; transitions in rhs (in order)
;; (kernel * prod -> trans-key list)) (define (run-lr0-backward a rhs start num-states)
(define (compute-includes-and-lookback a g) (let loop ((states (list start))
(let* ((non-terms (grammar-non-terms g)) (rhs (reverse rhs)))
(num-states (vector-length (send a get-states))) (cond
(num-non-terms (length non-terms)) ((null? rhs) states)
(includes (make-array2d num-states num-non-terms null)) (else (loop (kernel-list-remove-duplicates
(lookback (make-array2d num-states (send a run-automaton-back states (car rhs))
(grammar-num-prods g) num-states)
null))) (cdr rhs))))))
(send a for-each-state
(lambda (state) ;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
(for-each ;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
(lambda (non-term) ;; and gamma =>* epsilon
(for-each (define (prod->items-for-include g prod nt)
(lambda (prod) (let* ((rhs (prod-rhs prod))
(let loop ((i (make-item prod 0)) (rhs-l (vector-length rhs)))
(p state)) (append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
(if (and p i) (list (make-item prod (sub1 rhs-l)))
(let* ((next-sym (sym-at-dot i)) null)
(new-i (move-dot-right i))) (let loop ((i (sub1 rhs-l)))
(if (and (non-term? next-sym) (cond
(nullable-after-dot? new-i g)) ((and (> i 0)
(array2d-add! includes (non-term? (vector-ref rhs i))
(kernel-index p) (send g nullable-non-term? (vector-ref rhs i)))
(gram-sym-index next-sym) (if (eq? nt (vector-ref rhs (sub1 i)))
(make-trans-key state non-term))) (cons (make-item prod (sub1 i))
(if (not new-i) (loop (sub1 i)))
(array2d-add! lookback (loop (sub1 i))))
(kernel-index p) (else null))))))
(prod-index prod)
(make-trans-key state non-term))) ;; prod-list->items-for-include: grammar * prod list * non-term -> lr0-item list
(if next-sym ;; return the list of all (B -> beta . nt gamma) such that (B -> beta nt gamma) in prod-list
(loop new-i ;; and gamma =>* epsilon
(send a run-automaton p next-sym))))))) (define (prod-list->items-for-include g prod-list nt)
(get-nt-prods g non-term))) (apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
non-terms)))
;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
(values (lambda (tk) (define (compute-includes a g)
(array2d-ref includes (let ((non-terms (send g get-non-terms))
(kernel-index (trans-key-st tk)) (num-states (send a get-num-states)))
(gram-sym-index (trans-key-gs tk)))) (lambda (tk)
(lambda (state prod) (let ((goal-state (trans-key-st tk))
(array2d-ref lookback (non-term (trans-key-gs tk)))
(kernel-index state) (apply append
(prod-index prod)))))) (map (lambda (B)
(map (lambda (state)
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term list) (make-trans-key state B))
(kernel-list-remove-duplicates
(let ((items (prod-list->items-for-include g (send g get-prods-for-non-term B) non-term)))
(apply append
(map (lambda (item)
(let ((rhs (prod-rhs (item-prod item))))
(run-lr0-backward a
(list-head (vector->list rhs)
(- (vector-length rhs)
(item-dot-pos item)))
goal-state
num-states)))
items)))
num-states)))
non-terms))))))
;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
; (define (compute-includes a g)
; (let* ((non-terms (send g get-non-terms))
; (num-states (vector-length (send a get-states)))
; (num-non-terms (length non-terms))
; (includes (make-array2d num-states num-non-terms null)))
; (send a for-each-state
; (lambda (state)
; (for-each
; (lambda (non-term)
; (for-each
; (lambda (prod)
; (let loop ((i (make-item prod 0))
; (p state))
; (if (and p i)
; (let* ((next-sym (sym-at-dot i))
; (new-i (move-dot-right i)))
; (if (and (non-term? next-sym)
; (send g nullable-after-dot? new-i))
; (array2d-add! includes
; (kernel-index p)
; (gram-sym-index next-sym)
; (make-trans-key state non-term)))
; (if next-sym
; (loop new-i
; (send a run-automaton p next-sym)))))))
; (send g get-prods-for-non-term non-term)))
; non-terms)))
;
; (lambda (tk)
; (array2d-ref includes
; (kernel-index (trans-key-st tk))
; (gram-sym-index (trans-key-gs tk))))))
;
; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
(define (compute-lookback a g)
(let ((num-states (send a get-num-states)))
(lambda (state prod)
(map (lambda (k) (make-trans-key k (prod-lhs prod)))
(run-lr0-backward a (vector->list (prod-rhs prod)) state num-states)))))
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
;; output term set is represented in bit-vector form
(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-tk->terml (send a get-mapped-non-term-keys) (digraph-tk->terml (send a get-mapped-non-term-keys)
includes includes
read read
(vector-length (send a get-states)) (send a get-num-states)
(length (grammar-terms g)) (send g get-num-terms)
(length (grammar-non-terms g))))) (send g get-num-non-terms))))
;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term list) ;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set)
;; output term set is represented in bit-vector form
(define (compute-LA a g) (define (compute-LA a g)
(let-values (((includes lookback) (time (compute-includes-and-lookback a g)))) (let* ((includes (compute-includes a g))
(let ((follow (time (compute-follow a g includes)))) (lookback (compute-lookback a g))
(lambda (k p) (follow (compute-follow a g includes)))
(let* ((l (lookback k p)) (lambda (k p)
(f (map follow l))) (let* ((l (lookback k p))
(apply bitwise-ior (cons 0 f))))))) (f (map follow l)))
(apply bitwise-ior (cons 0 f))))))
(define (print-DR dr a g) (define (print-DR dr a g)
@ -141,7 +209,7 @@
state state
(gram-sym-symbol non-term) (gram-sym-symbol non-term)
(print-output res))))) (print-output res)))))
(grammar-non-terms g)))) (send g get-non-terms))))
(newline)) (newline))
(define (print-input-st-prod f name a g print-output) (define (print-input-st-prod f name a g print-output)
@ -159,8 +227,8 @@
(kernel-index state) (kernel-index state)
(prod-index prod) (prod-index prod)
(print-output res))))) (print-output res)))))
(get-nt-prods g non-term))) (send g get-prods-for-non-term non-term)))
(grammar-non-terms g))))) (send g get-non-terms)))))
(define (print-output-terms r) (define (print-output-terms r)
(map (map

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

@ -16,10 +16,13 @@
;; kernel = (make-kernel (LR1-item list) index) ;; kernel = (make-kernel (LR1-item list) index)
;; the list must be kept sorted according to item<? so that equal? can ;; the list must be kept sorted according to item<? so that equal? can
;; be used to compare kernels ;; be used to compare kernels
;; Each kernel is assigned a uniqui index, 0 <= index < number of states
;; 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))
;; kernel-list-remove-duplicates: kernel list * int -> kernel list
(define (kernel-list-remove-duplicates k num-states) (define (kernel-list-remove-duplicates k num-states)
(let ((v (make-vector num-states #f))) (let ((v (make-vector num-states #f)))
(for-each (for-each
@ -28,12 +31,12 @@
k) k)
(let loop ((i 0)) (let loop ((i 0))
(cond (cond
((< i num-states) ((< i num-states)
(let ((k (vector-ref v i))) (let ((k (vector-ref v i)))
(if k (if k
(cons k (loop (add1 i))) (cons k (loop (add1 i)))
(loop (add1 i))))) (loop (add1 i)))))
(else null))))) (else null)))))
@ -41,6 +44,7 @@
(define lr0% (define lr0%
(class object% (class object%
(super-instantiate ()) (super-instantiate ())
;; Hash tables that map a trans-keys to a kernel
(init term-hash non-term-hash) (init term-hash non-term-hash)
(init-field states epsilons num-terms num-non-terms) (init-field states epsilons num-terms num-non-terms)
@ -64,6 +68,9 @@
(define/public (get-states) (define/public (get-states)
states) states)
(define/public (get-num-states)
(vector-length states))
(define/public (get-epsilon-trans) (define/public (get-epsilon-trans)
epsilons) epsilons)
@ -157,8 +164,8 @@
(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 (grammar-terms grammar))) (terms (list->vector (send grammar get-terms)))
(non-terms (list->vector (grammar-non-terms grammar))) (non-terms (list->vector (send grammar get-non-terms)))
(num-non-terms (vector-length non-terms)) (num-non-terms (vector-length non-terms))
(num-gram-syms (+ num-non-terms (vector-length terms))) (num-gram-syms (+ num-non-terms (vector-length terms)))
(epsilons (make-hash-table 'equal)) (epsilons (make-hash-table 'equal))
@ -170,12 +177,12 @@
;; 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 (grammar-non-terms grammar) (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)))
(get-nt-prods grammar 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)))
@ -197,8 +204,9 @@
(map (lambda (non-term) (map (lambda (non-term)
(map (lambda (x) (map (lambda (x)
(make-item x 0)) (make-item x 0))
(get-nt-prods grammar (send grammar
non-term))) get-prods-for-non-term
non-term)))
(first-non-term next-gsym))) (first-non-term next-gsym)))
(LR0-closure (cdr i))))) (LR0-closure (cdr i)))))
(else (else
@ -321,7 +329,7 @@
(else null)))))))) (else null))))))))
(start (list (make-item (get-init-prod grammar) 0))) (start (list (make-item (send grammar get-init-prod) 0)))
(startk (make-kernel start 0)) (startk (make-kernel start 0))
(new-kernels (make-queue))) (new-kernels (make-queue)))

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

@ -4,7 +4,8 @@
(require "input-file-parser.ss" (require "input-file-parser.ss"
"table.ss" "table.ss"
"parser-actions.ss" "parser-actions.ss"
"grammar.ss") "grammar.ss"
(lib "class.ss"))
(provide build-parser) (provide build-parser)
@ -74,7 +75,7 @@
(else action))) (else action)))
(vector->list table))))) (vector->list table)))))
(num-non-terms (length (grammar-non-terms grammar))) (num-non-terms (send grammar get-num-non-terms))
(token-code (token-code
`(let ((ht (make-hash-table))) `(let ((ht (make-hash-table)))
@ -83,11 +84,11 @@
`(hash-table-put! ht `(hash-table-put! ht
',(gram-sym-symbol term) ',(gram-sym-symbol term)
,(+ num-non-terms (gram-sym-index term)))) ,(+ num-non-terms (gram-sym-index term))))
(grammar-terms grammar)) (send grammar get-terms))
ht))) ht)))
(actions-code (actions-code
`(vector ,@(map prod-action (grammar-prods grammar))))) `(vector ,@(map prod-action (send grammar get-prods)))))
(values table-code (values table-code
token-code token-code
actions-code actions-code

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

@ -216,18 +216,18 @@
;; 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 (time (build-lr0-automaton g))) (let* ((a (time (build-lr0-automaton g)))
(terms (grammar-terms g)) (terms (send g get-terms))
(non-terms (grammar-non-terms g)) (non-terms (send g get-non-terms))
(get-term (list->vector terms)) (get-term (list->vector terms))
(get-non-term (list->vector non-terms)) (get-non-term (list->vector non-terms))
(get-prod (list->vector (grammar-prods g))) (get-prod (list->vector (send g get-prods)))
(num-terms (vector-length get-term)) (num-terms (vector-length get-term))
(num-non-terms (vector-length get-non-term)) (num-non-terms (vector-length get-non-term))
(end-term-indexes (end-term-indexes
(map (map
(lambda (term) (lambda (term)
(+ num-non-terms (gram-sym-index term))) (+ num-non-terms (gram-sym-index term)))
(grammar-end-terms g))) (send g get-end-terms)))
(num-gram-syms (+ num-terms num-non-terms)) (num-gram-syms (+ num-terms num-non-terms))
(table (make-array2d (vector-length (send a get-states)) num-gram-syms #f)) (table (make-array2d (vector-length (send a get-states)) num-gram-syms #f))
(array2d-add! (array2d-add!
@ -239,7 +239,7 @@
(array2d-set! v i1 i2 (cons a old)))) (array2d-set! v i1 i2 (cons a old))))
(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 (time (compute-LA a g))))
(time (time
(send a for-each-state (send a for-each-state
(lambda (state) (lambda (state)
@ -299,7 +299,7 @@
(exn:i/o:filesystem-detail e))))] (exn:i/o:filesystem-detail e))))]
(call-with-output-file file (call-with-output-file file
(lambda (port) (lambda (port)
(display-parser a table get-term get-non-term (grammar-prods g) (display-parser a table get-term get-non-term (send g get-prods)
port))))) port)))))
(resolve-conflicts a table num-terms num-non-terms suppress) (resolve-conflicts a table num-terms num-non-terms suppress)
table)) table))

Write Preview
Loading…
Cancel
Save