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

*** empty log message ***

Browse Source 
original commit: 175b3e676da894cafbe6d905adfe0e3b50a24015
tokens
Scott Owens 22 years ago
parent 95300ddd13
commit c3e3cb5d26
6 changed files with 231 additions and 223 deletions
Show Stats Download Patch File Download Diff File

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

@ -185,7 +185,14 @@
(if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i)))
(loop (add1 i))
#f))
((= i prod-length) #t)))))))
((= i prod-length) #t)))))
(define/public (nullable-non-term-thunk)
(lambda (nt)
(nullable-non-term? nt)))
(define/public (nullable-after-dot?-thunk)
(lambda (item)
(nullable-after-dot? item)))))
;; ------------------------ Productions ---------------------------

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

@ -10,12 +10,6 @@
(lib "class.ss"))
(provide compute-LA)
(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
@ -33,38 +27,49 @@
;; compute-reads:
;; LR0-automaton * grammar -> (trans-key -> trans-key list)
(define (compute-reads a g)
(lambda (tk)
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
(map (lambda (x) (make-trans-key r x))
(filter (lambda (non-term)
(and (send g nullable-non-term? non-term)
(send a run-automaton r non-term)))
(send g get-non-terms ))))))
(let ((nullable-non-terms
(filter (lambda (nt) (send g nullable-non-term? nt))
(send g get-non-terms))))
(lambda (tk)
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
(map (lambda (x) (make-trans-key r x))
(filter (lambda (non-term) (send a run-automaton r non-term))
nullable-non-terms))))))
;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
;; output term set is represented in bit-vector form
(define (compute-read a g)
(let* ((dr (compute-DR a g))
(reads (compute-reads a g)))
(digraph-tk->terml (send a get-mapped-non-term-keys)
reads
dr
(send a get-num-states)
(send g get-num-terms)
(send g get-num-non-terms))))
(time
(digraph-tk->terml (send a get-mapped-non-term-keys)
reads
dr
(send a get-num-states)
(send g get-num-terms)
(send g get-num-non-terms))))
)
; ;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list
; ;; returns the list of all k such that state k transitions to state start on the
; ;; transitions in rhs (in order)
; (define (run-lr0-backward a rhs start num-states)
; (let loop ((states (list start))
; (rhs (reverse rhs)))
; (cond
; ((null? rhs) states)
; (else (loop (send a run-automaton-back states (car rhs))
; (cdr rhs))))))
;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list
;; gram-sym list * kernel * int -> kernel list
;; returns the list of all k such that state k transitions to state start on the
;; transitions in rhs (in order)
(define (run-lr0-backward a rhs start num-states)
(define (run-lr0-backward a rhs dot-pos start num-states)
(let loop ((states (list start))
(rhs (reverse rhs)))
(i (sub1 dot-pos)))
(cond
((null? rhs) states)
(else (loop (kernel-list-remove-duplicates
(send a run-automaton-back states (car rhs))
num-states)
(cdr rhs))))))
((< i 0) states)
(else (loop (send a run-automaton-back states (vector-ref rhs i))
(sub1 i))))))
;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
@ -91,74 +96,75 @@
;; and gamma =>* epsilon
(define (prod-list->items-for-include g prod-list nt)
(apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
;; 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 (send a get-num-states)))
(let ((num-states (send a get-num-states))
(items-for-input-nt (make-vector (send g get-num-non-terms) null)))
(for-each
(lambda (input-nt)
(vector-set! items-for-input-nt (non-term-index input-nt)
(prod-list->items-for-include g (send g get-prods) input-nt)))
(send g get-non-terms))
(lambda (tk)
(let ((goal-state (trans-key-st tk))
(non-term (trans-key-gs tk)))
(apply append
(map (lambda (B)
(map (lambda (state)
(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)))
(let* ((goal-state (trans-key-st tk))
(non-term (trans-key-gs tk))
(items (vector-ref items-for-input-nt (non-term-index non-term))))
(trans-key-list-remove-dups
(apply append
(map (lambda (item)
(let* ((prod (item-prod item))
(rhs (prod-rhs prod))
(lhs (prod-lhs prod)))
(map (lambda (state)
(make-trans-key state lhs))
(run-lr0-backward a
rhs
(item-dot-pos item)
goal-state
num-states))))
items)))))))
; ;; compute-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)
; (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)))))
(run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))))
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
;; output term set is represented in bit-vector form
@ -176,7 +182,7 @@
(define (compute-LA a g)
(let* ((includes (compute-includes a g))
(lookback (compute-lookback a g))
(follow (compute-follow a g includes)))
(follow (compute-follow a g includes)))
(lambda (k p)
(let* ((l (lookback k p))
(f (map follow l)))

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

@ -10,8 +10,8 @@
(lib "class.ss"))
(provide build-lr0-automaton lr0%
(struct trans-key (st gs))
kernel-items kernel-index kernel-list-remove-duplicates)
(struct trans-key (st gs)) trans-key-list-remove-dups
kernel-items kernel-index)
;; kernel = (make-kernel (LR1-item list) index)
;; the list must be kept sorted according to item<? so that equal? can
@ -21,25 +21,30 @@
(define-struct kernel (items index) (make-inspector))
(define-struct trans-key (st gs) (make-inspector))
(define (trans-key<? a b)
(let ((kia (kernel-index (trans-key-st a)))
(kib (kernel-index (trans-key-st b))))
(or (< kia kib)
(and (= kia kib)
(< (non-term-index (trans-key-gs a))
(non-term-index (trans-key-gs b)))))))
;; kernel-list-remove-duplicates: kernel list * int -> kernel list
(define (kernel-list-remove-duplicates k num-states)
(let ((v (make-vector num-states #f)))
(for-each
(lambda (k)
(vector-set! v (kernel-index k) k))
k)
(let loop ((i 0))
(cond
((< i num-states)
(let ((k (vector-ref v i)))
(if k
(cons k (loop (add1 i)))
(loop (add1 i)))))
(else null)))))
(define (trans-key-list-remove-dups tkl)
(let loop ((sorted (quicksort tkl trans-key<?)))
(cond
((null? sorted) null)
((null? (cdr sorted)) sorted)
(else
(if (and (= (non-term-index (trans-key-gs (car sorted)))
(non-term-index (trans-key-gs (cadr sorted))))
(= (kernel-index (trans-key-st (car sorted)))
(kernel-index (trans-key-st (cadr sorted)))))
(loop (cdr sorted))
(cons (car sorted) (loop (cdr sorted))))))))
;; kernel-list-remove-duplicates
;; LR0-automaton = object of class lr0%
(define lr0%
(class object%
@ -48,13 +53,13 @@
(init term-hash non-term-hash)
(init-field states epsilons num-terms num-non-terms)
(define term-transitions (make-lr0-table term-hash (vector-length states) num-terms))
(define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms))
(define term-transitions (make-lr0-table term-hash (vector-length states) num-terms #f))
(define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms #f))
(define reverse-term-hash (reverse-hash term-hash))
(define reverse-non-term-hash (reverse-hash non-term-hash))
(define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms))
(define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms))
(define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms null))
(define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms null))
(define mapped-non-terms
(hash-table-map non-term-hash (lambda (k v) k)))
@ -101,8 +106,8 @@
(array2d-ref reverse-non-term-transitions (kernel-index k) (non-term-index s)))
k))))))
(define (make-lr0-table auto-hash states syms)
(let ((t (make-array2d states syms #f)))
(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

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

@ -2,9 +2,9 @@
(module parser-builder mzscheme
(require "input-file-parser.ss"
"table.ss"
"parser-actions.ss"
"grammar.ss"
"table.ss"
(lib "class.ss"))
(provide build-parser)
@ -42,41 +42,8 @@
(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-code
`((lambda (table-list)
(let ((v (list->vector table-list)))
(let build-table-loop ((i 0))
(cond
((< i (vector-length v))
(let ((vi (vector-ref v i)))
(cond
((list? vi)
(vector-set! v i
(cond
((eq? 's (car vi))
(make-shift (cadr vi)))
((eq? 'r (car vi))
(make-reduce (cadr vi) (caddr vi) (cadddr vi)))
((eq? 'a (car vi)) (make-accept)))))))
(build-table-loop (add1 i)))
(else v)))))
(quote
,(map (lambda (action)
(cond
((shift? action)
`(s ,(shift-state action)))
((reduce? action)
`(r ,(reduce-prod-num action)
,(reduce-lhs-num action)
,(reduce-rhs-length action)))
((accept? action)
`(a))
(else action)))
(vector->list table)))))
(table (build-table grammar filename suppress))
(num-non-terms (send grammar get-num-non-terms))
(token-code
`(let ((ht (make-hash-table)))
(begin
@ -86,12 +53,22 @@
,(+ num-non-terms (gram-sym-index term))))
(send grammar get-terms))
ht)))
(actions-code
`(vector ,@(map prod-action (send grammar get-prods)))))
(values table-code
token-code
actions-code
(fix-check-syntax start input-terms prods assocs end))))
(let loop ((i 1))
(if (< i (vector-length table))
(let ((a (vector-ref table i)))
(vector-set! table i (cond
((accept? a) 'accept)
((shift? a) (- (shift-state a)))
((reduce? a) (vector (reduce-prod-num a)
(reduce-lhs-num a)
(reduce-rhs-length a)))
(else a)))
(loop (add1 i)))))
(values table
token-code
actions-code
(fix-check-syntax start input-terms prods assocs end))))
)

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

@ -213,9 +213,9 @@
;; In the result table the first index is the state and the second is the
;; term/non-term index (with the non-terms coming first)
;; buile-table: grammar * string -> action2d-array
;; buile-table: grammar * string -> action array2d
(define (build-table g file suppress)
(let* ((a (time (build-lr0-automaton g)))
(let* ((a (build-lr0-automaton g))
(terms (send g get-terms))
(non-terms (send g get-non-terms))
(get-term (list->vector terms))
@ -229,7 +229,7 @@
(+ num-non-terms (gram-sym-index term)))
(send g get-end-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 (send a get-num-states) num-gram-syms #f))
(array2d-add!
(lambda (v i1 i2 a)
(let ((old (array2d-ref v i1 i2)))
@ -240,69 +240,71 @@
(else (if (not (equal? a old))
(array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (time (compute-LA a g))))
(time
(send a for-each-state
(lambda (state)
(let loop ((i 0))
(if (< i num-gram-syms)
(begin
(let* ((s (if (< i num-non-terms)
(vector-ref get-non-term i)
(vector-ref get-term (- i num-non-terms))))
(goto
(send a run-automaton state s)))
(if goto
(array2d-set! table
(kernel-index state)
i
(cond
((< i num-non-terms)
(kernel-index goto))
((member i end-term-indexes)
(make-accept))
(else
(make-shift
(kernel-index goto)))))))
(loop (add1 i)))))
(send a for-each-state
(lambda (state)
(let loop ((i 0))
(if (< i num-gram-syms)
(begin
(let* ((s (if (< i num-non-terms)
(vector-ref get-non-term i)
(vector-ref get-term (- i num-non-terms))))
(goto
(send a run-automaton state s)))
(if goto
(array2d-set! table
(kernel-index state)
i
(cond
((< i num-non-terms)
(kernel-index goto))
((member i end-term-indexes)
(make-accept))
(else
(make-shift
(kernel-index goto)))))))
(loop (add1 i)))))
(for-each
(lambda (item)
(let ((item-prod (item-prod item)))
(bit-vector-for-each
(lambda (term-index)
(array2d-add! table
(kernel-index state)
(+ num-non-terms term-index)
(cond
((not (start-item? item))
(make-reduce
(prod-index item-prod)
(gram-sym-index (prod-lhs item-prod))
(vector-length (prod-rhs item-prod)))))))
(get-lookahead state item-prod))))
(for-each
(lambda (item)
(let ((item-prod (item-prod item)))
(bit-vector-for-each
(lambda (term-index)
(array2d-add! table
(kernel-index state)
(+ num-non-terms term-index)
(cond
((not (start-item? item))
(make-reduce
(prod-index item-prod)
(gram-sym-index (prod-lhs item-prod))
(vector-length (prod-rhs item-prod)))))))
(get-lookahead state item-prod))))
(append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items state)))))))
(append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items state))))))
(resolve-prec-conflicts a table get-term get-prod num-terms
num-non-terms)
(if (not (string=? file ""))
(with-handlers [(exn:i/o:filesystem?
(lambda (e)
(fprintf
(current-error-port)
"Cannot write debug output to file \"~a\". ~a~n"
(exn:i/o:filesystem-pathname e)
(exn:i/o:filesystem-detail e))))]
(call-with-output-file file
(lambda (port)
(display-parser a table get-term get-non-term (send g get-prods)
port)))))
(resolve-conflicts a table num-terms num-non-terms suppress)
table))
)
num-non-terms)
(if (not (string=? file ""))
(with-handlers [(exn:i/o:filesystem?
(lambda (e)
(fprintf
(current-error-port)
"Cannot write debug output to file \"~a\". ~a~n"
(exn:i/o:filesystem-pathname e)
(exn:i/o:filesystem-detail e))))]
(call-with-output-file file
(lambda (port)
(display-parser a table get-term get-non-term (send g get-prods)
port)))))
(resolve-conflicts a table num-terms num-non-terms suppress)
table))
)

15
collects/parser-tools/yacc.ss
Unescape Escape View File

@ -3,8 +3,7 @@
(require-for-syntax "private-yacc/parser-builder.ss"
"private-yacc/yacc-helper.ss")
(require "private-yacc/parser-actions.ss"
"private-yacc/array2d.ss"
(require "private-yacc/array2d.ss"
"private-lex/token.ss"
(lib "readerr.ss" "syntax"))
@ -154,6 +153,18 @@
(define (false-thunk) #f)
(define shift? integer?)
(define (shift-state x) (- x))
(define reduce? vector?)
(define (reduce-prod-num x) (vector-ref x 0))
(define (reduce-lhs-num x) (vector-ref x 1))
(define (reduce-rhs-length x) (vector-ref x 2))
(define (accept? x) (eq? x 'accept))
;; The table format is an array2d that maps each state/term pair to either
;; an accept, shift or reduce structure - or a #f. Except that we will encode
;; by changing (make-accept) -> 'accept, (make-shift i) -> i and
;; (make-reduce i1 i2 i3) -> #(i1 i2 i3)
(define (parser-body err ends table term-sym->index actions src-pos)
(letrec ((input->token
(if src-pos

Write Preview
Loading…
Cancel
Save