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.
br-parser-tools/collects/parser-tools/private-yacc/table.rkt

290 lines
11 KiB
Racket

#lang scheme/base
;; Routine to build the LALR table
(require "grammar.rkt"
"lr0.rkt"
"lalr.rkt"
"parser-actions.rkt"
mzlib/contract
mzlib/list
mzlib/class)
(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)))
(for-each
(lambda (gs/actions)
(let ((group (hash-ref ht (car gs/actions) (lambda () null))))
(unless (member (cdr gs/actions) group)
(hash-set! ht (car gs/actions) (cons (cdr gs/actions) group)))))
state-entry)
(hash-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)
(letrec ((for-each
(lambda (bv number)
(cond
((= 0 bv) (void))
((= 1 (bitwise-and 1 bv))
(f number)
(for-each (arithmetic-shift bv -1) (add1 number)))
(else (for-each (arithmetic-shift bv -1) (add1 number)))))))
(for-each bv 0)))
;; print-entry: symbol action output-port ->
;; prints the action a for lookahead sym to the given 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" (prod-index (reduce-prod a))))
((accept? a)
(fprintf port s sym "accept" ""))
((goto? a)
(fprintf port s sym "goto" (goto-state 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: LR0-automaton grouped-parse-table (listof prod?) output-port ->
;; Prints out the parser given by table.
(define (display-parser a grouped-table prods port)
(let* ((SR-conflicts 0)
(RR-conflicts 0))
(for-each
(lambda (prod)
(fprintf port
"~a\t~a\t=\t~a\n"
(prod-index prod)
(gram-sym-symbol (prod-lhs prod))
(map gram-sym-symbol (vector->list (prod-rhs prod)))))
prods)
(send a for-each-state
(lambda (state)
(fprintf port "State ~a\n" (kernel-index state))
(for-each (lambda (item)
(fprintf port "\t~a\n" (item->string item)))
(kernel-items state))
(newline port)
(for-each
(lambda (gs/action)
(let ((sym (gram-sym-symbol (car gs/action)))
(act (cdr gs/action)))
(cond
((null? act) (void))
((null? (cdr act))
(print-entry sym (car act) port))
(else
(fprintf port "begin conflict:\n")
(when (> (count reduce? act) 1)
(set! RR-conflicts (add1 RR-conflicts)))
(when (> (count shift? act) 0)
(set! SR-conflicts (add1 SR-conflicts)))
(map (lambda (x) (print-entry sym x port)) act)
(fprintf port "end conflict\n")))))
(vector-ref grouped-table (kernel-index state)))
(newline port)))
(when (> SR-conflicts 0)
(fprintf port "~a shift/reduce conflict~a\n"
SR-conflicts
(if (= SR-conflicts 1) "" "s")))
(when (> RR-conflicts 0)
(fprintf port "~a reduce/reduce conflict~a\n"
RR-conflicts
(if (= RR-conflicts 1) "" "s")))))
;; resolve-conflict : (listof action?) -> action? bool bool
(define (resolve-conflict actions)
(cond
((null? actions) (values (make-no-action) #f #f))
((null? (cdr actions))
(values (car actions) #f #f))
(else
(let ((SR-conflict? (> (count shift? actions) 0))
(RR-conflict? (> (count reduce? actions) 1)))
(let loop ((current-guess #f)
(rest actions))
(cond
((null? rest) (values current-guess SR-conflict? RR-conflict?))
((shift? (car rest)) (values (car rest) SR-conflict? RR-conflict?))
((not current-guess)
(loop (car rest) (cdr rest)))
((and (reduce? (car rest))
(< (prod-index (reduce-prod (car rest)))
(prod-index (reduce-prod current-guess))))
(loop (car rest) (cdr rest)))
((accept? (car rest))
(eprintf "accept/reduce or accept/shift conflicts. Check the grammar for useless cycles of productions\n")
(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)
(eprintf "~a shift/reduce conflict~a\n"
SR-conflicts
(if (= SR-conflicts 1) "" "s")))
(when (> RR-conflicts 0)
(eprintf "~a reduce/reduce conflict~a\n"
RR-conflicts
(if (= RR-conflicts 1) "" "s"))))
table))
;; resolve-sr-conflict : (listof action) (union int #f) -> (listof action)
;; Resolves a single shift-reduce conflict, if precedences are in place.
(define (resolve-sr-conflict/prec actions shift-prec)
(let* ((shift (if (shift? (car actions))
(car actions)
(cadr actions)))
(reduce (if (shift? (car actions))
(cadr actions)
(car actions)))
(reduce-prec (prod-prec (reduce-prod reduce))))
(cond
((and shift-prec reduce-prec)
(cond
((< (prec-num shift-prec) (prec-num reduce-prec))
(list reduce))
((> (prec-num shift-prec) (prec-num reduce-prec))
(list shift))
((eq? 'left (prec-assoc shift-prec))
(list reduce))
((eq? 'right (prec-assoc shift-prec))
(list shift))
(else null)))
(else actions))))
;; resolve-prec-conflicts : parse-table -> grouped-parse-table
(define (resolve-prec-conflicts table)
(table-map
(lambda (gs actions)
(cond
((and (term? gs)
(= 2 (length actions))
(or (shift? (car actions))
(shift? (cadr actions))))
(resolve-sr-conflict/prec actions (term-prec gs)))
(else actions)))
(group-table table)))
;; build-table: grammar string bool -> parse-table
(define (build-table g file suppress)
(let* ((a (build-lr0-automaton g))
(term-vector (list->vector (send g get-terms)))
(end-terms (send g get-end-terms))
(table (make-parse-table (send a get-num-states)))
(get-lookahead (compute-LA a g))
(reduce-cache (make-hash)))
(for-each
(lambda (trans-key/state)
(let ((from-state-index (kernel-index (trans-key-st (car trans-key/state))))
(gs (trans-key-gs (car trans-key/state)))
(to-state (cdr trans-key/state)))
(table-add! table from-state-index gs
(cond
((non-term? gs)
(make-goto (kernel-index to-state)))
((member gs end-terms)
(make-accept))
(else
(make-shift
(kernel-index to-state)))))))
(send a get-transitions))
(send a for-each-state
(lambda (state)
(for-each
(lambda (item)
(let ((item-prod (item-prod item)))
(bit-vector-for-each
(lambda (term-index)
(unless (start-item? item)
(let ((r (hash-ref reduce-cache item-prod
(lambda ()
(let ((r (make-reduce item-prod)))
(hash-set! reduce-cache item-prod r)
r)))))
(table-add! table
(kernel-index state)
(vector-ref term-vector term-index)
r))))
(get-lookahead state item-prod))))
(append (hash-ref (send a get-epsilon-trans) state (lambda () null))
(filter (lambda (item)
(not (move-dot-right item)))
(kernel-items state))))))
(let ((grouped-table (resolve-prec-conflicts table)))
(unless (string=? file "")
(with-handlers [(exn:fail:filesystem?
(lambda (e)
(eprintf
"Cannot write debug output to file \"~a\": ~a\n"
file
(exn-message e))))]
(call-with-output-file file
(lambda (port)
(display-parser a grouped-table (send g get-prods) port))
#:exists 'truncate)))
(resolve-conflicts grouped-table suppress))))