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))) (if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i)))
(loop (add1 i)) (loop (add1 i))
#f)) #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 --------------------------- ;; ------------------------ Productions ---------------------------

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

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

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

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

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

@ -2,9 +2,9 @@
(module parser-builder mzscheme (module parser-builder mzscheme
(require "input-file-parser.ss" (require "input-file-parser.ss"
"table.ss"
"parser-actions.ss" "parser-actions.ss"
"grammar.ss" "grammar.ss"
"table.ss"
(lib "class.ss")) (lib "class.ss"))
(provide build-parser) (provide build-parser)
@ -42,41 +42,8 @@
(define (build-parser filename src-pos suppress input-terms start end assocs prods runtime) (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)) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
(table (build-table grammar filename suppress)) (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)))))
(num-non-terms (send grammar get-num-non-terms)) (num-non-terms (send grammar get-num-non-terms))
(token-code (token-code
`(let ((ht (make-hash-table))) `(let ((ht (make-hash-table)))
(begin (begin
@ -86,12 +53,22 @@
,(+ num-non-terms (gram-sym-index term)))) ,(+ num-non-terms (gram-sym-index term))))
(send grammar get-terms)) (send grammar get-terms))
ht))) ht)))
(actions-code (actions-code
`(vector ,@(map prod-action (send grammar get-prods))))) `(vector ,@(map prod-action (send grammar get-prods)))))
(values table-code (let loop ((i 1))
token-code (if (< i (vector-length table))
actions-code (let ((a (vector-ref table i)))
(fix-check-syntax start input-terms prods assocs end)))) (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 ;; 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)
;; buile-table: grammar * string -> action2d-array ;; buile-table: grammar * string -> action array2d
(define (build-table g file suppress) (define (build-table g file suppress)
(let* ((a (time (build-lr0-automaton g))) (let* ((a (build-lr0-automaton g))
(terms (send g get-terms)) (terms (send g get-terms))
(non-terms (send g get-non-terms)) (non-terms (send g get-non-terms))
(get-term (list->vector terms)) (get-term (list->vector terms))
@ -229,7 +229,7 @@
(+ num-non-terms (gram-sym-index term))) (+ num-non-terms (gram-sym-index term)))
(send g get-end-terms))) (send g get-end-terms)))
(num-gram-syms (+ num-terms num-non-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! (array2d-add!
(lambda (v i1 i2 a) (lambda (v i1 i2 a)
(let ((old (array2d-ref v i1 i2))) (let ((old (array2d-ref v i1 i2)))
@ -240,69 +240,71 @@
(else (if (not (equal? a old)) (else (if (not (equal? a old))
(array2d-set! v i1 i2 (list a old)))))))) (array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (time (compute-LA a g)))) (get-lookahead (time (compute-LA a g))))
(time
(send a for-each-state (send a for-each-state
(lambda (state) (lambda (state)
(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
(send a run-automaton state s))) (send a run-automaton state s)))
(if goto (if goto
(array2d-set! table (array2d-set! table
(kernel-index state) (kernel-index 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
(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 (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
(lambda (item) (filter (lambda (item)
(let ((item-prod (item-prod item))) (not (move-dot-right item)))
(bit-vector-for-each (kernel-items state))))))
(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)))))))
(resolve-prec-conflicts a table get-term get-prod num-terms (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?
(lambda (e) (lambda (e)
(fprintf (fprintf
(current-error-port) (current-error-port)
"Cannot write debug output to file \"~a\". ~a~n" "Cannot write debug output to file \"~a\". ~a~n"
(exn:i/o:filesystem-pathname e) (exn:i/o:filesystem-pathname e)
(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 a table get-term get-non-term (send g get-prods) (display-parser a table get-term get-non-term (send g get-prods)
port))))) port)))))
(resolve-conflicts a table num-terms num-non-terms suppress) (resolve-conflicts a table num-terms num-non-terms suppress)
table)) table))
)
)

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

@ -3,8 +3,7 @@
(require-for-syntax "private-yacc/parser-builder.ss" (require-for-syntax "private-yacc/parser-builder.ss"
"private-yacc/yacc-helper.ss") "private-yacc/yacc-helper.ss")
(require "private-yacc/parser-actions.ss" (require "private-yacc/array2d.ss"
"private-yacc/array2d.ss"
"private-lex/token.ss" "private-lex/token.ss"
(lib "readerr.ss" "syntax")) (lib "readerr.ss" "syntax"))
@ -154,6 +153,18 @@
(define (false-thunk) #f) (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) (define (parser-body err ends table term-sym->index actions src-pos)
(letrec ((input->token (letrec ((input->token
(if src-pos (if src-pos

Write Preview
Loading…
Cancel
Save