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

*** empty log message ***

Browse Source 
original commit: 6b32165ccb7a18f2ef44c454684ea8d3df46da6b
tokens
Scott Owens 23 years ago
parent f00785e838
commit 8525a6ab43
5 changed files with 293 additions and 208 deletions
Show Stats Download Patch File Download Diff File

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

@ -119,7 +119,9 @@
(list-of-terms
(syntax-case term-defs (tokens)
(syntax-case* term-defs (tokens)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((tokens term-def ...)
(andmap identifier? (syntax->list (syntax (term-def ...))))
(remove-duplicates
@ -148,7 +150,9 @@
;; Get the list of terminals out of input-terms
(list-of-non-terms
(syntax-case prods (grammar)
(syntax-case* prods (grammar)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((grammar (non-term production ...) ...)
(begin
(for-each
@ -179,7 +183,9 @@
;; Check the precedence declarations for errors and turn them into data
(precs
(syntax-case prec-decls (precs)
(syntax-case* prec-decls (precs)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((precs (type term ...) ...)
(let ((p-terms
(apply append (syntax-object->datum
@ -286,7 +292,9 @@
;; parse-prod+action: non-term * syntax-object -> production
(parse-prod+action
(lambda (nt prod-so)
(syntax-case prod-so (prec)
(syntax-case* prod-so (prec)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((prod-rhs action)
(let ((p (parse-prod (syntax prod-rhs))))
(set! counter (add1 counter))

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

@ -53,47 +53,46 @@
;; lr0-automaton * grammar -> (value (trans-key -> trans-key list)
;; (kernel * prod -> trans-key list))
(define (compute-includes-and-lookback a g)
(let* ((states (lr0-states a))
(non-terms (grammar-non-terms g))
(num-states (vector-length states))
(let* ((non-terms (grammar-non-terms g))
(num-states (vector-length (lr0-states a)))
(num-non-terms (length non-terms))
(includes (make-array2d num-states num-non-terms null))
(lookback (make-array2d num-states
(grammar-num-prods g)
null)))
(let loop ((state 0))
(if (< state num-states)
(begin
(for-each
(lambda (non-term)
(for-each
(lambda (prod)
(let loop ((i (make-item prod 0))
(p (vector-ref states state)))
(if (and p i)
(begin
(if (and (non-term? (sym-at-dot i))
(nullable-after-dot? (move-dot-right i)
g))
(array2d-add! includes
(kernel-index p)
(gram-sym-index
(sym-at-dot i))
(make-trans-key
(vector-ref states state)
non-term)))
(if (not (move-dot-right i))
(array2d-add! lookback
(kernel-index p)
(prod-index prod)
(make-trans-key
(vector-ref states state)
non-term)))
(loop (move-dot-right i)
(run-automaton p (sym-at-dot i) a))))))
(get-nt-prods g non-term)))
non-terms)
(loop (add1 state)))))
(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)
(begin
(if (and (non-term? (sym-at-dot i))
(nullable-after-dot? (move-dot-right i)
g))
(array2d-add! includes
(kernel-index p)
(gram-sym-index
(sym-at-dot i))
(make-trans-key
state
non-term)))
(if (not (move-dot-right i))
(array2d-add! lookback
(kernel-index p)
(prod-index prod)
(make-trans-key
state
non-term)))
(loop (move-dot-right i)
(run-automaton p (sym-at-dot i) a))))))
(get-nt-prods g non-term)))
non-terms))
a)
(values (lambda (tk)
(array2d-ref includes
(kernel-index (trans-key-st tk))
@ -118,9 +117,79 @@
(define (compute-LA a g)
(let-values (((includes lookback) (compute-includes-and-lookback a g)))
(let ((follow (compute-follow a g includes)))
(print-lookback lookback a g)
(print-follow follow a g)
(lambda (k p)
(let* ((l (lookback k p))
(f (map follow l)))
(apply append f))))))
(define (print-DR dr a g)
(print-input-st-sym dr "DR" a g print-output-terms))
(define (print-Read Read a g)
(print-input-st-sym Read "Read" a g print-output-terms))
(define (print-includes i a g)
(print-input-st-sym i "includes" a g print-output-st-nt))
(define (print-lookback l a g)
(print-input-st-prod l "lookback" a g print-output-st-nt))
(define (print-follow f a g)
(print-input-st-sym f "follow" a g print-output-terms))
(define (print-LA l a g)
(print-input-st-prod l "LA" a g print-output-terms))
(define (print-input-st-sym f name a g print-output)
(printf "~a:~n" name)
(for-each-state
(lambda (state)
(for-each
(lambda (non-term)
(let ((res (f (make-trans-key state non-term))))
(if (not (null? res))
(printf "~a(~a, ~a) = ~a~n"
name
state
(gram-sym-symbol non-term)
(print-output res)))))
(grammar-non-terms g)))
a)
(newline))
(define (print-input-st-prod f name a g print-output)
(printf "~a:~n" name)
(for-each-state
(lambda (state)
(for-each
(lambda (non-term)
(for-each
(lambda (prod)
(let ((res (f state prod)))
(if (not (null? res))
(printf "~a(~a, ~a) = ~a~n"
name
(kernel-index state)
(prod-index prod)
(print-output res)))))
(get-nt-prods g non-term)))
(grammar-non-terms g)))
a))
(define (print-output-terms r)
(map
(lambda (p)
(gram-sym-symbol p))
r))
)
(define (print-output-st-nt r)
(map
(lambda (p)
(list
(kernel-index (trans-key-st p))
(gram-sym-symbol (trans-key-gs p))))
r))
)

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

@ -8,7 +8,7 @@
(lib "list.ss"))
(provide union build-lr0-automaton run-automaton (struct trans-key (st gs))
lr0-transitions lr0-states kernel-items kernel-index)
lr0-transitions lr0-states kernel-items kernel-index for-each-state)
(define (union comp<?)
(letrec ((union
@ -34,6 +34,18 @@
(define-struct kernel (items index) (make-inspector))
(define-struct trans-key (st gs) (make-inspector))
(define-struct lr0 (transitions states) (make-inspector))
;; A macro to allow easy iteration over the states in an automaton
(define-syntax for-each-state
(syntax-rules ()
((_ function automaton)
(let* ((states (lr0-states automaton))
(num-states (vector-length states)))
(let loop ((i 0))
(if (< i num-states)
(begin
(function (vector-ref states i))
(loop (add1 i)))))))))
;; The kernels in the automaton are represented cannonically.
;; That is (equal? a b) <=> (eq? a b)

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

@ -39,11 +39,9 @@
;; action array2d * term vector * non-term vector * kernel vector *
;; output-port ->
;; Prints out the parser given by table.
(define (display-parser table terms non-terms states prods port)
(define (display-parser a table terms non-terms prods port)
(let* ((num-terms (vector-length terms))
(num-non-terms (vector-length non-terms))
(num-gram-syms (+ num-terms num-non-terms))
(num-states (vector-length states))
(SR-conflicts 0)
(RR-conflicts 0))
(for-each
@ -54,62 +52,62 @@
(gram-sym-symbol (prod-lhs prod))
(map gram-sym-symbol (vector->list (prod-rhs prod)))))
prods)
(let loop ((i 0))
(if (< i num-states)
(begin
(fprintf port "State ~a~n" i)
(for-each (lambda (item)
(fprintf port "\t~a~n" (item->string item)))
(kernel-items (vector-ref states i)))
(newline port)
(let loop ((j 0))
(if (< j num-terms)
(begin
(let ((act (array2d-ref
table
i
(+ j num-non-terms))))
(cond
((list? act)
(fprintf port "begin conflict:~n")
(if (> (count reduce? act) 1)
(set! RR-conflicts (add1 RR-conflicts)))
(if (> (count shift? act) 0)
(set! SR-conflicts (add1 SR-conflicts)))
(map (lambda (x)
(print-entry
(gram-sym-symbol (vector-ref terms j))
x
port))
act)
(fprintf port "end conflict~n"))
(act (print-entry
(gram-sym-symbol (vector-ref terms j))
act
port))))
(loop (add1 j)))))
(newline port)
(let loop ((j 0))
(if (< j num-non-terms)
(begin
(let ((s (array2d-ref table i j)))
(if s
(print-entry
(gram-sym-symbol (vector-ref non-terms j))
s
port)))
(loop (add1 j)))))
(for-each-state
(lambda (state)
(fprintf port "State ~a~n" (kernel-index state))
(for-each (lambda (item)
(fprintf port "\t~a~n" (item->string item)))
(kernel-items state))
(newline port)
(let loop ((j 0))
(if (< j num-terms)
(begin
(let ((act (array2d-ref
table
(kernel-index state)
(+ j num-non-terms))))
(cond
((list? act)
(fprintf port "begin conflict:~n")
(if (> (count reduce? act) 1)
(set! RR-conflicts (add1 RR-conflicts)))
(if (> (count shift? act) 0)
(set! SR-conflicts (add1 SR-conflicts)))
(map (lambda (x)
(print-entry
(gram-sym-symbol (vector-ref terms j))
x
port))
act)
(fprintf port "end conflict~n"))
(act (print-entry
(gram-sym-symbol (vector-ref terms j))
act
port))))
(loop (add1 j)))))
(newline port)
(let loop ((j 0))
(if (< j num-non-terms)
(begin
(let ((s (array2d-ref table (kernel-index state) j)))
(if s
(print-entry
(gram-sym-symbol (vector-ref non-terms j))
s
port)))
(loop (add1 j)))))
(newline port))
a)
(newline port)
(loop (add1 i)))))
(if (> SR-conflicts 0)
(fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
(if (> RR-conflicts 0)
(fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))
(define (resolve-conflicts table num-states num-terms num-non-terms)
(define (resolve-conflicts a table num-terms num-non-terms)
(letrec ((SR-conflicts 0)
(RR-conflicts 0)
(get-action
@ -130,19 +128,19 @@
(loop (car rest) (cdr rest)))
(else (loop current-guess (cdr rest))))))
(else entry)))))
(let loop ((state 0))
(if (< state num-states)
(begin
(let loop ((term 0))
(if (< term num-terms)
(begin
(array2d-set! table state (+ num-non-terms term)
(get-action
(array2d-ref table
state
(+ num-non-terms term))))
(loop (add1 term)))))
(loop (add1 state)))))
(for-each-state
(lambda (state)
(let loop ((term 0))
(if (< term num-terms)
(begin
(array2d-set! table (kernel-index state) (+ num-non-terms term)
(get-action
(array2d-ref table
(kernel-index state)
(+ num-non-terms term))))
(loop (add1 term))))))
a)
(if (> SR-conflicts 0)
(fprintf (current-error-port)
"~a shift/reduce conflicts~n"
@ -154,53 +152,52 @@
(define (resolve-prec-conflicts table get-term get-prod
num-states num-terms num-non-terms)
(let loop ((state 0))
(if (< state num-states)
(begin
(let loop ((term 0))
(if (< term num-terms)
(begin
(let ((action (array2d-ref table
state
(+ num-non-terms term))))
(if (and (list? action)
(= 2 (length action))
(or (shift? (car action))
(shift? (cadr action))))
(let* ((shift (if (shift? (car action))
(car action)
(cadr action)))
(reduce (if (shift? (car action))
(cadr action)
(car action)))
(s-prec (term-prec
(vector-ref get-term
term)))
(r-prec (prod-prec
(vector-ref
get-prod
(reduce-prod-num reduce)))))
(if (and s-prec r-prec)
(array2d-set!
table
state
(+ num-non-terms term)
(cond
((< (prec-num s-prec)
(prec-num r-prec))
reduce)
((> (prec-num s-prec)
(prec-num r-prec))
shift)
((eq? 'left (prec-assoc s-prec))
reduce)
((eq? 'right (prec-assoc s-prec))
shift)
(else #f)))))))
(loop (add1 term)))))
(loop (add1 state))))))
(define (resolve-prec-conflicts a table get-term get-prod
num-terms num-non-terms)
(for-each-state
(lambda (state)
(let loop ((term 0))
(if (< term num-terms)
(begin
(let ((action (array2d-ref table
(kernel-index state)
(+ num-non-terms term))))
(if (and (list? action)
(= 2 (length action))
(or (shift? (car action))
(shift? (cadr action))))
(let* ((shift (if (shift? (car action))
(car action)
(cadr action)))
(reduce (if (shift? (car action))
(cadr action)
(car action)))
(s-prec (term-prec
(vector-ref get-term
term)))
(r-prec (prod-prec
(vector-ref
get-prod
(reduce-prod-num reduce)))))
(if (and s-prec r-prec)
(array2d-set!
table
(kernel-index state)
(+ num-non-terms term)
(cond
((< (prec-num s-prec)
(prec-num r-prec))
reduce)
((> (prec-num s-prec)
(prec-num r-prec))
shift)
((eq? 'left (prec-assoc s-prec))
reduce)
((eq? 'right (prec-assoc s-prec))
shift)
(else #f)))))))
(loop (add1 term))))))
a))
;; 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)
@ -234,56 +231,53 @@
(array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (compute-LA a g)))
(let loop ((state 0))
(if (< state num-states)
(begin
(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
(run-automaton (vector-ref get-state state)
s
a)))
(if goto
(array2d-set! table
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)))))
(let ((items
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items
(vector-ref get-state state)))))
(for-each
(lambda (item)
(for-each
(lambda (t)
(array2d-add! table
state
(+ num-non-terms (gram-sym-index t))
(cond
((not (start-item? item))
(make-reduce
(item-prod-index item)
(gram-sym-index (prod-lhs (item-prod item)))
(vector-length (prod-rhs (item-prod item))))))))
(get-lookahead (vector-ref get-state state)
(item-prod item))))
items))
(loop (add1 state)))))
(resolve-prec-conflicts table get-term get-prod num-states num-terms
num-non-terms)
(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
(run-automaton (vector-ref get-state (kernel-index state))
s
a)))
(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)
(for-each
(lambda (t)
(array2d-add! table
(kernel-index state)
(+ num-non-terms (gram-sym-index t))
(cond
((not (start-item? item))
(make-reduce
(item-prod-index item)
(gram-sym-index (prod-lhs (item-prod item)))
(vector-length (prod-rhs (item-prod item))))))))
(get-lookahead (vector-ref get-state (kernel-index state))
(item-prod item))))
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items
(vector-ref get-state (kernel-index state))))))
a)
(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)
@ -294,9 +288,9 @@
(exn:i/o:filesystem-detail e))))]
(call-with-output-file file
(lambda (port)
(display-parser table get-term get-non-term get-state (grammar-prods g)
(display-parser a table get-term get-non-term (grammar-prods g)
port)))))
(resolve-conflicts table num-states num-terms num-non-terms)
(resolve-conflicts a table num-terms num-non-terms)
table))
)

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

@ -23,7 +23,9 @@
(grammar #f))
(for-each
(lambda (arg)
(syntax-case arg (debug error tokens start end precs grammar)
(syntax-case* arg (debug error tokens start end precs grammar)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((debug filename)
(cond
((not (string? (syntax-object->datum (syntax filename))))

Write Preview
Loading…
Cancel
Save