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

265 lines
10 KiB
Racket

#lang racket/base
(require yaragg/parser-tools/private-yacc/grammar
yaragg/parser-tools/private-yacc/lr0
yaragg/parser-tools/private-yacc/lalr
yaragg/parser-tools/private-yacc/parser-actions
racket/contract
racket/list
racket/class)
;; Routine to build the LALR table
(define (is-a-grammar%? x) (is-a? x grammar%))
(provide/contract
(build-table (-> is-a-grammar%? string? any/c
(vectorof (listof (cons/c (or/c 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
(for/list ([state-entry (in-list (vector->list table))])
(define ht (make-hasheq))
(for* ([gs/actions (in-list state-entry)]
[group (in-value (hash-ref ht (car gs/actions) (λ () null)))]
#:unless (member (cdr gs/actions) group))
(hash-set! ht (car gs/actions) (cons (cdr gs/actions) group)))
(hash-map ht cons))))
;; 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
(for/list ([state-entry (in-list (vector->list table))])
(for/list ([gs/X (in-list state-entry)])
(cons (car gs/X) (f (car gs/X) (cdr gs/X)))))))
(define (bit-vector-for-each f bv)
(let loop ([bv bv] [number 0])
(cond
[(zero? bv) (void)]
[(= 1 (bitwise-and 1 bv))
(f number)
(loop (arithmetic-shift bv -1) (add1 number))]
[else (loop (arithmetic-shift bv -1) (add1 number))])))
;; print-entry: symbol action output-port ->
;; prints the action a for lookahead sym to the given port
(define (print-entry sym a port)
(define 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)
(define SR-conflicts 0)
(define RR-conflicts 0)
(for ([prod (in-list prods)])
(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)))))
(send a for-each-state
(λ (state)
(fprintf port "State ~a\n" (kernel-index state))
(for ([item (in-list (kernel-items state))])
(fprintf port "\t~a\n" (item->string item)))
(newline port)
(for ([gs/action (in-list (vector-ref grouped-table (kernel-index state)))])
(define sym (gram-sym-symbol (car gs/action)))
(define 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 (λ (x) (print-entry sym x port)) act)
(fprintf port "end conflict\n")]))
(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
(define SR-conflict? (> (count shift? actions) 0))
(define 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)
(define SR-conflicts 0)
(define RR-conflicts 0)
(define table (table-map
(λ (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)
(define shift (if (shift? (car actions))
(car actions)
(cadr actions)))
(define reduce (if (shift? (car actions))
(cadr actions)
(car actions)))
(define 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
(λ (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)
(define a (build-lr0-automaton g))
(define term-vector (list->vector (send g get-terms)))
(define end-terms (send g get-end-terms))
(define table (make-parse-table (send a get-num-states)))
(define get-lookahead (compute-LA a g))
(define reduce-cache (make-hash))
(for ([trans-key/state (in-list (send a get-transitions))])
(define from-state-index (kernel-index (trans-key-st (car trans-key/state))))
(define gs (trans-key-gs (car trans-key/state)))
(define 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 for-each-state
(λ (state)
(for ([item (in-list (append (hash-ref (send a get-epsilon-trans) state (λ () null))
(filter (λ (item)
(not (move-dot-right item)))
(kernel-items state))))])
(let ([item-prod (item-prod item)])
(bit-vector-for-each
(λ (term-index)
(unless (start-item? item)
(let ((r (hash-ref reduce-cache item-prod
(λ ()
(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))))))
(define grouped-table (resolve-prec-conflicts table))
(unless (string=? file "")
(with-handlers [(exn:fail:filesystem?
(λ (e)
(eprintf
"Cannot write debug output to file \"~a\": ~a\n"
file
(exn-message e))))]
(call-with-output-file file
(λ (port)
(display-parser a grouped-table (send g get-prods) port))
#:exists 'truncate)))
(resolve-conflicts grouped-table suppress))