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

A more compact representation for the parse tables.

Browse Source 
original commit: 628dceba74adac3cdf33ab76a5eb6d90642d24cf
tokens
Scott Owens 20 years ago
parent 5b78d5815c
commit 75ba3a3f22
5 changed files with 324 additions and 320 deletions
Show Stats Download Patch File Download Diff File

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

@ -15,7 +15,7 @@
;; 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
;; be used to compare kernels ;; be used to compare kernels
;; Each kernel is assigned a uniqui index, 0 <= index < number of states ;; Each kernel is assigned a unique index, 0 <= index < number of states
;; trans-key = (make-trans-key kernel gram-sym) ;; trans-key = (make-trans-key kernel gram-sym)
(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))

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

@ -1,29 +1,46 @@
(module parser-actions mzscheme (module parser-actions mzscheme
(require "grammar.ss")
(provide (all-defined))
;; The entries into the action table ;; An action is
;; - (make-shift int)
;; - (make-reduce prod)
;; - (make-accept)
;; - (make-goto int)
(define-struct action () (make-inspector))
(define-struct (shift action) (state) (make-inspector))
(define-struct (reduce action) (prod) (make-inspector))
(define-struct (accept action) () (make-inspector))
(define-struct (goto action) (state) (make-inspector))
;; A runtime-action is
;; non-negative-int (shift)
;; (vector int symbol int) (reduce)
;; 'accept (accept)
;; negative-int (goto)
(define (action->runtime-action a)
(cond
((shift? a) (shift-state a))
((reduce? a)
(let ((p (reduce-prod a)))
(vector (prod-index p)
(gram-sym-symbol (prod-lhs p))
(vector-length (prod-rhs p)))))
((accept? a) 'accept)
((goto? a) (- (+ (goto-state a) 1)))))
(provide shift? reduce? accept? (define (runtime-shift? x) (and (integer? x) (>= x 0)))
shift-state reduce-prod-num reduce-lhs-num reduce-rhs-length (define runtime-reduce? vector?)
make-shift make-reduce make-accept) (define (runtime-accept? x) (eq? x 'accept))
(define (runtime-goto? x) (and (integer? x) (< x 0)))
;; action = (shift int) (define runtime-shift-state values)
;; | (reduce int int int) (define (runtime-reduce-prod-num x) (vector-ref x 0))
;; | (accept) (define (runtime-reduce-lhs x) (vector-ref x 1))
;; | int>=0 (define (runtime-reduce-rhs-length x) (vector-ref x 2))
;; | #f (define (runtime-goto-state x) (- (+ x 1)))
(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))
) )

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

@ -73,21 +73,15 @@
(define (build-parser filename src-pos suppress input-terms start end assocs prods) (define (build-parser filename src-pos suppress input-terms start end assocs prods)
(let* ((grammar (parse-input input-terms start end assocs prods src-pos)) (let* ((grammar (parse-input input-terms start end assocs prods src-pos))
(table (build-table grammar filename suppress)) (table (build-table grammar filename suppress))
(num-non-terms (send grammar get-num-non-terms)) (all-tokens (make-hash-table))
(token-code
`(let ((ht (make-hash-table)))
(begin
,@(map (lambda (term)
`(hash-table-put! ht
',(gram-sym-symbol term)
,(+ num-non-terms (gram-sym-index term))))
(send grammar get-terms))
ht)))
(actions-code (actions-code
`(vector ,@(map prod-action (send grammar get-prods))))) `(vector ,@(map prod-action (send grammar get-prods)))))
(values table (for-each (lambda (term)
token-code (hash-table-put! all-tokens (gram-sym-symbol term) #t))
actions-code (send grammar get-terms))
(fix-check-syntax input-terms start end assocs prods)))) (values table
all-tokens
actions-code
(fix-check-syntax input-terms start end assocs prods))))
) )

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

@ -4,14 +4,55 @@
(require "grammar.ss" (require "grammar.ss"
"lr0.ss" "lr0.ss"
"array2d.ss"
"lalr.ss" "lalr.ss"
"parser-actions.ss" "parser-actions.ss"
(lib "list.ss") (lib "contract.ss")
(lib "list.ss")
(lib "class.ss")) (lib "class.ss"))
(provide build-table) (provide/contract
(build-table ((is-a?/c grammar%) string? any/c . -> .
(vectorof (listof (cons/c (union term? non-term?) action?))))))
;; A parse-table is (vectorof (listof (cons/c gram-sym? action)))
;; A grouped-parse-table is (vectorof (listof (cons/c gram-sym? (listof action))))
;; make-parse-table : int -> parse-table
(define (make-parse-table num-states)
(make-vector num-states null))
;; table-add!: parse-table nat symbol action ->
(define (table-add! table state-index symbol val)
(vector-set! table state-index (cons (cons symbol val)
(vector-ref table state-index))))
;; group-table : parse-table -> grouped-parse-table
(define (group-table table)
(list->vector
(map
(lambda (state-entry)
(let ((ht (make-hash-table 'equal)))
(for-each
(lambda (gs/actions)
(let ((group (hash-table-get ht (car gs/actions) (lambda () null))))
(unless (member (cdr gs/actions) group)
(hash-table-put! ht (car gs/actions) (cons (cdr gs/actions) group)))))
state-entry)
(hash-table-map ht cons)))
(vector->list table))))
;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) ->
;; (vectorof (listof (cons/c gram-sym? Y)))
(define (table-map f table)
(list->vector
(map
(lambda (state-entry)
(map
(lambda (gs/X)
(cons (car gs/X) (f (car gs/X) (cdr gs/X))))
state-entry))
(vector->list table))))
(define (bit-vector-for-each f bv) (define (bit-vector-for-each f bv)
(letrec ((for-each (letrec ((for-each
@ -25,19 +66,19 @@
(for-each bv 0))) (for-each bv 0)))
;; print-entry: symbol * action * output-port -> ;; print-entry: symbol action output-port ->
;; prints the action a for lookahead sym to port ;; prints the action a for lookahead sym to the given port
(define (print-entry sym a port) (define (print-entry sym a port)
(let ((s "\t~a\t\t\t\t\t~a\t~a\n")) (let ((s "\t~a\t\t\t\t\t~a\t~a\n"))
(cond (cond
((shift? a) ((shift? a)
(fprintf port s sym "shift" (shift-state a))) (fprintf port s sym "shift" (shift-state a)))
((reduce? a) ((reduce? a)
(fprintf port s sym "reduce" (reduce-prod-num a))) (fprintf port s sym "reduce" (prod-index (reduce-prod a))))
((accept? a) ((accept? a)
(fprintf port s sym "accept" "")) (fprintf port s sym "accept" ""))
(a ((goto? a)
(fprintf port s sym "goto" a))))) (fprintf port s sym "goto" (goto-state a))))))
;; count: ('a -> bool) * 'a list -> num ;; count: ('a -> bool) * 'a list -> num
@ -48,14 +89,10 @@
((pred (car list)) (+ 1 (count pred (cdr list)))) ((pred (car list)) (+ 1 (count pred (cdr list))))
(else (count pred (cdr list))))) (else (count pred (cdr list)))))
;; display-parser: ;; display-parser: LR0-automaton grouped-parse-table (listof prod?) output-port ->
;; action array2d * term vector * non-term vector * kernel vector *
;; output-port ->
;; Prints out the parser given by table. ;; Prints out the parser given by table.
(define (display-parser a table terms non-terms prods port) (define (display-parser a grouped-table prods port)
(let* ((num-terms (vector-length terms)) (let* ((SR-conflicts 0)
(num-non-terms (vector-length non-terms))
(SR-conflicts 0)
(RR-conflicts 0)) (RR-conflicts 0))
(for-each (for-each
(lambda (prod) (lambda (prod)
@ -66,231 +103,169 @@
(map gram-sym-symbol (vector->list (prod-rhs prod))))) (map gram-sym-symbol (vector->list (prod-rhs prod)))))
prods) prods)
(send a for-each-state (send a for-each-state
(lambda (state) (lambda (state)
(fprintf port "State ~a~n" (kernel-index state)) (fprintf port "State ~a~n" (kernel-index state))
(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 state))
(newline port) (newline port)
(let loop ((j 0)) (for-each
(if (< j num-terms) (lambda (gs/action)
(begin (let ((sym (gram-sym-symbol (car gs/action)))
(let ((act (array2d-ref (act (cdr gs/action)))
table (cond
(kernel-index state) ((null? (cdr act))
(+ j num-non-terms)))) (print-entry sym (car act) port))
(cond (else
((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) (print-entry sym x port)) act)
(map (lambda (x) (fprintf port "end conflict~n")))))
(print-entry (vector-ref grouped-table (kernel-index state)))
(gram-sym-symbol (vector-ref terms j)) (newline port)))
x
port)) (when (> SR-conflicts 0)
act) (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
(fprintf port "end conflict~n")) (when (> RR-conflicts 0)
(act (print-entry (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))
(gram-sym-symbol (vector-ref terms j))
act ;; resolve-conflict : (listof action?) -> action? bool bool
port)))) (define (resolve-conflict actions)
(loop (add1 j))))) (cond
((null? (cdr actions))
(newline port) (values (car actions) #f #f))
(else
(let loop ((j 0)) (let ((SR-conflict? (> (count shift? actions) 0))
(if (< j num-non-terms) (RR-conflict? (> (count reduce? actions) 1)))
(begin (let loop ((current-guess #f)
(let ((s (array2d-ref table (kernel-index state) j))) (rest actions))
(if s (cond
(print-entry ((null? rest) (values current-guess SR-conflict? RR-conflict?))
(gram-sym-symbol (vector-ref non-terms j)) ((shift? (car rest)) (values (car rest) SR-conflict? RR-conflict?))
s ((not current-guess)
port))) (loop (car rest) (cdr rest)))
(loop (add1 j))))) ((and (reduce? (car rest))
(< (prod-index (reduce-prod (car rest)))
(newline port))) (prod-index (reduce-prod current-guess))))
(loop (car rest) (cdr rest)))
(if (> SR-conflicts 0) ((accept? (car rest))
(fprintf port "~a shift/reduce conflicts~n" SR-conflicts)) (fprintf (current-error-port)
(if (> RR-conflicts 0) "accept/reduce or accept/shift conflicts. Check the grammar for useless cycles of productions~n")
(fprintf port "~a reduce/reduce conflicts~n" RR-conflicts)))) (loop current-guess (cdr rest)))
(else (loop current-guess (cdr rest)))))))))
;; resolve-conflicts : grouped-parse-table bool -> parse-table
(define (resolve-conflicts grouped-table suppress)
(let* ((SR-conflicts 0)
(RR-conflicts 0)
(table (table-map
(lambda (gs actions)
(let-values (((action SR? RR?)
(resolve-conflict actions)))
(when SR?
(set! SR-conflicts (add1 SR-conflicts)))
(when RR?
(set! RR-conflicts (add1 RR-conflicts)))
action))
grouped-table)))
(unless suppress
(when (> SR-conflicts 0)
(fprintf (current-error-port)
"~a shift/reduce conflicts~n"
SR-conflicts))
(when (> RR-conflicts 0)
(fprintf (current-error-port)
"~a reduce/reduce conflicts~n"
RR-conflicts)))
table))
(define (resolve-conflicts a table num-terms num-non-terms suppress) ;; resolve-sr-conflict : (listof action) (union int #f) -> (listof action)
(letrec ((SR-conflicts 0) ;; Resolves a single shift-reduce conflict, if precedences are in place.
(RR-conflicts 0) (define (resolve-sr-conflict/prec actions shift-prec)
(get-action (let* ((shift (if (shift? (car actions))
(lambda (entry) (car actions)
(cond (cadr actions)))
((list? entry) (reduce (if (shift? (car actions))
(if (> (count shift? entry) 0) (cadr actions)
(set! SR-conflicts (add1 SR-conflicts))) (car actions)))
(if (> (count reduce? entry) 1) (reduce-prec (prod-prec (reduce-prod reduce))))
(set! RR-conflicts (add1 RR-conflicts))) (cond
(let loop ((current-guess (make-reduce +inf.0 -1 -1)) ((and shift-prec reduce-prec)
(rest entry)) (list
(cond (cond
((null? rest) current-guess) ((< (prec-num shift-prec) (prec-num reduce-prec))
((shift? (car rest)) (car rest)) reduce)
((and (reduce? (car rest)) ((> (prec-num shift-prec) (prec-num reduce-prec))
(< (reduce-prod-num (car rest)) shift)
(reduce-prod-num current-guess))) ((eq? 'left (prec-assoc shift-prec))
(loop (car rest) (cdr rest))) reduce)
((accept? (car rest)) ((eq? 'right (prec-assoc shift-prec))
(fprintf (current-error-port) shift))))
"accept/reduce or accept/shift conflicts. Check the grammar for useless cycles of productions~n") (else actions))))
(loop current-guess (cdr rest)))
(else (loop current-guess (cdr rest))))))
(else entry)))))
(send a 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)))))))
(if (not suppress)
(begin
(if (> SR-conflicts 0)
(fprintf (current-error-port)
"~a shift/reduce conflicts~n"
SR-conflicts))
(if (> RR-conflicts 0)
(fprintf (current-error-port)
"~a reduce/reduce conflicts~n"
RR-conflicts))))))
;; resolve-prec-conflicts : parse-table -> grouped-parse-table
(define (resolve-prec-conflicts a table get-term get-prod (define (resolve-prec-conflicts table)
num-terms num-non-terms) (table-map
(send a for-each-state (lambda (gs actions)
(lambda (state) (cond
(let loop ((term 0)) ((and (term? gs)
(if (< term num-terms) (= 2 (length actions))
(begin (or (shift? (car actions))
(let ((action (array2d-ref table (shift? (cadr actions))))
(kernel-index state) (resolve-sr-conflict/prec actions (term-prec gs)))
(+ num-non-terms term)))) (else actions)))
(if (and (list? action) (group-table table)))
(= 2 (length action))
(or (shift? (car action)) ;; build-table: grammar string bool -> parse-table
(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))))))))
;; 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)
;; buile-table: grammar * string -> action array2d
(define (build-table g file suppress) (define (build-table g file suppress)
(let* ((a (build-lr0-automaton g)) (let* ((a (build-lr0-automaton g))
(num-terms (send g get-num-terms)) (term-list (send g get-terms))
(num-non-terms (send g get-num-non-terms)) (term-vector (list->vector term-list))
(get-term (list->vector (send g get-terms))) (non-term-list (send g get-non-terms))
(get-non-term (list->vector (send g get-non-terms))) (end-terms (send g get-end-terms))
(get-prod (list->vector (send g get-prods))) (table (make-parse-table (send a get-num-states)))
(end-term-indexes
(map
(lambda (term)
(+ num-non-terms (gram-sym-index term)))
(send g get-end-terms)))
(num-gram-syms (+ num-terms num-non-terms))
(table (make-array2d (send a get-num-states) num-gram-syms #f))
(array2d-add!
(lambda (v i1 i2 a)
(let ((old (array2d-ref v i1 i2)))
(cond
((not old) (array2d-set! v i1 i2 a))
((list? old) (if (not (member a old))
(array2d-set! v i1 i2 (cons a old))))
(else (if (not (equal? a old))
(array2d-set! v i1 i2 (list a old))))))))
(get-lookahead (compute-LA a g))) (get-lookahead (compute-LA a g)))
(send a for-each-state (send a for-each-state
(lambda (state) (lambda (state)
(let loop ((i 0)) (for-each
(if (< i num-gram-syms) (lambda (gs)
(begin (let ((goto (send a run-automaton state gs)))
(let* ((s (if (< i num-non-terms) (when goto
(vector-ref get-non-term i) (table-add! table (kernel-index state) gs
(vector-ref get-term (- i num-non-terms)))) (cond
(goto ((non-term? gs)
(send a run-automaton state s))) (make-goto (kernel-index goto)))
(if goto ((member gs end-terms)
(array2d-set! table (make-accept))
(kernel-index state) (else
i (make-shift
(cond (kernel-index goto))))))))
((< i num-non-terms) (append non-term-list term-list))
(kernel-index goto))
((member i end-term-indexes) (for-each
(make-accept)) (lambda (item)
(else (let ((item-prod (item-prod item)))
(make-shift (bit-vector-for-each
(kernel-index goto))))))) (lambda (term-index)
(loop (add1 i))))) (unless (start-item? item)
(for-each (table-add! table
(lambda (item) (kernel-index state)
(let ((item-prod (item-prod item))) (vector-ref term-vector term-index)
(bit-vector-for-each (make-reduce item-prod))))
(lambda (term-index) (get-lookahead state item-prod))))
(array2d-add! table
(kernel-index state) (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
(+ num-non-terms term-index) (filter (lambda (item)
(cond (not (move-dot-right item)))
((not (start-item? item)) (kernel-items state))))))
(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 (let ((grouped-table (resolve-prec-conflicts table)))
num-non-terms) (unless (string=? file "")
(if (not (string=? file ""))
(with-handlers [(exn:fail:filesystem? (with-handlers [(exn:fail:filesystem?
(lambda (e) (lambda (e)
(fprintf (fprintf
@ -299,12 +274,9 @@
file)))] file)))]
(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 grouped-table (send g get-prods) port)))))
port)))))
(resolve-conflicts grouped-table suppress))))
(resolve-conflicts a table num-terms num-non-terms suppress)
table))
) )

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

@ -1,9 +1,10 @@
(module yacc mzscheme (module yacc mzscheme
(require-for-syntax "private-yacc/parser-builder.ss" (require-for-syntax "private-yacc/parser-builder.ss"
"private-yacc/yacc-helper.ss") "private-yacc/grammar.ss"
(require "private-yacc/array2d.ss" "private-yacc/yacc-helper.ss"
"private-lex/token.ss" "private-yacc/parser-actions.ss")
(require "private-lex/token.ss"
"private-yacc/parser-actions.ss" "private-yacc/parser-actions.ss"
(lib "etc.ss") (lib "etc.ss")
(lib "pretty.ss") (lib "pretty.ss")
@ -11,6 +12,23 @@
(provide parser) (provide parser)
;; convert-parse-table : (vectorof (listof (cons/c gram-sym? action?))) ->
;; (vectorof (symbol runtime-action hashtable))
(define-for-syntax (convert-parse-table table)
(list->vector
(map
(lambda (state-entry)
(let ((ht (make-hash-table)))
(for-each
(lambda (gs/action)
(hash-table-put! ht
(gram-sym-symbol (car gs/action))
(action->runtime-action (cdr gs/action))))
state-entry)
ht))
(vector->list table))))
(define-syntax (parser stx) (define-syntax (parser stx)
(syntax-case stx () (syntax-case stx ()
((_ args ...) ((_ args ...)
@ -141,7 +159,7 @@
(raise-syntax-error #f "missing end declaration" stx)) (raise-syntax-error #f "missing end declaration" stx))
(unless start (unless start
(raise-syntax-error #f "missing start declaration" stx)) (raise-syntax-error #f "missing start declaration" stx))
(let-values (((table term-sym->index actions check-syntax-fix) (let-values (((table all-term-syms actions check-syntax-fix)
(build-parser (if debug debug "") (build-parser (if debug debug "")
src-pos src-pos
suppress suppress
@ -171,14 +189,14 @@
(ends end) (ends end)
(starts start) (starts start)
(debug debug) (debug debug)
(table table) (table (convert-parse-table table))
(term-sym->index term-sym->index) (all-term-syms all-term-syms)
(actions actions) (actions actions)
(src-pos src-pos)) (src-pos src-pos))
(syntax (syntax
(begin (begin
check-syntax-fix check-syntax-fix
(parser-body debug err (quote starts) (quote ends) table term-sym->index actions src-pos))))))) (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos)))))))
(_ (_
(raise-syntax-error #f (raise-syntax-error #f
"parser must have the form (parser args ...)" "parser must have the form (parser args ...)"
@ -231,11 +249,12 @@
(define (make-empty-stack i) (list (make-stack-frame i #f #f #f))) (define (make-empty-stack i) (list (make-stack-frame i #f #f #f)))
;; 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 ;; The table is a vector that maps each state to a hash-table that maps a
;; by changing (make-accept) -> 'accept, (make-shift i) -> i and ;; terminal symbol to either an accept, shift, reduce, or goto structure.
;; (make-reduce i1 i2 i3) -> #(i1 i2 i3) ; We encode the structures according to the runtime-action data definition in
(define (parser-body debug? err starts ends table term-sym->index actions src-pos) ;; parser-actions.ss
(define (parser-body debug? err starts ends table all-term-syms actions src-pos)
(local ((define extract (local ((define extract
(if src-pos (if src-pos
extract-src-pos extract-src-pos
@ -249,9 +268,9 @@
#f #f #f #f #f) #f #f #f #f #f)
(let ((a (find-action stack tok val start-pos end-pos))) (let ((a (find-action stack tok val start-pos end-pos)))
(cond (cond
((shift? a) ((runtime-shift? a)
;; (printf "shift:~a~n" (shift-state a)) ;; (printf "shift:~a~n" (runtime-shift-state a))
(cons (make-stack-frame (shift-state a) (cons (make-stack-frame (runtime-shift-state a)
val val
start-pos start-pos
end-pos) end-pos)
@ -264,11 +283,11 @@
(let remove-states () (let remove-states ()
(let ((a (find-action stack 'error #f start-pos end-pos))) (let ((a (find-action stack 'error #f start-pos end-pos)))
(cond (cond
((shift? a) ((runtime-shift? a)
;; (printf "shift:~a~n" (shift-state a)) ;; (printf "shift:~a~n" (runtime-shift-state a))
(set! stack (set! stack
(cons (cons
(make-stack-frame (shift-state a) (make-stack-frame (runtime-shift-state a)
#f #f
start-pos start-pos
end-pos) end-pos)
@ -285,19 +304,18 @@
(remove-states))))))))) (remove-states)))))))))
(define (find-action stack tok val start-pos end-pos) (define (find-action stack tok val start-pos end-pos)
(let ((token-index (hash-table-get term-sym->index (unless (hash-table-get all-term-syms
tok tok
(lambda () #f)))) (lambda () #f))
(if token-index (if src-pos
(array2d-ref table (err #f tok val start-pos end-pos)
(stack-frame-state (car stack)) (err #f tok val))
token-index) (raise-read-error (format "parser: got token of unknown type ~a" tok)
(begin #f #f #f #f #f))
(if src-pos (hash-table-get (vector-ref table (stack-frame-state (car stack)))
(err #f tok val start-pos end-pos) tok
(err #f tok val)) (lambda () #f)))
(raise-read-error (format "parser: got token of unknown type ~a" tok)
#f #f #f #f #f)))))
(define (make-parser start-number) (define (make-parser start-number)
(lambda (get-token) (lambda (get-token)
(let parsing-loop ((stack (make-empty-stack start-number)) (let parsing-loop ((stack (make-empty-stack start-number))
@ -306,41 +324,44 @@
(extract ip))) (extract ip)))
(let ((action (find-action stack tok val start-pos end-pos))) (let ((action (find-action stack tok val start-pos end-pos)))
(cond (cond
((shift? action) ((runtime-shift? action)
;; (printf "shift:~a~n" (shift-state action)) ;; (printf "shift:~a~n" (runtime-shift-state action))
(parsing-loop (cons (make-stack-frame (shift-state action) (parsing-loop (cons (make-stack-frame (runtime-shift-state action)
val val
start-pos start-pos
end-pos) end-pos)
stack) stack)
(get-token))) (get-token)))
((reduce? action) ((runtime-reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action)) ;; (printf "reduce:~a~n" (runtime-reduce-prod-num action))
(let-values (((new-stack args) (let-values (((new-stack args)
(reduce-stack stack (reduce-stack stack
(reduce-rhs-length action) (runtime-reduce-rhs-length action)
null null
src-pos))) src-pos)))
(let* ((A (reduce-lhs-num action)) (let ((goto
(goto (array2d-ref table (stack-frame-state (car new-stack)) A))) (runtime-goto-state
(hash-table-get
(vector-ref table (stack-frame-state (car new-stack)))
(runtime-reduce-lhs action)))))
(parsing-loop (parsing-loop
(cons (cons
(if src-pos (if src-pos
(make-stack-frame (make-stack-frame
goto goto
(apply (vector-ref actions (reduce-prod-num action)) args) (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
(if (null? args) start-pos (cadr args)) (if (null? args) start-pos (cadr args))
(if (null? args) (if (null? args)
end-pos end-pos
(list-ref args (- (* (reduce-rhs-length action) 3) 1)))) (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1))))
(make-stack-frame (make-stack-frame
goto goto
(apply (vector-ref actions (reduce-prod-num action)) args) (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
#f #f
#f)) #f))
new-stack) new-stack)
ip)))) ip))))
((accept? action) ((runtime-accept? action)
;; (printf "accept~n") ;; (printf "accept~n")
(stack-frame-value (car stack))) (stack-frame-value (car stack)))
(else (else

Write Preview
Loading…
Cancel
Save