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