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.
280 lines
10 KiB
Scheme
280 lines
10 KiB
Scheme
(module lalr mzscheme
|
|
|
|
;; Compute LALR lookaheads from DeRemer and Pennello 1982
|
|
|
|
(require "lr0.ss"
|
|
"grammar.ss"
|
|
"array2d.ss"
|
|
"graph.ss"
|
|
(lib "list.ss")
|
|
(lib "class.ss"))
|
|
|
|
(provide compute-LA)
|
|
|
|
;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
|
|
;; computes for each state, non-term transition pair, the terminals
|
|
;; which can transition out of the resulting state
|
|
;; output term set is represented in bit-vector form
|
|
(define (compute-DR a g)
|
|
(lambda (tk)
|
|
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
|
|
(term-list->bit-vector
|
|
(filter
|
|
(lambda (term)
|
|
(send a run-automaton r term))
|
|
(send g get-terms))))))
|
|
|
|
;; compute-reads:
|
|
;; LR0-automaton * grammar -> (trans-key -> trans-key list)
|
|
(define (compute-reads a g)
|
|
(let ((nullable-non-terms
|
|
(filter (lambda (nt) (send g nullable-non-term? nt))
|
|
(send g get-non-terms))))
|
|
(lambda (tk)
|
|
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
|
|
(map (lambda (x) (make-trans-key r x))
|
|
(filter (lambda (non-term) (send a run-automaton r non-term))
|
|
nullable-non-terms))))))
|
|
|
|
;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
|
|
;; output term set is represented in bit-vector form
|
|
(define (compute-read a g)
|
|
(let* ((dr (compute-DR a g))
|
|
(reads (compute-reads a g)))
|
|
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
|
reads
|
|
dr
|
|
(send a get-num-states)
|
|
(send g get-num-terms)
|
|
(send g get-num-non-terms))))
|
|
;; 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 dot-pos start num-states)
|
|
(let loop ((states (list start))
|
|
(i (sub1 dot-pos)))
|
|
(cond
|
|
((< i 0) states)
|
|
(else (loop (send a run-automaton-back states (vector-ref rhs i))
|
|
(sub1 i))))))
|
|
|
|
;; 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)
|
|
;; and gamma =>* epsilon
|
|
(define (prod->items-for-include g prod nt)
|
|
(let* ((rhs (prod-rhs prod))
|
|
(rhs-l (vector-length rhs)))
|
|
(append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
|
|
(list (make-item prod (sub1 rhs-l)))
|
|
null)
|
|
(let loop ((i (sub1 rhs-l)))
|
|
(cond
|
|
((and (> i 0)
|
|
(non-term? (vector-ref rhs i))
|
|
(send g nullable-non-term? (vector-ref rhs i)))
|
|
(if (eq? nt (vector-ref rhs (sub1 i)))
|
|
(cons (make-item prod (sub1 i))
|
|
(loop (sub1 i)))
|
|
(loop (sub1 i))))
|
|
(else null))))))
|
|
|
|
;; prod-list->items-for-include: grammar * prod list * non-term -> lr0-item list
|
|
;; return the list of all (B -> beta . nt gamma) such that (B -> beta nt gamma) in prod-list
|
|
;; and gamma =>* epsilon
|
|
(define (prod-list->items-for-include g prod-list nt)
|
|
(apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
|
|
|
|
;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
|
|
(define (compute-includes a g)
|
|
(let ((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)
|
|
(let* ((goal-state (trans-key-st tk))
|
|
(non-term (trans-key-gs tk))
|
|
(items (vector-ref items-for-input-nt (non-term-index non-term))))
|
|
(trans-key-list-remove-dups
|
|
(apply append
|
|
(map (lambda (item)
|
|
(let* ((prod (item-prod item))
|
|
(rhs (prod-rhs prod))
|
|
(lhs (prod-lhs prod)))
|
|
(map (lambda (state)
|
|
(make-trans-key state lhs))
|
|
(run-lr0-backward a
|
|
rhs
|
|
(item-dot-pos item)
|
|
goal-state
|
|
num-states))))
|
|
items)))))))
|
|
|
|
;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
|
|
(define (compute-lookback a g)
|
|
(let ((num-states (send a get-num-states)))
|
|
(lambda (state prod)
|
|
(map (lambda (k) (make-trans-key k (prod-lhs prod)))
|
|
(run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))))
|
|
|
|
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
|
|
;; output term set is represented in bit-vector form
|
|
(define (compute-follow a g includes)
|
|
(let ((read (compute-read a g)))
|
|
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
|
includes
|
|
read
|
|
(send a get-num-states)
|
|
(send g get-num-terms)
|
|
(send g get-num-non-terms))))
|
|
|
|
;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set)
|
|
;; output term set is represented in bit-vector form
|
|
(define (compute-LA a g)
|
|
(let* ((includes (compute-includes a g))
|
|
(lookback (compute-lookback a g))
|
|
(follow (compute-follow a g includes)))
|
|
(lambda (k p)
|
|
(let* ((l (lookback k p))
|
|
(f (map follow l)))
|
|
(apply bitwise-ior (cons 0 f))))))
|
|
|
|
|
|
(define (print-DR dr a g)
|
|
(print-input-st-sym dr "DR" a g print-output-terms))
|
|
(define (print-Read Read a g)
|
|
(print-input-st-sym Read "Read" a g print-output-terms))
|
|
(define (print-includes i a g)
|
|
(print-input-st-sym i "includes" a g print-output-st-nt))
|
|
(define (print-lookback l a g)
|
|
(print-input-st-prod l "lookback" a g print-output-st-nt))
|
|
(define (print-follow f a g)
|
|
(print-input-st-sym f "follow" a g print-output-terms))
|
|
(define (print-LA l a g)
|
|
(print-input-st-prod l "LA" a g print-output-terms))
|
|
|
|
(define (print-input-st-sym f name a g print-output)
|
|
(printf "~a:~n" name)
|
|
(send a for-each-state
|
|
(lambda (state)
|
|
(for-each
|
|
(lambda (non-term)
|
|
(let ((res (f (make-trans-key state non-term))))
|
|
(if (not (null? res))
|
|
(printf "~a(~a, ~a) = ~a~n"
|
|
name
|
|
state
|
|
(gram-sym-symbol non-term)
|
|
(print-output res)))))
|
|
(send g get-non-terms))))
|
|
(newline))
|
|
|
|
(define (print-input-st-prod f name a g print-output)
|
|
(printf "~a:~n" name)
|
|
(send a for-each-state
|
|
(lambda (state)
|
|
(for-each
|
|
(lambda (non-term)
|
|
(for-each
|
|
(lambda (prod)
|
|
(let ((res (f state prod)))
|
|
(if (not (null? res))
|
|
(printf "~a(~a, ~a) = ~a~n"
|
|
name
|
|
(kernel-index state)
|
|
(prod-index prod)
|
|
(print-output res)))))
|
|
(send g get-prods-for-non-term non-term)))
|
|
(send g get-non-terms)))))
|
|
|
|
(define (print-output-terms r)
|
|
(map
|
|
(lambda (p)
|
|
(gram-sym-symbol p))
|
|
r))
|
|
|
|
(define (print-output-st-nt r)
|
|
(map
|
|
(lambda (p)
|
|
(list
|
|
(kernel-index (trans-key-st p))
|
|
(gram-sym-symbol (trans-key-gs p))))
|
|
r))
|
|
|
|
;; digraph-tk->terml:
|
|
;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
|
|
;; -> (trans-key -> term list)
|
|
;; DeRemer and Pennello 1982
|
|
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
|
|
;; A specialization of digraph in the file graph.ss
|
|
(define (digraph-tk->terml nodes edges f- num-states num-terms num-non-terms)
|
|
(letrec (
|
|
;; Will map elements of trans-key to term sets represented as bit vectors
|
|
(results-terms (make-array2d num-states num-terms 0))
|
|
(results-non-terms (make-array2d num-states num-non-terms 0))
|
|
|
|
;; Maps elements of trans-keys to integers.
|
|
(N-terms (make-array2d num-states num-terms 0))
|
|
(N-non-terms (make-array2d num-states num-non-terms 0))
|
|
|
|
(lookup-tk-map
|
|
(lambda (map-term map-non-term)
|
|
(lambda (tk)
|
|
(let ((st (trans-key-st tk))
|
|
(gs (trans-key-gs tk)))
|
|
(if (term? gs)
|
|
(array2d-ref map-term (kernel-index st) (term-index gs))
|
|
(array2d-ref map-non-term (kernel-index st) (non-term-index gs)))))))
|
|
(add-tk-map
|
|
(lambda (map-term map-non-term)
|
|
(lambda (tk v)
|
|
(let ((st (trans-key-st tk))
|
|
(gs (trans-key-gs tk)))
|
|
(if (term? gs)
|
|
(array2d-set! map-term (kernel-index st) (term-index gs) v)
|
|
(array2d-set! map-non-term (kernel-index st) (non-term-index gs) v))))))
|
|
|
|
(get-N (lookup-tk-map N-terms N-non-terms))
|
|
(set-N (add-tk-map N-terms N-non-terms))
|
|
(get-f (lookup-tk-map results-terms results-non-terms))
|
|
(set-f (add-tk-map results-terms results-non-terms))
|
|
|
|
(stack null)
|
|
(push (lambda (x)
|
|
(set! stack (cons x stack))))
|
|
(pop (lambda ()
|
|
(begin0
|
|
(car stack)
|
|
(set! stack (cdr stack)))))
|
|
(depth (lambda () (length stack)))
|
|
|
|
;; traverse: 'a ->
|
|
(traverse
|
|
(lambda (x)
|
|
(push x)
|
|
(let ((d (depth)))
|
|
(set-N x d)
|
|
(set-f x (f- x))
|
|
(for-each (lambda (y)
|
|
(if (= 0 (get-N y))
|
|
(traverse y))
|
|
(set-f x (bitwise-ior (get-f x) (get-f y)))
|
|
(set-N x (min (get-N x) (get-N y))))
|
|
(edges x))
|
|
(if (= d (get-N x))
|
|
(let loop ((p (pop)))
|
|
(set-N p +inf.0)
|
|
(set-f p (get-f x))
|
|
(if (not (equal? x p))
|
|
(loop (pop)))))))))
|
|
(for-each (lambda (x)
|
|
(if (= 0 (get-N x))
|
|
(traverse x)))
|
|
nodes)
|
|
get-f))
|
|
)
|
|
|
|
|
|
|