module/system/base/lalr.upstream.scm

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