a73501a894f79210c0deaafc249f69cff8a89125
[mes.git] / module / mes / lalr.mes
1 ;;;
2 ;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
3 ;;;
4 ;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
5 ;; Copyright 1993, 2010 Dominique Boucher
6 ;;
7 ;; This program is free software: you can redistribute it and/or
8 ;; modify it under the terms of the GNU Lesser General Public License
9 ;; as published by the Free Software Foundation, either version 3 of
10 ;; the License, or (at your option) any later version.
11 ;;
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 ;; GNU Lesser General Public License for more details.
16 ;;
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20
21 (define *lalr-scm-version* "2.5.0")
22
23 (cond-expand 
24
25  ;; -- Gambit-C
26  (gambit
27
28    (display "Gambit-C!")
29    (newline)
30    
31   (define-macro (def-macro form . body)
32     `(define-macro ,form (let () ,@body)))
33
34   (def-macro (BITS-PER-WORD) 28)
35   (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
36   (def-macro (lalr-error msg obj) `(error ,msg ,obj))
37
38   (define pprint pretty-print)
39   (define lalr-keyword? keyword?)
40   (define (note-source-location lvalue tok) lvalue))
41  
42  ;; -- 
43  (bigloo
44   (define-macro (def-macro form . body)
45     `(define-macro ,form (let () ,@body)))
46
47   (define pprint (lambda (obj) (write obj) (newline)))
48   (define lalr-keyword? keyword?)
49   (def-macro (BITS-PER-WORD) 29)
50   (def-macro (logical-or x . y) `(bit-or ,x ,@y))
51   (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
52   (define (note-source-location lvalue tok) lvalue))
53  
54  ;; -- Chicken
55  (chicken
56   
57   (define-macro (def-macro form . body)
58     `(define-macro ,form (let () ,@body)))
59
60   (define pprint pretty-print)
61   (define lalr-keyword? symbol?)
62   (def-macro (BITS-PER-WORD) 30)
63   (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
64   (def-macro (lalr-error msg obj) `(error ,msg ,obj))
65   (define (note-source-location lvalue tok) lvalue))
66
67  ;; -- STKlos
68  (stklos
69   (require "pp")
70
71   (define (pprint form) (pp form :port (current-output-port)))
72
73   (define lalr-keyword? keyword?)
74   (define-macro (BITS-PER-WORD) 30)
75   (define-macro (logical-or x . y) `(bit-or ,x ,@y))
76   (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
77   (define (note-source-location lvalue tok) lvalue))
78
79  ;; -- Guile
80  (guile
81   (use-modules (ice-9 pretty-print))
82   (use-modules (srfi srfi-9))
83
84   (define pprint pretty-print)
85   (define lalr-keyword? symbol?)
86   (define-macro (BITS-PER-WORD) 30)
87   (define-macro (logical-or x . y) `(logior ,x ,@y))
88   (define-macro (lalr-error msg obj) `(error ,msg ,obj))
89   (define (note-source-location lvalue tok)
90     (if (and (supports-source-properties? lvalue)
91              (not (source-property lvalue 'loc))
92              (lexical-token? tok))
93         (set-source-property! lvalue 'loc (lexical-token-source tok)))
94     lvalue))
95
96  ;; -- Mes
97   (mes
98    (define pprint display)
99    (define lalr-keyword? symbol?)
100    (define-macro (BITS-PER-WORD) 30)
101    (define-macro (logical-or x . y) `(logior ,x ,@y))
102    (define-macro (lalr-error msg obj) `(error ,msg ,obj))
103    (define (note-source-location lvalue tok) lvalue)
104    )
105   
106  ;; -- Kawa
107  (kawa
108   (require 'pretty-print)
109   (define (BITS-PER-WORD) 30)
110   (define logical-or logior)
111   (define (lalr-keyword? obj) (keyword? obj))
112   (define (pprint obj) (pretty-print obj))
113   (define (lalr-error msg obj) (error msg obj))
114   (define (note-source-location lvalue tok) lvalue))
115
116  ;; -- SISC
117  (sisc
118   (import logicops)
119   (import record)
120         
121   (define pprint pretty-print)
122   (define lalr-keyword? symbol?)
123   (define-macro BITS-PER-WORD (lambda () 32))
124   (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
125   (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
126   (define (note-source-location lvalue tok) lvalue))
127        
128  ;; -- Gauche
129  (gauche
130   (use gauche.record)
131   (define-macro (def-macro form . body)
132     `(define-macro ,form (let () ,@body)))
133   (define pprint (lambda (obj) (write obj) (newline)))
134   (define lalr-keyword? symbol?)
135   (def-macro (BITS-PER-WORD) 30)
136   (def-macro (logical-or x . y) `(logior ,x . ,y))
137   (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
138   (define (note-source-location lvalue tok) lvalue))
139
140  (else
141   (error "Unsupported Scheme system")))
142
143
144 (define-record-type lexical-token
145   (make-lexical-token category source value)
146   lexical-token?
147   (category lexical-token-category)
148   (source   lexical-token-source)
149   (value    lexical-token-value))
150
151
152 (define-record-type source-location
153   (make-source-location input line column offset length)
154   source-location?
155   (input   source-location-input)
156   (line    source-location-line)
157   (column  source-location-column)
158   (offset  source-location-offset)
159   (length  source-location-length))
160
161
162
163       ;; - Macros pour la gestion des vecteurs de bits
164
165 (define-macro (lalr-parser . arguments)
166   (define (set-bit v b)
167     (let ((x (quotient b (BITS-PER-WORD)))
168           (y (expt 2 (remainder b (BITS-PER-WORD)))))
169       (vector-set! v x (logical-or (vector-ref v x) y))))
170
171   (define (bit-union v1 v2 n)
172     (do ((i 0 (+ i 1)))
173         ((= i n))
174       (vector-set! v1 i (logical-or (vector-ref v1 i)
175                                     (vector-ref v2 i)))))
176
177   ;; - Macro pour les structures de donnees
178
179   (define (new-core)              (make-vector 4 0))
180   (define (set-core-number! c n)  (vector-set! c 0 n))
181   (define (set-core-acc-sym! c s) (vector-set! c 1 s))
182   (define (set-core-nitems! c n)  (vector-set! c 2 n))
183   (define (set-core-items! c i)   (vector-set! c 3 i))
184   (define (core-number c)         (vector-ref c 0))
185   (define (core-acc-sym c)        (vector-ref c 1))
186   (define (core-nitems c)         (vector-ref c 2))
187   (define (core-items c)          (vector-ref c 3))
188
189   (define (new-shift)              (make-vector 3 0))
190   (define (set-shift-number! c x)  (vector-set! c 0 x))
191   (define (set-shift-nshifts! c x) (vector-set! c 1 x))
192   (define (set-shift-shifts! c x)  (vector-set! c 2 x))
193   (define (shift-number s)         (vector-ref s 0))
194   (define (shift-nshifts s)        (vector-ref s 1))
195   (define (shift-shifts s)         (vector-ref s 2))
196
197   (define (new-red)                (make-vector 3 0))
198   (define (set-red-number! c x)    (vector-set! c 0 x))
199   (define (set-red-nreds! c x)     (vector-set! c 1 x))
200   (define (set-red-rules! c x)     (vector-set! c 2 x))
201   (define (red-number c)           (vector-ref c 0))
202   (define (red-nreds c)            (vector-ref c 1))
203   (define (red-rules c)            (vector-ref c 2))
204
205
206   (define (new-set nelem)
207     (make-vector nelem 0))
208
209
210   (define (vector-map f v)
211     (let ((vm-n (- (vector-length v) 1)))
212       (let loop ((vm-low 0) (vm-high vm-n))
213         (if (= vm-low vm-high)
214             (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
215             (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
216               (loop vm-low vm-middle)
217               (loop (+ vm-middle 1) vm-high))))))
218
219
220   ;; - Constantes
221   (define STATE-TABLE-SIZE 1009)
222
223
224   ;; - Tableaux 
225   (define rrhs         #f)
226   (define rlhs         #f)
227   (define ritem        #f)
228   (define nullable     #f)
229   (define derives      #f)
230   (define fderives     #f)
231   (define firsts       #f)
232   (define kernel-base  #f)
233   (define kernel-end   #f)
234   (define shift-symbol #f)
235   (define shift-set    #f)
236   (define red-set      #f)
237   (define state-table  #f)
238   (define acces-symbol #f)
239   (define reduction-table #f)
240   (define shift-table  #f)
241   (define consistent   #f)
242   (define lookaheads   #f)
243   (define LA           #f)
244   (define LAruleno     #f)
245   (define lookback     #f)
246   (define goto-map     #f)
247   (define from-state   #f)
248   (define to-state     #f)
249   (define includes     #f)
250   (define F            #f)
251   (define action-table #f)
252
253   ;; - Variables
254   (define nitems          #f)
255   (define nrules          #f)
256   (define nvars           #f)
257   (define nterms          #f)
258   (define nsyms           #f)
259   (define nstates         #f)
260   (define first-state     #f)
261   (define last-state      #f)
262   (define final-state     #f)
263   (define first-shift     #f)
264   (define last-shift      #f)
265   (define first-reduction #f)
266   (define last-reduction  #f)
267   (define nshifts         #f)
268   (define maxrhs          #f)
269   (define ngotos          #f)
270   (define token-set-size  #f)
271
272   (define driver-name     'lr-driver)
273
274   (define (glr-driver?)
275     (eq? driver-name 'glr-driver))
276   (define (lr-driver?)
277     (eq? driver-name 'lr-driver))
278
279   (define (gen-tables! tokens gram )
280     (initialize-all)
281     (rewrite-grammar
282      tokens
283      gram
284      (lambda (terms terms/prec vars gram gram/actions)
285        (set! the-terminals/prec (list->vector terms/prec))
286        (set! the-terminals (list->vector terms))
287        (set! the-nonterminals (list->vector vars))
288        (set! nterms (length terms))
289        (set! nvars  (length vars))
290        (set! nsyms  (+ nterms nvars))
291        (let ((no-of-rules (length gram/actions))
292              (no-of-items (let loop ((l gram/actions) (count 0))
293                             (if (null? l)
294                                 count
295                                 (loop (cdr l) (+ count (length (caar l))))))))
296          (pack-grammar no-of-rules no-of-items gram)
297          (set-derives)
298          (set-nullable)
299          (generate-states)
300          (lalr)
301          (build-tables)
302          (compact-action-table terms)
303          gram/actions))))
304
305
306   (define (initialize-all)
307     (set! rrhs         #f)
308     (set! rlhs         #f)
309     (set! ritem        #f)
310     (set! nullable     #f)
311     (set! derives      #f)
312     (set! fderives     #f)
313     (set! firsts       #f)
314     (set! kernel-base  #f)
315     (set! kernel-end   #f)
316     (set! shift-symbol #f)
317     (set! shift-set    #f)
318     (set! red-set      #f)
319     (set! state-table  (make-vector STATE-TABLE-SIZE '()))
320     (set! acces-symbol #f)
321     (set! reduction-table #f)
322     (set! shift-table  #f)
323     (set! consistent   #f)
324     (set! lookaheads   #f)
325     (set! LA           #f)
326     (set! LAruleno     #f)
327     (set! lookback     #f)
328     (set! goto-map     #f)
329     (set! from-state   #f)
330     (set! to-state     #f)
331     (set! includes     #f)
332     (set! F            #f)
333     (set! action-table #f)
334     (set! nstates         #f)
335     (set! first-state     #f)
336     (set! last-state      #f)
337     (set! final-state     #f)
338     (set! first-shift     #f)
339     (set! last-shift      #f)
340     (set! first-reduction #f)
341     (set! last-reduction  #f)
342     (set! nshifts         #f)
343     (set! maxrhs          #f)
344     (set! ngotos          #f)
345     (set! token-set-size  #f)
346     (set! rule-precedences '()))
347
348
349   (define (pack-grammar no-of-rules no-of-items gram)
350     (set! nrules (+  no-of-rules 1))
351     (set! nitems no-of-items)
352     (set! rlhs (make-vector nrules #f))
353     (set! rrhs (make-vector nrules #f))
354     (set! ritem (make-vector (+ 1 nitems) #f))
355
356     (let loop ((p gram) (item-no 0) (rule-no 1))
357       (if (not (null? p))
358           (let ((nt (caar p)))
359             (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
360               (if (null? prods)
361                   (loop (cdr p) it-no2 rl-no2)
362                   (begin
363                     (vector-set! rlhs rl-no2 nt)
364                     (vector-set! rrhs rl-no2 it-no2)
365                     (let loop3 ((rhs (car prods)) (it-no3 it-no2))
366                       (if (null? rhs)
367                           (begin
368                             (vector-set! ritem it-no3 (- rl-no2))
369                             (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
370                           (begin
371                             (vector-set! ritem it-no3 (car rhs))
372                             (loop3 (cdr rhs) (+ it-no3 1))))))))))))
373
374
375   (define (set-derives)
376     (define delts (make-vector (+ nrules 1) 0))
377     (define dset  (make-vector nvars -1))
378
379     (let loop ((i 1) (j 0))             ; i = 0
380       (if (< i nrules)
381           (let ((lhs (vector-ref rlhs i)))
382             (if (>= lhs 0)
383                 (begin
384                   (vector-set! delts j (cons i (vector-ref dset lhs)))
385                   (vector-set! dset lhs j)
386                   (loop (+ i 1) (+ j 1)))
387                 (loop (+ i 1) j)))))
388
389     (set! derives (make-vector nvars 0))
390
391     (let loop ((i 0))
392       (if (< i nvars)
393           (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
394                      (if (< j 0)
395                          s
396                          (let ((x (vector-ref delts j)))
397                            (loop2 (cdr x) (cons (car x) s)))))))
398             (vector-set! derives i q)
399             (loop (+ i 1))))))
400
401
402
403   (define (set-nullable)
404     (set! nullable (make-vector nvars #f))
405     (let ((squeue (make-vector nvars #f))
406           (rcount (make-vector (+ nrules 1) 0))
407           (rsets  (make-vector nvars #f))
408           (relts  (make-vector (+ nitems nvars 1) #f)))
409       (let loop ((r 0) (s2 0) (p 0))
410         (let ((*r (vector-ref ritem r)))
411           (if *r
412               (if (< *r 0)
413                   (let ((symbol (vector-ref rlhs (- *r))))
414                     (if (and (>= symbol 0)
415                              (not (vector-ref nullable symbol)))
416                         (begin
417                           (vector-set! nullable symbol #t)
418                           (vector-set! squeue s2 symbol)
419                           (loop (+ r 1) (+ s2 1) p))))
420                   (let loop2 ((r1 r) (any-tokens #f))
421                     (let* ((symbol (vector-ref ritem r1)))
422                       (if (> symbol 0)
423                           (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
424                           (if (not any-tokens)
425                               (let ((ruleno (- symbol)))
426                                 (let loop3 ((r2 r) (p2 p))
427                                   (let ((symbol (vector-ref ritem r2)))
428                                     (if (> symbol 0)
429                                         (begin
430                                           (vector-set! rcount ruleno
431                                                        (+ (vector-ref rcount ruleno) 1))
432                                           (vector-set! relts p2
433                                                        (cons (vector-ref rsets symbol)
434                                                              ruleno))
435                                           (vector-set! rsets symbol p2)
436                                           (loop3 (+ r2 1) (+ p2 1)))
437                                         (loop (+ r2 1) s2 p2)))))
438                               (loop (+ r1 1) s2 p))))))
439               (let loop ((s1 0) (s3 s2))
440                 (if (< s1 s3)
441                     (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
442                       (if p
443                           (let* ((x (vector-ref relts p))
444                                  (ruleno (cdr x))
445                                  (y (- (vector-ref rcount ruleno) 1)))
446                             (vector-set! rcount ruleno y)
447                             (if (= y 0)
448                                 (let ((symbol (vector-ref rlhs ruleno)))
449                                   (if (and (>= symbol 0)
450                                            (not (vector-ref nullable symbol)))
451                                       (begin
452                                         (vector-set! nullable symbol #t)
453                                         (vector-set! squeue s4 symbol)
454                                         (loop2 (car x) (+ s4 1)))
455                                       (loop2 (car x) s4)))
456                                 (loop2 (car x) s4))))
457                       (loop (+ s1 1) s4)))))))))
458
459
460
461   (define (set-firsts)
462     (set! firsts (make-vector nvars '()))
463
464     ;; -- initialization
465     (let loop ((i 0))
466       (if (< i nvars)
467           (let loop2 ((sp (vector-ref derives i)))
468             (if (null? sp)
469                 (loop (+ i 1))
470                 (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
471                   (if (< -1 sym nvars)
472                       (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
473                   (loop2 (cdr sp)))))))
474
475     ;; -- reflexive and transitive closure
476     (let loop ((continue #t))
477       (if continue
478           (let loop2 ((i 0) (cont #f))
479             (if (>= i nvars)
480                 (loop cont)
481                 (let* ((x (vector-ref firsts i))
482                        (y (let loop3 ((l x) (z x))
483                             (if (null? l)
484                                 z
485                                 (loop3 (cdr l)
486                                        (sunion (vector-ref firsts (car l)) z))))))
487                   (if (equal? x y)
488                       (loop2 (+ i 1) cont)
489                       (begin
490                         (vector-set! firsts i y)
491                         (loop2 (+ i 1) #t))))))))
492
493     (let loop ((i 0))
494       (if (< i nvars)
495           (begin
496             (vector-set! firsts i (sinsert i (vector-ref firsts i)))
497             (loop (+ i 1))))))
498
499
500
501
502   (define (set-fderives)
503     (set! fderives (make-vector nvars #f))
504
505     (set-firsts)
506
507     (let loop ((i 0))
508       (if (< i nvars)
509           (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
510                      (if (null? l)
511                          fd
512                          (loop2 (cdr l)
513                                 (sunion (vector-ref derives (car l)) fd))))))
514             (vector-set! fderives i x)
515             (loop (+ i 1))))))
516
517
518   (define (closure core)
519     ;; Initialization
520     (define ruleset (make-vector nrules #f))
521
522     (let loop ((csp core))
523       (if (not (null? csp))
524           (let ((sym (vector-ref ritem (car csp))))
525             (if (< -1 sym nvars)
526                 (let loop2 ((dsp (vector-ref fderives sym)))
527                   (if (not (null? dsp))
528                       (begin
529                         (vector-set! ruleset (car dsp) #t)
530                         (loop2 (cdr dsp))))))
531             (loop (cdr csp)))))
532
533     (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
534       (if (< ruleno nrules)
535           (if (vector-ref ruleset ruleno)
536               (let ((itemno (vector-ref rrhs ruleno)))
537                 (let loop2 ((c csp) (itemsetv2 itemsetv))
538                   (if (and (pair? c)
539                            (< (car c) itemno))
540                       (loop2 (cdr c) (cons (car c) itemsetv2))
541                       (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
542               (loop (+ ruleno 1) csp itemsetv))
543           (let loop2 ((c csp) (itemsetv2 itemsetv))
544             (if (pair? c)
545                 (loop2 (cdr c) (cons (car c) itemsetv2))
546                 (reverse itemsetv2))))))
547
548
549
550   (define (allocate-item-sets)
551     (set! kernel-base (make-vector nsyms 0))
552     (set! kernel-end  (make-vector nsyms #f)))
553
554
555   (define (allocate-storage)
556     (allocate-item-sets)
557     (set! red-set (make-vector (+ nrules 1) 0)))
558
559                                         ; --
560
561
562   (define (initialize-states)
563     (let ((p (new-core)))
564       (set-core-number! p 0)
565       (set-core-acc-sym! p #f)
566       (set-core-nitems! p 1)
567       (set-core-items! p '(0))
568
569       (set! first-state (list p))
570       (set! last-state first-state)
571       (set! nstates 1)))
572
573
574
575   (define (generate-states)
576     (allocate-storage)
577     (set-fderives)
578     (initialize-states)
579     (let loop ((this-state first-state))
580       (if (pair? this-state)
581           (let* ((x (car this-state))
582                  (is (closure (core-items x))))
583             (save-reductions x is)
584             (new-itemsets is)
585             (append-states)
586             (if (> nshifts 0)
587                 (save-shifts x))
588             (loop (cdr this-state))))))
589
590
591   (define (new-itemsets itemset)
592     ;; - Initialization
593     (set! shift-symbol '())
594     (let loop ((i 0))
595       (if (< i nsyms)
596           (begin
597             (vector-set! kernel-end i '())
598             (loop (+ i 1)))))
599
600     (let loop ((isp itemset))
601       (if (pair? isp)
602           (let* ((i (car isp))
603                  (sym (vector-ref ritem i)))
604             (if (>= sym 0)
605                 (begin
606                   (set! shift-symbol (sinsert sym shift-symbol))
607                   (let ((x (vector-ref kernel-end sym)))
608                     (if (null? x)
609                         (begin
610                           (vector-set! kernel-base sym (cons (+ i 1) x))
611                           (vector-set! kernel-end sym (vector-ref kernel-base sym)))
612                         (begin
613                           (set-cdr! x (list (+ i 1)))
614                           (vector-set! kernel-end sym (cdr x)))))))
615             (loop (cdr isp)))))
616
617     (set! nshifts (length shift-symbol)))
618
619
620
621   (define (get-state sym)
622     (let* ((isp  (vector-ref kernel-base sym))
623            (n    (length isp))
624            (key  (let loop ((isp1 isp) (k 0))
625                    (if (null? isp1)
626                        (modulo k STATE-TABLE-SIZE)
627                        (loop (cdr isp1) (+ k (car isp1))))))
628            (sp   (vector-ref state-table key)))
629       (if (null? sp)
630           (let ((x (new-state sym)))
631             (vector-set! state-table key (list x))
632             (core-number x))
633           (let loop ((sp1 sp))
634             (if (and (= n (core-nitems (car sp1)))
635                      (let loop2 ((i1 isp) (t (core-items (car sp1))))
636                        (if (and (pair? i1)
637                                 (= (car i1)
638                                    (car t)))
639                            (loop2 (cdr i1) (cdr t))
640                            (null? i1))))
641                 (core-number (car sp1))
642                 (if (null? (cdr sp1))
643                     (let ((x (new-state sym)))
644                       (set-cdr! sp1 (list x))
645                       (core-number x))
646                     (loop (cdr sp1))))))))
647
648
649   (define (new-state sym)
650     (let* ((isp  (vector-ref kernel-base sym))
651            (n    (length isp))
652            (p    (new-core)))
653       (set-core-number! p nstates)
654       (set-core-acc-sym! p sym)
655       (if (= sym nvars) (set! final-state nstates))
656       (set-core-nitems! p n)
657       (set-core-items! p isp)
658       (set-cdr! last-state (list p))
659       (set! last-state (cdr last-state))
660       (set! nstates (+ nstates 1))
661       p))
662
663
664                                         ; --
665
666   (define (append-states)
667     (set! shift-set
668           (let loop ((l (reverse shift-symbol)))
669             (if (null? l)
670                 '()
671                 (cons (get-state (car l)) (loop (cdr l)))))))
672
673                                         ; --
674
675   (define (save-shifts core)
676     (let ((p (new-shift)))
677       (set-shift-number! p (core-number core))
678       (set-shift-nshifts! p nshifts)
679       (set-shift-shifts! p shift-set)
680       (if last-shift
681           (begin
682             (set-cdr! last-shift (list p))
683             (set! last-shift (cdr last-shift)))
684           (begin
685             (set! first-shift (list p))
686             (set! last-shift first-shift)))))
687
688   (define (save-reductions core itemset)
689     (let ((rs (let loop ((l itemset))
690                 (if (null? l)
691                     '()
692                     (let ((item (vector-ref ritem (car l))))
693                       (if (< item 0)
694                           (cons (- item) (loop (cdr l)))
695                           (loop (cdr l))))))))
696       (if (pair? rs)
697           (let ((p (new-red)))
698             (set-red-number! p (core-number core))
699             (set-red-nreds!  p (length rs))
700             (set-red-rules!  p rs)
701             (if last-reduction
702                 (begin
703                   (set-cdr! last-reduction (list p))
704                   (set! last-reduction (cdr last-reduction)))
705                 (begin
706                   (set! first-reduction (list p))
707                   (set! last-reduction first-reduction)))))))
708
709
710                                         ; --
711
712   (define (lalr)
713     (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
714     (set-accessing-symbol)
715     (set-shift-table)
716     (set-reduction-table)
717     (set-max-rhs)
718     (initialize-LA)
719     (set-goto-map)
720     (initialize-F)
721     (build-relations)
722     (digraph includes)
723     (compute-lookaheads))
724
725   (define (set-accessing-symbol)
726     (set! acces-symbol (make-vector nstates #f))
727     (let loop ((l first-state))
728       (if (pair? l)
729           (let ((x (car l)))
730             (vector-set! acces-symbol (core-number x) (core-acc-sym x))
731             (loop (cdr l))))))
732
733   (define (set-shift-table)
734     (set! shift-table (make-vector nstates #f))
735     (let loop ((l first-shift))
736       (if (pair? l)
737           (let ((x (car l)))
738             (vector-set! shift-table (shift-number x) x)
739             (loop (cdr l))))))
740
741   (define (set-reduction-table)
742     (set! reduction-table (make-vector nstates #f))
743     (let loop ((l first-reduction))
744       (if (pair? l)
745           (let ((x (car l)))
746             (vector-set! reduction-table (red-number x) x)
747             (loop (cdr l))))))
748
749   (define (set-max-rhs)
750     (let loop ((p 0) (curmax 0) (length 0))
751       (let ((x (vector-ref ritem p)))
752         (if x
753             (if (>= x 0)
754                 (loop (+ p 1) curmax (+ length 1))
755                 (loop (+ p 1) (max curmax length) 0))
756             (set! maxrhs curmax)))))
757
758   (define (initialize-LA)
759     (define (last l)
760       (if (null? (cdr l))
761           (car l)
762           (last (cdr l))))
763
764     (set! consistent (make-vector nstates #f))
765     (set! lookaheads (make-vector (+ nstates 1) #f))
766
767     (let loop ((count 0) (i 0))
768       (if (< i nstates)
769           (begin
770             (vector-set! lookaheads i count)
771             (let ((rp (vector-ref reduction-table i))
772                   (sp (vector-ref shift-table i)))
773               (if (and rp
774                        (or (> (red-nreds rp) 1)
775                            (and sp
776                                 (not
777                                  (< (vector-ref acces-symbol
778                                                 (last (shift-shifts sp)))
779                                     nvars)))))
780                   (loop (+ count (red-nreds rp)) (+ i 1))
781                   (begin
782                     (vector-set! consistent i #t)
783                     (loop count (+ i 1))))))
784
785           (begin
786             (vector-set! lookaheads nstates count)
787             (let ((c (max count 1)))
788               (set! LA (make-vector c #f))
789               (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
790               (set! LAruleno (make-vector c -1))
791               (set! lookback (make-vector c #f)))
792             (let loop ((i 0) (np 0))
793               (if (< i nstates)
794                   (if (vector-ref consistent i)
795                       (loop (+ i 1) np)
796                       (let ((rp (vector-ref reduction-table i)))
797                         (if rp
798                             (let loop2 ((j (red-rules rp)) (np2 np))
799                               (if (null? j)
800                                   (loop (+ i 1) np2)
801                                   (begin
802                                     (vector-set! LAruleno np2 (car j))
803                                     (loop2 (cdr j) (+ np2 1)))))
804                             (loop (+ i 1) np))))))))))
805
806
807   (define (set-goto-map)
808     (set! goto-map (make-vector (+ nvars 1) 0))
809     (let ((temp-map (make-vector (+ nvars 1) 0)))
810       (let loop ((ng 0) (sp first-shift))
811         (if (pair? sp)
812             (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
813               (if (pair? i)
814                   (let ((symbol (vector-ref acces-symbol (car i))))
815                     (if (< symbol nvars)
816                         (begin
817                           (vector-set! goto-map symbol
818                                        (+ 1 (vector-ref goto-map symbol)))
819                           (loop2 (cdr i) (+ ng2 1)))
820                         (loop2 (cdr i) ng2)))
821                   (loop ng2 (cdr sp))))
822
823             (let loop ((k 0) (i 0))
824               (if (< i nvars)
825                   (begin
826                     (vector-set! temp-map i k)
827                     (loop (+ k (vector-ref goto-map i)) (+ i 1)))
828
829                   (begin
830                     (do ((i 0 (+ i 1)))
831                         ((>= i nvars))
832                       (vector-set! goto-map i (vector-ref temp-map i)))
833
834                     (set! ngotos ng)
835                     (vector-set! goto-map nvars ngotos)
836                     (vector-set! temp-map nvars ngotos)
837                     (set! from-state (make-vector ngotos #f))
838                     (set! to-state (make-vector ngotos #f))
839
840                     (do ((sp first-shift (cdr sp)))
841                         ((null? sp))
842                       (let* ((x (car sp))
843                              (state1 (shift-number x)))
844                         (do ((i (shift-shifts x) (cdr i)))
845                             ((null? i))
846                           (let* ((state2 (car i))
847                                  (symbol (vector-ref acces-symbol state2)))
848                             (if (< symbol nvars)
849                                 (let ((k (vector-ref temp-map symbol)))
850                                   (vector-set! temp-map symbol (+ k 1))
851                                   (vector-set! from-state k state1)
852                                   (vector-set! to-state k state2))))))))))))))
853
854
855   (define (map-goto state symbol)
856     (let loop ((low (vector-ref goto-map symbol))
857                (high (- (vector-ref goto-map (+ symbol 1)) 1)))
858       (if (> low high)
859           (begin
860             (display (list "Error in map-goto" state symbol)) (newline)
861             0)
862           (let* ((middle (quotient (+ low high) 2))
863                  (s (vector-ref from-state middle)))
864             (cond
865              ((= s state)
866               middle)
867              ((< s state)
868               (loop (+ middle 1) high))
869              (else
870               (loop low (- middle 1))))))))
871
872
873   (define (initialize-F)
874     (set! F (make-vector ngotos #f))
875     (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
876
877     (let ((reads (make-vector ngotos #f)))
878
879       (let loop ((i 0) (rowp 0))
880         (if (< i ngotos)
881             (let* ((rowf (vector-ref F rowp))
882                    (stateno (vector-ref to-state i))
883                    (sp (vector-ref shift-table stateno)))
884               (if sp
885                   (let loop2 ((j (shift-shifts sp)) (edges '()))
886                     (if (pair? j)
887                         (let ((symbol (vector-ref acces-symbol (car j))))
888                           (if (< symbol nvars)
889                               (if (vector-ref nullable symbol)
890                                   (loop2 (cdr j) (cons (map-goto stateno symbol)
891                                                        edges))
892                                   (loop2 (cdr j) edges))
893                               (begin
894                                 (set-bit rowf (- symbol nvars))
895                                 (loop2 (cdr j) edges))))
896                         (if (pair? edges)
897                             (vector-set! reads i (reverse edges))))))
898               (loop (+ i 1) (+ rowp 1)))))
899       (digraph reads)))
900
901   (define (add-lookback-edge stateno ruleno gotono)
902     (let ((k (vector-ref lookaheads (+ stateno 1))))
903       (let loop ((found #f) (i (vector-ref lookaheads stateno)))
904         (if (and (not found) (< i k))
905             (if (= (vector-ref LAruleno i) ruleno)
906                 (loop #t i)
907                 (loop found (+ i 1)))
908
909             (if (not found)
910                 (begin (display "Error in add-lookback-edge : ")
911                        (display (list stateno ruleno gotono)) (newline))
912                 (vector-set! lookback i
913                              (cons gotono (vector-ref lookback i))))))))
914
915
916   (define (transpose r-arg n)
917     (let ((new-end (make-vector n #f))
918           (new-R  (make-vector n #f)))
919       (do ((i 0 (+ i 1)))
920           ((= i n))
921         (let ((x (list 'bidon)))
922           (vector-set! new-R i x)
923           (vector-set! new-end i x)))
924       (do ((i 0 (+ i 1)))
925           ((= i n))
926         (let ((sp (vector-ref r-arg i)))
927           (if (pair? sp)
928               (let loop ((sp2 sp))
929                 (if (pair? sp2)
930                     (let* ((x (car sp2))
931                            (y (vector-ref new-end x)))
932                       (set-cdr! y (cons i (cdr y)))
933                       (vector-set! new-end x (cdr y))
934                       (loop (cdr sp2))))))))
935       (do ((i 0 (+ i 1)))
936           ((= i n))
937         (vector-set! new-R i (cdr (vector-ref new-R i))))
938
939       new-R))
940
941
942
943   (define (build-relations)
944
945     (define (get-state stateno symbol)
946       (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
947                  (stno stateno))
948         (if (null? j)
949             stno
950             (let ((st2 (car j)))
951               (if (= (vector-ref acces-symbol st2) symbol)
952                   st2
953                   (loop (cdr j) st2))))))
954
955     (set! includes (make-vector ngotos #f))
956     (do ((i 0 (+ i 1)))
957         ((= i ngotos))
958       (let ((state1 (vector-ref from-state i))
959             (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
960         (let loop ((rulep (vector-ref derives symbol1))
961                    (edges '()))
962           (if (pair? rulep)
963               (let ((*rulep (car rulep)))
964                 (let loop2 ((rp (vector-ref rrhs *rulep))
965                             (stateno state1)
966                             (states (list state1)))
967                   (let ((*rp (vector-ref ritem rp)))
968                     (if (> *rp 0)
969                         (let ((st (get-state stateno *rp)))
970                           (loop2 (+ rp 1) st (cons st states)))
971                         (begin
972
973                           (if (not (vector-ref consistent stateno))
974                               (add-lookback-edge stateno *rulep i))
975
976                           (let loop2 ((done #f)
977                                       (stp (cdr states))
978                                       (rp2 (- rp 1))
979                                       (edgp edges))
980                             (if (not done)
981                                 (let ((*rp (vector-ref ritem rp2)))
982                                   (if (< -1 *rp nvars)
983                                       (loop2 (not (vector-ref nullable *rp))
984                                              (cdr stp)
985                                              (- rp2 1)
986                                              (cons (map-goto (car stp) *rp) edgp))
987                                       (loop2 #t stp rp2 edgp)))
988
989                                 (loop (cdr rulep) edgp))))))))
990               (vector-set! includes i edges)))))
991     (set! includes (transpose includes ngotos)))
992
993
994
995   (define (compute-lookaheads)
996     (let ((n (vector-ref lookaheads nstates)))
997       (let loop ((i 0))
998         (if (< i n)
999             (let loop2 ((sp (vector-ref lookback i)))
1000               (if (pair? sp)
1001                   (let ((LA-i (vector-ref LA i))
1002                         (F-j  (vector-ref F (car sp))))
1003                     (bit-union LA-i F-j token-set-size)
1004                     (loop2 (cdr sp)))
1005                   (loop (+ i 1))))))))
1006
1007
1008
1009   (define (digraph relation)
1010     (define infinity (+ ngotos 2))
1011     (define INDEX (make-vector (+ ngotos 1) 0))
1012     (define VERTICES (make-vector (+ ngotos 1) 0))
1013     (define top 0)
1014     (define R relation)
1015
1016     (define (traverse i)
1017       (set! top (+ 1 top))
1018       (vector-set! VERTICES top i)
1019       (let ((height top))
1020         (vector-set! INDEX i height)
1021         (let ((rp (vector-ref R i)))
1022           (if (pair? rp)
1023               (let loop ((rp2 rp))
1024                 (if (pair? rp2)
1025                     (let ((j (car rp2)))
1026                       (if (= 0 (vector-ref INDEX j))
1027                           (traverse j))
1028                       (if (> (vector-ref INDEX i)
1029                              (vector-ref INDEX j))
1030                           (vector-set! INDEX i (vector-ref INDEX j)))
1031                       (let ((F-i (vector-ref F i))
1032                             (F-j (vector-ref F j)))
1033                         (bit-union F-i F-j token-set-size))
1034                       (loop (cdr rp2))))))
1035           (if (= (vector-ref INDEX i) height)
1036               (let loop ()
1037                 (let ((j (vector-ref VERTICES top)))
1038                   (set! top (- top 1))
1039                   (vector-set! INDEX j infinity)
1040                   (if (not (= i j))
1041                       (begin
1042                         (bit-union (vector-ref F i)
1043                                    (vector-ref F j)
1044                                    token-set-size)
1045                         (loop)))))))))
1046
1047     (let loop ((i 0))
1048       (if (< i ngotos)
1049           (begin
1050             (if (and (= 0 (vector-ref INDEX i))
1051                      (pair? (vector-ref R i)))
1052                 (traverse i))
1053             (loop (+ i 1))))))
1054
1055
1056   ;; ----------------------------------------------------------------------
1057   ;; operator precedence management
1058   ;; ----------------------------------------------------------------------
1059       
1060   ;; a vector of precedence descriptors where each element
1061   ;; is of the form (terminal type precedence)
1062   (define the-terminals/prec #f)   ; terminal symbols with precedence 
1063                                         ; the precedence is an integer >= 0
1064   (define (get-symbol-precedence sym)
1065     (caddr (vector-ref the-terminals/prec sym)))
1066                                         ; the operator type is either 'none, 'left, 'right, or 'nonassoc
1067   (define (get-symbol-assoc sym)
1068     (cadr (vector-ref the-terminals/prec sym)))
1069
1070   (define rule-precedences '())
1071   (define (add-rule-precedence! rule sym)
1072     (set! rule-precedences
1073           (cons (cons rule sym) rule-precedences)))
1074
1075   (define (get-rule-precedence ruleno)
1076     (cond
1077      ((assq ruleno rule-precedences)
1078       => (lambda (p)
1079            (get-symbol-precedence (cdr p))))
1080      (else
1081       ;; process the rule symbols from left to right
1082       (let loop ((i    (vector-ref rrhs ruleno))
1083                  (prec 0))
1084         (let ((item (vector-ref ritem i)))
1085           ;; end of rule
1086           (if (< item 0)
1087               prec
1088               (let ((i1 (+ i 1)))
1089                 (if (>= item nvars)
1090                     ;; it's a terminal symbol
1091                     (loop i1 (get-symbol-precedence (- item nvars)))
1092                     (loop i1 prec)))))))))
1093
1094   ;; ----------------------------------------------------------------------
1095   ;; Build the various tables
1096   ;; ----------------------------------------------------------------------
1097
1098   (define expected-conflicts 0)
1099
1100   (define (build-tables)
1101
1102     (define (resolve-conflict sym rule)
1103       (let ((sym-prec   (get-symbol-precedence sym))
1104             (sym-assoc  (get-symbol-assoc sym))
1105             (rule-prec  (get-rule-precedence rule)))
1106         (cond
1107          ((> sym-prec rule-prec)     'shift)
1108          ((< sym-prec rule-prec)     'reduce)
1109          ((eq? sym-assoc 'left)      'reduce)
1110          ((eq? sym-assoc 'right)     'shift)
1111          (else                       'none))))
1112
1113     (define conflict-messages '())
1114
1115     (define (add-conflict-message . l)
1116       (set! conflict-messages (cons l conflict-messages)))
1117
1118     (define (log-conflicts)
1119       (if (> (length conflict-messages) expected-conflicts)
1120           (for-each
1121            (lambda (message)
1122              (for-each display message)
1123              (newline))
1124            conflict-messages)))
1125
1126     ;; --- Add an action to the action table
1127     (define (add-action state symbol new-action)
1128       (let* ((state-actions (vector-ref action-table state))
1129              (actions       (assv symbol state-actions)))
1130         (if (pair? actions)
1131             (let ((current-action (cadr actions)))
1132               (if (not (= new-action current-action))
1133                   ;; -- there is a conflict 
1134                   (begin
1135                     (if (and (<= current-action 0) (<= new-action 0))
1136                         ;; --- reduce/reduce conflict
1137                         (begin
1138                           (add-conflict-message
1139                            "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) 
1140                            ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1141                           (if (glr-driver?)
1142                               (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1143                               (set-car! (cdr actions) (max current-action new-action))))
1144                         ;; --- shift/reduce conflict
1145                         ;; can we resolve the conflict using precedences?
1146                         (case (resolve-conflict symbol (- current-action))
1147                           ;; -- shift
1148                           ((shift)   (if (glr-driver?)
1149                                          (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1150                                          (set-car! (cdr actions) new-action)))
1151                           ;; -- reduce
1152                           ((reduce)  #f) ; well, nothing to do...
1153                           ;; -- signal a conflict!
1154                           (else      (add-conflict-message
1155                                       "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
1156                                       ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1157                                      (if (glr-driver?)
1158                                          (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1159                                          (set-car! (cdr actions) new-action))))))))
1160           
1161             (vector-set! action-table state (cons (list symbol new-action) state-actions)))
1162         ))
1163
1164     (define (add-action-for-all-terminals state action)
1165       (do ((i 1 (+ i 1)))
1166           ((= i nterms))
1167         (add-action state i action)))
1168
1169     (set! action-table (make-vector nstates '()))
1170
1171     (do ((i 0 (+ i 1)))                 ; i = state
1172         ((= i nstates))
1173       (let ((red (vector-ref reduction-table i)))
1174         (if (and red (>= (red-nreds red) 1))
1175             (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1176                 (if (glr-driver?)
1177                     (add-action-for-all-terminals i (- (car (red-rules red))))
1178                     (add-action i 'default (- (car (red-rules red)))))
1179                 (let ((k (vector-ref lookaheads (+ i 1))))
1180                   (let loop ((j (vector-ref lookaheads i)))
1181                     (if (< j k)
1182                         (let ((rule (- (vector-ref LAruleno j)))
1183                               (lav  (vector-ref LA j)))
1184                           (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1185                             (if (< token nterms)
1186                                 (begin
1187                                   (let ((in-la-set? (modulo x 2)))
1188                                     (if (= in-la-set? 1)
1189                                         (add-action i token rule)))
1190                                   (if (= y (BITS-PER-WORD))
1191                                       (loop2 (+ token 1)
1192                                              (vector-ref lav (+ z 1))
1193                                              1
1194                                              (+ z 1))
1195                                       (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1196                           (loop (+ j 1)))))))))
1197
1198       (let ((shiftp (vector-ref shift-table i)))
1199         (if shiftp
1200             (let loop ((k (shift-shifts shiftp)))
1201               (if (pair? k)
1202                   (let* ((state (car k))
1203                          (symbol (vector-ref acces-symbol state)))
1204                     (if (>= symbol nvars)
1205                         (add-action i (- symbol nvars) state))
1206                     (loop (cdr k))))))))
1207
1208     (add-action final-state 0 'accept)
1209     (log-conflicts))
1210
1211   (define (compact-action-table terms)
1212     (define (most-common-action acts)
1213       (let ((accums '()))
1214         (let loop ((l acts))
1215           (if (pair? l)
1216               (let* ((x (cadar l))
1217                      (y (assv x accums)))
1218                 (if (and (number? x) (< x 0))
1219                     (if y
1220                         (set-cdr! y (+ 1 (cdr y)))
1221                         (set! accums (cons `(,x . 1) accums))))
1222                 (loop (cdr l)))))
1223
1224         (let loop ((l accums) (max 0) (sym #f))
1225           (if (null? l)
1226               sym
1227               (let ((x (car l)))
1228                 (if (> (cdr x) max)
1229                     (loop (cdr l) (cdr x) (car x))
1230                     (loop (cdr l) max sym)))))))
1231
1232     (define (translate-terms acts)
1233       (map (lambda (act)
1234              (cons (list-ref terms (car act))
1235                    (cdr act)))
1236            acts))
1237
1238     (do ((i 0 (+ i 1)))
1239         ((= i nstates))
1240       (let ((acts (vector-ref action-table i)))
1241         (if (vector? (vector-ref reduction-table i))
1242             (let ((act (most-common-action acts)))
1243               (vector-set! action-table i
1244                            (cons `(*default* ,(if act act '*error*))
1245                                  (translate-terms
1246                                   (lalr-filter (lambda (x)
1247                                                  (not (and (= (length x) 2)
1248                                                            (eq? (cadr x) act))))
1249                                                acts)))))
1250             (vector-set! action-table i
1251                          (cons `(*default* *error*)
1252                                (translate-terms acts)))))))
1253
1254
1255
1256   ;; --
1257
1258   (define (rewrite-grammar tokens grammar k)
1259
1260     (define eoi '*eoi*)
1261
1262     (define (check-terminal term terms)
1263       (cond
1264        ((not (valid-terminal? term))
1265         (lalr-error "invalid terminal: " term))
1266        ((member term terms)
1267         (lalr-error "duplicate definition of terminal: " term))))
1268
1269     (define (prec->type prec)
1270       (cdr (assq prec '((left:     . left)
1271                         (right:    . right)
1272                         (nonassoc: . nonassoc)))))
1273
1274     (cond
1275      ;; --- a few error conditions
1276      ((not (list? tokens))
1277       (lalr-error "Invalid token list: " tokens))
1278      ((not (pair? grammar))
1279       (lalr-error "Grammar definition must have a non-empty list of productions" '()))
1280
1281      (else
1282       ;; --- check the terminals
1283       (let loop1 ((lst            tokens)
1284                   (rev-terms      '())
1285                   (rev-terms/prec '())
1286                   (prec-level     0))
1287         (if (pair? lst)
1288             (let ((term (car lst)))
1289               (cond
1290                ((pair? term)
1291                 (if (and (memq (car term) '(left: right: nonassoc:))
1292                          (not (null? (cdr term))))
1293                     (let ((prec    (+ prec-level 1))
1294                           (optype  (prec->type (car term))))
1295                       (let loop-toks ((l             (cdr term))
1296                                       (rev-terms      rev-terms)
1297                                       (rev-terms/prec rev-terms/prec))
1298                         (if (null? l)
1299                             (loop1 (cdr lst) rev-terms rev-terms/prec prec)
1300                             (let ((term (car l)))
1301                               (check-terminal term rev-terms)
1302                               (loop-toks
1303                                (cdr l)
1304                                (cons term rev-terms)
1305                                (cons (list term optype prec) rev-terms/prec))))))
1306
1307                     (lalr-error "invalid operator precedence specification: " term)))
1308
1309                (else
1310                 (check-terminal term rev-terms)
1311                 (loop1 (cdr lst)
1312                        (cons term rev-terms)
1313                        (cons (list term 'none 0) rev-terms/prec)
1314                        prec-level))))
1315
1316             ;; --- check the grammar rules
1317             (let loop2 ((lst grammar) (rev-nonterm-defs '()))
1318               (if (pair? lst)
1319                   (let ((def (car lst)))
1320                     (if (not (pair? def))
1321                         (lalr-error "Nonterminal definition must be a non-empty list" '())
1322                         (let ((nonterm (car def)))
1323                           (cond ((not (valid-nonterminal? nonterm))
1324                                  (lalr-error "Invalid nonterminal:" nonterm))
1325                                 ((or (member nonterm rev-terms)
1326                                      (assoc nonterm rev-nonterm-defs))
1327                                  (lalr-error "Nonterminal previously defined:" nonterm))
1328                                 (else
1329                                  (loop2 (cdr lst)
1330                                         (cons def rev-nonterm-defs)))))))
1331                   (let* ((terms        (cons eoi            (cons 'error          (reverse rev-terms))))
1332                          (terms/prec   (cons '(eoi none 0)  (cons '(error none 0) (reverse rev-terms/prec))))
1333                          (nonterm-defs (reverse rev-nonterm-defs))
1334                          (nonterms     (cons '*start* (map car nonterm-defs))))
1335                     (if (= (length nonterms) 1)
1336                         (lalr-error "Grammar must contain at least one nonterminal" '())
1337                         (let loop-defs ((defs      (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1338                                                          nonterm-defs))
1339                                         (ruleno    0)
1340                                         (comp-defs '()))
1341                           (if (pair? defs)
1342                               (let* ((nonterm-def  (car defs))
1343                                      (compiled-def (rewrite-nonterm-def
1344                                                     nonterm-def
1345                                                     ruleno
1346                                                     terms nonterms)))
1347                                 (loop-defs (cdr defs)
1348                                            (+ ruleno (length compiled-def))
1349                                            (cons compiled-def comp-defs)))
1350
1351                               (let ((compiled-nonterm-defs (reverse comp-defs)))
1352                                 (k terms
1353                                    terms/prec
1354                                    nonterms
1355                                    (map (lambda (x) (cons (caaar x) (map cdar x)))
1356                                         compiled-nonterm-defs)
1357                                    (apply append compiled-nonterm-defs))))))))))))))
1358
1359
1360   (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
1361
1362     (define No-NT (length nonterms))
1363
1364     (define (encode x)
1365       (let ((PosInNT (pos-in-list x nonterms)))
1366         (if PosInNT
1367             PosInNT
1368             (let ((PosInT (pos-in-list x terms)))
1369               (if PosInT
1370                   (+ No-NT PosInT)
1371                   (lalr-error "undefined symbol : " x))))))
1372
1373     (define (process-prec-directive rhs ruleno)
1374       (let loop ((l rhs))
1375         (if (null? l)
1376             '()
1377             (let ((first (car l))
1378                   (rest  (cdr l)))
1379               (cond
1380                ((or (member first terms) (member first nonterms))
1381                 (cons first (loop rest)))
1382                ((and (pair? first)
1383                      (eq? (car first) 'prec:))
1384                 (if (and (pair? (cdr first))
1385                          (null? (cddr first))
1386                          (member (cadr first) terms))
1387                     (if (null? rest)
1388                         (begin
1389                           (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
1390                           (loop rest))
1391                         (lalr-error "prec: directive should be at end of rule: " rhs))
1392                     (lalr-error "Invalid prec: directive: " first)))
1393                (else
1394                 (lalr-error "Invalid terminal or nonterminal: " first)))))))
1395
1396     (define (check-error-production rhs)
1397       (let loop ((rhs rhs))
1398         (if (pair? rhs)
1399             (begin
1400               (if (and (eq? (car rhs) 'error)
1401                        (or (null? (cdr rhs))
1402                            (not (member (cadr rhs) terms))
1403                            (not (null? (cddr rhs)))))
1404                   (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token.:" rhs))
1405               (loop (cdr rhs))))))
1406
1407
1408     (if (not (pair? (cdr nonterm-def)))
1409         (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
1410         (let ((name (symbol->string (car nonterm-def))))
1411           (let loop1 ((lst (cdr nonterm-def))
1412                       (i 1)
1413                       (rev-productions-and-actions '()))
1414             (if (not (pair? lst))
1415                 (reverse rev-productions-and-actions)
1416                 (let* ((rhs  (process-prec-directive (car lst) (+ ruleno i -1)))
1417                        (rest (cdr lst))
1418                        (prod (map encode (cons (car nonterm-def) rhs))))
1419                   ;; -- check for undefined tokens
1420                   (for-each (lambda (x)
1421                               (if (not (or (member x terms) (member x nonterms)))
1422                                   (lalr-error "Invalid terminal or nonterminal:" x)))
1423                             rhs)
1424                   ;; -- check 'error' productions
1425                   (check-error-production rhs)
1426
1427                   (if (and (pair? rest)
1428                            (eq? (car rest) ':)
1429                            (pair? (cdr rest)))
1430                       (loop1 (cddr rest)
1431                              (+ i 1)
1432                              (cons (cons prod (cadr rest))
1433                                    rev-productions-and-actions))
1434                       (let* ((rhs-length (length rhs))
1435                              (action
1436                               (cons 'vector
1437                                     (cons (list 'quote (string->symbol
1438                                                         (string-append
1439                                                          name
1440                                                          "-"
1441                                                          (number->string i))))
1442                                           (let loop-j ((j 1))
1443                                             (if (> j rhs-length)
1444                                                 '()
1445                                                 (cons (string->symbol
1446                                                        (string-append
1447                                                         "$"
1448                                                         (number->string j)))
1449                                                       (loop-j (+ j 1)))))))))
1450                         (loop1 rest
1451                                (+ i 1)
1452                                (cons (cons prod action)
1453                                      rev-productions-and-actions))))))))))
1454
1455   (define (valid-nonterminal? x)
1456     (symbol? x))
1457
1458   (define (valid-terminal? x)
1459     (symbol? x))                        ; DB 
1460
1461   ;; ----------------------------------------------------------------------
1462   ;; Miscellaneous
1463   ;; ----------------------------------------------------------------------
1464   (define (pos-in-list x lst)
1465     (let loop ((lst lst) (i 0))
1466       (cond ((not (pair? lst))    #f)
1467             ((equal? (car lst) x) i)
1468             (else                 (loop (cdr lst) (+ i 1))))))
1469
1470   (define (sunion lst1 lst2)            ; union of sorted lists
1471     (let loop ((L1 lst1)
1472                (L2 lst2))
1473       (cond ((null? L1)    L2)
1474             ((null? L2)    L1)
1475             (else
1476              (let ((x (car L1)) (y (car L2)))
1477                (cond
1478                 ((> x y)
1479                  (cons y (loop L1 (cdr L2))))
1480                 ((< x y)
1481                  (cons x (loop (cdr L1) L2)))
1482                 (else
1483                  (loop (cdr L1) L2))
1484                 ))))))
1485
1486   (define (sinsert elem lst)
1487     (let loop ((l1 lst))
1488       (if (null? l1)
1489           (cons elem l1)
1490           (let ((x (car l1)))
1491             (cond ((< elem x)
1492                    (cons elem l1))
1493                   ((> elem x)
1494                    (cons x (loop (cdr l1))))
1495                   (else
1496                    l1))))))
1497
1498   (define (lalr-filter p lst)
1499     (let loop ((l lst))
1500       (if (null? l)
1501           '()
1502           (let ((x (car l)) (y (cdr l)))
1503             (if (p x)
1504                 (cons x (loop y))
1505                 (loop y))))))
1506       
1507   ;; ----------------------------------------------------------------------
1508   ;; Debugging tools ...
1509   ;; ----------------------------------------------------------------------
1510   (define the-terminals #f)             ; names of terminal symbols
1511   (define the-nonterminals #f)          ; non-terminals
1512
1513   (define (print-item item-no)
1514     (let loop ((i item-no))
1515       (let ((v (vector-ref ritem i)))
1516         (if (>= v 0)
1517             (loop (+ i 1))
1518             (let* ((rlno    (- v))
1519                    (nt      (vector-ref rlhs rlno)))
1520               (display (vector-ref the-nonterminals nt)) (display " --> ")
1521               (let loop ((i (vector-ref rrhs rlno)))
1522                 (let ((v (vector-ref ritem i)))
1523                   (if (= i item-no)
1524                       (display ". "))
1525                   (if (>= v 0)
1526                       (begin
1527                         (display (get-symbol v))
1528                         (display " ")
1529                         (loop (+ i 1)))
1530                       (begin
1531                         (display "   (rule ")
1532                         (display (- v))
1533                         (display ")")
1534                         (newline))))))))))
1535
1536   (define (get-symbol n)
1537     (if (>= n nvars)
1538         (vector-ref the-terminals (- n nvars))
1539         (vector-ref the-nonterminals n)))
1540
1541
1542   (define (print-states)
1543     (define (print-action act)
1544       (cond
1545        ((eq? act '*error*)
1546         (display " : Error"))
1547        ((eq? act 'accept)
1548         (display " : Accept input"))
1549        ((< act 0)
1550         (display " : reduce using rule ")
1551         (display (- act)))
1552        (else
1553         (display " : shift and goto state ")
1554         (display act)))
1555       (newline)
1556       #t)
1557
1558     (define (print-actions acts)
1559       (let loop ((l acts))
1560         (if (null? l)
1561             #t
1562             (let ((sym (caar l))
1563                   (act (cadar l)))
1564               (display "   ")
1565               (cond
1566                ((eq? sym 'default)
1567                 (display "default action"))
1568                (else
1569                 (if (number? sym)
1570                     (display (get-symbol (+ sym nvars)))
1571                     (display sym))))
1572               (print-action act)
1573               (loop (cdr l))))))
1574
1575     (if (not action-table)
1576         (begin
1577           (display "No generated parser available!")
1578           (newline)
1579           #f)
1580         (begin
1581           (display "State table") (newline)
1582           (display "-----------") (newline) (newline)
1583
1584           (let loop ((l first-state))
1585             (if (null? l)
1586                 #t
1587                 (let* ((core  (car l))
1588                        (i     (core-number core))
1589                        (items (core-items core))
1590                        (actions (vector-ref action-table i)))
1591                   (display "state ") (display i) (newline)
1592                   (newline)
1593                   (for-each (lambda (x) (display "   ") (print-item x))
1594                             items)
1595                   (newline)
1596                   (print-actions actions)
1597                   (newline)
1598                   (loop (cdr l))))))))
1599
1600
1601
1602   ;; ----------------------------------------------------------------------
1603       
1604   (define build-goto-table
1605     (lambda ()
1606       `(vector
1607         ,@(map
1608            (lambda (shifts)
1609              (list 'quote
1610                    (if shifts
1611                        (let loop ((l (shift-shifts shifts)))
1612                          (if (null? l)
1613                              '()
1614                              (let* ((state  (car l))
1615                                     (symbol (vector-ref acces-symbol state)))
1616                                (if (< symbol nvars)
1617                                    (cons `(,symbol . ,state)
1618                                          (loop (cdr l)))
1619                                    (loop (cdr l))))))
1620                        '())))
1621            (vector->list shift-table)))))
1622
1623
1624   (define build-reduction-table
1625     (lambda (gram/actions)
1626       `(vector
1627         '()
1628         ,@(map
1629            (lambda (p)
1630              (let ((act (cdr p)))
1631                `(lambda ,(if (eq? driver-name 'lr-driver)
1632                              '(___stack ___sp ___goto-table ___push yypushback)
1633                              '(___sp ___goto-table ___push))
1634                   ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1635                      `(let* (,@(if act
1636                                    (let loop ((i 1) (l rhs))
1637                                      (if (pair? l)
1638                                          (let ((rest (cdr l))
1639                                                (ns (number->string (+ (- n i) 1))))
1640                                            (cons
1641                                             `(tok ,(if (eq? driver-name 'lr-driver)
1642                                                        `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
1643                                                        `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
1644                                             (cons
1645                                              `(,(string->symbol (string-append "$" ns))
1646                                                (if (lexical-token? tok) (lexical-token-value tok) tok))
1647                                              (cons
1648                                               `(,(string->symbol (string-append "@" ns))
1649                                                 (if (lexical-token? tok) (lexical-token-source tok) tok))
1650                                               (loop (+ i 1) rest)))))
1651                                          '()))
1652                                    '()))
1653                         ,(if (= nt 0)
1654                              '$1
1655                              `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) 
1656                                        ,(if (eq? driver-name 'lr-driver)
1657                                             `(vector-ref ___stack (- ___sp ,(length rhs)))
1658                                             `(list-ref ___sp ,(length rhs))))))))))
1659
1660            gram/actions))))
1661
1662
1663
1664   ;; Options
1665
1666   (define *valid-options*
1667     (list
1668      (cons 'out-table:
1669            (lambda (option)
1670              (and (list? option)
1671                   (= (length option) 2)
1672                   (string? (cadr option)))))
1673      (cons 'output:
1674            (lambda (option)
1675              (and (list? option)
1676                   (= (length option) 3)
1677                   (symbol? (cadr option))
1678                   (string? (caddr option)))))
1679      (cons 'expect:
1680            (lambda (option)
1681              (and (list? option)
1682                   (= (length option) 2)
1683                   (integer? (cadr option))
1684                   (>= (cadr option) 0))))
1685
1686      (cons 'driver:
1687            (lambda (option)
1688              (and (list? option)
1689                   (= (length option) 2)
1690                   (symbol? (cadr option))
1691                   (memq (cadr option) '(lr glr)))))))
1692
1693
1694   (define (validate-options options)
1695     (for-each
1696      (lambda (option)
1697        (let ((p (assoc (car option) *valid-options*)))
1698          (if (or (not p)
1699                  (not ((cdr p) option)))
1700              (lalr-error "Invalid option:" option))))
1701      options))
1702
1703
1704   (define (output-parser! options code)
1705     (let ((option (assq 'output: options)))
1706       (if option
1707           (let ((parser-name (cadr option))
1708                 (file-name   (caddr option)))
1709             (with-output-to-file file-name
1710               (lambda ()
1711                 (pprint `(define ,parser-name ,code))
1712                 (newline)))))))
1713
1714
1715   (define (output-table! options)
1716     (let ((option (assq 'out-table: options)))
1717       (if option
1718           (let ((file-name (cadr option)))
1719             (with-output-to-file file-name print-states)))))
1720
1721
1722   (define (set-expected-conflicts! options)
1723     (let ((option (assq 'expect: options)))
1724       (set! expected-conflicts (if option (cadr option) 0))))
1725
1726   (define (set-driver-name! options)
1727     (let ((option (assq 'driver: options)))
1728       (if option
1729           (let ((driver-type (cadr option)))
1730             (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
1731
1732
1733   ;; -- arguments
1734
1735   (define (extract-arguments lst proc)
1736     (let loop ((options '())
1737                (tokens  '())
1738                (rules   '())
1739                (lst     lst))
1740       (if (pair? lst)
1741           (let ((p (car lst)))
1742             (cond
1743              ((and (pair? p)
1744                    (lalr-keyword? (car p))
1745                    (assq (car p) *valid-options*))
1746               (loop (cons p options) tokens rules (cdr lst)))
1747              (else
1748               (proc options p (cdr lst)))))
1749           (lalr-error "Malformed lalr-parser form" lst))))
1750
1751
1752   (define (build-driver options tokens rules)
1753     (validate-options options)
1754     (set-expected-conflicts! options)
1755     (set-driver-name! options)
1756     (let* ((gram/actions (gen-tables! tokens rules))
1757            (code         `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
1758     
1759       (output-table! options)
1760       (output-parser! options code)
1761       code))
1762
1763   (extract-arguments arguments build-driver))
1764    
1765
1766
1767 ;;;
1768 ;;;; --
1769 ;;;; Implementation of the lr-driver
1770 ;;;
1771
1772
1773 (cond-expand
1774  (gambit
1775   (declare
1776    (standard-bindings)
1777    (fixnum)
1778    (block)
1779    (not safe)))
1780  (chicken
1781   (declare
1782    (uses extras)
1783    (usual-integrations)
1784    (fixnum)
1785    (not safe)))
1786  (guile)
1787  (else))
1788
1789
1790 ;;;
1791 ;;;; Source location utilities
1792 ;;;
1793
1794
1795 ;; This function assumes that src-location-1 and src-location-2 are source-locations
1796 ;; Returns #f if they are not locations for the same input 
1797 (define (combine-locations src-location-1 src-location-2)
1798   (let ((offset-1 (source-location-offset src-location-1))
1799         (offset-2 (source-location-offset src-location-2))
1800         (length-1 (source-location-length src-location-1))
1801         (length-2 (source-location-length src-location-2)))
1802
1803     (cond ((not (equal? (source-location-input src-location-1)
1804                         (source-location-input src-location-2)))
1805            #f)
1806           ((or (not (number? offset-1)) (not (number? offset-2))
1807                (not (number? length-1)) (not (number? length-2))
1808                (< offset-1 0) (< offset-2 0)
1809                (< length-1 0) (< length-2 0))
1810            (make-source-location (source-location-input src-location-1)
1811                                  (source-location-line src-location-1)
1812                                  (source-location-column src-location-1)
1813                                  -1 -1))
1814           ((<= offset-1 offset-2)
1815            (make-source-location (source-location-input src-location-1)
1816                                  (source-location-line src-location-1)
1817                                  (source-location-column src-location-1)
1818                                  offset-1
1819                                  (- (+ offset-2 length-2) offset-1)))
1820           (else
1821            (make-source-location (source-location-input src-location-1)
1822                                  (source-location-line src-location-1)
1823                                  (source-location-column src-location-1)
1824                                  offset-2
1825                                  (- (+ offset-1 length-1) offset-2))))))
1826
1827
1828 ;;;
1829 ;;;;  LR-driver
1830 ;;;
1831
1832
1833 (define *max-stack-size* 500)
1834
1835 (define (lr-driver action-table goto-table reduction-table)
1836   (define ___atable action-table)
1837   (define ___gtable goto-table)
1838   (define ___rtable reduction-table)
1839
1840   (define ___lexerp #f)
1841   (define ___errorp #f)
1842   
1843   (define ___stack  #f)
1844   (define ___sp     0)
1845   
1846   (define ___curr-input #f)
1847   (define ___reuse-input #f)
1848   
1849   (define ___input #f)
1850   (define (___consume)
1851     (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
1852     (set! ___reuse-input #f)
1853     (set! ___curr-input ___input))
1854   
1855   (define (___pushback)
1856     (set! ___reuse-input #t))
1857   
1858   (define (___initstack)
1859     (set! ___stack (make-vector *max-stack-size* 0))
1860     (set! ___sp 0))
1861   
1862   (define (___growstack)
1863     (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
1864       (let loop ((i (- (vector-length ___stack) 1)))
1865         (if (>= i 0)
1866             (begin
1867               (vector-set! new-stack i (vector-ref ___stack i))
1868               (loop (- i 1)))))
1869       (set! ___stack new-stack)))
1870   
1871   (define (___checkstack)
1872     (if (>= ___sp (vector-length ___stack))
1873         (___growstack)))
1874   
1875   (define (___push delta new-category lvalue tok)
1876     (set! ___sp (- ___sp (* delta 2)))
1877     (let* ((state     (vector-ref ___stack ___sp))
1878            (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
1879       (set! ___sp (+ ___sp 2))
1880       (___checkstack)
1881       (vector-set! ___stack ___sp new-state)
1882       (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
1883   
1884   (define (___reduce st)
1885     ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
1886   
1887   (define (___shift token attribute)
1888     (set! ___sp (+ ___sp 2))
1889     (___checkstack)
1890     (vector-set! ___stack (- ___sp 1) attribute)
1891     (vector-set! ___stack ___sp token))
1892   
1893   (define (___action x l)
1894     (let ((y (assoc x l)))
1895       (if y (cadr y) (cadar l))))
1896   
1897   (define (___recover tok)
1898     (let find-state ((sp ___sp))
1899       (if (< sp 0)
1900           (set! ___sp sp)
1901           (let* ((state (vector-ref ___stack sp))
1902                  (act   (assoc 'error (vector-ref ___atable state))))
1903             (if act
1904                 (begin
1905                   (set! ___sp sp)
1906                   (___sync (cadr act) tok))
1907                 (find-state (- sp 2)))))))
1908   
1909   (define (___sync state tok)
1910     (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
1911       (set! ___sp (+ ___sp 4))
1912       (___checkstack)
1913       (vector-set! ___stack (- ___sp 3) #f)
1914       (vector-set! ___stack (- ___sp 2) state)
1915       (let skip ()
1916         (let ((i (___category ___input)))
1917           (if (eq? i '*eoi*)
1918               (set! ___sp -1)
1919               (if (memq i sync-set)
1920                   (let ((act (assoc i (vector-ref ___atable state))))
1921                     (vector-set! ___stack (- ___sp 1) #f)
1922                     (vector-set! ___stack ___sp (cadr act)))
1923                   (begin
1924                     (___consume)
1925                     (skip))))))))
1926   
1927   (define (___category tok)
1928     (if (lexical-token? tok)
1929         (lexical-token-category tok)
1930         tok))
1931
1932   (define (___run)
1933     (let loop ()
1934       (if ___input
1935           (let* ((state (vector-ref ___stack ___sp))
1936                  (i     (___category ___input))
1937                  (act   (___action i (vector-ref ___atable state))))
1938             
1939             (cond ((not (symbol? i))
1940                    (___errorp "Syntax error: invalid token: " ___input)
1941                    #f)
1942              
1943                   ;; Input succesfully parsed
1944                   ((eq? act 'accept)
1945                    (vector-ref ___stack 1))
1946                   
1947                   ;; Syntax error in input
1948                   ((eq? act '*error*)
1949                    (if (eq? i '*eoi*)
1950                        (begin
1951                          (___errorp "Syntax error: unexpected end of input")
1952                          #f)
1953                        (begin
1954                          (___errorp "Syntax error: unexpected token : " ___input)
1955                          (___recover i)
1956                          (if (>= ___sp 0)
1957                              (set! ___input #f)
1958                              (begin
1959                                (set! ___sp 0)
1960                                (set! ___input '*eoi*)))
1961                          (loop))))
1962              
1963                   ;; Shift current token on top of the stack
1964                   ((>= act 0)
1965                    (___shift act ___input)
1966                    (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
1967                    (loop))
1968              
1969                   ;; Reduce by rule (- act)
1970                   (else
1971                    (___reduce (- act))
1972                    (loop))))
1973           
1974           ;; no lookahead, so check if there is a default action
1975           ;; that does not require the lookahead
1976           (let* ((state  (vector-ref ___stack ___sp))
1977                  (acts   (vector-ref ___atable state))
1978                  (defact (if (pair? acts) (cadar acts) #f)))
1979             (if (and (= 1 (length acts)) (< defact 0))
1980                 (___reduce (- defact))
1981                 (___consume))
1982             (loop)))))
1983   
1984
1985   (lambda (lexerp errorp)
1986     (set! ___errorp errorp)
1987     (set! ___lexerp lexerp)
1988     (___initstack)
1989     (___run)))
1990
1991
1992 ;;;
1993 ;;;;  Simple-minded GLR-driver
1994 ;;;
1995
1996
1997 (define (glr-driver action-table goto-table reduction-table)
1998   (define ___atable action-table)
1999   (define ___gtable goto-table)
2000   (define ___rtable reduction-table)
2001
2002   (define ___lexerp #f)
2003   (define ___errorp #f)
2004   
2005   ;; -- Input handling 
2006   
2007   (define *input* #f)
2008   (define (initialize-lexer lexer)
2009     (set! ___lexerp lexer)
2010     (set! *input* #f))
2011   (define (consume)
2012     (set! *input* (___lexerp)))
2013   
2014   (define (token-category tok)
2015     (if (lexical-token? tok)
2016         (lexical-token-category tok)
2017         tok))
2018
2019   (define (token-attribute tok)
2020     (if (lexical-token? tok)
2021         (lexical-token-value tok)
2022         tok))
2023
2024   ;; -- Processes (stacks) handling
2025   
2026   (define *processes* '())
2027   
2028   (define (initialize-processes)
2029     (set! *processes* '()))
2030   (define (add-process process)
2031     (set! *processes* (cons process *processes*)))
2032   (define (get-processes)
2033     (reverse *processes*))
2034   
2035   (define (for-all-processes proc)
2036     (let ((processes (get-processes)))
2037       (initialize-processes)
2038       (for-each proc processes)))
2039   
2040   ;; -- parses
2041   (define *parses* '())
2042   (define (get-parses)
2043     *parses*)
2044   (define (initialize-parses)
2045     (set! *parses* '()))
2046   (define (add-parse parse)
2047     (set! *parses* (cons parse *parses*)))
2048     
2049
2050   (define (push delta new-category lvalue stack tok)
2051     (let* ((stack     (drop stack (* delta 2)))
2052            (state     (car stack))
2053            (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
2054         (cons new-state (cons (note-source-location lvalue tok) stack))))
2055   
2056   (define (reduce state stack)
2057     ((vector-ref ___rtable state) stack ___gtable push))
2058   
2059   (define (shift state symbol stack)
2060     (cons state (cons symbol stack)))
2061   
2062   (define (get-actions token action-list)
2063     (let ((pair (assoc token action-list)))
2064       (if pair 
2065           (cdr pair)
2066           (cdar action-list)))) ;; get the default action
2067   
2068
2069   (define (run)
2070     (let loop-tokens ()
2071       (consume)
2072       (let ((symbol (token-category *input*)))
2073         (for-all-processes
2074          (lambda (process)
2075            (let loop ((stacks (list process)) (active-stacks '()))
2076              (cond ((pair? stacks)
2077                     (let* ((stack   (car stacks))
2078                            (state   (car stack)))
2079                       (let actions-loop ((actions      (get-actions symbol (vector-ref ___atable state)))
2080                                          (active-stacks active-stacks))
2081                         (if (pair? actions)
2082                             (let ((action        (car actions))
2083                                   (other-actions (cdr actions)))
2084                               (cond ((eq? action '*error*)
2085                                      (actions-loop other-actions active-stacks))
2086                                     ((eq? action 'accept)
2087                                      (add-parse (car (take-right stack 2)))
2088                                      (actions-loop other-actions active-stacks))
2089                                     ((>= action 0)
2090                                      (let ((new-stack (shift action *input* stack)))
2091                                        (add-process new-stack))
2092                                      (actions-loop other-actions active-stacks))
2093                                     (else
2094                                      (let ((new-stack (reduce (- action) stack)))
2095                                       (actions-loop other-actions (cons new-stack active-stacks))))))
2096                             (loop (cdr stacks) active-stacks)))))
2097                    ((pair? active-stacks)
2098                     (loop (reverse active-stacks) '())))))))
2099       (if (pair? (get-processes))
2100           (loop-tokens))))
2101
2102   
2103   (lambda (lexerp errorp)
2104     (set! ___errorp errorp)
2105     (initialize-lexer lexerp)
2106     (initialize-processes)
2107     (initialize-parses)
2108     (add-process '(0))
2109     (run)
2110     (get-parses)))
2111
2112
2113 (define (drop l n)
2114   (cond ((and (> n 0) (pair? l))
2115          (drop (cdr l) (- n 1)))
2116         (else
2117          l)))
2118
2119 (define (take-right l n)
2120   (drop l (- (length l) n)))