artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

lib/lalr-debug.scm

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-26 23:34:00 +02:00
parent d949b81402
commit 300c997d43
1 changed files with 94 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

105
lib/lalr.scm
View file

@ -281,11 +281,14 @@
(eq? driver-name 'lr-driver)) (eq? driver-name 'lr-driver))
(define (gen-tables! tokens gram ) (define (gen-tables! tokens gram )
(display "gen-tables!") (newline)
(initialize-all) (initialize-all)
(display "gen-tables!2") (newline)
(rewrite-grammar (rewrite-grammar
tokens tokens
gram gram
(lambda (terms terms/prec vars gram gram/actions) (lambda (terms terms/prec vars gram gram/actions)
(display "inside kee") (newline)
(set! the-terminals/prec (list->vector terms/prec)) (set! the-terminals/prec (list->vector terms/prec))
(set! the-terminals (list->vector terms)) (set! the-terminals (list->vector terms))
(set! the-nonterminals (list->vector vars)) (set! the-nonterminals (list->vector vars))
@ -297,13 +300,21 @@
(if (null? l) (if (null? l)
count count
(loop (cdr l) (+ count (length (caar l)))))))) (loop (cdr l) (+ count (length (caar l))))))))
(display "inside kee2") (newline)
(pack-grammar no-of-rules no-of-items gram) (pack-grammar no-of-rules no-of-items gram)
(display "inside kee3") (newline)
(set-derives) (set-derives)
(display "inside kee4") (newline)
(set-nullable) (set-nullable)
(display "inside kee5") (newline)
(generate-states) (generate-states)
(display "inside kee6") (newline)
(lalr) (lalr)
(display "inside kee7") (newline)
(build-tables) (build-tables)
(display "inside kee8") (newline)
(compact-action-table terms) (compact-action-table terms)
(display "inside kee9") (newline)
gram/actions)))) gram/actions))))
@ -381,6 +392,7 @@
(define dset (make-vector nvars -1)) (define dset (make-vector nvars -1))
(let loop ((i 1) (j 0)) ; i = 0 (let loop ((i 1) (j 0)) ; i = 0
(display "set-derives loop i=") (display i) (newline)
(if (< i nrules) (if (< i nrules)
(let ((lhs (vector-ref rlhs i))) (let ((lhs (vector-ref rlhs i)))
(if (>= lhs 0) (if (>= lhs 0)
@ -391,7 +403,7 @@
(loop (+ i 1) j))))) (loop (+ i 1) j)))))
(set! derives (make-vector nvars 0)) (set! derives (make-vector nvars 0))
(display "set-derives derives=") (display derives) (newline)
(let loop ((i 0)) (let loop ((i 0))
(if (< i nvars) (if (< i nvars)
(let ((q (let loop2 ((j (vector-ref dset i)) (s '())) (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
@ -465,17 +477,28 @@
(define (set-firsts) (define (set-firsts)
(set! firsts (make-vector nvars '())) (set! firsts (make-vector nvars '()))
(display "set-firsts firsts=") (display firsts) (newline)
;; -- initialization ;; -- initialization
(let loop ((i 0)) (let loop ((i 0))
(display "loop firsts i=") (display i)
(display " firsts=") (display firsts) (newline)
(if (< i nvars) (if (< i nvars)
(let loop2 ((sp (vector-ref derives i))) (let loop2 ((sp (vector-ref derives i)))
(if (null? sp) (if (null? sp)
(loop (+ i 1)) (loop (+ i 1))
(let ((sym (vector-ref ritem (vector-ref rrhs (car sp))))) (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
(display "sym=") (display sym)
(display " nvars=") (display nvars)
(display " < -1 sym nvars: ") (display (< -1 sym nvars)) (newline)
(if (< -1 sym nvars) (if (< -1 sym nvars)
(vector-set! firsts i (sinsert sym (vector-ref firsts i)))) (begin
(display "set i=") (display i)
(display " :") (sinsert sym (vector-ref firsts i)) (newline)
(vector-set! firsts i (sinsert sym (vector-ref firsts i))))
(begin (display "no set i=") (display i) (newline)))
(loop2 (cdr sp))))))) (loop2 (cdr sp)))))))
(display "set-firsts 2 firsts=") (display firsts) (newline)
;; -- reflexive and transitive closure ;; -- reflexive and transitive closure
(let loop ((continue #t)) (let loop ((continue #t))
(if continue (if continue
@ -509,6 +532,7 @@
(set-firsts) (set-firsts)
(let loop ((i 0)) (let loop ((i 0))
(display "fderives i=") (display i) (newline)
(if (< i nvars) (if (< i nvars)
(let ((x (let loop2 ((l (vector-ref firsts i)) (fd '())) (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
(if (null? l) (if (null? l)
@ -577,9 +601,13 @@
(define (generate-states) (define (generate-states)
(display "inside generate-states") (newline)
(allocate-storage) (allocate-storage)
(display "inside generate-states2") (newline)
(set-fderives) (set-fderives)
(display "inside generate-states3") (newline)
(initialize-states) (initialize-states)
(display "inside generate-states4") (newline)
(let loop ((this-state first-state)) (let loop ((this-state first-state))
(if (pair? this-state) (if (pair? this-state)
(let* ((x (car this-state)) (let* ((x (car this-state))
@ -715,15 +743,25 @@
(define (lalr) (define (lalr)
(set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD)))) (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
(display "lalr") (newline)
(set-accessing-symbol) (set-accessing-symbol)
(display "lalr 1") (newline)
(set-shift-table) (set-shift-table)
(display "lalr 2") (newline)
(set-reduction-table) (set-reduction-table)
(display "lalr 3") (newline)
(set-max-rhs) (set-max-rhs)
(display "lalr 4") (newline)
(initialize-LA) (initialize-LA)
(display "lalr 5") (newline)
(set-goto-map) (set-goto-map)
(display "lalr 6") (newline)
(initialize-F) (initialize-F)
(display "lalr 7") (newline)
(build-relations) (build-relations)
(display "lalr 8") (newline)
(digraph includes) (digraph includes)
(display "lalr 8") (newline)
(compute-lookaheads)) (compute-lookaheads))
(define (set-accessing-symbol) (define (set-accessing-symbol)
@ -1275,6 +1313,7 @@
(right: . right) (right: . right)
(nonassoc: . nonassoc))))) (nonassoc: . nonassoc)))))
(display "rewrite-grammar!") (newline)
(cond (cond
;; --- a few error conditions ;; --- a few error conditions
((not (list? tokens)) ((not (list? tokens))
@ -1288,6 +1327,7 @@
(rev-terms '()) (rev-terms '())
(rev-terms/prec '()) (rev-terms/prec '())
(prec-level 0)) (prec-level 0))
(display "rewrite-grammar! loop1") (newline)
(if (pair? lst) (if (pair? lst)
(let ((term (car lst))) (let ((term (car lst)))
(cond (cond
@ -1319,6 +1359,7 @@
;; --- check the grammar rules ;; --- check the grammar rules
(let loop2 ((lst grammar) (rev-nonterm-defs '())) (let loop2 ((lst grammar) (rev-nonterm-defs '()))
(display "rewrite-grammar! loop2") (newline)
(if (pair? lst) (if (pair? lst)
(let ((def (car lst))) (let ((def (car lst)))
(if (not (pair? def)) (if (not (pair? def))
@ -1332,16 +1373,24 @@
(else (else
(loop2 (cdr lst) (loop2 (cdr lst)
(cons def rev-nonterm-defs))))))) (cons def rev-nonterm-defs)))))))
(let* ((terms (cons eoi (cons 'error (reverse rev-terms)))) (let* (;;(foobar (begin (display "foobar") (newline)))
(terms (cons eoi (cons 'error (reverse rev-terms))))
;;(foobar1 (begin (display "foobar2") (newline)))
(terms/prec (cons '(eoi none 0) (cons '(error none 0) (reverse rev-terms/prec)))) (terms/prec (cons '(eoi none 0) (cons '(error none 0) (reverse rev-terms/prec))))
;;(foobar2 (begin (display "foobar3") (newline)))
(nonterm-defs (reverse rev-nonterm-defs)) (nonterm-defs (reverse rev-nonterm-defs))
(nonterms (cons '*start* (map car nonterm-defs)))) ;;(foobar3 (begin (display "foobar4") (newline)))
(nonterms (cons '*start* (map car nonterm-defs)))
;;(foobar4 (begin (display "foobar5") (newline)))
)
(display "terms") (newline)
(if (= (length nonterms) 1) (if (= (length nonterms) 1)
(lalr-error "Grammar must contain at least one nonterminal" '()) (lalr-error "Grammar must contain at least one nonterminal" '())
(let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) : $1) (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
nonterm-defs)) nonterm-defs))
(ruleno 0) (ruleno 0)
(comp-defs '())) (comp-defs '()))
(display "loop-defs") (newline)
(if (pair? defs) (if (pair? defs)
(let* ((nonterm-def (car defs)) (let* ((nonterm-def (car defs))
(compiled-def (rewrite-nonterm-def (compiled-def (rewrite-nonterm-def
@ -1352,13 +1401,28 @@
(+ ruleno (length compiled-def)) (+ ruleno (length compiled-def))
(cons compiled-def comp-defs))) (cons compiled-def comp-defs)))
(let ((compiled-nonterm-defs (reverse comp-defs))) (let* ((compiled-nonterm-defs (reverse comp-defs))
(k terms (foobar6 (begin (display "foobar6") (newline)))
terms/prec (foobar7 (begin (display "compiled-nonterm-defs:") (display compiled-nonterm-defs) (newline)))
nonterms (aa (apply append compiled-nonterm-defs))
(map (lambda (x) (cons (caaar x) (map cdar x))) (foobar8 (begin (display "foobar8 aa=") (display aa) (newline)))
compiled-nonterm-defs) (mep (map (lambda (x) (cons (caaar x) (map cdar x))) compiled-nonterm-defs))
(apply append compiled-nonterm-defs)))))))))))))) (foobar9 (begin (display "foobar9 mep=") (display mep) (newline)))
)
(display "K...") (newline)
(display "k=") (display k) (newline)
(let ((kee
(k terms
terms/prec
nonterms
;;;(map (lambda (x) (cons (caaar x) (map cdar x))) compiled-nonterm-defs)
mep
;;(apply append compiled-nonterm-defs)
aa
)))
(display "K...dun") (newline)
kee
)))))))))))))
(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms) (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
@ -1624,7 +1688,18 @@
'()))) '())))
(vector->list shift-table))))) (vector->list shift-table)))))
(define (build-goto-table---)
(display "build-goto-table...")
(let ((r (build-goto-table-)))
(newline)
r))
(define (build-reduction-table--- gram/actions)
(display "build-reduction-table...")
(let ((r (build-reduction-table- gram/actions)))
(newline)
r))
(define build-reduction-table (define build-reduction-table
(lambda (gram/actions) (lambda (gram/actions)
`(vector `(vector
@ -1696,8 +1771,10 @@
(define (validate-options options) (define (validate-options options)
(display "validate-options options=") (display options) (newline)
(for-each (for-each
(lambda (option) (lambda (option)
(display "option=") (display option) (newline)
(let ((p (assoc (car option) *valid-options*))) (let ((p (assoc (car option) *valid-options*)))
(if (or (not p) (if (or (not p)
(not ((cdr p) option))) (not ((cdr p) option)))
@ -1737,18 +1814,24 @@
;; -- arguments ;; -- arguments
(define (extract-arguments lst proc) (define (extract-arguments lst proc)
;; (display "extracting") (newline)
(let loop ((options '()) (let loop ((options '())
(tokens '()) (tokens '())
(rules '()) (rules '())
(lst lst)) (lst lst))
(if (pair? lst) (if (pair? lst)
(let ((p (car lst))) (let ((p (car lst)))
;; (display "p:") (display p) (newline)
;; (display "keyword?: ") (display (lalr-keyword? (car p))) (newline)
(cond (cond
((and (pair? p) ((and (pair? p)
(lalr-keyword? (car p)) (lalr-keyword? (car p))
(assq (car p) *valid-options*)) (assq (car p) *valid-options*))
(loop (cons p options) tokens rules (cdr lst))) (loop (cons p options) tokens rules (cdr lst)))
(else (else
;; (display "CALLING PROC") (newline)
;; (display "LST:") (display (cdr lst)) (newline)
;; (display "options:") (display options) (newline)
(proc options p (cdr lst))))) (proc options p (cdr lst)))))
(lalr-error "Malformed lalr-parser form" lst)))) (lalr-error "Malformed lalr-parser form" lst))))