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))

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

@ -53,47 +53,46 @@
;; 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))
(nullable-after-dot? (move-dot-right i) (nullable-after-dot? (move-dot-right i)
g)) g))
(array2d-add! includes (array2d-add! includes
(kernel-index p) (kernel-index p)
(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)

320
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,62 +52,62 @@
(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 state))
(kernel-items (vector-ref states i))) (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 (kernel-index state)
i (+ j num-non-terms))))
(+ j num-non-terms)))) (cond
(cond ((list? act)
((list? act) (fprintf port "begin conflict:~n")
(fprintf port "begin conflict:~n") (if (> (count reduce? act) 1)
(if (> (count reduce? act) 1) (set! RR-conflicts (add1 RR-conflicts)))
(set! RR-conflicts (add1 RR-conflicts))) (if (> (count shift? act) 0)
(if (> (count shift? act) 0) (set! SR-conflicts (add1 SR-conflicts)))
(set! SR-conflicts (add1 SR-conflicts))) (map (lambda (x)
(map (lambda (x) (print-entry
(print-entry (gram-sym-symbol (vector-ref terms j))
(gram-sym-symbol (vector-ref terms j)) x
x port))
port)) act)
act) (fprintf port "end conflict~n"))
(fprintf port "end conflict~n")) (act (print-entry
(act (print-entry (gram-sym-symbol (vector-ref terms j))
(gram-sym-symbol (vector-ref terms j)) act
act port))))
port)))) (loop (add1 j)))))
(loop (add1 j)))))
(newline port)
(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)))))
(let loop ((j 0)) (newline port))
(if (< j num-non-terms) a)
(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)))))
(newline port)
(loop (add1 i)))))
(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 (kernel-index state) (+ num-non-terms term)
(array2d-set! table state (+ num-non-terms term) (get-action
(get-action (array2d-ref table
(array2d-ref table (kernel-index state)
state (+ num-non-terms term))))
(+ num-non-terms term)))) (loop (add1 term))))))
(loop (add1 term))))) a)
(loop (add1 state)))))
(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,53 +152,52 @@
(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 (kernel-index state)
state (+ num-non-terms term))))
(+ num-non-terms term)))) (if (and (list? action)
(if (and (list? action) (= 2 (length action))
(= 2 (length action)) (or (shift? (car action))
(or (shift? (car action)) (shift? (cadr action))))
(shift? (cadr action)))) (let* ((shift (if (shift? (car action))
(let* ((shift (if (shift? (car action)) (car action)
(car action) (cadr action)))
(cadr action))) (reduce (if (shift? (car action))
(reduce (if (shift? (car action)) (cadr action)
(cadr action) (car action)))
(car action))) (s-prec (term-prec
(s-prec (term-prec (vector-ref get-term
(vector-ref get-term term)))
term))) (r-prec (prod-prec
(r-prec (prod-prec (vector-ref
(vector-ref get-prod
get-prod (reduce-prod-num reduce)))))
(reduce-prod-num reduce))))) (if (and s-prec r-prec)
(if (and s-prec r-prec) (array2d-set!
(array2d-set! table
table (kernel-index state)
state (+ num-non-terms term)
(+ num-non-terms term) (cond
(cond ((< (prec-num s-prec)
((< (prec-num s-prec) (prec-num r-prec))
(prec-num r-prec)) reduce)
reduce) ((> (prec-num s-prec)
((> (prec-num s-prec) (prec-num r-prec))
(prec-num r-prec)) shift)
shift) ((eq? 'left (prec-assoc s-prec))
((eq? 'left (prec-assoc s-prec)) reduce)
reduce) ((eq? 'right (prec-assoc s-prec))
((eq? 'right (prec-assoc s-prec)) shift)
shift) (else #f)))))))
(else #f))))))) (loop (add1 term))))))
(loop (add1 term))))) a))
(loop (add1 state))))))
;; 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,56 +231,53 @@
(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 (let* ((s (if (< i num-non-terms)
(let* ((s (if (< i num-non-terms) (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 (kernel-index state))
(run-automaton (vector-ref get-state state) s
s a)))
a))) (if goto
(if goto (array2d-set! table
(array2d-set! table (kernel-index state)
state i
i (cond
(cond ((< i num-non-terms)
((< i num-non-terms) (kernel-index goto))
(kernel-index goto)) ((member i end-term-indexes)
((member i end-term-indexes) (make-accept))
(make-accept)) (else
(else (make-shift
(make-shift (kernel-index goto)))))))
(kernel-index goto))))))) (loop (add1 i)))))
(loop (add1 i))))) (for-each
(let ((items (lambda (item)
(filter (lambda (item) (for-each
(not (move-dot-right item))) (lambda (t)
(kernel-items (array2d-add! table
(vector-ref get-state state))))) (kernel-index state)
(for-each (+ num-non-terms (gram-sym-index t))
(lambda (item) (cond
(for-each ((not (start-item? item))
(lambda (t) (make-reduce
(array2d-add! table (item-prod-index item)
state (gram-sym-index (prod-lhs (item-prod item)))
(+ num-non-terms (gram-sym-index t)) (vector-length (prod-rhs (item-prod item))))))))
(cond (get-lookahead (vector-ref get-state (kernel-index state))
((not (start-item? item)) (item-prod item))))
(make-reduce (filter (lambda (item)
(item-prod-index item) (not (move-dot-right item)))
(gram-sym-index (prod-lhs (item-prod item))) (kernel-items
(vector-length (prod-rhs (item-prod item)))))))) (vector-ref get-state (kernel-index state))))))
(get-lookahead (vector-ref get-state state) a)
(item-prod item)))) (resolve-prec-conflicts a table get-term get-prod num-terms
items)) num-non-terms)
(loop (add1 state)))))
(resolve-prec-conflicts table get-term get-prod num-states num-terms
num-non-terms)
(if (not (string=? file "")) (if (not (string=? file ""))
(with-handlers [(exn:i/o:filesystem? (with-handlers [(exn:i/o:filesystem?
(lambda (e) (lambda (e)
@ -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