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

*** empty log message ***

Browse Source 
original commit: 05ffe8f9eeb1eb268708f90f027afd49a0a47f72
tokens
Scott Owens 23 years ago
parent 31a4843987
commit 1975e21608
6 changed files with 50 additions and 109 deletions
Show Stats Download Patch File Download Diff File

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

@ -6,6 +6,7 @@
(require "lr0.ss"
"grammar.ss"
"array2d.ss"
"graph.ss"
(lib "list.ss")
(lib "class.ss"))
@ -41,25 +42,12 @@
(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)
(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))))))
;; 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 dot-pos start num-states)
@ -123,40 +111,6 @@
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)
(define (compute-lookback a g)
@ -175,7 +129,7 @@
(send a get-num-states)
(send g get-num-terms)
(send g get-num-non-terms))))
;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set)
;; output term set is represented in bit-vector form
(define (compute-LA a g)

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

@ -171,8 +171,8 @@
(letrec (
(terms (list->vector (send grammar get-terms)))
(non-terms (list->vector (send grammar get-non-terms)))
(num-non-terms (vector-length non-terms))
(num-gram-syms (+ num-non-terms (vector-length terms)))
(num-non-terms (send grammar get-num-non-terms))
(num-gram-syms (+ num-non-terms (send grammar get-num-terms)))
(epsilons (make-hash-table 'equal))
;; first-non-term: non-term -> non-term list
@ -191,7 +191,7 @@
(lambda (nt) (list nt))
(union non-term<?)
(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,
;; X -> .o is in it too.
@ -218,7 +218,6 @@
(cons (car i) (LR0-closure (cdr i))))))))))
;; maps trans-keys to kernels
(automaton-term (make-hash-table 'equal))
(automaton-non-term (make-hash-table 'equal))
@ -274,7 +273,6 @@
(for-each (lambda (item)
(add-item! table item))
(LR0-closure (kernel-items kernel)))
;; each group is a new kernel, with the dot advanced.
;; sorts the items in a kernel so kernels can be compared
@ -333,8 +331,7 @@
(loop (add1 i)))))))
(else null))))))))
(start (list (make-item (send grammar get-init-prod) 0)))
(start (list (make-item (send grammar get-init-prod) 0)))
(startk (make-kernel start 0))
(new-kernels (make-queue)))

19
collects/parser-tools/private-yacc/parser-actions.ss
Unescape Escape View File

@ -10,10 +10,21 @@
;; action = (shift int)
;; | (reduce int int int)
;; | (accept)
;; | int
;; | int>=0
;; | #f
(define-struct shift (state) (make-inspector))
(define-struct reduce (prod-num lhs-num rhs-length) (make-inspector))
(define-struct accept () (make-inspector))
(define (shift? x) (and (integer? x) (< x 0)))
(define (make-shift x) (- (+ x 1)))
(define (shift-state x) (- (+ x 1)))
(define reduce? vector?)
(define make-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))
(define (make-accept) 'accept)
;(define-struct shift (state) (make-inspector))
;(define-struct reduce (prod-num lhs-num rhs-length) (make-inspector))
;(define-struct accept () (make-inspector))
)

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

@ -2,7 +2,6 @@
(module parser-builder mzscheme
(require "input-file-parser.ss"
"parser-actions.ss"
"grammar.ss"
"table.ss"
(lib "class.ss"))
@ -55,17 +54,6 @@
ht)))
(actions-code
`(vector ,@(map prod-action (send grammar get-prods)))))
(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

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

@ -216,13 +216,11 @@
;; buile-table: grammar * string -> action array2d
(define (build-table g file suppress)
(let* ((a (build-lr0-automaton g))
(terms (send g get-terms))
(non-terms (send g get-non-terms))
(get-term (list->vector terms))
(get-non-term (list->vector non-terms))
(num-terms (send g get-num-terms))
(num-non-terms (send g get-num-non-terms))
(get-term (list->vector (send g get-terms)))
(get-non-term (list->vector (send g get-non-terms)))
(get-prod (list->vector (send g get-prods)))
(num-terms (vector-length get-term))
(num-non-terms (vector-length get-non-term))
(end-term-indexes
(map
(lambda (term)
@ -240,7 +238,7 @@
(else (if (not (equal? a old))
(array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (compute-LA a g)))
(send a for-each-state
(lambda (state)
(let loop ((i 0))
@ -264,7 +262,6 @@
(make-shift
(kernel-index goto)))))))
(loop (add1 i)))))
(for-each
(lambda (item)
(let ((item-prod (item-prod item)))
@ -285,26 +282,27 @@
(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))
)
)

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

@ -5,6 +5,7 @@
"private-yacc/yacc-helper.ss")
(require "private-yacc/array2d.ss"
"private-lex/token.ss"
"private-yacc/parser-actions.ss"
(lib "readerr.ss" "syntax"))
(provide parser)
@ -153,14 +154,6 @@
(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

Write Preview
Loading…
Cancel
Save