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