nyacc: merge master 0.76.0
[mes.git] / module / nyacc / lalr.scm
1 ;;; nyacc/lalr.scm
2 ;;;
3 ;;; Copyright (C) 2014-2016 Matthew R. Wette
4 ;;;
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;; Lesser General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 (cond-expand
20  (guile-2)
21  (guile
22   (use-modules (ice-9 syncase))
23   (use-modules (ice-9 optargs)))
24  (mes))
25
26 ;; I need to find way to preserve srconf, rrconf after hashify.
27 ;; compact needs to deal with it ...
28
29 (define-module (nyacc lalr)
30   #:export-syntax (lalr-spec)
31   #:export (*nyacc-version*
32             make-lalr-machine compact-machine hashify-machine 
33             lalr-match-table
34             restart-spec add-recovery-logic!
35             pp-lalr-notice pp-lalr-grammar pp-lalr-machine
36             write-lalr-actions write-lalr-tables
37             pp-rule find-terminal gen-match-table ; used by (nyacc bison)
38
39             ;; for debugging:
40             with-spec make-LR0-machine
41             its-member its-trans
42             looking-at first-item
43             terminal? non-terminal?
44             range-next
45             )
46   #:use-module ((srfi srfi-1) #:select (fold fold-right remove lset-union
47                                              lset-intersection lset-difference))
48   #:use-module ((srfi srfi-9) #:select (define-record-type))
49   #:use-module ((srfi srfi-43) #:select (vector-map vector-for-each vector-any))
50   #:use-module (nyacc util)
51   )
52
53 (define *nyacc-version* "0.76.0+c99dev")
54
55 ;; @deffn proxy-? sym rhs
56 ;; @example
57 ;; (LHS (($? RHS))
58 ;; ($P (($$ #f))
59 ;;     ($P RHS ($$ (set-cdr! (last-pair $1) (list $2)) $1)))
60 ;; @end example
61 (define (proxy-? sym rhs)
62   (list sym
63         (list '(action #f #f (list)))
64         rhs))
65
66 ;; @deffn proxy-+ sym rhs
67 ;; @example
68 ;; (LHS (($* RHS))
69 ;; ($P (($$ '()))
70 ;;     ($P RHS ($$ (set-cdr! (last-pair $1) (list $2)) $1)))
71 ;; @end example
72 (define (proxy-* sym rhs)
73   (if (pair? (filter (lambda (elt) (eqv? 'action (car elt))) rhs))
74       (error "no RHS action allowed")) ;; rhs
75   (list
76    sym
77    (list '(action #f #f (list)))
78    (append (cons (cons 'non-terminal sym) rhs)
79            (list '(action #f #f
80                           (set-cdr! (last-pair $1) (list $2))
81                           $1)))))
82
83 ;; @deffn proxy-+ sym rhs
84 ;; @example
85 ;; (LHS (($+ RHS))
86 ;; ($P (RHS ($$ (list $1)))
87 ;;     ($P RHS ($$ (set-cdr! (last-pair $1) (list $2)) $1)))
88 ;; @end example
89 (define (proxy-+ sym rhs)
90   (if (pair? (filter (lambda (elt) (eq? 'action (car elt))) rhs))
91       (error "no RHS action allowed")) ;; rhs
92   (list
93    sym
94    (append rhs (list '(action #f #f (list $1))))
95    (append (cons (cons 'non-terminal sym) rhs)
96            (list '(action #f #f
97                           (set-cdr! (last-pair $1) (list $2))
98                           $1)))))
99
100 ;; @deffn reserved? grammar-symbol
101 ;; Determine whether the syntax argument is a reserved symbol, that is.
102 ;; So instead of writing @code{'$fixed} for syntax one can write
103 ;; @code{$fixed}.  We may want to change this to
104 ;; @example
105 ;; (reserved-terminal? grammar-symbol)
106 ;; (reserved-non-term? grammar-symbol)
107 ;; @end example
108 (define (reserved? grammar-symbol)
109   ;; If the first character `$' then it's reserved.
110   (eqv? #\$ (string-ref (symbol->string (syntax->datum grammar-symbol)) 0)))
111   
112 ;; @deffn lalr-spec grammar => spec
113 ;; This routine reads a grammar in a scheme-like syntax and returns an a-list.
114 ;; This spec' can be an input for @item{make-parser-generator} or 
115 ;; @item{pp-spec}.
116 ;;.This will return the specification.  Notably the grammar will have rhs
117 ;; arguments decorated with type (e.g., @code{(terminal . #\,)}).
118 ;; Each production rule in the grammar will be of the form
119 ;; @code{(lhs rhs1 rhs2 ...)} where each element of the RHS is one of
120 ;; @itemize
121 ;; @item @code{('terminal . atom)}
122 ;; @item @code{('non-terminal . symbol)}
123 ;; @item @code{('action . (ref narg guts)}
124 ;; @item @code{('proxy . production-rule)}
125 ;; @end itemize
126 ;; Currently, the number of arguments for items is computed in the routine
127 ;; @code{process-grammar}.
128 (define-syntax lalr-spec
129   (syntax-rules +++ () 
130     ((_ <expr> +++)
131      (let* ()
132        (letrec-syntax
133            ((with-attr-list
134              (syntax-rules ($prune)
135                ((_ ($prune <symb>) <ex> ...)
136                 (cons '(prune . <symb>) (with-attr-list <ex> ...)))
137                ((_) '())))
138             (parse-rhs
139              (lambda (x)
140                ;; The following is syntax-case because we use a fender.
141                (syntax-case x (quote $$ $$/ref $$-ref $prec $with $empty
142                                      $? $* $+)
143                  ;; action specifications
144                  ((_ ($$ <guts> ...) <e2> ...)
145                   #'(cons '(action #f #f <guts> ...) (parse-rhs <e2> ...)))
146                  ((_ ($$-ref <ref>) <e2> ...)
147                   ;;#'(cons '(action #f <ref> #f) (parse-rhs <e2> ...)))
148                   #'(cons `(action #f ,<ref> . #f) (parse-rhs <e2> ...)))
149                  ((_ ($$/ref <ref> <guts> ...) <e2> ...)
150                   #'(cons `(action #f ,<ref> <guts> ...) (parse-rhs <e2> ...)))
151
152                  ;; other internal $-syntax
153                  ((_ ($prec <tok>) <e2> ...)
154                   #'(cons (cons 'prec (tokenize <tok>)) (parse-rhs <e2> ...)))
155                  ((_ ($with <lhs-ref> <ex> ...) <e2> ...)
156                   #'(cons `(with <lhs-ref> ,@(with-attr-list <ex> ...))
157                           (parse-rhs <e2> ...)))
158                  ((_ $empty <e2> ...)   ; TODO: propagate to processor
159                   #'(parse-rhs <e2> ...))
160                  
161                  ;; (experimental) proxies
162                  ((_ ($? <s1> <s2> ...) <e2> ...)
163                   #'(cons (cons* 'proxy proxy-? (parse-rhs <s1> <s2> ...))
164                           (parse-rhs <e2> ...)))
165                  ((_ ($+ <s1> <s2> ...) <e2> ...)
166                   #'(cons (cons* 'proxy proxy-+ (parse-rhs <s1> <s2> ...))
167                           (parse-rhs <e2> ...)))
168                  ((_ ($* <s1> <s2> ...) <e2> ...)
169                   #'(cons (cons* 'proxy proxy-* (parse-rhs <s1> <s2> ...))
170                           (parse-rhs <e2> ...)))
171                  
172                  ;; terminals and non-terminals
173                  ((_ (quote <e1>) <e2> ...)
174                   #'(cons '(terminal . <e1>) (parse-rhs <e2> ...)))
175                  ((_ (<f> ...) <e2> ...)
176                   #'(cons (<f> ...) (parse-rhs <e2> ...)))
177                  ((_ <e1> <e2> ...)
178                   (identifier? (syntax <e1>)) ; fender to trap non-term's
179                   (if (reserved? (syntax <e1>))
180                       #'(cons '(terminal . <e1>) (parse-rhs <e2> ...))
181                       #'(cons '(non-terminal . <e1>) (parse-rhs <e2> ...))))
182                  ((_ <e1> <e2> ...)
183                   #'(cons '(terminal . <e1>) (parse-rhs <e2> ...)))
184                  ((_) #'(list)))))
185             (parse-rhs-list
186              (syntax-rules ()
187                ((_ (<ex> ...) <rhs> ...)
188                 (cons (parse-rhs <ex> ...)
189                       (parse-rhs-list <rhs> ...)))
190                ((_) '())))
191             (parse-grammar
192              (syntax-rules ()
193                ((_ (<lhs> <rhs> ...) <prod> ...)
194                 (cons (cons '<lhs> (parse-rhs-list <rhs> ...))
195                       (parse-grammar <prod> ...)))
196                ((_) '())))
197             (tokenize
198              (lambda (x)
199                (syntax-case x ()
200                  ((_ <tk>) (identifier? (syntax <tk>)) #'(quote <tk>))
201                  ((_ <tk>) #'<tk>))))
202             (tokenize-list
203              (syntax-rules ()
204                ((_ <tk1> <tk2> ...)
205                 (cons (tokenize <tk1>) (tokenize-list <tk2> ...)))
206                ((_) '())))
207             (parse-precedence
208              (syntax-rules (left right nonassoc)
209                ((_ (left <tk> ...) <ex> ...)
210                 (cons (cons 'left (tokenize-list <tk> ...))
211                       (parse-precedence <ex> ...)))
212                ((_ (right <tk> ...) <ex> ...)
213                 (cons (cons 'right (tokenize-list <tk> ...))
214                       (parse-precedence <ex> ...)))
215                ((_ (nonassoc <tk> ...) <ex> ...)
216                 (cons (cons 'nonassoc (tokenize-list <tk> ...))
217                       (parse-precedence <ex> ...)))
218                ((_ <tk> <ex> ...)
219                 (cons (list 'undecl (tokenize <tk>))
220                       (parse-precedence <ex> ...)))
221                ((_) '())))
222             (lalr-spec-1
223              (syntax-rules (start expect notice prec< prec> grammar)
224                ((_ (start <symb>) <e> ...)
225                 (cons (cons 'start '<symb>) (lalr-spec-1 <e> ...)))
226                ((_ (expect <n>) <e> ...)
227                 (cons (cons 'expect <n>) (lalr-spec-1 <e> ...)))
228                ((_ (notice <str>) <e> ...)
229                 (cons (cons 'notice <str>) (lalr-spec-1 <e> ...)))
230                ((_ (prec< <ex> ...) <e> ...)
231                 (cons (cons 'precedence (parse-precedence <ex> ...))
232                       (lalr-spec-1 <e> ...)))
233                ((_ (prec> <ex> ...) <e> ...)
234                 (cons (cons 'precedence (reverse (parse-precedence <ex> ...)))
235                       (lalr-spec-1 <e> ...)))
236                ((_ (grammar <prod> ...) <e> ...)
237                 (cons (cons 'grammar (parse-grammar <prod> ...))
238                       (lalr-spec-1 <e> ...))) 
239                ((_) '()))))
240          (process-spec (lalr-spec-1 <expr> +++)))))))
241
242 ;; @deffn atomize terminal => object
243 ;; Generate an atomic object for a terminal.   Expected terminals are strings,
244 ;; characters and symbols.  This will convert the strings @code{s} to symbols
245 ;; of the form @code{'$:s}.
246 (define (atomize terminal)
247   (if (string? terminal)
248       (string->symbol (string-append "$:" terminal))
249       terminal))
250
251 ;; @deffn normize terminal => char|symbol
252 ;; Normalize a token. This routine will normalize tokens in order to check
253 ;; for similarities. For example, @code{"+"} and @code{#\+} are similar,
254 ;; @code{'foo} and @code{"foo"} are similar.
255 (define (normize terminal)
256   (if (not (string? terminal)) terminal
257       (if (= 1 (string-length terminal))
258           (string-ref terminal 0)
259           (string->symbol terminal))))
260
261 ;; @deffn eqv-terminal? a b
262 ;; This is a predicate to determine if the terminals @code{a} and @code{b}
263 ;; are equivalent.
264 (define (eqv-terminal? a b)
265   (eqv? (atomize a) (atomize b)))
266
267 ;; @deffn find-terminal symb term-l => term-symb
268 ;; Find the terminal in @code{term-l} that is equivalent to @code{symb}.
269 (define (find-terminal symb term-l)
270   (let iter ((tl term-l))
271     (if (null? tl) #f
272         (if (eqv-terminal? symb (car tl)) (car tl)
273             (iter (cdr tl))))))
274   
275 ;; @deffn process-spec tree => specification (as a-list)
276 ;; Here we sweep through the production rules. We flatten and order the rules
277 ;; and place all p-rules with like LHSs together.  There is a non-trivial
278 ;; amount of extra code to deal with mid-rule actions (MRAs).
279 (define (process-spec tree)
280
281   ;; Make a new symbol. This is a helper for proxies and mid-rule-actions.
282   ;; The counter here is the only @code{set!} in @code{process-spec}.
283   ;; Otherwise, I believe @code{process-spec} is referentially transparent.
284   (define maksy
285     (let ((cntr 1))
286       (lambda ()
287         (let ((c cntr))
288           (set! cntr (1+ cntr))
289           (string->symbol (string-append "$P" (number->string c)))))))
290
291   ;; Canonicalize precedence and associativity. Precedence will appear
292   ;; as sets of equivalent items in increasing order of precedence
293   ;; (e.g., @code{((+ -) (* /)}).  The input tree has nodes that look like
294   ;; @example
295   ;; '(precedence (left "+" "-") (left "*" "/"))
296   ;; '(precedence ('then "else")
297   ;; @end example
298   ;; @noindent
299   ;; =>
300   ;; @example
301   ;; (prec ((+ -) (* /)) ((then) (else)))
302   ;; @end example
303   (define (prec-n-assc tree)
304     ;; prec-l; lt-assc-l rt-assc-l non-assc-l pspec
305     (let iter ((pll '()) (pl '()) (la '()) (ra '()) (na '())
306                (spec '()) (tree tree))
307       (cond
308        ((pair? spec)
309         ;; item ~ ('left "+" "-") => a ~ 'left, tl ~ (#\+ #\-)
310         (let* ((item (car spec)) (as (car item)) (tl (map atomize (cdr item))))
311           (case as
312             ((left)
313              (iter pll (cons tl pl) (append tl la) ra na (cdr spec) tree))
314             ((right)
315              (iter pll (cons tl pl) la (append tl ra) na (cdr spec) tree))
316             ((nonassoc)
317              (iter pll (cons tl pl) la ra (append tl na) (cdr spec) tree))
318             ((undecl)
319              (iter pll (cons tl pl) la ra na (cdr spec) tree)))))
320        ((pair? pl)
321         (iter (cons (reverse pl) pll) '() la ra na spec tree))
322        ((pair? tree)
323         (iter pll pl la ra na
324               (if (eqv? 'precedence (caar tree)) (cdar tree) '()) (cdr tree)))
325        (else
326         (list
327          `(prec . ,(reverse pll))
328          `(assc (left ,@la) (right ,@ra) (nonassoc ,@na)))))))
329
330   ;;.@deffn make-mra-proxy sy pel act => ???
331   ;; Generate a mid-rule-action proxy.
332   (define (make-mra-proxy sy pel act)
333     (list sy (list (cons* 'action (length pel) (cdr act)))))
334
335   ;; @deffn gram-check-2 tl nl err-l
336   ;; Check for fatal: symbol used as terminal and non-terminal.
337   (define (gram-check-2 tl nl err-l)
338     (let ((cf (lset-intersection eqv? (map atomize tl) nl)))
339       (if (pair? cf)
340           (cons (fmtstr "*** symbol is terminal and non-terminal: ~S" cf)
341                 err-l) err-l)))
342                
343   ;; @deffn gram-check-3 ll nl err-l
344   ;; Check for fatal: non-terminal's w/o production rule.
345   (define (gram-check-3 ll nl err-l)
346     (fold
347      (lambda (n l)
348        (if (not (memq n ll))
349            (cons (fmtstr "*** non-terminal with no production rule: ~A" n) l)
350            l))
351      err-l nl))
352
353   ;; @deffn gram-check-4 ll nl err-l
354   ;; Check for warning: unused LHS.
355   ;; TODO: which don't appear in OTHER RHS, e.g., (foo (foo))
356   (define (gram-check-4 ll nl err-l)
357     (fold
358      (lambda (s l) (cons (fmtstr "+++ LHS not used in any RHS: ~A" s) l))
359      err-l
360      (let iter ((ull '()) (all ll)) ; unused LHSs, all LHS's
361        (if (null? all) ull
362            (iter (if (or (memq (car all) nl)
363                          (memq (car all) ull)
364                          (eq? (car all) '$start))
365                      ull (cons (car all) ull))
366                  (cdr all))))))
367
368   ;; TODO: check for repeated tokens in precedence spec's: prec<, prec>
369                
370   (let* ((gram (assq-ref tree 'grammar))
371          (start-symbol (and=> (assq-ref tree 'start) atomize))
372          (start-rule (lambda () (list start-symbol)))
373          (add-el (lambda (e l) (if (member e l) l (cons e l))))
374          (pna (prec-n-assc tree)))
375     ;; We sweep through the grammar to generate a canonical specification.
376     ;; Note: the local rhs is used to hold RHS terms, but a
377     ;; value of @code{'()} is used to signal "add rule", and a value of
378     ;; @code{#f} is used to signal ``done, proceed to next rule.''
379     ;; We use @code{tail} below to go through all remaining rules so that any
380     ;; like LHS get absorbed before proceeding: This keeps LHS in sequence.
381     ;; Note: code-comm and lone-comm are added to terminals so that they end
382     ;; up in the match-table.  The parser will skip these if the automoton has
383     ;; no associated transitions for these.  This allows users to parse for
384     ;; comments in some rules but skip the rest.
385     (let iter ((ll '($start))           ; LHS list
386                (@l (list                ; attributes per prod' rule
387                     `((rhs . ,(vector start-symbol))
388                       (ref . all) (act 1 $1))))
389                (tl '($code-comm $lone-comm $error $end)) ; set of terminals
390                (nl (list start-symbol)) ; set of non-terminals
391                ;;
392                (head gram)             ; head of unprocessed productions
393                (prox '())              ; proxy productions for MRA
394                (lhs #f)                ; current LHS (symbol)
395                (tail '())              ; tail of grammar productions
396                (rhs-l '())             ; list of RHSs being processed
397                (attr '())              ; per-rule attributes (action, prec)
398                (pel '())               ; processed RHS terms: '$:if ...
399                (rhs #f))               ; elts to process: (terminal . '$:if) ...
400       (cond
401        ((pair? rhs)
402         ;; Capture info on RHS term.
403         (case (caar rhs)
404           ((terminal)
405            (iter ll @l (add-el (cdar rhs) tl) nl head prox lhs tail
406                  rhs-l attr (cons (atomize (cdar rhs)) pel) (cdr rhs)))
407           ((non-terminal)
408            (iter ll @l tl (add-el (cdar rhs) nl) head prox lhs tail
409                  rhs-l attr (cons (cdar rhs) pel) (cdr rhs)))
410           ((action)
411            (if (pair? (cdr rhs))
412                ;; mid-rule action: generate a proxy (car act is # args)
413                (let* ((sy (maksy))
414                       (pr (make-mra-proxy sy pel (cdar rhs))))
415                  (iter ll @l tl (cons sy nl) head (cons pr prox)
416                        lhs tail rhs-l attr (cons sy pel) (cdr rhs)))
417                ;; end-rule action
418                (iter ll @l tl nl head prox lhs tail
419                      rhs-l (acons 'action (cdar rhs) attr) pel (cdr rhs))))
420           ((proxy)
421            (let* ((sy (maksy))
422                   (pf (cadar rhs))      ; proxy function
423                   (p1 (pf sy (cddar rhs))))
424              (iter ll @l tl (cons sy nl) head (cons p1 prox) lhs
425                    tail rhs-l attr (cons sy pel) (cdr rhs))))
426           ((prec)
427            (iter ll @l (add-el (cdar rhs) tl) nl head prox lhs tail rhs-l
428                  (acons 'prec (atomize (cdar rhs)) attr) pel (cdr rhs)))
429           ((with)
430            (let* ((psy (maksy))               ; proxy symbol
431                   (rhsx (cadar rhs))          ; symbol to expand
432                   (p-l (map cdr (cddar rhs))) ; prune list
433                   (p1 (list psy `((non-terminal . ,rhsx)
434                                   (action #f #f $1)))))
435              (iter ll @l tl (cons psy nl) head (cons p1 prox) lhs tail rhs-l
436                    (acons 'with (cons psy p-l) attr) (cons psy pel) (cdr rhs))))
437           (else
438            (error (fmtstr "bug=~S" (caar rhs))))))
439
440        ((null? rhs)
441         ;; End of RHS items for current rule.
442         ;; Add the p-rules items to the lists ll, rl, xl, and @@l.
443         ;; @code{act} is now:
444         ;; @itemize
445         ;; @item for mid-rule-action: (narg ref code)
446         ;; @item for end-rule-action: (#f ref code)
447         ;; @end itemize
448         (let* ((ln (length pel))
449                (action (assq-ref attr 'action))
450                (with (assq-ref attr 'with))
451                (nrg (if action (or (car action) ln) ln))  ; number of args
452                (ref (if action (cadr action) #f))
453                (act (cond
454                      ((and action (cddr action)) (cddr action))
455                      ;; if error rule then default action is print err msg:
456                      ((memq '$error pel) '((display "syntax error\n")))
457                      ((zero? nrg) '((list)))
458                      (else '($1)))))
459           (if with (simple-format #t "WITH WHAT?\n"))
460           (iter (cons lhs ll)
461                 (cons (cons* (cons 'rhs (list->vector (reverse pel)))
462                              (cons* 'act nrg act) (cons 'ref ref) attr) @l)
463                 tl nl head prox lhs tail rhs-l attr pel #f)))
464
465        ((pair? rhs-l)
466         ;; Work through next RHS.
467         (iter ll @l tl nl head prox lhs tail
468               (cdr rhs-l) '() '() (car rhs-l)))
469
470        ((pair? tail)
471         ;; Check the next CAR of the tail.  If it matches
472         ;; the current LHS process it, else skip it.
473         (iter ll @l tl nl head prox lhs (cdr tail) 
474               (if (eqv? (caar tail) lhs) (cdar tail) '())
475               attr pel #f))
476
477        ((pair? prox)
478         ;; If a proxy then we have ((lhs RHS) (lhs RHS))
479         (iter ll @l tl nl (cons (car prox) head) (cdr prox)
480               lhs tail rhs-l attr pel rhs))
481
482        ((pair? head)
483         ;; Check the next rule-set.  If the lhs has aready
484         ;; been processed, then skip.  Otherwise, copy copy
485         ;; to tail and process.
486         (let ((lhs (caar head)) (rhs-l (cdar head))
487               (rest (cdr head)))
488           (if (memq lhs ll)
489               (iter ll @l tl nl rest prox #f '() '() attr pel #f)
490               (iter ll @l tl nl rest prox lhs rest rhs-l attr pel rhs))))
491
492        (else
493         (let* ((al (reverse @l))        ; attribute list
494                (err-1 '()) ;; not used
495                ;; symbol used as terminal and non-terminal:
496                (err-2 (gram-check-2 tl nl err-1))
497                ;; non-terminal's w/o production rule:
498                (err-3 (gram-check-3 ll nl err-2))
499                ;; TODO: which don't appear in OTHER RHS, e.g., (foo (foo))
500                (err-4 (gram-check-4 ll nl err-3))
501                ;; todo: Check that with withs are not mixed
502                (err-l err-4))
503           (for-each (lambda (e) (fmterr "~A\n" e)) err-l)
504           (if (pair? (filter (lambda (s) (char=? #\* (string-ref s 0))) err-l))
505               #f
506               (list
507                ;; most referenced
508                (cons 'non-terms nl)
509                (cons 'lhs-v (list->vector (reverse ll)))
510                (cons 'rhs-v (map-attr->vector al 'rhs))
511                (cons 'terminals tl)
512                (cons 'start start-symbol)
513                (cons 'attr (list
514                             (cons 'expect (or (assq-ref tree 'expect) 0))
515                             (cons 'notice (assq-ref tree 'notice))))
516                (cons 'prec (assq-ref pna 'prec)) ; lowest-to-highest
517                (cons 'assc (assq-ref pna 'assc))
518                (cons 'prp-v (map-attr->vector al 'prec)) ; per-rule precedence
519                (cons 'act-v (map-attr->vector al 'act))
520                (cons 'ref-v (map-attr->vector al 'ref))
521                (cons 'err-l err-l)))))))))
522   
523 ;;; === Code for processing the specification. ================================
524
525 ;; @subsubheading Note
526 ;; The fluid @code{*lalr-core*} is used during the machine generation
527 ;; cycles to access core parameters of the specification.  This includes
528 ;; the list of non-terminals, the vector of left-hand side symbols and the
529 ;; vector of vector of right-hand side symbols.
530 (define *lalr-core* (make-fluid #f))
531
532 ;; This record holds the minimum data from the grammar needed to build the
533 ;; machine from the grammar specification.
534 (define-record-type lalr-core-type
535   (make-lalr-core non-terms terminals start lhs-v rhs-v eps-l)
536   lalr-core-type?
537   (non-terms core-non-terms)          ; list of non-terminals
538   (terminals core-terminals)          ; list of non-terminals
539   (start core-start)                  ; start non-terminal
540   (lhs-v core-lhs-v)                  ; vec of left hand sides
541   (rhs-v core-rhs-v)                  ; vec of right hand sides
542   (eps-l core-eps-l))                 ; non-terms w/ eps prod's
543
544 ;; @deffn make-core spec => lalr-core-type
545 (define (make-core spec)
546   (make-lalr-core (assq-ref spec 'non-terms)
547                   (assq-ref spec 'terminals)
548                   (assq-ref spec 'start)
549                   (assq-ref spec 'lhs-v)
550                   (assq-ref spec 'rhs-v)
551                   '()))
552
553 ;; @deffn make-core/extras spec => lalr-core-type
554 ;; Add list of symbols with epsilon productions.
555 (define (make-core/extras spec)
556   (let ((non-terms (assq-ref spec 'non-terms))
557         (terminals (assq-ref spec 'terminals))
558         (start (assq-ref spec 'start))
559         (lhs-v (assq-ref spec 'lhs-v))
560         (rhs-v (assq-ref spec 'rhs-v)))
561     (make-lalr-core non-terms terminals start lhs-v rhs-v
562                     (find-eps non-terms lhs-v rhs-v))))
563
564
565 ;; @section Routines
566
567 ;; @deffn <? a b po => #t | #f
568 ;; Given tokens @code{a} and @code{b} and partial ordering @code{po} report
569 ;; if precedence of @code{b} is greater than @code{a}?
570 (define (<? a b po)
571   (if (member (cons a b) po) #t
572       (let iter ((po po))
573         (if (null? po) #f
574             (if (and (eqv? (caar po) a)
575                      (<? (cdar po) b po))
576                 #t
577                 (iter (cdr po)))))))
578
579 ;; @deffn prece a b po
580 ;; Return precedence for @code{a,b} given the partial order @code{po} as
581 ;; @code{#\<}, @code{#\>}, @code{#\=} or @code{#f}.
582 ;; This is not a true partial order as we can have a<b and b<a => a=b.
583 ;; @example
584 ;; @code{(prece a a po)} => @code{#\=}.
585 ;; @end example
586 (define (prece a b po)
587   (cond
588    ((eqv? a b) #\=)
589    ((eqv? a '$error) #\<)
590    ((eqv? b '$error) #\>)
591    ((<? a b po)  (if (<? b a po) #\= #\<))
592    (else (if (<? b a po) #\> #f))))
593   
594 ;; @deffn non-terminal? symb
595 (define (non-terminal? symb)
596   (cond
597    ((eqv? symb '$epsilon) #t)
598    ((eqv? symb '$end) #f)
599    ((eqv? symb '$@) #f)
600    ((string? symb) #f)
601    (else
602     (memq symb (core-non-terms (fluid-ref *lalr-core*))))))
603
604 ;; @deffn terminal? symb
605 (define (terminal? symb)
606   (not (non-terminal? symb)))
607
608 ;; @deffn prule-range lhs => (start-ix . (1+ end-ix))
609 ;; Find the range of productiion rules for the lhs.
610 ;; If not found raise error.
611 (define (prule-range lhs)
612   ;; If this needs to be really fast then we move to where lhs is an integer
613   ;; and that used to index into a table that provides the ranges.
614   (let* ((core (fluid-ref *lalr-core*))
615          (lhs-v (core-lhs-v core))
616          (n (vector-length lhs-v))
617          (match? (lambda (ix symb) (eqv? (vector-ref lhs-v ix) symb))))
618     (cond
619      ((terminal? lhs) '())
620      ((eq? lhs '$epsilon) '())
621      (else
622       (let iter-st ((st 0))
623         ;; Iterate to find the start index.
624         (if (= st n) '()                ; not found
625             (if (match? st lhs)
626                 ;; Start found, now iteratate to find end index.
627                 (let iter-nd ((nd st))
628                   (if (= nd n) (cons st nd)
629                       (if (not (match? nd lhs)) (cons st nd)
630                           (iter-nd (1+ nd)))))
631                 (iter-st (1+ st)))))))))
632
633 ;; @deffn range-next rng -> rng
634 ;; Given a range in the form of @code{(cons start (1+ end))} return the next
635 ;; value or '() if at end.  That is @code{(3 . 4)} => @code{'()}.
636 (define (range-next rng)
637   (if (null? rng) '()
638       (let ((nxt (cons (1+ (car rng)) (cdr rng))))
639         (if (= (car nxt) (cdr nxt)) '() nxt))))
640
641 ;; @deffn range-last? rng
642 ;; Predicate to indicate last p-rule in range.
643 ;; If off end (i.e., null rng) then #f.
644 (define (range-last? rng)
645   (and (pair? rng) (= (1+ (car rng)) (cdr rng))))
646
647 ;; @deffn lhs-symb prod-ix
648 ;; Return the LHS symbol for the production at index @code{prod-id}.
649 (define (lhs-symb gx)
650   (vector-ref (core-lhs-v (fluid-ref *lalr-core*)) gx))
651
652 ;; @deffn looking-at (p-rule-ix . rhs-ix)
653 ;; Return symbol we are looking at for this item state.
654 ;; If at the end (position = -1) (or rule is zero-length) then return
655 ;; @code{'$epsilon}.
656 (define (looking-at item)
657   (let* ((core (fluid-ref *lalr-core*))
658          (rhs-v (core-rhs-v core))
659          (rule (vector-ref rhs-v (car item))))
660     (if (last-item? item)
661         '$epsilon
662         (vector-ref rule (cdr item)))))
663
664 ;; @deffn first-item gx
665 ;; Given grammar rule index return the first item.
666 ;; This will return @code{(gx . 0)}, or @code{(gx . -1)} if the rule has
667 ;; no RHS elements.
668 (define (first-item gx)
669   (let* ((core (fluid-ref *lalr-core*))
670          (rlen (vector-length (vector-ref (core-rhs-v core) gx))))
671     (cons gx (if (zero? rlen) -1 0))))
672
673 ;; @deffn last-item? item
674 ;; Predictate to indicate last item in (or end of) production rule.
675 (define (last-item? item)
676   (negative? (cdr item)))
677
678 ;; @deffn next-item item
679 ;; Return the next item in the production rule.
680 ;; A position of @code{-1} means the end.  If at end, then @code{'()}
681 (define (next-item item)
682   (let* ((core (fluid-ref *lalr-core*))
683          (gx (car item)) (rx (cdr item)) (rxp1 (1+ rx))
684          (rlen (vector-length (vector-ref (core-rhs-v core) gx))))
685     (cond
686      ((negative? rx) '())
687      ((eqv? rxp1 rlen) (cons gx -1))
688      (else (cons gx rxp1)))))
689
690 ;; @deffn prev-item item
691 ;; Return the previous item in the grammar.
692 ;; prev (0 . 0) is currently (0 . 0)
693 (define (prev-item item)
694   (let* ((core (fluid-ref *lalr-core*))
695          (rhs-v (core-rhs-v core))
696          (p-ix (car item))
697          (p-ixm1 (1- p-ix))
698          (r-ix (cdr item))
699          (r-ixm1 (if (negative? r-ix)
700                      (1- (vector-length (vector-ref rhs-v p-ix)))
701                      (1- r-ix))))
702     (if (zero? r-ix)
703         (if (zero? p-ix) item           ; start, i.e., (0 . 0)
704             (cons p-ixm1 -1))           ; prev p-rule
705         (cons p-ix r-ixm1))))
706
707 ;; @deffn error-rule? gx => #t|#f
708 ;; Predicate to indicate if gx rule has @code{$error} as rhs member.
709 (define (error-rule? gx)
710   (let* ((core (fluid-ref *lalr-core*))
711          (rhs-v (core-rhs-v core)))
712     (vector-any (lambda (e) (eqv? e '$error)) (vector-ref rhs-v gx))))
713      
714 ;; @deffn non-kernels symb => list of prule indices
715 ;; Compute the set of non-kernel rules for symbol @code{symb}.  If grammar
716 ;; looks like
717 ;; @example
718 ;; 1: A => Bcd
719 ;; ...
720 ;; 5: B => Cde
721 ;; ...
722 ;; 7: B => Abe
723 ;; @end example
724 ;; @noindent
725 ;; then @code{non-kernels 'A} results in @code{(1 5 7)}.
726 ;; Note: To support pruning this routine will need to be rewritten.
727 (define (non-kernels symb)
728   (let* ((core (fluid-ref *lalr-core*))
729          (lhs-v (core-lhs-v core))
730          (rhs-v (core-rhs-v core))
731          (glen (vector-length lhs-v))
732          (lhs-symb (lambda (gx) (vector-ref lhs-v gx))))
733     (let iter ((rslt '())               ; result is set of p-rule indices
734                (done '())               ; symbols completed or queued
735                (next '())               ; next round of symbols to process
736                (curr (list symb))       ; this round of symbols to process
737                (gx 0))                  ; p-rule index
738       (cond
739        ((< gx glen)
740         (cond
741          ((memq (lhs-symb gx) curr)
742           ;; Add rhs to next and rslt if not already done.
743           (let* ((rhs1 (looking-at (first-item gx))) ; 1st-RHS-sym|$eps
744                  (rslt1 (if (memq gx rslt) rslt (cons gx rslt)))
745                  (done1 (if (memq rhs1 done) done (cons rhs1 done)))
746                  (next1 (cond ((memq rhs1 done) next)
747                               ((terminal? rhs1) next)
748                               (else (cons rhs1 next)))))
749             (iter rslt1 done1 next1 curr (1+ gx))))
750          (else
751           ;; Nothing to check; process next rule.
752           (iter rslt done next curr (1+ gx)))))
753        ((pair? next)
754         ;; Start another sweep throught the grammar.
755         (iter rslt done '() next 0))
756        (else
757         ;; Done, so return.
758         (reverse rslt))))))
759
760 ;; @deffn expand-k-item => item-set
761 ;; Expand a kernel-item into a list with the non-kernels.
762 (define (expand-k-item k-item)
763   (reverse
764    (fold (lambda (gx items) (cons (first-item gx) items))
765               (list k-item)
766               (non-kernels (looking-at k-item)))))
767
768 ;; @deffn its-equal?
769 ;; Helper for step1
770 (define (its-equal? its-1 its-2)
771   (let iter ((its1 its-1) (its2 its-2)) ; cdr to strip off the ind
772     (if (and (null? its1) (null? its2)) #t ; completed run through => #f
773         (if (or (null? its1) (null? its2)) #f ; lists not equal length => #f
774             (if (not (member (car its1) its-2)) #f ; mismatch => #f
775                 (iter (cdr its1) (cdr its2)))))))
776
777 ;; @deffn its-member its its-l
778 ;; Helper for step1
779 ;; If itemset @code{its} is a member of itemset list @code{its-l} return the
780 ;; index, else return #f.
781 (define (its-member its its-l)
782   (let iter ((itsl its-l))
783     (if (null? itsl) #f
784         (if (its-equal? its (cdar itsl)) (caar itsl)
785             (iter (cdr itsl))))))
786   
787 ;; @deffn its-trans itemset => alist of (symb . itemset)
788 ;; Compute transitions from an itemset.   Thatis, map a list of kernel
789 ;; items to a list of (symbol post-shift items).
790 ;; @example
791 ;; ((0 . 1) (2 . 3) => ((A (0 . 2) (2 . 4)) (B (2 . 4) ...))
792 ;; @end example
793 (define (its-trans items)
794   (let iter ((rslt '())                 ; result
795              (k-items items)            ; items
796              (itl '()))                 ; one k-item w/ added non-kernels
797     (cond
798      ((pair? itl)
799       (let* ((it (car itl))             ; item
800              (sy (looking-at it))       ; symbol
801              (nx (next-item it))
802              (sq (assq sy rslt)))       ; if we have seen it
803         (cond
804          ((eq? sy '$epsilon)
805           ;; don't transition end-of-rule items
806           (iter rslt k-items (cdr itl)))
807          ((not sq)
808           ;; haven't seen this symbol yet
809           (iter (acons sy (list nx) rslt) k-items (cdr itl)))
810          ((member nx (cdr sq))
811           ;; repeat
812           (iter rslt k-items (cdr itl)))
813          (else
814           ;; SY is in RSLT and item not yet in: add it.
815           (set-cdr! sq (cons nx (cdr sq)))
816           (iter rslt k-items (cdr itl))))))
817      ((pair? k-items)
818       (iter rslt (cdr k-items) (expand-k-item (car k-items))))
819      (else
820       rslt))))
821
822 ;; @deffn step1 [input-a-list] => p-mach-1
823 ;; Compute the sets of LR(0) kernel items and the transitions associated with
824 ;; spec.  These are returned as vectors in the alist with keys @code{'kis-v}
825 ;; and @code{'kix-v}, repspectively.   Each entry in @code{kis-v} is a list of
826 ;; items in the form @code{(px . rx)} where @code{px} is the production rule
827 ;; index and @code{rx} is the index of the RHS symbol.  Each entry in the
828 ;; vector @code{kix-v} is an a-list with entries @code{(sy . kx)} where
829 ;; @code{sy} is a (terminal or non-terminal) symbol and @code{kx} is the
830 ;; index of the kernel itemset.  The basic algorithm is discussed on
831 ;; pp. 228-229 of the DB except that we compute non-kernel items on the fly
832 ;; using @code{expand-k-item}.  See Example 4.46 on p. 241 of the DB.
833 (define (step1 . rest)
834   (let* ((al-in (if (pair? rest) (car rest) '()))
835          (add-kset (lambda (upd kstz)   ; give upd a ks-ix and add to kstz
836                      (acons (1+ (caar kstz)) upd kstz)))
837          (init '(0 (0 . 0))))
838     (let iter ((ksets (list init))      ; w/ index
839                (ktrnz '())              ; ((symb src dst) (symb src dst) ...)
840                (next '())               ; w/ index
841                (todo (list init))       ; w/ index
842                (curr #f)                ; current state ix
843                (trans '()))             ; ((symb it1 it2 ...) (symb ...))
844       (cond
845        ((pair? trans)
846         ;; Check next symbol for transitions (symb . (item1 item2 ...)).
847         (let* ((dst (cdar trans))              ; destination item
848                (dst-ix (its-member dst ksets)) ; return ix else #f
849                (upd (if dst-ix '() (cons (1+ (caar ksets)) dst)))
850                (ksets1 (if dst-ix ksets (cons upd ksets)))
851                (next1 (if dst-ix next (cons upd next)))
852                (dsx (if dst-ix dst-ix (car upd))) ; dest state index
853                (ktrnz1 (cons (list (caar trans) curr dsx) ktrnz)))
854           (iter ksets1 ktrnz1 next1 todo curr (cdr trans))))
855        ((pair? todo)
856         ;; Process the next state (aka itemset).
857         (iter ksets ktrnz next (cdr todo) (caar todo) (its-trans (cdar todo))))
858        ((pair? next)
859         ;; Sweep throught the grammar again.
860         (iter ksets ktrnz '() next curr '()))
861        (else
862         (let* ((nkis (length ksets))    ; also (caar ksets)
863                (kisv (make-vector nkis #f))
864                (kitv (make-vector nkis '())))
865           ;; Vectorize kernel sets
866           (for-each
867            (lambda (kis) (vector-set! kisv (car kis) (cdr kis)))
868            ksets)
869           ;; Vectorize transitions (by src kx).
870           (for-each
871            (lambda (kit)
872              (vector-set! kitv (cadr kit)
873                           (acons (car kit) (caddr kit)
874                                  (vector-ref kitv (cadr kit)))))
875            ktrnz)
876           ;; Return kis-v, kernel itemsets, and kix-v transitions.
877           (cons* (cons 'kis-v kisv) (cons 'kix-v kitv) al-in)))))))
878
879 ;; @deffn find-eps non-terms lhs-v rhs-v => eps-l
880 ;; Generate a list of non-terminals which have epsilon productions.
881 (define (find-eps nterms lhs-v rhs-v)
882   (let* ((nprod (vector-length lhs-v))
883          (find-new
884           (lambda (e l)
885             (let iter ((ll l) (gx 0) (lhs #f) (rhs #()) (rx 0))
886               (cond
887                ((< rx (vector-length rhs))
888                 (if (and (memq (vector-ref rhs rx) nterms) ; non-term
889                          (memq (vector-ref rhs rx) ll))    ; w/ eps prod
890                     (iter ll gx lhs rhs (1+ rx)) ; yes: check next
891                     (iter ll (1+ gx) #f #() 0))) ; no: next p-rule
892                ((and lhs (= rx (vector-length rhs))) ; we have eps-prod
893                 (iter (if (memq lhs ll) ll (cons lhs ll)) (1+ gx) #f #() 0))
894                ((< gx nprod)            ; check next p-rule if not on list
895                 (if (memq (vector-ref lhs-v gx) ll)
896                     (iter ll (1+ gx) #f #() 0)
897                     (iter ll gx (vector-ref lhs-v gx) (vector-ref rhs-v gx) 0)))
898                (else ll))))))
899     (fixed-point find-new (find-new #f '()))))
900
901 ;; @deffn merge1 v l
902 ;; add v to l if not in l
903 (define (merge1 v l)
904   (if (memq v l) l (cons v l)))
905
906 ;; @deffn merge2 v l al
907 ;; add v to l if not in l or al
908 (define (merge2 v l al) 
909   (if (memq v l) l (if (memq v al) l (cons v l))))
910
911 ;; @deffn first symbol-list end-token-list
912 ;; Return list of terminals starting the string @code{symbol-list}
913 ;; (see DB, p. 188).  If the symbol-list can generate epsilon then the
914 ;; result will include @code{end-token-list}.
915 (define (first symbol-list end-token-list)
916   (let* ((core (fluid-ref *lalr-core*))
917          (eps-l (core-eps-l core)))
918     ;; This loop strips off the leading symbol from stng and then adds to
919     ;; todo list, which results in range of p-rules getting checked for
920     ;; terminals.
921     (let iter ((rslt '())               ; terminals collected
922                (stng symbol-list)       ; what's left of input string
923                (hzeps #t)               ; if eps-prod so far
924                (done '())               ; non-terminals checked
925                (todo '())               ; non-terminals to assess
926                (p-range '())            ; range of p-rules to check
927                (item '()))              ; item in production
928       (cond
929        ((pair? item)
930         (let ((sym (looking-at item)))
931           (cond
932            ((eq? sym '$epsilon)         ; at end of rule, go next
933             (iter rslt stng hzeps done todo p-range '()))
934            ((terminal? sym)             ; terminal, log it
935             (iter (merge1 sym rslt) stng hzeps done todo p-range '()))
936            ((memq sym eps-l)            ; symbol has eps prod
937             (iter rslt stng hzeps (merge1 sym done) (merge2 sym todo done)
938                   p-range (next-item item)))
939            (else ;; non-terminal, add to todo/done, goto next
940             (iter rslt stng hzeps
941                   (merge1 sym done) (merge2 sym todo done) p-range '())))))
942        
943        ((pair? p-range)                 ; next one to do
944         ;; run through next rule
945         (iter rslt stng hzeps done todo
946               (range-next p-range) (first-item (car p-range))))
947
948        ((pair? todo)
949         (iter rslt stng hzeps done (cdr todo) (prule-range (car todo)) '()))
950
951        ((and hzeps (pair? stng))
952         ;; Last pass saw an $epsilon so check the next input symbol,
953         ;; with saweps reset to #f.
954         (let* ((symb (car stng)) (stng1 (cdr stng)) (symbl (list symb)))
955           (if (terminal? symb)
956               (iter (cons symb rslt) stng1
957                     (and hzeps (memq symb eps-l))
958                     done todo p-range '())
959               (iter rslt stng1
960                     (or (eq? symb '$epsilon) (memq symb eps-l))
961                     symbl symbl '() '()))))
962        (hzeps
963         ;; $epsilon passes all the way through.
964         ;; If end-token-list provided use that.
965         (if (pair? end-token-list)
966             (lset-union eqv? rslt end-token-list)
967             (cons '$epsilon rslt)))
968        (else
969         rslt)))))
970
971 ;; @deffn item->stng item => list-of-symbols
972 ;; Convert item (e.g., @code{(1 . 2)}) to list of symbols to the end of the
973 ;; production(?). If item is at the end of the rule then return
974 ;; @code{'$epsilon}.  The term "stng" is used to avoid confusion about the
975 ;; term string.
976 (define (item->stng item)
977   (if (eqv? (cdr item) -1)
978       (list '$epsilon)
979       (let* ((core (fluid-ref *lalr-core*))
980              (rhs-v (core-rhs-v core))
981              (rhs (vector-ref rhs-v (car item))))
982         (let iter ((res '()) (ix (1- (vector-length rhs))))
983           (if (< ix (cdr item)) res
984               (iter (cons (vector-ref rhs ix) res) (1- ix)))))))
985
986 ;; add (item . toks) to (front of) la-item-l
987 ;; i.e., la-item-l is unmodified
988 (define (merge-la-item la-item-l item toks)
989   (let* ((pair (assoc item la-item-l))
990          (tokl (if (pair? pair) (cdr pair) '()))
991          (allt ;; union of toks and la-item-l toks
992           (let iter ((tl tokl) (ts toks))
993             (if (null? ts) tl
994                 (iter (if (memq (car ts) tl) tl (cons (car ts) tl))
995                       (cdr ts))))))
996     (if (not pair) (acons item allt la-item-l)
997         (if (eqv? tokl allt) la-item-l
998             (acons item allt la-item-l)))))
999
1000 ;; @deffn first-following item toks => token-list
1001 ;; For la-item A => x.By,z (where  @code{item}, @code{toks}), this
1002 ;; procedure computes @code{FIRST(yz)}.
1003 (define (first-following item toks)
1004   (first (item->stng (next-item item)) toks))
1005
1006 ;; @deffn closure la-item-l => la-item-l
1007 ;; Compute the closure of a list of la-items.
1008 ;; Ref: DB, Fig 4.38, Sec. 4.7, p. 232
1009 (define (closure la-item-l)
1010   ;; Compute the fixed point of I, aka @code{la-item-l}, with procedure
1011   ;;    for each item [A => x.By, a] in I
1012   ;;      each production B => z in G
1013   ;;      and each terminal b in FIRST(ya)
1014   ;;      such that [B => .z, b] is not in I do
1015   ;;        add [B => .z, b] to I
1016   ;; The routine @code{fixed-point} operates on one element of the input set.
1017   (prune-assoc
1018    (fixed-point
1019     (lambda (la-item seed)
1020       (let* ((item (car la-item)) (toks (cdr la-item)) (symb (looking-at item)))
1021         (cond
1022          ((last-item? (car la-item)) seed)
1023          ((terminal? (looking-at (car la-item))) seed)
1024          (else
1025           (let iter ((seed seed) (pr (prule-range symb)))
1026             (cond
1027              ((null? pr) seed)
1028              (else
1029               (iter (merge-la-item seed (first-item (car pr))
1030                                    (first-following item toks))
1031                     (range-next pr)))))))))
1032     la-item-l)))
1033
1034 ;; @deffn kit-add kit-v tokens sx item
1035 ;; Add @code{tokens} to the list of lookaheads for the (kernel) @code{item}
1036 ;; in state @code{sx}.   This is a helper for @code{step2}.
1037 (define (kit-add kit-v tokens kx item)
1038   (let* ((al (vector-ref kit-v kx))     ; a-list for k-set kx
1039          (ar (assoc item al))           ; tokens for item
1040          (sd (if (pair? ar)             ; set difference
1041                  (lset-difference eqv? tokens (cdr ar))
1042                  tokens)))
1043     (cond ; no entry, update entry, no update
1044      ((null? tokens) #f)
1045      ((not ar) (vector-set! kit-v kx (acons item tokens al)) #t)
1046      ((pair? sd) (set-cdr! ar (append sd (cdr ar))) #t)
1047      (else #f))))
1048
1049 ;; @deffn kip-add kip-v sx0 it0 sx1 it1
1050 ;; This is a helper for step2.  It updates kip-v with a propagation from
1051 ;; state @code{sx0}, item @code{it0} to state @code{sx1}, item @code{it1}.
1052 ;; [kip-v sx0] -> (it0 . ((sx1 . it1)
1053 (define (kip-add kip-v sx0 it0 sx1 it1)
1054   (let* ((al (vector-ref kip-v sx0)) (ar (assoc it0 al)))
1055     (cond
1056      ((not ar)
1057       (vector-set! kip-v sx0 (acons it0 (list (cons sx1 it1)) al)) #t)
1058      ((member it1 (cdr ar)) #f)
1059      (else
1060       (set-cdr! ar (acons sx1 it1 (cdr ar))) #t))))
1061
1062 ;; @deffn step2 p-mach-1 => p-mach-2
1063 ;; This implements steps 2 and 3 of Algorithm 4.13 on p. 242 of the DB.
1064 ;; The a-list @code{p-mach-1} includes the kernel itemsets and transitions
1065 ;; from @code{step1}.   This routine adds two entries to the a-list:
1066 ;; the initial set of lookahead tokens in a vector associated with key
1067 ;; @code{'kit-v} and a vector of spontaneous propagations associated with
1068 ;; key @code{'kip-v}.
1069 ;; @example
1070 ;; for-each item I in some itemset
1071 ;;   for-each la-item J in closure(I,#)
1072 ;;     for-each token T in lookaheads(J)
1073 ;;       if LA is #, then add to J propagate-to list
1074 ;;       otherwise add T to spontaneously-generated list
1075 ;; @end example
1076 (define (step2 p-mach)
1077   (let* ((kis-v (assq-ref p-mach 'kis-v))
1078          (kix-v (assq-ref p-mach 'kix-v)) ; transitions?
1079          (nkset (vector-length kis-v))  ; number of k-item-sets
1080          ;; kernel-itemset tokens
1081          (kit-v (make-vector nkset '())) ; sx => alist: (item latoks)
1082          ;; kernel-itemset propagations
1083          (kip-v (make-vector nkset '()))) ; sx0 => ((ita (sx1a . it1a) (sx2a
1084     (vector-set! kit-v 0 (closure (list (list '(0 . 0) '$end))))
1085     (let iter ((kx -1) (kset '()))
1086       (cond
1087        ((pair? kset)
1088         (for-each
1089          (lambda (la-item)
1090            (let* ((item (car la-item))     ; closure item
1091                   (tokl (cdr la-item))     ; tokens
1092                   (sym (looking-at item))  ; transition symbol
1093                   (item1 (next-item item)) ; next item after sym
1094                   (sx1 (assq-ref (vector-ref kix-v kx) sym)) ; goto(I,sym)
1095                   (item0 (car kset)))      ; kernel item
1096              (kit-add kit-v (delq '$@ tokl) sx1 item1) ; spontaneous
1097              (if (memq '$@ tokl)        ; propagates
1098                  (kip-add kip-v kx item0 sx1 item1))))
1099          (remove ;; todo: check this remove
1100           (lambda (li) (last-item? (car li)))
1101           (closure (list (cons (car kset) '($@))))))
1102         (iter kx (cdr kset)))
1103
1104        ((< (1+ kx) nkset)
1105         (iter (1+ kx)
1106               ;; End-items don't shift, so don't propagate.
1107               (remove last-item? (vector-ref kis-v (1+ kx)))))))
1108     ;;(when #f (pp-kip-v kip-v) (pp-kit-v kit-v)) ; for debugging
1109     (cons* (cons 'kit-v kit-v) (cons 'kip-v kip-v) p-mach)))
1110
1111 ;; debug for step2
1112 (define (pp-kit ix kset)
1113   (fmtout "~S:\n" ix)
1114   (for-each
1115    (lambda (item) (fmtout "    ~A, ~S\n" (pp-item (car item)) (cdr item)))
1116    kset))
1117 (define (pp-kit-v kit-v)
1118   (fmtout "spontaneous:\n")
1119   (vector-for-each pp-kit kit-v))
1120 (define (pp-kip ix kset)
1121   (for-each
1122    (lambda (x)
1123      (fmtout "~S: ~A\n" ix (pp-item (car x)))
1124      (for-each
1125       (lambda (y) (fmtout "   => ~S: ~A\n" (car y) (pp-item (cdr y))))
1126       (cdr x)))
1127    kset))
1128 (define (pp-kip-v kip-v)
1129   (fmtout "propagate:\n")
1130   (vector-for-each pp-kip kip-v))
1131
1132 ;; @deffn step3 p-mach-2 => p-mach-3
1133 ;; Execute nyacc step 3, where p-mach means ``partial machine''.
1134 ;; This implements step 4 of Algorithm 4.13 from the DB.
1135 (define (step3 p-mach)
1136   (let* ((kit-v (assq-ref p-mach 'kit-v))
1137          (kip-v (assq-ref p-mach 'kip-v))
1138          (nkset (vector-length kit-v)))
1139     (let iter ((upd #t)                 ; token propagated?
1140                (kx -1)                  ; current index
1141                (ktal '())               ; (item . LA) list for kx
1142                (toks '())               ; LA tokens being propagated
1143                (item '())               ; from item 
1144                (prop '()))              ; to items
1145       (cond
1146        ((pair? prop)
1147         ;; Propagate lookaheads.
1148         (let* ((sx1 (caar prop)) (it1 (cdar prop)))
1149           (iter (or (kit-add kit-v toks sx1 it1) upd)
1150                 kx ktal toks item (cdr prop))))
1151
1152        ((pair? ktal)
1153         ;; Process the next (item . tokl) in the alist ktal.
1154         (iter upd kx (cdr ktal) (cdar ktal) (caar ktal)
1155               (assoc-ref (vector-ref kip-v kx) (caar ktal))))
1156
1157        ((< (1+ kx) nkset)
1158         ;; Process the next itemset.
1159         (iter upd (1+ kx) (vector-ref kit-v (1+ kx)) '() '() '()))
1160
1161        (upd
1162         ;; Have updates, rerun.
1163         (iter #f 0 '() '() '() '()))))
1164     p-mach))
1165
1166 ;; @deffn reductions kit-v sx => ((tokA gxA1 ...) (tokB gxB1 ...) ...)
1167 ;; This is a helper for @code{step4}.
1168 ;; Return an a-list of reductions for state @code{sx}.
1169 ;; The a-list pairs are make of a token and a list of prule indicies.
1170 ;; CHECK the following.  We are brute-force using @code{closure} here.
1171 ;; It works, but there should be a better algorithm.
1172 ;; Note on reductions: We reduce if the kernel-item is an end-item or a 
1173 ;; non-kernel item with an epsilon-production.  That is, if we have a
1174 ;; kernel item of the form
1175 ;; @example
1176 ;; A => abc.
1177 ;; @end example
1178 ;; or if we have the non-kernel item of the form
1179 ;; @example
1180 ;; B => .de
1181 ;; @end example
1182 ;; where FIRST(de,#) includes #.  See the second paragraph under ``Efficient
1183 ;; Construction of LALR Parsing Tables'' in DB Sec 4.7.
1184 (define (old-reductions kit-v sx)
1185   (let iter ((ral '())                    ; result: reduction a-list
1186              (lais (vector-ref kit-v sx)) ; la-item list
1187              (toks '())                   ; kernel la-item LA tokens
1188              (itms '())                   ; all items
1189              (gx #f)                      ; rule reduced by tl
1190              (tl '()))                    ; LA-token list
1191     (cond
1192      ((pair? tl) ;; add (token . p-rule) to reduction list
1193       (let* ((tk (car tl)) (rp (assq tk ral)))
1194         (cond
1195          ;; already have this, skip to next token
1196          ((and rp (memq gx (cdr rp)))
1197           (iter ral lais toks itms gx (cdr tl)))
1198          (rp
1199           ;; have token, add prule
1200           (set-cdr! rp (cons gx (cdr rp)))
1201           (iter ral lais toks itms gx (cdr tl)))
1202          (else
1203           ;; add token w/ prule
1204           (iter (cons (list tk gx) ral) lais toks itms gx (cdr tl))))))
1205
1206      ((pair? itms)
1207       (if (last-item? (car itms))
1208           ;; last item, add it 
1209           (iter ral lais toks (cdr itms) (caar itms) toks)
1210           ;; skip to next
1211           (iter ral lais toks (cdr itms) 0 '())))
1212
1213      ((pair? lais) ;; process next la-item
1214       (iter ral (cdr lais) (cdar lais) (expand-k-item (caar lais)) 0 '()))
1215
1216      (else ral))))
1217 ;; I think the above is broken because I'm not including the proper tail
1218 ;; string.  The following just uses closure to do the job.  It works but
1219 ;; may not be very efficient: seems a bit brute force.
1220 (define (new-reductions kit-v sx)
1221   (let iter ((ral '())                    ; result: reduction a-list
1222              (klais (vector-ref kit-v sx)) ; kernel la-item list
1223              (laits '())                   ; all la-items
1224              (gx #f)                       ; rule reduced by tl
1225              (tl '()))                    ; LA-token list
1226     (cond
1227      ((pair? tl) ;; add (token . p-rule) to reduction list
1228       (let* ((tk (car tl)) (rp (assq tk ral)))
1229         (cond
1230          ((and rp (memq gx (cdr rp)))
1231           ;; already have this, skip to next token
1232           (iter ral klais laits gx (cdr tl)))
1233          (rp
1234           ;; have token, add prule
1235           (set-cdr! rp (cons gx (cdr rp)))
1236           (iter ral klais laits gx (cdr tl)))
1237          (else
1238           ;; add token w/ prule
1239           (iter (cons (list tk gx) ral) klais laits gx (cdr tl))))))
1240
1241      ((pair? laits) ;; process a la-itemset
1242       (if (last-item? (caar laits))
1243           ;; last item, add it 
1244           (iter ral klais (cdr laits) (caaar laits) (cdar laits))
1245           ;; else skip to next
1246           (iter ral klais (cdr laits) 0 '())))
1247
1248      ((pair? klais) ;; expand next kernel la-item
1249       ;; There is a cheaper way than closure to do this but for now ...
1250       (iter ral (cdr klais) (closure (list (car klais))) 0 '()))
1251
1252      (else
1253       ral))))
1254 (define reductions new-reductions)
1255
1256 ;; Generate parse-action-table from the shift a-list and reduce a-list.
1257 ;; This is a helper for @code{step4}.  It converts a list of state transitions
1258 ;; and a list of reductions into a parse-action table of shift, reduce,
1259 ;; accept, shift-reduce conflict or reduce-reduce conflict.
1260 ;; The actions take the form:
1261 ;; @example
1262 ;; (shift . <dst-state>)
1263 ;; (reduce . <rule-index>)
1264 ;; (accept . 0)
1265 ;; (srconf . (<dst-state> . <p-rule>))
1266 ;; (rrconf . <list of p-rules indices>)
1267 ;; @end example
1268 ;; If a shift has multiple reduce conflicts we report only one reduction.
1269 (define (gen-pat sft-al red-al)
1270   (let iter ((res '()) (sal sft-al) (ral red-al))
1271     (cond
1272      ((pair? sal)
1273       (let* ((term (caar sal))           ; terminal 
1274              (goto (cdar sal))           ; target state
1275              (redp (assq term ral))      ; a-list entry, may be removed
1276              ;;(redl (if redp (cdr redp) #f))) ; reductions on terminal
1277              (redl (and=> redp cdr)))   ; reductions on terminal
1278         (cond
1279          ((and redl (pair? (cdr redl)))
1280           ;; This means we have a shift-reduce and reduce-reduce conflicts.
1281           ;; We record only one shift-reduce and keep the reduce-reduce.
1282           (iter (cons (cons* term 'srconf goto (car redl)) res)
1283                 (cdr sal) ral))
1284          (redl
1285           ;; The terminal (aka token) signals a single reduction.  This means
1286           ;; we have one shift-reduce conflict.  We have a chance to repair
1287           ;; the parser using precedence/associativity rules so we remove the
1288           ;; reduction from the reduction-list.
1289           (iter (cons (cons* term 'srconf goto (car redl)) res)
1290                 (cdr sal) (delete redp ral)))
1291          (else
1292           ;; The terminal (aka token) signals a shift only.
1293           (iter (cons (cons* term 'shift goto) res)
1294                 (cdr sal) ral)))))
1295      ((pair? ral)
1296       (let ((term (caar ral)) (rest (cdar ral)))
1297         ;; We keep 'accept as explict action.  Another option is to reduce and
1298         ;; have 0-th p-rule action generate return from parser (via prompt?).
1299         (iter
1300          (cons (cons term
1301                      (cond ;; => action and arg(s)
1302                       ((zero? (car rest)) (cons 'accept 0))
1303                       ((zero? (car rest)) (cons 'reduce (car rest)))
1304                       ((> (length rest) 1) (cons 'rrconf rest))
1305                       (else (cons 'reduce (car rest)))))
1306                res) sal (cdr ral))))
1307      (else res))))
1308
1309
1310 ;; @deffn step4 p-mach-0 => p-mach-1
1311 ;; This generates the parse action table from the itemsets and then applies
1312 ;; precedence and associativity rules to eliminate shift-reduce conflicts
1313 ;; where possible.  The output includes the parse action table (entry
1314 ;; @code{'pat-v} and TBD (list of errors in @code{'err-l}).
1315 ;;.per-state: alist by symbol:
1316 ;;   (symb <id>) if <id> > 0 SHIFT to <id>, else REDUCE by <id> else
1317 ;; so ('$end . 0) means ACCEPT!
1318 ;; but 0 for SHIFT and REDUCE, but reduce 0 is really ACCEPT
1319 ;; if reduce by zero we are done. so never hit state zero accept on ACCEPT?
1320 ;; For each state, the element of pat-v looks like
1321 ;; ((tokenA . (reduce . 79)) (tokenB . (reduce . 91)) ... )
1322 (define (step4 p-mach)
1323
1324   (define (setup-assc assc)
1325     (fold (lambda (al seed)
1326             (append (x-flip al) seed)) '() assc))
1327
1328   (define (setup-prec prec)
1329     (let iter ((res '()) (rl '()) (hd '()) (pl '()) (pll prec))
1330       (cond
1331        ((pair? pl)
1332         (let* ((p (car pl)) (hdp (x-comb hd p))
1333                (pp (remove (lambda (p) (eqv? (car p) (cdr p))) (x-comb p p))))
1334           (iter res (append rl hdp pp) (car pl) (cdr pl) pll)))
1335        ((pair? rl) (iter (append res rl) '() hd pl pll))
1336        ((pair? pll) (iter res rl '() (car pll) (cdr pll)))
1337        (else res))))
1338
1339   (define (prev-sym act its)
1340     (let* ((a act)
1341            (tok (car a)) (sft (caddr a)) (red (cdddr a))
1342            ;; @code{pit} is the end-item in the p-rule to be reduced.
1343            (pit (prev-item (prev-item (cons red -1))))
1344            ;; @code{psy} is the last symbol in the p-rule to be reduced.
1345            (psy (looking-at pit)))
1346       psy))
1347
1348   (let* ((kis-v (assq-ref p-mach 'kis-v)) ; states
1349          (kit-v (assq-ref p-mach 'kit-v)) ; la-toks
1350          (kix-v (assq-ref p-mach 'kix-v)) ; transitions
1351          (assc (assq-ref p-mach 'assc))   ; associativity rules
1352          (assc (setup-assc assc))         ; trying it
1353          (prec (assq-ref p-mach 'prec))   ; precedence rules
1354          (prec (setup-prec prec))         ; trying it
1355          (nst (vector-length kis-v))      ; number of states
1356          (pat-v (make-vector nst '()))    ; parse-act tab /state
1357          (rat-v (make-vector nst '()))    ; removed-act tab /state
1358          (gen-pat-ix (lambda (ix)         ; pat from shifts & reduc's
1359                        (gen-pat (vector-ref kix-v ix) (reductions kit-v ix))))
1360          (prp-v (assq-ref p-mach 'prp-v))  ; per-rule precedence
1361          (tl (assq-ref p-mach 'terminals)) ; for error msgs
1362          )
1363     ;; We run through each itemset.
1364     ;; @enumerate
1365     ;; @item We have a-list of symbols to shift state (i.e., @code{kix-v}).
1366     ;; @item We generate a list of tokens to reduction from @code{kit-v}.
1367     ;; @end enumerate
1368     ;; Q: should '$end be edited out of shifts?
1369     ;; kit-v is vec of a-lists of form ((item tok1 tok2 ...) ...)
1370     ;; turn to (tok1 item1 item2 ...)
1371     (let iter ((ix 0)           ; state index
1372                (pat '())        ; parse-action table
1373                (rat '())        ; removed-action table
1374                (wrn '())        ; warnings on unsolicited removals
1375                (ftl '())        ; fatal conflicts
1376                (actl (gen-pat-ix 0))) ; action list
1377       (cond
1378        ((pair? actl)
1379         (case (cadar actl)
1380           ((shift reduce accept)
1381            (iter ix (cons (car actl) pat) rat wrn ftl (cdr actl)))
1382           ((srconf)
1383            (let* ((act (car actl))
1384                   (tok (car act)) (sft (caddr act)) (red (cdddr act))
1385                   (prp (vector-ref prp-v red))
1386                   (psy (prev-sym act (vector-ref kis-v ix)))
1387                   (preced (or (and prp (prece prp tok prec)) ; rule-based
1388                               (prece psy tok prec))) ; oper-based
1389                   (sft-a (cons* tok 'shift sft))
1390                   (red-a (cons* tok 'reduce red)))
1391              (call-with-values
1392                  (lambda ()
1393                    ;; Use precedence or, if =, associativity.
1394                    (case preced
1395                      ((#\>)
1396                       (values red-a (cons sft-a 'pre) #f #f))
1397                      ((#\<)
1398                       (values sft-a (cons red-a 'pre) #f #f))
1399                      ((#\=) ;; Now use associativity
1400                       (case (assq-ref assc tok)
1401                         ((left)
1402                          (values red-a (cons sft-a 'ass) #f #f))
1403                         ((right)
1404                          (values sft-a (cons red-a 'ass) #f #f))
1405                         ((nonassoc)
1406                          (values (cons* tok 'error red) #f #f (cons ix act)))
1407                         (else
1408                          (values sft-a (cons red-a 'def) (cons ix act) #f))))
1409                      (else ;; Or default, which is shift.
1410                       (values sft-a (cons red-a 'def) (cons ix act) #f))))
1411                (lambda (a r w f)
1412                  (iter ix
1413                        (if a (cons a pat) pat)
1414                        (if r (cons r rat) rat)
1415                        (if w (cons w wrn) wrn)
1416                        (if f (cons f ftl) ftl)
1417                        (cdr actl))))))
1418           ((rrconf)
1419            #;(fmterr "*** reduce-reduce conflict: in state ~A on ~A: ~A\n"
1420                    ix (obj->str (find-terminal (caar actl) tl)) (cddar actl))
1421            (iter ix (cons (car actl) pat) rat wrn
1422                  (cons (cons ix (car actl)) ftl) (cdr actl)))
1423           (else
1424            (error "PROBLEM"))))
1425        ((null? actl)
1426         (vector-set! pat-v ix pat)
1427         (vector-set! rat-v ix rat)
1428         (iter ix pat rat wrn ftl #f))
1429        ((< (1+ ix) nst)
1430         (iter (1+ ix) '() '() wrn ftl (gen-pat-ix (1+ ix))))
1431        (else
1432         (let* ((attr (assq-ref p-mach 'attr))
1433                (expect (assq-ref attr 'expect))) ; expected # srconf
1434           (if (not (= (length wrn) expect))
1435               (for-each (lambda (m) (fmterr "+++ warning: ~A\n" (conf->str m)))
1436                         (reverse wrn)))
1437           (for-each
1438            (lambda (m) (fmterr "*** fatal: ~A\n" (conf->str m)))
1439            (reverse ftl))
1440           ))))
1441     ;; Return mach with parse-action and removed-action tables.
1442     (cons* (cons 'pat-v pat-v) (cons 'rat-v rat-v) p-mach)))
1443
1444 ;; @deffn conf->str cfl => string
1445 ;; map conflict (e.g., @code{('rrconf 1 . 2}) to string.
1446 (define (conf->str cfl)
1447   (let* ((st (list-ref cfl 0)) (tok (list-ref cfl 1)) (typ (list-ref cfl 2))
1448          (core (fluid-ref *lalr-core*)) (terms (core-terminals core)))
1449     (fmtstr "in state ~A, ~A conflict on ~A"
1450             st
1451             (case typ
1452               ((srconf) "shift-reduce")
1453               ((rrconf) "reduce-reduce")
1454               (else "unknown"))
1455             (obj->str (find-terminal tok terms)))))
1456                      
1457 ;; @deffn gen-match-table mach => mach
1458 ;; Generate the match-table for a machine.  The match table is a list of
1459 ;; pairs: the car is the token used in the grammar specification, the cdr
1460 ;; is the symbol that should be returned by the lexical analyzer.
1461 ;;
1462 ;; The match-table may be passed to
1463 ;; the lexical analyzer builder to identify strings or string-types as tokens.
1464 ;; The associated key in the machine is @code{mtab}. 
1465 ;; @enumerate
1466 ;; @item
1467 ;; @sc{nyacc}-reserved symbols are provided as symbols
1468 ;; @example
1469 ;; $ident -> ($ident . $ident)
1470 ;; @end example
1471 ;; @item
1472 ;; Terminals used as symbols (@code{'comment} versus @code{"comment"}) are
1473 ;; provided as symbols.  The spec parser will provide a warning if symbols
1474 ;; are used in both ways.
1475 ;; @item
1476 ;; Others are provided as strings.
1477 ;; @end enumerate
1478 ;; The procedure @code{hashify-machine} will convert the cdrs to integers.
1479 ;; Test: "$abc" => ("$abc" '$abc) '$abc => ('$abc . '$abc)
1480 (define (gen-match-table mach)
1481   (cons
1482    (cons 'mtab (map (lambda (term) (cons term (atomize term)))
1483                     (assq-ref mach 'terminals)))
1484    mach))
1485
1486
1487 ;; @deffn add-recovery-logic! mach => mach
1488 ;; Target of transition from @code{'$error} should have a default rule that
1489 ;; loops back.
1490 (define (add-recovery-logic-1 mach)
1491   (let* ((kis-v (assq-ref mach 'kis-v))
1492          (rhs-v (assq-ref mach 'rhs-v))
1493          (pat-v (assq-ref mach 'pat-v))
1494          (n (vector-length pat-v))
1495          )
1496     (vector-for-each
1497      (lambda (kx kis)
1498        ;;(fmtout "kis=~S\n " kis)
1499        (for-each
1500         (lambda (ki)
1501           (let* ((pi (prev-item ki))
1502                  (rhs (vector-ref rhs-v (car pi))))
1503             (when (and (not (negative? (cdr pi)))
1504                        (eqv? '$error (looking-at pi)))
1505               (vector-set! pat-v kx
1506                            (append
1507                             (vector-ref pat-v kx)
1508                             `(($default shift . ,kx))))
1509               #;(fmtout " => ~S\n" (vector-ref pat-v kx)))))
1510         kis)
1511        ;;(fmtout "\n")
1512        #f)
1513      kis-v)
1514     mach))
1515
1516 (define (add-recovery-logic! mach)
1517   (let ((prev-core (fluid-ref *lalr-core*)))
1518     (dynamic-wind
1519         (lambda () (fluid-set! *lalr-core* (make-core/extras mach)))
1520         (lambda () (add-recovery-logic-1 mach))
1521         (lambda () (fluid-set! *lalr-core* prev-core)))))
1522
1523 ;; to build parser, need:
1524 ;;   pat-v - parse action table
1525 ;;   ref-v - references
1526 ;;   len-v - rule lengths
1527 ;;   rto-v - hashed lhs symbols
1528 ;; to print itemsets need:
1529 ;;   kis-v - itemsets
1530 ;;   lhs-v - left hand sides
1531 ;;   rhs-v - right hand sides
1532 ;;   pat-v - action table
1533
1534 ;; @deffn restart-spec spec start => spec
1535 ;; This generates a new spec with a different start.
1536 ;; @example
1537 ;; (restart-spec clang-spec 'expression) => cexpr-spec
1538 ;; @end example
1539 (define (restart-spec spec start)
1540   (let* ((rhs-v (vector-copy (assq-ref spec 'rhs-v))))
1541     (vector-set! rhs-v 0 (vector start))
1542     (cons* (cons 'start start)
1543            (cons 'rhs-v rhs-v)
1544            spec)))
1545
1546 ;; @deffn make-lalr-machine spec => pgen
1547 ;; Generate a-list of items used for building/debugging parsers.
1548 ;; It might be useful to add hashify and compact with keyword arguments.
1549 (define (make-lalr-machine spec)
1550   (if (not spec) (error "make-lalr-machine: expecting valid specification"))
1551   (let ((prev-core (fluid-ref *lalr-core*)))
1552     (dynamic-wind
1553         (lambda () (fluid-set! *lalr-core* (make-core/extras spec)))
1554         (lambda ()
1555           (let* ((sm1 (step1 spec))
1556                  (sm2 (step2 sm1))
1557                  (sm3 (step3 sm2))
1558                  (sm4 (step4 sm3))
1559                  (sm5 (gen-match-table sm4)))
1560             (cons*
1561              (cons 'len-v (vector-map (lambda (i v) (vector-length v))
1562                                       (assq-ref sm5 'rhs-v)))
1563              (cons 'rto-v (vector-copy (assq-ref sm5 'lhs-v)))
1564              sm5)))
1565         (lambda () (fluid-set! *lalr-core* prev-core)))))
1566
1567 ;; for debugging
1568 (define (make-LR0-machine spec)
1569   (if (not spec) (error "make-LR0-machine: expecting valid specification"))
1570   (let ((prev-core (fluid-ref *lalr-core*)))
1571     (dynamic-wind
1572         (lambda () (fluid-set! *lalr-core* (make-core/extras spec)))
1573         (lambda () (step1 spec))
1574         (lambda () (fluid-set! *lalr-core* prev-core)))))
1575
1576 ;; @deffn with-spec spec proc arg ...
1577 ;; Execute with spec or mach.
1578 (define (with-spec spec proc . args)
1579   (if (not spec) (error "with-spec: expecting valid specification"))
1580   (let ((prev-core (fluid-ref *lalr-core*)))
1581     (dynamic-wind
1582         (lambda () (fluid-set! *lalr-core* (make-core/extras spec)))
1583         (lambda () (apply proc args))
1584         (lambda () (fluid-set! *lalr-core* prev-core)))))
1585
1586 ;; @deffn lalr-match-table mach => match-table
1587 ;; Get the match-table
1588 (define (lalr-match-table mach)
1589   (assq-ref mach 'mtab))
1590
1591 ;; @deffn machine-compacted? mach => #t|#f
1592 ;; Indicate if the machine has been compacted.
1593 ;; TODO: needs update to deal with error recovery hooks.
1594 (define (machine-compacted? mach)
1595   ;; Works by searching for $default phony-token.
1596   (call-with-prompt 'got-it
1597     ;; Search for '$default.  If not found return #f.
1598     (lambda ()
1599       (vector-for-each
1600        (lambda (ix pat)
1601          (for-each
1602           (lambda (a) (if (or (eqv? (car a) '$default) (eqv? (car a) -1))
1603                           (abort-to-prompt 'got-it)))
1604           pat))
1605        (assq-ref mach 'pat-v))
1606       #f)
1607     ;; otherwise, return #t.
1608     (lambda () #t)))
1609
1610 ;; @deffn compact-machine mach [#:keep 3] => mach
1611 ;; A "filter" to compact the parse table.  For each state this will replace
1612 ;; the most populus set of reductions of the same production rule with a
1613 ;; default production.  However, reductions triggered by keepers like
1614 ;; @code{'$error}, @code{'$lone-comm} or @code{'$lone-comm} are not counted.
1615 ;; The parser will want to treat errors and comments separately so that they
1616 ;; can be trapped (e.g., unaccounted comments are skipped).
1617 (define* (compact-machine mach #:key (keep 3))
1618   (let* ((pat-v (assq-ref mach 'pat-v))
1619          (nst (vector-length pat-v))
1620          (hashed (number? (caar (vector-ref pat-v 0)))) ; been hashified?
1621          (reduce? (if hashed
1622                       (lambda (a) (and (number? a) (negative? a)))
1623                       (lambda (a) (eq? 'reduce (car a)))))
1624          (reduce-pr (if hashed abs cdr))
1625          (reduce-to? (if hashed
1626                          (lambda (a r) (eqv? (- r) a))
1627                          (lambda (a r) (and (eq? 'reduce (car a))
1628                                             (eqv? r (cdr a))))))
1629          (mk-default (if hashed
1630                          (lambda (r) (cons -1 (- r)))
1631                          (lambda (r) `($default reduce . ,r))))
1632          (mtab (assq-ref mach 'mtab))
1633          (keepers (list (assq-ref mtab '$lone-comm)
1634                         (assq-ref mtab '$code-comm)
1635                         (assq-ref mtab '$error))))
1636
1637     ;; Keep an a-list mapping reduction prod-rule => count.
1638     (let iter ((sx nst) (trn-l #f) (cnt-al '()) (p-max '(0 . 0)))
1639       (cond
1640        ((pair? trn-l)
1641         (cond
1642         ((not (reduce? (cdar trn-l)))
1643          ;; A shift, so not a candidate for default reduction.
1644          (iter sx (cdr trn-l) cnt-al p-max))
1645         ((memq (caar trn-l) keepers)
1646          ;; Don't consider keepers because these will not be included.
1647          (iter sx (cdr trn-l) cnt-al p-max))
1648         (else
1649          ;; A reduction, so update the count for reducing this prod-rule.
1650          (let* ((ix (reduce-pr (cdar trn-l)))
1651                 (cnt (1+ (or (assq-ref cnt-al ix) 0)))
1652                 (cnt-p (cons ix cnt)))
1653            (iter sx (cdr trn-l) (cons cnt-p cnt-al)
1654                  (if (> cnt (cdr p-max)) cnt-p p-max))))))
1655               
1656        ((null? trn-l)
1657         ;; We have processed all transitions. If more than @code{keep} common
1658         ;; reductions then generate default rule to replace those.
1659         (if (> (cdr p-max) keep)
1660             (vector-set!
1661              pat-v sx
1662              (fold-right
1663               (lambda (trn pat) ;; transition action
1664                 ;; If not a comment and reduces to the most-popular prod-rule
1665                 ;; then transfer to the default transition.
1666                 (if (and (not (memq (car trn) keepers))
1667                          (reduce-to? (cdr trn) (car p-max)))
1668                     pat
1669                     (cons trn pat)))
1670               (list (mk-default (car p-max))) ;; default is last
1671               (vector-ref pat-v sx))))
1672         (iter sx #f #f #f))
1673        ((positive? sx) ;; next state
1674         (iter (1- sx) (vector-ref pat-v (1- sx)) '() '(0 . 0)))))
1675     mach))
1676
1677 ;;.@section Using hash tables
1678 ;; The lexical analyzer will generate tokens.  The parser generates state
1679 ;; transitions based on these tokens.  When we build a lexical analyzer
1680 ;; (via @code{make-lexer}) we provide a list of strings to detect along with
1681 ;; associated tokens to return to the parser.  By default the tokens returned
1682 ;; are symbols or characters.  But these could as well be integers.  Also,
1683 ;; the parser uses symbols to represent non-terminals, which are also used
1684 ;; to trigger state transitions.  We could use integers instead of symbols
1685 ;; and characters by mapping via a hash table.   We will bla bla bla.
1686 ;; There are also standard tokens we need to worry about.  These are
1687 ;; @enumerate
1688 ;; @item the @code{$end} marker
1689 ;; @item identifiers (using the symbolic token @code{$ident}
1690 ;; @item non-negative integers (using the symbolic token @code{$fixed})
1691 ;; @item non-negative floats (using the symbolic token @code{$float})
1692 ;; @item @code{$default} => 0
1693 ;; @end enumerate
1694 ;; And action
1695 ;; @enumerate
1696 ;; @item positive => shift
1697 ;; @item negative => reduce
1698 ;; @item zero => accept
1699 ;; @end enumerate
1700 ;; However, if these are used they should appear in the spec's terminal list.
1701 ;; For the hash table we use positive integers for terminals and negative
1702 ;; integers for non-terminals.  To apply such a hash table we need to:
1703 ;; @enumerate
1704 ;; @item from the spec's list of terminals (aka tokens), generate a list of
1705 ;; terminal to integer pairs (and vice versa)
1706 ;; @item from the spec's list of non-terminals generate a list of symbols
1707 ;; to integers and vice versa.
1708 ;; @item Go through the parser-action table and convert symbols and characters
1709 ;; to integers
1710 ;; @item Go through the XXX list passed to the lexical analyizer and replace
1711 ;; symbols and characters with integers.
1712 ;; @end enumerate
1713 ;; One issue we need to deal with is separating out the identifier-like
1714 ;; terminals (aka keywords) from those that are not identifier-like.  I guess
1715 ;; this should be done as part of @code{make-lexer}, by filtering the token
1716 ;; list through the ident-reader.
1717 ;; NOTE: The parser is hardcoded to assume that the phony token for the
1718 ;; default (reduce) action is @code{'$default} for unhashed machine or
1719 ;; @code{-1} for a hashed machine.
1720
1721 ;; NEW: need to add reduction of ERROR
1722
1723 ;; @deffn machine-hashed? mach => #t|#f
1724 ;; Indicate if the machine has been hashed.
1725 (define (machine-hashed? mach)
1726   ;; If hashed, the parse action for rule 0 will always be a number.
1727   (number? (caar (vector-ref (assq-ref mach 'pat-v) 0))))
1728
1729 ;; @deffn hashify-machine mach => mach
1730 (define (hashify-machine mach)
1731   (if (machine-hashed? mach) mach
1732       (let* ((terminals (assq-ref mach 'terminals))
1733              (non-terms (assq-ref mach 'non-terms))
1734              (lhs-v (assq-ref mach 'lhs-v))
1735              (sm ;; = (cons sym->int int->sym)
1736               (let iter ((si (list (cons '$default -1)))
1737                          (is (list (cons -1 '$default)))
1738                          (ix 1) (tl terminals) (nl non-terms))
1739                 (if (null? nl) (cons (reverse si) (reverse is))
1740                     (let* ((s (atomize (if (pair? tl) (car tl) (car nl))))
1741                            (tl1 (if (pair? tl) (cdr tl) tl))
1742                            (nl1 (if (pair? tl) nl (cdr nl))))
1743                       (iter (acons s ix si) (acons ix s is) (1+ ix) tl1 nl1)))))
1744              (sym->int (lambda (s) (assq-ref (car sm) s)))
1745              ;;
1746              (pat-v0 (assq-ref mach 'pat-v))
1747              (npat (vector-length pat-v0))
1748              (pat-v1 (make-vector npat '())))
1749         ;; replace symbol/chars with integers
1750         (let iter1 ((ix 0))
1751           (unless (= ix npat)
1752             (let iter2 ((al1 '()) (al0 (vector-ref pat-v0 ix)))
1753               (if (null? al0) (vector-set! pat-v1 ix (reverse al1))
1754                   (let* ((a0 (car al0))
1755                          ;; tk: token; ac: action; ds: destination
1756                          (tk (car a0)) (ac (cadr a0)) (ds (cddr a0))
1757                          ;; t: encoded token; d: encoded destination
1758                          (t (sym->int tk))
1759                          (d (case ac
1760                               ((shift) ds) ((reduce) (- ds))
1761                               ((accept) 0) (else #f))))
1762                     (unless t
1763                       (fmterr "~S ~S ~S\n" tk ac ds)
1764                       (error "expect something"))
1765                     (iter2 (acons t d al1) (cdr al0)))))
1766             (iter1 (1+ ix))))
1767         ;;
1768         (cons*
1769          (cons 'pat-v pat-v1)
1770          (cons 'siis sm) ;; sm = (cons sym->int int->sym)
1771          (cons 'mtab
1772                (let iter ((mt1 '()) (mt0 (assq-ref mach 'mtab)))
1773                  (if (null? mt0) (reverse mt1)
1774                      (iter (cons (cons (caar mt0) (sym->int (cdar mt0))) mt1)
1775                            (cdr mt0)))))
1776          ;; reduction symbols = lhs:
1777          (cons 'rto-v (vector-map (lambda (i v) (sym->int v)) lhs-v))
1778          mach))))
1779
1780 ;; === grammar/machine printing ======
1781
1782 ;; @deffn elt->str elt terms => string
1783 (define (elt->str elt terms)
1784   (or (and=> (find-terminal elt terms) obj->str)
1785       (symbol->string elt)))
1786
1787 ;; @deffn pp-rule indent gx [port]
1788 ;; Pretty-print a production rule.
1789 (define (pp-rule il gx . rest)
1790   (let* ((port (if (pair? rest) (car rest) (current-output-port)))
1791          (core (fluid-ref *lalr-core*))
1792          (lhs (vector-ref (core-lhs-v core) gx))
1793          (rhs (vector-ref (core-rhs-v core) gx))
1794          (tl (core-terminals core)))
1795     (display (substring "                     " 0 (min il 20)) port)
1796     (fmt port "~A =>" lhs)
1797     (vector-for-each (lambda (ix e) (fmt port " ~A" (elt->str e tl))) rhs)
1798     (newline port)))
1799          
1800 ;; @deffn pp-item item => string
1801 ;; This could be called item->string.
1802 ;; This needs terminals to work correctly, like pp-lalr-grammar.
1803 (define (pp-item item) 
1804   (let* ((core (fluid-ref *lalr-core*))
1805          (tl (core-terminals core))
1806          (gx (car item))
1807          (lhs (vector-ref (core-lhs-v core) gx))
1808          (rhs (vector-ref (core-rhs-v core) gx))
1809          (rhs-len (vector-length rhs)))
1810     (apply
1811      string-append
1812      (let iter ((rx 0) (sl (list (fmtstr "~S =>" lhs))))
1813        (if (= rx rhs-len)
1814            (append sl (if (= -1 (cdr item)) '(" .") '()))
1815            (iter (1+ rx)
1816                  (append
1817                   sl (if (= rx (cdr item)) '(" .") '())
1818                   (let ((e (vector-ref rhs rx)))
1819                     (list (string-append " " (elt->str e tl)))))))))))
1820
1821 ;; @deffn pp-lalr-notice spec [port]
1822 (define (pp-lalr-notice spec . rest)
1823   (let* ((port (if (pair? rest) (car rest) (current-output-port)))
1824          (notice (assq-ref (assq-ref spec 'attr) 'notice))
1825          (lines (if notice (string-split notice #\newline) '())))
1826     (for-each (lambda (l) (simple-format port "  ~A\n" l)) lines)
1827     (newline)))
1828
1829 ;; @deffn pp-lalr-grammar spec [port]
1830 ;; Pretty-print the grammar to the specified port, or current output.
1831 (define (pp-lalr-grammar spec . rest)
1832   (let* ((port (if (pair? rest) (car rest) (current-output-port)))
1833          (lhs-v (assq-ref spec 'lhs-v))
1834          (rhs-v (assq-ref spec 'rhs-v))
1835          (nrule (vector-length lhs-v))
1836          (act-v (assq-ref spec 'act-v))
1837          ;;(prp-v (assq-ref mach 'prp-v)) ; per-rule precedence
1838          (terms (assq-ref spec 'terminals))
1839          (prev-core (fluid-ref *lalr-core*)))
1840     (fluid-set! *lalr-core* (make-core spec)) ; OR dynamic-wind ???
1841     ;; Print out the grammar.
1842     (do ((i 0 (1+ i))) ((= i nrule))
1843       (let* ((lhs (vector-ref lhs-v i)) (rhs (vector-ref rhs-v i)))
1844         (if #f
1845             (pp-rule 0 i)
1846             (begin
1847               (fmt port "~A ~A =>" i lhs)
1848               (vector-for-each
1849                (lambda (ix e) (fmt port " ~A" (elt->str e terms)))
1850                rhs)
1851               ;;(fmt port "\t~S" (vector-ref act-v i))
1852               (newline port)))))
1853     (newline port)
1854     (fluid-set! *lalr-core* prev-core)))
1855
1856 ;; @deffn pp-lalr-machine mach [port]
1857 ;; Print the states of the parser with items and shift/reduce actions.
1858 (define (pp-lalr-machine mach . rest)
1859   (let* ((port (if (pair? rest) (car rest) (current-output-port)))
1860          (lhs-v (assq-ref mach 'lhs-v))
1861          (rhs-v (assq-ref mach 'rhs-v))
1862          (nrule (vector-length lhs-v))
1863          (pat-v (assq-ref mach 'pat-v))
1864          (rat-v (assq-ref mach 'rat-v))
1865          (kis-v (assq-ref mach 'kis-v))
1866          (kit-v (assq-ref mach 'kit-v))
1867          (nst (vector-length kis-v))    ; number of states
1868          (i->s (or (and=> (assq-ref mach 'siis) cdr) '()))
1869          (terms (assq-ref mach 'terminals))
1870          (prev-core (fluid-ref *lalr-core*)))
1871     (fluid-set! *lalr-core* (make-core mach))
1872     ;; Print out the itemsets and shift reduce actions.
1873     (do ((i 0 (1+ i))) ((= i nst))
1874       (let* ((state (vector-ref kis-v i))
1875              (pat (vector-ref pat-v i))
1876              (rat (if rat-v (vector-ref rat-v i) '())))
1877         (fmt port "~A:" i)           ; itemset index (aka state index)
1878         (for-each
1879          (lambda (k-item)
1880            (for-each                    ; item, print it
1881             (lambda (item)
1882               (fmt port "\t~A" (pp-item item))
1883               ;; show lookaheads:
1884               (if (and #f (negative? (cdr item)) kit-v (equal? item k-item))
1885                   (fmt port " ~A"
1886                        (map (lambda (tok) (elt->str tok terms))
1887                             (assoc-ref (vector-ref kit-v i) k-item))))
1888               (fmt port "\n"))
1889             (expand-k-item k-item)))
1890          state)
1891         (for-each                       ; action, print it
1892          (lambda (act)
1893            (if (pair? (cdr act))
1894                (let ((sy (car act)) (pa (cadr act)) (gt (cddr act)))
1895                  (case pa
1896                    ((srconf)
1897                     (fmt port "\t\t~A => CONFLICT: shift ~A, reduce ~A\n"
1898                          (elt->str sy terms) (car gt) (cdr gt)))
1899                    ((rrconf)
1900                     (fmt port "\t\t~A => CONFLICT: reduce ~A\n"
1901                          (elt->str sy terms)
1902                          (string-join (map number->string gt) ", reduce ")))
1903                    (else
1904                     (fmt port "\t\t~A => ~A ~A\n" (elt->str sy terms) pa gt))))
1905                (let* ((sy (car act)) (p (cdr act))
1906                       (pa (cond ((eq? #f p) 'CONFLICT)
1907                                 ((positive? p) 'shift)
1908                                 ((negative? p) 'reduce)
1909                                 (else 'accept)))
1910                       (gt (and=> p abs)))
1911                  (fmt port "\t\t~A => ~A ~A\n"
1912                       (elt->str (assq-ref i->s sy) terms)
1913                       pa gt))))
1914          pat)
1915         (for-each                       ; action, print it
1916          (lambda (ra)
1917            ;; FIX: should indicate if precedence removed user rule or default
1918            (fmt port "\t\t[~A => ~A ~A] REMOVED by ~A\n"
1919                 (elt->str (caar ra) terms) (cadar ra) (cddar ra)
1920                 (case (cdr ra)
1921                   ((pre) "precedence")
1922                   ((ass) "associativity")
1923                   ((def) "default shift")
1924                   (else (cdr ra)))))
1925          rat)
1926         (newline)))
1927     (fluid-set! *lalr-core* prev-core)
1928     (values)))
1929
1930 ;; === output routines ===============
1931
1932 (use-modules (ice-9 pretty-print))
1933 (use-modules (ice-9 regex))
1934
1935 (define (write-notice mach port)
1936   (let* ((comm-leader ";; ")
1937          (notice (assq-ref (assq-ref mach 'attr) 'notice))
1938          (lines (if notice (string-split notice #\newline) '())))
1939     (for-each
1940      (lambda (l) (fmt port "~A~A\n" comm-leader l))
1941      lines)
1942     (if (pair? lines) (newline port))))
1943
1944 (define (string-sub str pat repl)
1945   (let ((m (string-match pat str)))
1946     (if m
1947         (regexp-substitute #f m 'pre repl 'post)
1948         str)))
1949
1950 ;; @deffn write-lalr-tables mach filename [#:lang output-lang]
1951 ;; For example,
1952 ;; @example
1953 ;; write-lalr-tables mach "tables.scm"
1954 ;; write-lalr-tables mach "tables.tcl" #:lang 'tcl
1955 ;; @end example
1956 (define* (write-lalr-tables mach filename #:key (lang 'scheme))
1957
1958   (define (write-table mach name port)
1959     (fmt port "(define ~A\n  " name)
1960     (ugly-print (assq-ref mach name) port)
1961     (fmt port ")\n\n"))
1962
1963   (call-with-output-file filename
1964     (lambda (port)
1965       (fmt port ";; ~A\n\n" (string-sub filename ".new$" ""))
1966       (write-notice mach port)
1967       (write-table mach 'len-v port)
1968       (write-table mach 'pat-v port)
1969       (write-table mach 'rto-v port)
1970       (write-table mach 'mtab port)
1971       (display ";;; end tables" port)
1972       (newline port))))
1973
1974
1975 ;; @deffn write-lalr-actions mach filename [#:lang output-lang]
1976 ;; For example,
1977 ;; @example
1978 ;; write-lalr-actions mach "actions.scm"
1979 ;; write-lalr-actions mach "actions.tcl" #:lang 'tcl
1980 ;; @end example
1981 (define* (write-lalr-actions mach filename #:key (lang 'scheme))
1982
1983   (define (pp-rule/ts gx)
1984     (let* ((core (fluid-ref *lalr-core*))
1985            (lhs (vector-ref (core-lhs-v core) gx))
1986            (rhs (vector-ref (core-rhs-v core) gx))
1987            (tl (core-terminals core))
1988            (line (string-append
1989                   (symbol->string lhs) " => "
1990                   (string-join 
1991                    (map (lambda (elt) (elt->str elt tl))
1992                         (vector->list rhs))
1993                    " "))))
1994       (if (> (string-length line) 72)
1995           (string-append (substring/shared line 0 69) "...")
1996           line)))
1997   (define (NEW-pp-rule/ts gx)
1998     ;; TBD: use start for zeroth rule
1999     (let* ((core (fluid-ref *lalr-core*))
2000            (lhs (vector-ref (core-lhs-v core) gx))
2001            (rhs (vector-ref (core-rhs-v core) gx))
2002            (tl (core-terminals core))
2003            (line (string-append
2004                   (symbol->string lhs) " => "
2005                   (string-join 
2006                    (map (lambda (elt) (elt->str elt tl))
2007                         (vector->list rhs))
2008                    " "))))
2009       (if (> (string-length line) 72)
2010           (string-append (substring/shared line 0 69) "...")
2011           line)))
2012     
2013   (define (write-actions mach port)
2014     (with-fluid*
2015      *lalr-core* (make-core mach)
2016      (lambda ()
2017        (fmt port "(define act-v\n  (vector\n")
2018        (vector-for-each
2019         (lambda (gx actn)
2020           (fmt port "   ;; ~A\n" (pp-rule/ts gx))
2021           (pretty-print (wrap-action actn) port #:per-line-prefix "   "))
2022         (assq-ref mach 'act-v))
2023        (fmt port "   ))\n\n"))))
2024
2025   (call-with-output-file filename
2026     (lambda (port)
2027       (fmt port ";; ~A\n\n" (string-sub filename ".new$" ""))
2028       (write-notice mach port)
2029       (write-actions mach port)
2030       (display ";;; end tables" port)
2031       (newline port))))
2032
2033 ;; @end itemize
2034 ;;; --- last line ---