You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
287 lines
8.0 KiB
Scheme
287 lines
8.0 KiB
Scheme
#cs
|
|
(module table mzscheme
|
|
|
|
;; Routine to build the LALR table
|
|
|
|
(require "grammar.ss"
|
|
"lr0.ss"
|
|
"array2d.ss"
|
|
"lalr.ss"
|
|
"parser-actions.ss"
|
|
(lib "list.ss"))
|
|
|
|
(provide build-table)
|
|
|
|
;; print-entry: symbol * action * output-port ->
|
|
;; prints the action a for lookahead sym to port
|
|
(define (print-entry sym a port)
|
|
(let ((s "\t~a\t\t\t\t\t~a\t~a\n"))
|
|
(cond
|
|
((shift? a)
|
|
(fprintf port s sym "shift" (shift-state a)))
|
|
((reduce? a)
|
|
(fprintf port s sym "reduce" (reduce-prod-num a)))
|
|
((accept? a)
|
|
(fprintf port s sym "accept" ""))
|
|
(a
|
|
(fprintf port s sym "goto" a)))))
|
|
|
|
|
|
;; count: ('a -> bool) * 'a list -> num
|
|
;; counts the number of elements in list that satisfy pred
|
|
(define (count pred list)
|
|
(cond
|
|
((null? list) 0)
|
|
((pred (car list)) (+ 1 (count pred (cdr list))))
|
|
(else (count pred (cdr list)))))
|
|
|
|
|
|
;; display-parser:
|
|
;; 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 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))
|
|
(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)))))
|
|
|
|
(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)
|
|
(letrec ((SR-conflicts 0)
|
|
(RR-conflicts 0)
|
|
(get-action
|
|
(lambda (entry)
|
|
(cond
|
|
((list? entry)
|
|
(if (> (count shift? entry) 0)
|
|
(set! SR-conflicts (add1 SR-conflicts)))
|
|
(if (> (count reduce? entry) 1)
|
|
(set! RR-conflicts (add1 RR-conflicts)))
|
|
(let loop ((current-guess (make-reduce +inf.0 -1 -1))
|
|
(rest entry))
|
|
(cond
|
|
((null? rest) current-guess)
|
|
((shift? (car rest)) (car rest))
|
|
((< (reduce-prod-num (car rest))
|
|
(reduce-prod-num current-guess))
|
|
(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)))))
|
|
(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))))
|
|
|
|
|
|
|
|
(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))))))
|
|
|
|
;; 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 -> action2d-array
|
|
(define (build-table g file)
|
|
(let* ((a (build-lr0-automaton g))
|
|
(terms (grammar-terms g))
|
|
(non-terms (grammar-non-terms g))
|
|
(get-state (lr0-states a))
|
|
(get-term (list->vector terms))
|
|
(get-non-term (list->vector non-terms))
|
|
(get-prod (list->vector (grammar-prods g)))
|
|
(num-states (vector-length get-state))
|
|
(num-terms (vector-length get-term))
|
|
(num-non-terms (vector-length get-non-term))
|
|
(num-gram-syms (+ num-terms num-non-terms))
|
|
(table (make-array2d 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)))
|
|
|
|
(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
|
|
(if (< i num-non-terms)
|
|
(kernel-index goto)
|
|
(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)
|
|
(if (not (string=? file ""))
|
|
(with-handlers [(exn:i/o:filesystem?
|
|
(lambda (e)
|
|
(fprintf
|
|
(current-error-port)
|
|
"Cannot write debug output to file \"~a\". ~a~n"
|
|
(exn:i/o:filesystem-pathname e)
|
|
(exn:i/o:filesystem-detail e))))]
|
|
(call-with-output-file file
|
|
(lambda (port)
|
|
(display-parser table get-term get-non-term get-state port)))))
|
|
(resolve-conflicts table num-states num-terms num-non-terms)
|
|
table))
|
|
)
|
|
|