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