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

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

@ -53,23 +53,22 @@
;; lr0-automaton * grammar -> (value (trans-key -> trans-key list) ;; lr0-automaton * grammar -> (value (trans-key -> trans-key list)
;; (kernel * prod -> trans-key list)) ;; (kernel * prod -> trans-key list))
(define (compute-includes-and-lookback a g) (define (compute-includes-and-lookback a g)
(let* ((states (lr0-states a)) (let* ((non-terms (grammar-non-terms g))
(non-terms (grammar-non-terms g)) (num-states (vector-length (lr0-states a)))
(num-states (vector-length states))
(num-non-terms (length non-terms)) (num-non-terms (length non-terms))
(includes (make-array2d num-states num-non-terms null)) (includes (make-array2d num-states num-non-terms null))
(lookback (make-array2d num-states (lookback (make-array2d num-states
(grammar-num-prods g) (grammar-num-prods g)
null))) null)))
(let loop ((state 0))
(if (< state num-states) (for-each-state
(begin (lambda (state)
(for-each (for-each
(lambda (non-term) (lambda (non-term)
(for-each (for-each
(lambda (prod) (lambda (prod)
(let loop ((i (make-item prod 0)) (let loop ((i (make-item prod 0))
(p (vector-ref states state))) (p state))
(if (and p i) (if (and p i)
(begin (begin
(if (and (non-term? (sym-at-dot i)) (if (and (non-term? (sym-at-dot i))
@ -80,20 +79,20 @@
(gram-sym-index (gram-sym-index
(sym-at-dot i)) (sym-at-dot i))
(make-trans-key (make-trans-key
(vector-ref states state) state
non-term))) non-term)))
(if (not (move-dot-right i)) (if (not (move-dot-right i))
(array2d-add! lookback (array2d-add! lookback
(kernel-index p) (kernel-index p)
(prod-index prod) (prod-index prod)
(make-trans-key (make-trans-key
(vector-ref states state) state
non-term))) non-term)))
(loop (move-dot-right i) (loop (move-dot-right i)
(run-automaton p (sym-at-dot i) a)))))) (run-automaton p (sym-at-dot i) a))))))
(get-nt-prods g non-term))) (get-nt-prods g non-term)))
non-terms) non-terms))
(loop (add1 state))))) a)
(values (lambda (tk) (values (lambda (tk)
(array2d-ref includes (array2d-ref includes
(kernel-index (trans-key-st tk)) (kernel-index (trans-key-st tk))
@ -118,9 +117,79 @@
(define (compute-LA a g) (define (compute-LA a g)
(let-values (((includes lookback) (compute-includes-and-lookback a g))) (let-values (((includes lookback) (compute-includes-and-lookback a g)))
(let ((follow (compute-follow a g includes))) (let ((follow (compute-follow a g includes)))
(print-lookback lookback a g)
(print-follow follow a g)
(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 append f)))))) (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")) (lib "list.ss"))
(provide union build-lr0-automaton run-automaton (struct trans-key (st gs)) (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<?) (define (union comp<?)
(letrec ((union (letrec ((union
@ -35,6 +35,18 @@
(define-struct trans-key (st gs) (make-inspector)) (define-struct trans-key (st gs) (make-inspector))
(define-struct lr0 (transitions states) (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. ;; The kernels in the automaton are represented cannonically.
;; That is (equal? a b) <=> (eq? a b) ;; That is (equal? a b) <=> (eq? a b)
(define (kernel->string k) (define (kernel->string k)

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

@ -39,11 +39,9 @@
;; action array2d * term vector * non-term vector * kernel vector * ;; action array2d * term vector * non-term vector * kernel vector *
;; output-port -> ;; output-port ->
;; Prints out the parser given by table. ;; 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)) (let* ((num-terms (vector-length terms))
(num-non-terms (vector-length non-terms)) (num-non-terms (vector-length non-terms))
(num-gram-syms (+ num-terms num-non-terms))
(num-states (vector-length states))
(SR-conflicts 0) (SR-conflicts 0)
(RR-conflicts 0)) (RR-conflicts 0))
(for-each (for-each
@ -54,20 +52,19 @@
(gram-sym-symbol (prod-lhs prod)) (gram-sym-symbol (prod-lhs prod))
(map gram-sym-symbol (vector->list (prod-rhs prod))))) (map gram-sym-symbol (vector->list (prod-rhs prod)))))
prods) prods)
(let loop ((i 0)) (for-each-state
(if (< i num-states) (lambda (state)
(begin (fprintf port "State ~a~n" (kernel-index state))
(fprintf port "State ~a~n" i)
(for-each (lambda (item) (for-each (lambda (item)
(fprintf port "\t~a~n" (item->string item))) (fprintf port "\t~a~n" (item->string item)))
(kernel-items (vector-ref states i))) (kernel-items state))
(newline port) (newline port)
(let loop ((j 0)) (let loop ((j 0))
(if (< j num-terms) (if (< j num-terms)
(begin (begin
(let ((act (array2d-ref (let ((act (array2d-ref
table table
i (kernel-index state)
(+ j num-non-terms)))) (+ j num-non-terms))))
(cond (cond
((list? act) ((list? act)
@ -94,7 +91,7 @@
(let loop ((j 0)) (let loop ((j 0))
(if (< j num-non-terms) (if (< j num-non-terms)
(begin (begin
(let ((s (array2d-ref table i j))) (let ((s (array2d-ref table (kernel-index state) j)))
(if s (if s
(print-entry (print-entry
(gram-sym-symbol (vector-ref non-terms j)) (gram-sym-symbol (vector-ref non-terms j))
@ -102,14 +99,15 @@
port))) port)))
(loop (add1 j))))) (loop (add1 j)))))
(newline port) (newline port))
(loop (add1 i))))) a)
(if (> SR-conflicts 0) (if (> SR-conflicts 0)
(fprintf port "~a shift/reduce conflicts~n" SR-conflicts)) (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
(if (> RR-conflicts 0) (if (> RR-conflicts 0)
(fprintf port "~a reduce/reduce conflicts~n" RR-conflicts)))) (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) (letrec ((SR-conflicts 0)
(RR-conflicts 0) (RR-conflicts 0)
(get-action (get-action
@ -130,19 +128,19 @@
(loop (car rest) (cdr rest))) (loop (car rest) (cdr rest)))
(else (loop current-guess (cdr rest)))))) (else (loop current-guess (cdr rest))))))
(else entry))))) (else entry)))))
(let loop ((state 0)) (for-each-state
(if (< state num-states) (lambda (state)
(begin
(let loop ((term 0)) (let loop ((term 0))
(if (< term num-terms) (if (< term num-terms)
(begin (begin
(array2d-set! table state (+ num-non-terms term) (array2d-set! table (kernel-index state) (+ num-non-terms term)
(get-action (get-action
(array2d-ref table (array2d-ref table
state (kernel-index state)
(+ num-non-terms term)))) (+ num-non-terms term))))
(loop (add1 term))))) (loop (add1 term))))))
(loop (add1 state))))) a)
(if (> SR-conflicts 0) (if (> SR-conflicts 0)
(fprintf (current-error-port) (fprintf (current-error-port)
"~a shift/reduce conflicts~n" "~a shift/reduce conflicts~n"
@ -154,16 +152,15 @@
(define (resolve-prec-conflicts table get-term get-prod (define (resolve-prec-conflicts a table get-term get-prod
num-states num-terms num-non-terms) num-terms num-non-terms)
(let loop ((state 0)) (for-each-state
(if (< state num-states) (lambda (state)
(begin
(let loop ((term 0)) (let loop ((term 0))
(if (< term num-terms) (if (< term num-terms)
(begin (begin
(let ((action (array2d-ref table (let ((action (array2d-ref table
state (kernel-index state)
(+ num-non-terms term)))) (+ num-non-terms term))))
(if (and (list? action) (if (and (list? action)
(= 2 (length action)) (= 2 (length action))
@ -185,7 +182,7 @@
(if (and s-prec r-prec) (if (and s-prec r-prec)
(array2d-set! (array2d-set!
table table
state (kernel-index state)
(+ num-non-terms term) (+ num-non-terms term)
(cond (cond
((< (prec-num s-prec) ((< (prec-num s-prec)
@ -199,8 +196,8 @@
((eq? 'right (prec-assoc s-prec)) ((eq? 'right (prec-assoc s-prec))
shift) shift)
(else #f))))))) (else #f)))))))
(loop (add1 term))))) (loop (add1 term))))))
(loop (add1 state)))))) a))
;; In the result table the first index is the state and the second is the ;; 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) ;; term/non-term index (with the non-terms coming first)
@ -234,9 +231,8 @@
(array2d-set! v i1 i2 (list a old)))))))) (array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (compute-LA a g))) (get-lookahead (compute-LA a g)))
(let loop ((state 0)) (for-each-state
(if (< state num-states) (lambda (state)
(begin
(let loop ((i 0)) (let loop ((i 0))
(if (< i num-gram-syms) (if (< i num-gram-syms)
(begin (begin
@ -244,12 +240,12 @@
(vector-ref get-non-term i) (vector-ref get-non-term i)
(vector-ref get-term (- i num-non-terms)))) (vector-ref get-term (- i num-non-terms))))
(goto (goto
(run-automaton (vector-ref get-state state) (run-automaton (vector-ref get-state (kernel-index state))
s s
a))) a)))
(if goto (if goto
(array2d-set! table (array2d-set! table
state (kernel-index state)
i i
(cond (cond
((< i num-non-terms) ((< i num-non-terms)
@ -260,17 +256,12 @@
(make-shift (make-shift
(kernel-index goto))))))) (kernel-index goto)))))))
(loop (add1 i))))) (loop (add1 i)))))
(let ((items
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items
(vector-ref get-state state)))))
(for-each (for-each
(lambda (item) (lambda (item)
(for-each (for-each
(lambda (t) (lambda (t)
(array2d-add! table (array2d-add! table
state (kernel-index state)
(+ num-non-terms (gram-sym-index t)) (+ num-non-terms (gram-sym-index t))
(cond (cond
((not (start-item? item)) ((not (start-item? item))
@ -278,11 +269,14 @@
(item-prod-index item) (item-prod-index item)
(gram-sym-index (prod-lhs (item-prod item))) (gram-sym-index (prod-lhs (item-prod item)))
(vector-length (prod-rhs (item-prod item)))))))) (vector-length (prod-rhs (item-prod item))))))))
(get-lookahead (vector-ref get-state state) (get-lookahead (vector-ref get-state (kernel-index state))
(item-prod item)))) (item-prod item))))
items)) (filter (lambda (item)
(loop (add1 state))))) (not (move-dot-right item)))
(resolve-prec-conflicts table get-term get-prod num-states num-terms (kernel-items
(vector-ref get-state (kernel-index state))))))
a)
(resolve-prec-conflicts a table get-term get-prod num-terms
num-non-terms) num-non-terms)
(if (not (string=? file "")) (if (not (string=? file ""))
(with-handlers [(exn:i/o:filesystem? (with-handlers [(exn:i/o:filesystem?
@ -294,9 +288,9 @@
(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 table get-term get-non-term get-state (grammar-prods g) (display-parser a table get-term get-non-term (grammar-prods g)
port))))) port)))))
(resolve-conflicts table num-states num-terms num-non-terms) (resolve-conflicts a table num-terms num-non-terms)
table)) table))
) )

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

@ -23,7 +23,9 @@
(grammar #f)) (grammar #f))
(for-each (for-each
(lambda (arg) (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) ((debug filename)
(cond (cond
((not (string? (syntax-object->datum (syntax filename)))) ((not (string? (syntax-object->datum (syntax filename))))

Write Preview
Loading…
Cancel
Save