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