module/system/base/lalr.upstream.scm

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