lalr-el.scm

   1 ;; ---------------------------------------------------------------------- ;;
   2 ;; FICHIER               : lalr.scm                                       ;;
   3 ;; DATE DE CREATION      : Mon Jan 22 15:42:32 1996                       ;;
   4 ;; DERNIERE MODIFICATION : Mon Jun  3 10:24:43 1996                       ;;
   5 ;; ---------------------------------------------------------------------- ;;
   6 ;; Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc.          ;;
   7 ;;   (for the Bison source code translated in Scheme)                     ;;
   8 ;; Copyright (C) 1996 Dominique Boucher                                   ;;
   9 ;;   (for the translation in Scheme)                                      ;;
  10 ;; ---------------------------------------------------------------------- ;;
  11 ;; An efficient Scheme LALR(1) Parser Generator  -- lalr.scm              ;;
  12 ;; ---------------------------------------------------------------------- ;;
  13 ;; This file contains yet another LALR(1) parser generator written in     ;;
  14 ;; Scheme. In contrast to other such parser generators, this one          ;;
  15 ;; implements a more efficient algorithm for computing the lookahead sets.;;
  16 ;; The algorithm is the same as used in Bison (GNU yacc) and is described ;;
  17 ;; in the following paper:                                                ;;
  18 ;;                                                                        ;;
  19 ;; "Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and      ;;
  20 ;; T. Pennello, TOPLAS, vol. 4, no. 4, october 1982.                      ;;
  21 ;;                                                                        ;;
  22 ;; As a consequence, it is not written in a fully functional style.       ;;
  23 ;; The program has been successfully tested on several Scheme             ;;
  24 ;; interpreters and compilers, including scm4d3, Gambit v2.2, and         ;;
  25 ;; MIT-Scheme 7.2.0 (microcode 11.127, runtime 14.160).                   ;;
  26 ;; ---------------------------------------------------------------------- ;;
  27 ;; HOW TO USE THE PROGRAM                                                 ;;
  28 ;;                                                                        ;;
  29 ;; To generate a parser for a given grammar, the latter must be first     ;;
  30 ;; written down in scheme. The next section will describe the syntax      ;;
  31 ;; of the grammar. Now suppose your grammar is defined like this:         ;;
  32 ;;                                                                        ;;
  33 ;;    (define my-grammar { grammar })                                     ;;
  34 ;;                                                                        ;;
  35 ;; All you need to do is evaluate the expression:                         ;;
  36 ;;                                                                        ;;
  37 ;;    (gen-lalr1 my-grammar "file" [prefix])                              ;;
  38 ;;                                                                        ;;
  39 ;; where "file" is the name of the file (a string) that will contain the  ;;
  40 ;; tables for LR-parsing. The last argument must be supplied if you want  ;;
  41 ;; multiple parsers coexist in the same application. It must be a symbol, ;;
  42 ;; otherwise it will be ignored.                                          ;;
  43 ;;                                                                        ;;
  44 ;; To run the parser, you must first load the LR parsing driver(also part ;;
  45 ;; of this distribution):                                                 ;;
  46 ;;                                                                        ;;
  47 ;;      (load "lr-dvr.scm")                                               ;;
  48 ;;                                                                        ;;
  49 ;; The interface to the generated parser will be the function             ;;
  50 ;;                                                                        ;;
  51 ;;     ([prefix-]parse lexer errorp)                                      ;;
  52 ;;                                                                        ;;
  53 ;; where lexer is the name of the scanner feeding the parser with pairs   ;;
  54 ;; (token . lval) and errorp is the name of a user-defined error          ;;
  55 ;; function (the standard error function can be used as well).            ;;
  56 ;;                                                                        ;;
  57 ;;                                                                        ;;
  58 ;; Here are some notes about the lexer and the error function:            ;;
  59 ;;                                                                        ;;
  60 ;;   - the tokens (which are the first components of the pairs returned   ;;
  61 ;;     by the lexer) must agree with the tokens defined in the grammar.   ;;
  62 ;;                                                                        ;;
  63 ;;   - when the lexer wants to signal the end of the input, it must       ;;
  64 ;;     return the pair '(0) each time it's invoked.                       ;;
  65 ;;                                                                        ;;
  66 ;;   - the error function must accept two parameters (the standard error  ;;
  67 ;;     function accepts a variable number of parameters, so it accepts    ;;
  68 ;;     two).                                                              ;;
  69 ;;                                                                        ;;
  70 ;; ---------------------------------------------------------------------- ;;
  71 ;; THE GRAMMAR FORMAT                                                     ;;
  72 ;;                                                                        ;;
  73 ;; The grammar is specified by first giving the list of terminals and the ;;
  74 ;; list of non-terminal definitions. Each non-terminal definition         ;;
  75 ;; is a list where the first element is the non-terminal and the other    ;;
  76 ;; elements are the right-hand sides (lists of grammar symbols). In       ;;
  77 ;; addition to this, each rhs can be followed by a semantic action.       ;;
  78 ;; By convention, use strings for tokens and atoms for non-terminals.     ;;
  79 ;;                                                                        ;;
  80 ;; For example, consider the following (yacc) grammar:                    ;;
  81 ;;                                                                        ;;
  82 ;;   e : e '+' t                                                          ;;
  83 ;;     | t                                                                ;;
  84 ;;     ;                                                                  ;;
  85 ;;                                                                        ;;
  86 ;;   t : t '*' f                                                          ;;
  87 ;;     | f                                                                ;;
  88 ;;     ;                                                                  ;;
  89 ;;                                                                        ;;
  90 ;;   f : ID                                                               ;;
  91 ;;     ;                                                                  ;;
  92 ;;                                                                        ;;
  93 ;; The same grammar, written for the scheme parser generator, would look  ;;
  94 ;; like this (with semantic actions)                                      ;;
  95 ;;                                                                        ;;
  96 ;; (define my-grammar                                                     ;;
  97 ;;   '(                                                                   ;;
  98 ;;     ; Terminal symbols                                                 ;;
  99 ;;     ID ADD MULT                                                        ;;
 100 ;;     ; Productions                                                      ;;
 101 ;;     (e (e ADD t)  : (+ $1 $3)                                          ;;
 102 ;;        (t)        : $1                                                 ;;
 103 ;;        )                                                               ;;
 104 ;;     (t (t MULT f) : (* $1 $3)                                          ;;
 105 ;;        (f)        : $1                                                 ;;
 106 ;;        )                                                               ;;
 107 ;;     (f (ID)       : $1)                                                ;;
 108 ;;    ))                                                                  ;;
 109 ;;                                                                        ;;
 110 ;; In semantic actions, the symbol $<n> refers to the synthesized         ;;
 111 ;; attribute value of the nth symbol in the production. The value         ;;
 112 ;; associated with the non-terminal on the left is the result of          ;;
 113 ;; evaluating the semantic action (it defaults to #f).                    ;;
 114 ;;                                                                        ;;
 115 ;; If you evaluate                                                        ;;
 116 ;;                                                                        ;;
 117 ;;    (gen-lalr1 my-grammar "foo.scm" 'my)                                ;;
 118 ;;                                                                        ;;
 119 ;; then the generated parser will be named 'my-parser'.                   ;;
 120 ;;                                                                        ;;
 121 ;; NOTE ON CONFLICT RESOLUTION                                            ;;
 122 ;;                                                                        ;;
 123 ;; Conflicts in the grammar are handled in a conventional way.            ;;
 124 ;; Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce     ;;
 125 ;; conflicts are resolved by choosing the rule listed first in the        ;;
 126 ;; grammar definition.                                                    ;;
 127 ;;                                                                        ;;
 128 ;; You can print the states of the generated parser by evaluating         ;;
 129 ;; `(print-states)'. The format of the output is similar to the one       ;;
 130 ;; produced by bison when given the -v command-line option.               ;;
 131 ;; ---------------------------------------------------------------------- ;;
 132 ;; lalr.scm is free software; you can redistribute it and/or modify       ;;
 133 ;; it under the terms of the GNU General Public License as published by   ;;
 134 ;; the Free Software Foundation; either version 2, or (at your option)    ;;
 135 ;; any later version.                                                     ;;
 136 ;;                                                                        ;;
 137 ;; lalr.scm is distributed in the hope that it will be useful,            ;;
 138 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of         ;;
 139 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          ;;
 140 ;; GNU General Public License for more details.                           ;;
 141 ;;                                                                        ;;
 142 ;; You should have received a copy of the GNU General Public License      ;;
 143 ;; along with lalr.scm; see the file COPYING.  If not, write to           ;;
 144 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  ;;
 145 ;;                                                                        ;;
 146 ;; Dominique Boucher -- Universite de Montreal                            ;;
 147 ;;                                                                        ;;
 148 ;; Send questions, comments or suggestions to boucherd@iro.umontreal.ca   ;;
 149 ;; ---------------------------------------------------------------------- ;;
 150
 151 ;; 1998/08/16: Tanaka Akira <akr@jaist.ac.jp> transplants generating code from Scheme to Emacs-Lisp.
 152
 153 ;;; ---------- SYSTEM DEPENDENT SECTION -----------------
 154
 155 ;; -------- SCM
 156 (begin
 157   (defmacro def-macro (args body)
 158     `(defmacro ,(car args) ,(cdr args) ,body))
 159
 160   (def-macro (BITS-PER-WORD) 24)
 161   (def-macro (logical-or x . y) `(logior ,x ,@y))
 162   )
 163
 164 ;; -------- MIT-Scheme
 165 '(begin
 166   (declare (usual-integrations))
 167
 168   (define-macro (def-macro form . body)
 169     `(DEFINE-MACRO ,form (LET () ,@body)))
 170
 171   (def-macro (BITS-PER-WORD) 24)
 172   (def-macro (logical-or x . y) `(fix:or ,x ,@y))
 173   )
 174
 175 ;; -------- Gambit
 176 '(begin
 177
 178  (declare
 179   (standard-bindings)
 180   (fixnum)
 181   (block)
 182   (not safe))
 183
 184  (define-macro (def-macro form . body)
 185     `(DEFINE-MACRO ,form (LET () ,@body)))
 186
 187   (def-macro (BITS-PER-WORD) 28)
 188   (def-macro (logical-or x . y) `(,(string->symbol "##logior") ,x ,@y))
 189   )
 190
 191 ;; -------- Bigloo
 192 '(begin
 193
 194  (define-macro (def-macro form . body)
 195     `(DEFINE-MACRO ,form (LET () ,@body)))
 196  (def-macro (BITS-PER-WORD) 16)
 197  (def-macro (logical-or x . y) `(bit-or ,x ,@y))
 198  )
 199
 200 ;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------
 201
 202 ;; - Macros pour la gestion des vecteurs de bits
 203
 204 (def-macro (set-bit v b)
 205   `(let ((x (quotient ,b (BITS-PER-WORD)))
 206          (y (expt 2 (remainder ,b (BITS-PER-WORD)))))
 207      (vector-set! ,v x (logical-or (vector-ref ,v x) y))))
 208
 209 (def-macro (bit-union v1 v2 n)
 210   `(do ((i 0 (+ i 1)))
 211        ((= i ,n))
 212      (vector-set! ,v1 i (logical-or (vector-ref ,v1 i)
 213                                     (vector-ref ,v2 i)))))
 214
 215 ;; - Macro pour les structures de donnees
 216
 217 (def-macro (new-core)              `(make-vector 4 0))
 218 (def-macro (set-core-number! c n)  `(vector-set! ,c 0 ,n))
 219 (def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s))
 220 (def-macro (set-core-nitems! c n)  `(vector-set! ,c 2 ,n))
 221 (def-macro (set-core-items! c i)   `(vector-set! ,c 3 ,i))
 222 (def-macro (core-number c)         `(vector-ref ,c 0))
 223 (def-macro (core-acc-sym c)        `(vector-ref ,c 1))
 224 (def-macro (core-nitems c)         `(vector-ref ,c 2))
 225 (def-macro (core-items c)          `(vector-ref ,c 3))
 226
 227 (def-macro (new-shift)              `(make-vector 3 0))
 228 (def-macro (set-shift-number! c x)  `(vector-set! ,c 0 ,x))
 229 (def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x))
 230 (def-macro (set-shift-shifts! c x)  `(vector-set! ,c 2 ,x))
 231 (def-macro (shift-number s)         `(vector-ref ,s 0))
 232 (def-macro (shift-nshifts s)        `(vector-ref ,s 1))
 233 (def-macro (shift-shifts s)         `(vector-ref ,s 2))
 234
 235 (def-macro (new-red)                `(make-vector 3 0))
 236 (def-macro (set-red-number! c x)    `(vector-set! ,c 0 ,x))
 237 (def-macro (set-red-nreds! c x)     `(vector-set! ,c 1 ,x))
 238 (def-macro (set-red-rules! c x)     `(vector-set! ,c 2 ,x))
 239 (def-macro (red-number c)           `(vector-ref ,c 0))
 240 (def-macro (red-nreds c)            `(vector-ref ,c 1))
 241 (def-macro (red-rules c)            `(vector-ref ,c 2))
 242
 243
 244
 245 (def-macro (new-set nelem)
 246   `(make-vector ,nelem 0))
 247
 248
 249 (def-macro (vector-map f v)
 250   `(let ((vm-n (- (vector-length ,v) 1)))
 251     (let loop ((vm-low 0) (vm-high vm-n))
 252       (if (= vm-low vm-high)
 253           (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low))
 254           (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
 255             (loop vm-low vm-middle)
 256             (loop (+ vm-middle 1) vm-high))))))
 257
 258
 259 ;; - Constantes
 260 (define STATE-TABLE-SIZE 1009)
 261
 262
 263 ;; - Tableaux
 264 (define rrhs         #f)
 265 (define rlhs         #f)
 266 (define ritem        #f)
 267 (define nullable     #f)
 268 (define derives      #f)
 269 (define fderives     #f)
 270 (define firsts       #f)
 271 (define kernel-base  #f)
 272 (define kernel-end   #f)
 273 (define shift-symbol #f)
 274 (define shift-set    #f)
 275 (define red-set      #f)
 276 (define state-table  #f)
 277 (define acces-symbol #f)
 278 (define reduction-table #f)
 279 (define shift-table  #f)
 280 (define consistent   #f)
 281 (define lookaheads   #f)
 282 (define LA           #f)
 283 (define LAruleno     #f)
 284 (define lookback     #f)
 285 (define goto-map     #f)
 286 (define from-state   #f)
 287 (define to-state     #f)
 288 (define includes     #f)
 289 (define F            #f)
 290 (define action-table #f)
 291
 292 ;; - Variables
 293 (define nitems          #f)
 294 (define nrules          #f)
 295 (define nvars           #f)
 296 (define nterms          #f)
 297 (define nsyms           #f)
 298 (define nstates         #f)
 299 (define first-state     #f)
 300 (define last-state      #f)
 301 (define final-state     #f)
 302 (define first-shift     #f)
 303 (define last-shift      #f)
 304 (define first-reduction #f)
 305 (define last-reduction  #f)
 306 (define nshifts         #f)
 307 (define maxrhs          #f)
 308 (define ngotos          #f)
 309 (define token-set-size  #f)
 310
 311 (define (gen-larl1 gram output-file header footer . opt)
 312   (define (conv-rule-right rr)
 313     (if (null? rr)
 314       '()
 315       (cons (reverse (car rr))
 316         (cons (cadr rr)
 317           (cons (caddr rr)
 318             (conv-rule-right (cdddr rr)))))))
 319   (apply gen-lalr1
 320     (map
 321       (lambda (elt)
 322         (if (symbol? elt)
 323           elt
 324           (cons (car elt) (conv-rule-right (cdr elt)))))
 325       gram)
 326     output-file
 327     header
 328     footer
 329     opt))
 330
 331 (define (gen-lalr1 gram output-file header footer . opt)
 332   (initialize-all)
 333   (rewrite-grammar
 334    gram
 335    (lambda (terms vars gram gram/actions)
 336      (set! the-terminals (list->vector terms))
 337      (set! the-nonterminals (list->vector vars))
 338      (set! nterms (length terms))
 339      (set! nvars  (length vars))
 340      (set! nsyms  (+ nterms nvars))
 341      (let ((no-of-rules (length gram/actions))
 342            (no-of-items (let loop ((l gram/actions) (count 0))
 343                           (if (null? l)
 344                               count
 345                               (loop (cdr l) (+ count (length (caar l))))))))
 346        (pack-grammar no-of-rules no-of-items gram)
 347        (set-derives)
 348        (set-nullable)
 349        (generate-states)
 350        (lalr)
 351        (build-tables)
 352        (compact-action-table)
 353        (let* ((parser-name (if (and (pair? opt) (symbol? (car opt))) (car opt) #f))
 354               (prefix      (if parser-name
 355                                (string-append
 356                                 (symbol->string parser-name)
 357                                 ":")
 358                                ""))
 359               (parser-prefix (if parser-name
 360                                   (string-append (symbol->string parser-name) "-")
 361                                  "")))
 362          (with-output-to-file output-file
 363            (lambda ()
 364              (display "; *** Header ***")
 365              (newline)
 366              (output-header header parser-prefix)
 367              (display "; *** Token Definitions ***")
 368              (newline)
 369              (output-token-defs terms prefix)
 370              (display "; *** Action Table ***")
 371              (newline)
 372              (output-action-table prefix)
 373              (display "; *** Goto Table ***")
 374              (newline)
 375              (output-goto-table prefix)
 376              (display "; *** Reduction Table ***")
 377              (newline)
 378              (output-reduction-table gram/actions prefix)
 379              (display "; *** Parser Definition ***")
 380              (newline)
 381              (output-parser-def parser-prefix prefix)
 382              (display "; *** Footer ***")
 383              (newline)
 384              (output-footer footer)
 385              )))))))
 386
 387
 388 (define (initialize-all)
 389   (set! rrhs         #f)
 390   (set! rlhs         #f)
 391   (set! ritem        #f)
 392   (set! nullable     #f)
 393   (set! derives      #f)
 394   (set! fderives     #f)
 395   (set! firsts       #f)
 396   (set! kernel-base  #f)
 397   (set! kernel-end   #f)
 398   (set! shift-symbol #f)
 399   (set! shift-set    #f)
 400   (set! red-set      #f)
 401   (set! state-table  (make-vector STATE-TABLE-SIZE '()))
 402   (set! acces-symbol #f)
 403   (set! reduction-table #f)
 404   (set! shift-table  #f)
 405   (set! consistent   #f)
 406   (set! lookaheads   #f)
 407   (set! LA           #f)
 408   (set! LAruleno     #f)
 409   (set! lookback     #f)
 410   (set! goto-map     #f)
 411   (set! from-state   #f)
 412   (set! to-state     #f)
 413   (set! includes     #f)
 414   (set! F            #f)
 415   (set! action-table #f)
 416   (set! nstates         #f)
 417   (set! first-state     #f)
 418   (set! last-state      #f)
 419   (set! final-state     #f)
 420   (set! first-shift     #f)
 421   (set! last-shift      #f)
 422   (set! first-reduction #f)
 423   (set! last-reduction  #f)
 424   (set! nshifts         #f)
 425   (set! maxrhs          #f)
 426   (set! ngotos          #f)
 427   (set! token-set-size  #f))
 428
 429
 430 (define (pack-grammar no-of-rules no-of-items gram)
 431   (set! nrules (+  no-of-rules 1))
 432   (set! nitems no-of-items)
 433   (set! rlhs (make-vector nrules #f))
 434   (set! rrhs (make-vector nrules #f))
 435   (set! ritem (make-vector (+ 1 nitems) #f))
 436
 437   (let loop ((p gram) (item-no 0) (rule-no 1))
 438         (if (not (null? p))
 439         (let ((nt (caar p)))
 440           (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
 441                 (if (null? prods)
 442                 (loop (cdr p) it-no2 rl-no2)
 443                 (begin
 444                   (vector-set! rlhs rl-no2 nt)
 445                   (vector-set! rrhs rl-no2 it-no2)
 446                   (let loop3 ((rhs (car prods)) (it-no3 it-no2))
 447                         (if (null? rhs)
 448                         (begin
 449                           (vector-set! ritem it-no3 (- rl-no2))
 450                           (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
 451                         (begin
 452                           (vector-set! ritem it-no3 (car rhs))
 453                           (loop3 (cdr rhs) (+ it-no3 1))))))))))))
 454
 455
 456 ;; Fonction set-derives
 457 ;; --------------------
 458 (define (set-derives)
 459   (define delts (make-vector (+ nrules 1) 0))
 460   (define dset  (make-vector nvars -1))
 461
 462   (let loop ((i 1) (j 0))               ; i = 0
 463     (if (< i nrules)
 464         (let ((lhs (vector-ref rlhs i)))
 465           (if (>= lhs 0)
 466               (begin
 467                 (vector-set! delts j (cons i (vector-ref dset lhs)))
 468                 (vector-set! dset lhs j)
 469                 (loop (+ i 1) (+ j 1)))
 470               (loop (+ i 1) j)))))
 471
 472   (set! derives (make-vector nvars 0))
 473
 474   (let loop ((i 0))
 475     (if (< i nvars)
 476         (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
 477                    (if (< j 0)
 478                        s
 479                        (let ((x (vector-ref delts j)))
 480                          (loop2 (cdr x) (cons (car x) s)))))))
 481           (vector-set! derives i q)
 482           (loop (+ i 1))))))
 483
 484
 485
 486 (define (set-nullable)
 487   (set! nullable (make-vector nvars #f))
 488   (let ((squeue (make-vector nvars #f))
 489         (rcount (make-vector (+ nrules 1) 0))
 490         (rsets  (make-vector nvars #f))
 491         (relts  (make-vector (+ nitems nvars 1) #f)))
 492     (let loop ((r 0) (s2 0) (p 0))
 493       (let ((*r (vector-ref ritem r)))
 494         (if *r
 495             (if (< *r 0)
 496                 (let ((symbol (vector-ref rlhs (- *r))))
 497                   (if (and (>= symbol 0)
 498                            (not (vector-ref nullable symbol)))
 499                       (begin
 500                         (vector-set! nullable symbol #t)
 501                         (vector-set! squeue s2 symbol)
 502                         (loop (+ r 1) (+ s2 1) p))))
 503                 (let loop2 ((r1 r) (any-tokens #f))
 504                   (let* ((symbol (vector-ref ritem r1)))
 505                     (if (> symbol 0)
 506                         (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
 507                         (if (not any-tokens)
 508                             (let ((ruleno (- symbol)))
 509                               (let loop3 ((r2 r) (p2 p))
 510                                 (let ((symbol (vector-ref ritem r2)))
 511                                   (if (> symbol 0)
 512                                       (begin
 513                                         (vector-set! rcount ruleno
 514                                                      (+ (vector-ref rcount ruleno) 1))
 515                                         (vector-set! relts p2
 516                                                      (cons (vector-ref rsets symbol)
 517                                                            ruleno))
 518                                         (vector-set! rsets symbol p2)
 519                                         (loop3 (+ r2 1) (+ p2 1)))
 520                                       (loop (+ r2 1) s2 p2)))))
 521                             (loop (+ r1 1) s2 p))))))
 522             (let loop ((s1 0) (s3 s2))
 523               (if (< s1 s3)
 524                   (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
 525                     (if p
 526                         (let* ((x (vector-ref relts p))
 527                                (ruleno (cdr x))
 528                                (y (- (vector-ref rcount ruleno) 1)))
 529                           (vector-set! rcount ruleno y)
 530                           (if (= y 0)
 531                               (let ((symbol (vector-ref rlhs ruleno)))
 532                                 (if (and (>= symbol 0)
 533                                          (not (vector-ref nullable symbol)))
 534                                     (begin
 535                                       (vector-set! nullable symbol #t)
 536                                       (vector-set! squeue s4 symbol)
 537                                       (loop2 (car x) (+ s4 1)))
 538                                     (loop2 (car x) s4)))
 539                               (loop2 (car x) s4))))
 540                     (loop (+ s1 1) s4)))))))))
 541
 542
 543
 544 ; Fonction set-firsts qui calcule un tableau de taille
 545 ; nvars et qui donne, pour chaque non-terminal X, une liste des
 546 ; non-terminaux pouvant apparaitre au debut d'une derivation a
 547 ; partir de X.
 548
 549 (define (set-firsts)
 550   (set! firsts (make-vector nvars '()))
 551
 552   ;; -- initialization
 553   (let loop ((i 0))
 554     (if (< i nvars)
 555         (let loop2 ((sp (vector-ref derives i)))
 556           (if (null? sp)
 557               (loop (+ i 1))
 558               (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
 559                 (if (< -1 sym nvars)
 560                     (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
 561                 (loop2 (cdr sp)))))))
 562
 563   ;; -- reflexive and transitive closure
 564   (let loop ((continue #t))
 565     (if continue
 566         (let loop2 ((i 0) (cont #f))
 567           (if (>= i nvars)
 568               (loop cont)
 569               (let* ((x (vector-ref firsts i))
 570                      (y (let loop3 ((l x) (z x))
 571                           (if (null? l)
 572                               z
 573                               (loop3 (cdr l)
 574                                      (sunion (vector-ref firsts (car l)) z))))))
 575                 (if (equal? x y)
 576                     (loop2 (+ i 1) cont)
 577                     (begin
 578                       (vector-set! firsts i y)
 579                       (loop2 (+ i 1) #t))))))))
 580
 581   (let loop ((i 0))
 582     (if (< i nvars)
 583         (begin
 584           (vector-set! firsts i (sinsert i (vector-ref firsts i)))
 585           (loop (+ i 1))))))
 586
 587
 588
 589
 590 ; Fonction set-fderives qui calcule un tableau de taille
 591 ; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
 592 ; etre derivees a partir de ce non-terminal. (se sert de firsts)
 593
 594 (define (set-fderives)
 595   (set! fderives (make-vector nvars #f))
 596
 597   (set-firsts)
 598
 599   (let loop ((i 0))
 600     (if (< i nvars)
 601         (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
 602                    (if (null? l)
 603                        fd
 604                        (loop2 (cdr l)
 605                               (sunion (vector-ref derives (car l)) fd))))))
 606           (vector-set! fderives i x)
 607           (loop (+ i 1))))))
 608
 609
 610 ; Fonction calculant la fermeture d'un ensemble d'items LR0
 611 ; ou core est une liste d'items
 612
 613 (define (closure core)
 614   ;; Initialization
 615   (define ruleset (make-vector nrules #f))
 616
 617   (let loop ((csp core))
 618     (if (not (null? csp))
 619         (let ((sym (vector-ref ritem (car csp))))
 620           (if (< -1 sym nvars)
 621               (let loop2 ((dsp (vector-ref fderives sym)))
 622                 (if (not (null? dsp))
 623                     (begin
 624                       (vector-set! ruleset (car dsp) #t)
 625                       (loop2 (cdr dsp))))))
 626           (loop (cdr csp)))))
 627
 628   (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
 629     (if (< ruleno nrules)
 630         (if (vector-ref ruleset ruleno)
 631             (let ((itemno (vector-ref rrhs ruleno)))
 632               (let loop2 ((c csp) (itemsetv2 itemsetv))
 633                 (if (and (pair? c)
 634                          (< (car c) itemno))
 635                     (loop2 (cdr c) (cons (car c) itemsetv2))
 636                     (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
 637             (loop (+ ruleno 1) csp itemsetv))
 638         (let loop2 ((c csp) (itemsetv2 itemsetv))
 639           (if (pair? c)
 640               (loop2 (cdr c) (cons (car c) itemsetv2))
 641               (reverse itemsetv2))))))
 642
 643
 644
 645 (define (allocate-item-sets)
 646   (set! kernel-base (make-vector nsyms 0))
 647   (set! kernel-end  (make-vector nsyms #f)))
 648
 649
 650 (define (allocate-storage)
 651   (allocate-item-sets)
 652   (set! red-set (make-vector (+ nrules 1) 0)))
 653
 654 ;; --
 655
 656
 657 (define (initialize-states)
 658   (let ((p (new-core)))
 659     (set-core-number! p 0)
 660     (set-core-acc-sym! p #f)
 661     (set-core-nitems! p 1)
 662     (set-core-items! p '(0))
 663
 664     (set! first-state (list p))
 665     (set! last-state first-state)
 666     (set! nstates 1)))
 667
 668
 669
 670 (define (generate-states)
 671   (allocate-storage)
 672   (set-fderives)
 673   (initialize-states)
 674   (let loop ((this-state first-state))
 675     (if (pair? this-state)
 676         (let* ((x (car this-state))
 677                (is (closure (core-items x))))
 678           (save-reductions x is)
 679           (new-itemsets is)
 680           (append-states)
 681           (if (> nshifts 0)
 682               (save-shifts x))
 683           (loop (cdr this-state))))))
 684
 685
 686 ;; Fonction calculant les symboles sur lesquels il faut "shifter"
 687 ;; et regroupe les items en fonction de ces symboles
 688
 689 (define (new-itemsets itemset)
 690   ;; - Initialization
 691   (set! shift-symbol '())
 692   (let loop ((i 0))
 693     (if (< i nsyms)
 694         (begin
 695           (vector-set! kernel-end i '())
 696           (loop (+ i 1)))))
 697
 698   (let loop ((isp itemset))
 699     (if (pair? isp)
 700         (let* ((i (car isp))
 701                (sym (vector-ref ritem i)))
 702           (if (>= sym 0)
 703               (begin
 704                 (set! shift-symbol (sinsert sym shift-symbol))
 705                 (let ((x (vector-ref kernel-end sym)))
 706                   (if (null? x)
 707                       (begin
 708                         (vector-set! kernel-base sym (cons (+ i 1) x))
 709                         (vector-set! kernel-end sym (vector-ref kernel-base sym)))
 710                       (begin
 711                         (set-cdr! x (list (+ i 1)))
 712                         (vector-set! kernel-end sym (cdr x)))))))
 713           (loop (cdr isp)))))
 714
 715   (set! nshifts (length shift-symbol)))
 716
 717
 718
 719 (define (get-state sym)
 720   (let* ((isp  (vector-ref kernel-base sym))
 721          (n    (length isp))
 722          (key  (let loop ((isp1 isp) (k 0))
 723                  (if (null? isp1)
 724                      (modulo k STATE-TABLE-SIZE)
 725                      (loop (cdr isp1) (+ k (car isp1))))))
 726          (sp   (vector-ref state-table key)))
 727     (if (null? sp)
 728         (let ((x (new-state sym)))
 729           (vector-set! state-table key (list x))
 730           (core-number x))
 731         (let loop ((sp1 sp))
 732           (if (and (= n (core-nitems (car sp1)))
 733                    (let loop2 ((i1 isp) (t (core-items (car sp1))))
 734                      (if (and (pair? i1)
 735                               (= (car i1)
 736                                  (car t)))
 737                          (loop2 (cdr i1) (cdr t))
 738                          (null? i1))))
 739               (core-number (car sp1))
 740               (if (null? (cdr sp1))
 741                   (let ((x (new-state sym)))
 742                     (set-cdr! sp1 (list x))
 743                     (core-number x))
 744                   (loop (cdr sp1))))))))
 745
 746
 747 (define (new-state sym)
 748   (let* ((isp  (vector-ref kernel-base sym))
 749          (n    (length isp))
 750          (p    (new-core)))
 751     (set-core-number! p nstates)
 752     (set-core-acc-sym! p sym)
 753     (if (= sym nvars) (set! final-state nstates))
 754     (set-core-nitems! p n)
 755     (set-core-items! p isp)
 756     (set-cdr! last-state (list p))
 757     (set! last-state (cdr last-state))
 758     (set! nstates (+ nstates 1))
 759     p))
 760
 761
 762 ;; --
 763
 764 (define (append-states)
 765   (set! shift-set
 766         (let loop ((l (reverse shift-symbol)))
 767           (if (null? l)
 768               '()
 769               (cons (get-state (car l)) (loop (cdr l)))))))
 770
 771 ;; --
 772
 773 (define (save-shifts core)
 774   (let ((p (new-shift)))
 775         (set-shift-number! p (core-number core))
 776         (set-shift-nshifts! p nshifts)
 777         (set-shift-shifts! p shift-set)
 778         (if last-shift
 779         (begin
 780           (set-cdr! last-shift (list p))
 781           (set! last-shift (cdr last-shift)))
 782         (begin
 783           (set! first-shift (list p))
 784           (set! last-shift first-shift)))))
 785
 786 (define (save-reductions core itemset)
 787   (let ((rs (let loop ((l itemset))
 788               (if (null? l)
 789                   '()
 790                   (let ((item (vector-ref ritem (car l))))
 791                     (if (< item 0)
 792                         (cons (- item) (loop (cdr l)))
 793                         (loop (cdr l))))))))
 794     (if (pair? rs)
 795         (let ((p (new-red)))
 796           (set-red-number! p (core-number core))
 797           (set-red-nreds!  p (length rs))
 798           (set-red-rules!  p rs)
 799           (if last-reduction
 800               (begin
 801                 (set-cdr! last-reduction (list p))
 802                 (set! last-reduction (cdr last-reduction)))
 803               (begin
 804                 (set! first-reduction (list p))
 805                 (set! last-reduction first-reduction)))))))
 806
 807
 808 ;; --
 809
 810 (define (lalr)
 811   (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
 812   (set-accessing-symbol)
 813   (set-shift-table)
 814   (set-reduction-table)
 815   (set-max-rhs)
 816   (initialize-LA)
 817   (set-goto-map)
 818   (initialize-F)
 819   (build-relations)
 820   (digraph includes)
 821   (compute-lookaheads))
 822
 823 (define (set-accessing-symbol)
 824   (set! acces-symbol (make-vector nstates #f))
 825   (let loop ((l first-state))
 826     (if (pair? l)
 827         (let ((x (car l)))
 828           (vector-set! acces-symbol (core-number x) (core-acc-sym x))
 829           (loop (cdr l))))))
 830
 831 (define (set-shift-table)
 832   (set! shift-table (make-vector nstates #f))
 833   (let loop ((l first-shift))
 834     (if (pair? l)
 835         (let ((x (car l)))
 836           (vector-set! shift-table (shift-number x) x)
 837           (loop (cdr l))))))
 838
 839 (define (set-reduction-table)
 840   (set! reduction-table (make-vector nstates #f))
 841   (let loop ((l first-reduction))
 842     (if (pair? l)
 843         (let ((x (car l)))
 844           (vector-set! reduction-table (red-number x) x)
 845           (loop (cdr l))))))
 846
 847 (define (set-max-rhs)
 848   (let loop ((p 0) (curmax 0) (length 0))
 849     (let ((x (vector-ref ritem p)))
 850       (if x
 851           (if (>= x 0)
 852               (loop (+ p 1) curmax (+ length 1))
 853               (loop (+ p 1) (max curmax length) 0))
 854           (set! maxrhs curmax)))))
 855
 856 (define (initialize-LA)
 857   (define (last l)
 858     (if (null? (cdr l))
 859         (car l)
 860         (last (cdr l))))
 861
 862   (set! consistent (make-vector nstates #f))
 863   (set! lookaheads (make-vector (+ nstates 1) #f))
 864
 865   (let loop ((count 0) (i 0))
 866     (if (< i nstates)
 867         (begin
 868           (vector-set! lookaheads i count)
 869           (let ((rp (vector-ref reduction-table i))
 870                 (sp (vector-ref shift-table i)))
 871             (if (and rp
 872                      (or (> (red-nreds rp) 1)
 873                          (and sp
 874                               (not
 875                                (< (vector-ref acces-symbol
 876                                               (last (shift-shifts sp)))
 877                                   nvars)))))
 878                 (loop (+ count (red-nreds rp)) (+ i 1))
 879                 (begin
 880                   (vector-set! consistent i #t)
 881                   (loop count (+ i 1))))))
 882
 883         (begin
 884           (vector-set! lookaheads nstates count)
 885           (let ((c (max count 1)))
 886             (set! LA (make-vector c #f))
 887             (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
 888             (set! LAruleno (make-vector c -1))
 889             (set! lookback (make-vector c #f)))
 890           (let loop ((i 0) (np 0))
 891             (if (< i nstates)
 892                 (if (vector-ref consistent i)
 893                     (loop (+ i 1) np)
 894                     (let ((rp (vector-ref reduction-table i)))
 895                       (if rp
 896                           (let loop2 ((j (red-rules rp)) (np2 np))
 897                             (if (null? j)
 898                                 (loop (+ i 1) np2)
 899                                 (begin
 900                                   (vector-set! LAruleno np2 (car j))
 901                                   (loop2 (cdr j) (+ np2 1)))))
 902                           (loop (+ i 1) np))))))))))
 903
 904
 905 (define (set-goto-map)
 906   (set! goto-map (make-vector (+ nvars 1) 0))
 907   (let ((temp-map (make-vector (+ nvars 1) 0)))
 908     (let loop ((ng 0) (sp first-shift))
 909       (if (pair? sp)
 910           (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
 911             (if (pair? i)
 912                 (let ((symbol (vector-ref acces-symbol (car i))))
 913                   (if (< symbol nvars)
 914                       (begin
 915                         (vector-set! goto-map symbol
 916                                      (+ 1 (vector-ref goto-map symbol)))
 917                         (loop2 (cdr i) (+ ng2 1)))
 918                       (loop2 (cdr i) ng2)))
 919                 (loop ng2 (cdr sp))))
 920
 921           (let loop ((k 0) (i 0))
 922             (if (< i nvars)
 923                 (begin
 924                   (vector-set! temp-map i k)
 925                   (loop (+ k (vector-ref goto-map i)) (+ i 1)))
 926
 927                 (begin
 928                   (do ((i 0 (+ i 1)))
 929                       ((>= i nvars))
 930                     (vector-set! goto-map i (vector-ref temp-map i)))
 931
 932                   (set! ngotos ng)
 933                   (vector-set! goto-map nvars ngotos)
 934                   (vector-set! temp-map nvars ngotos)
 935                   (set! from-state (make-vector ngotos #f))
 936                   (set! to-state (make-vector ngotos #f))
 937
 938                   (do ((sp first-shift (cdr sp)))
 939                       ((null? sp))
 940                     (let* ((x (car sp))
 941                            (state1 (shift-number x)))
 942                       (do ((i (shift-shifts x) (cdr i)))
 943                           ((null? i))
 944                         (let* ((state2 (car i))
 945                                (symbol (vector-ref acces-symbol state2)))
 946                           (if (< symbol nvars)
 947                               (let ((k (vector-ref temp-map symbol)))
 948                                 (vector-set! temp-map symbol (+ k 1))
 949                                 (vector-set! from-state k state1)
 950                                 (vector-set! to-state k state2))))))))))))))
 951
 952
 953 (define (map-goto state symbol)
 954   (let loop ((low (vector-ref goto-map symbol))
 955              (high (- (vector-ref goto-map (+ symbol 1)) 1)))
 956     (if (> low high)
 957         (begin
 958           (display (list "Error in map-goto" state symbol)) (newline)
 959           0)
 960         (let* ((middle (quotient (+ low high) 2))
 961                (s (vector-ref from-state middle)))
 962           (cond
 963            ((= s state)
 964             middle)
 965            ((< s state)
 966             (loop (+ middle 1) high))
 967            (else
 968             (loop low (- middle 1))))))))
 969
 970
 971 (define (initialize-F)
 972   (set! F (make-vector ngotos #f))
 973   (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
 974
 975   (let ((reads (make-vector ngotos #f)))
 976
 977     (let loop ((i 0) (rowp 0))
 978       (if (< i ngotos)
 979           (let* ((rowf (vector-ref F rowp))
 980                  (stateno (vector-ref to-state i))
 981                  (sp (vector-ref shift-table stateno)))
 982             (if sp
 983                 (let loop2 ((j (shift-shifts sp)) (edges '()))
 984                   (if (pair? j)
 985                       (let ((symbol (vector-ref acces-symbol (car j))))
 986                         (if (< symbol nvars)
 987                             (if (vector-ref nullable symbol)
 988                                 (loop2 (cdr j) (cons (map-goto stateno symbol)
 989                                                      edges))
 990                                 (loop2 (cdr j) edges))
 991                             (begin
 992                               (set-bit rowf (- symbol nvars))
 993                               (loop2 (cdr j) edges))))
 994                       (if (pair? edges)
 995                           (vector-set! reads i (reverse edges))))))
 996               (loop (+ i 1) (+ rowp 1)))))
 997     (digraph reads)))
 998
 999 (define (add-lookback-edge stateno ruleno gotono)
1000   (let ((k (vector-ref lookaheads (+ stateno 1))))
1001     (let loop ((found #f) (i (vector-ref lookaheads stateno)))
1002       (if (and (not found) (< i k))
1003           (if (= (vector-ref LAruleno i) ruleno)
1004               (loop #t i)
1005               (loop found (+ i 1)))
1006
1007           (if (not found)
1008               (begin (display "Error in add-lookback-edge : ")
1009                      (display (list stateno ruleno gotono)) (newline))
1010               (vector-set! lookback i
1011                            (cons gotono (vector-ref lookback i))))))))
1012
1013
1014 (define (transpose r-arg n)
1015   (let ((new-end (make-vector n #f))
1016         (new-R  (make-vector n #f)))
1017     (do ((i 0 (+ i 1)))
1018         ((= i n))
1019       (let ((x (list 'bidon)))
1020         (vector-set! new-R i x)
1021         (vector-set! new-end i x)))
1022     (do ((i 0 (+ i 1)))
1023         ((= i n))
1024       (let ((sp (vector-ref r-arg i)))
1025         (if (pair? sp)
1026             (let loop ((sp2 sp))
1027               (if (pair? sp2)
1028                   (let* ((x (car sp2))
1029                          (y (vector-ref new-end x)))
1030                     (set-cdr! y (cons i (cdr y)))
1031                     (vector-set! new-end x (cdr y))
1032                     (loop (cdr sp2))))))))
1033     (do ((i 0 (+ i 1)))
1034         ((= i n))
1035       (vector-set! new-R i (cdr (vector-ref new-R i))))
1036
1037     new-R))
1038
1039
1040
1041 (define (build-relations)
1042
1043   (define (get-state stateno symbol)
1044     (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
1045                (stno stateno))
1046       (if (null? j)
1047           stno
1048           (let ((st2 (car j)))
1049             (if (= (vector-ref acces-symbol st2) symbol)
1050                 st2
1051                 (loop (cdr j) st2))))))
1052
1053   (set! includes (make-vector ngotos #f))
1054   (do ((i 0 (+ i 1)))
1055       ((= i ngotos))
1056     (let ((state1 (vector-ref from-state i))
1057           (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
1058       (let loop ((rulep (vector-ref derives symbol1))
1059                  (edges '()))
1060         (if (pair? rulep)
1061             (let ((*rulep (car rulep)))
1062               (let loop2 ((rp (vector-ref rrhs *rulep))
1063                           (stateno state1)
1064                           (states (list state1)))
1065                 (let ((*rp (vector-ref ritem rp)))
1066                   (if (> *rp 0)
1067                       (let ((st (get-state stateno *rp)))
1068                         (loop2 (+ rp 1) st (cons st states)))
1069                       (begin
1070
1071                         (if (not (vector-ref consistent stateno))
1072                             (add-lookback-edge stateno *rulep i))
1073
1074                         (let loop2 ((done #f)
1075                                     (stp (cdr states))
1076                                     (rp2 (- rp 1))
1077                                     (edgp edges))
1078                           (if (not done)
1079                               (let ((*rp (vector-ref ritem rp2)))
1080                                 (if (< -1 *rp nvars)
1081                                   (loop2 (not (vector-ref nullable *rp))
1082                                          (cdr stp)
1083                                          (- rp2 1)
1084                                          (cons (map-goto (car stp) *rp) edgp))
1085                                   (loop2 #t stp rp2 edgp)))
1086
1087                               (loop (cdr rulep) edgp))))))))
1088             (vector-set! includes i edges)))))
1089   (set! includes (transpose includes ngotos)))
1090
1091
1092
1093 (define (compute-lookaheads)
1094   (let ((n (vector-ref lookaheads nstates)))
1095     (let loop ((i 0))
1096       (if (< i n)
1097           (let loop2 ((sp (vector-ref lookback i)))
1098             (if (pair? sp)
1099                 (let ((LA-i (vector-ref LA i))
1100                       (F-j  (vector-ref F (car sp))))
1101                   (bit-union LA-i F-j token-set-size)
1102                   (loop2 (cdr sp)))
1103                 (loop (+ i 1))))))))
1104
1105
1106
1107 (define (digraph relation)
1108   (define infinity (+ ngotos 2))
1109   (define INDEX (make-vector (+ ngotos 1) 0))
1110   (define VERTICES (make-vector (+ ngotos 1) 0))
1111   (define top 0)
1112   (define R relation)
1113
1114   (define (traverse i)
1115     (set! top (+ 1 top))
1116     (vector-set! VERTICES top i)
1117     (let ((height top))
1118       (vector-set! INDEX i height)
1119       (let ((rp (vector-ref R i)))
1120         (if (pair? rp)
1121             (let loop ((rp2 rp))
1122               (if (pair? rp2)
1123                   (let ((j (car rp2)))
1124                     (if (= 0 (vector-ref INDEX j))
1125                         (traverse j))
1126                     (if (> (vector-ref INDEX i)
1127                            (vector-ref INDEX j))
1128                         (vector-set! INDEX i (vector-ref INDEX j)))
1129                     (let ((F-i (vector-ref F i))
1130                           (F-j (vector-ref F j)))
1131                       (bit-union F-i F-j token-set-size))
1132                     (loop (cdr rp2))))))
1133         (if (= (vector-ref INDEX i) height)
1134             (let loop ()
1135               (let ((j (vector-ref VERTICES top)))
1136                 (set! top (- top 1))
1137                 (vector-set! INDEX j infinity)
1138                 (if (not (= i j))
1139                     (begin
1140                       (bit-union (vector-ref F i)
1141                                  (vector-ref F j)
1142                                  token-set-size)
1143                       (loop)))))))))
1144
1145   (let loop ((i 0))
1146     (if (< i ngotos)
1147         (begin
1148           (if (and (= 0 (vector-ref INDEX i))
1149                    (pair? (vector-ref R i)))
1150               (traverse i))
1151           (loop (+ i 1))))))
1152
1153
1154 ;; --
1155
1156 (define (build-tables)
1157   (define (add-action St Sym Act)
1158     (let* ((x (vector-ref ACTION-TABLE St))
1159            (y (assv Sym x)))
1160       (if y
1161           (if (not (= Act (cdr y)))
1162               ;; -- there is a conflict
1163               (begin
1164                 (if (and (<= (cdr y) 0)
1165                          (<= Act 0))
1166                     (begin
1167                       (display "%% Reduce/Reduce conflict ")
1168                       (display "(reduce ") (display (- Act))
1169                       (display ", reduce ") (display (- (cdr y)))
1170                       (display ") on ") (print-symbol (+ Sym nvars))
1171                       (display " in state ") (display St)
1172                       (newline)
1173                       (set-cdr! y (max (cdr y) Act)))
1174                     (begin
1175                       (display "%% Shift/Reduce conflict ")
1176                       (display "(shift ") (display Act)
1177                       (display ", reduce ") (display (- (cdr y)))
1178                       (display ") on ") (print-symbol (+ Sym nvars))
1179                       (display " in state ") (display St)
1180                       (newline)
1181                       (set-cdr! y Act)))))
1182           (vector-set! ACTION-TABLE St
1183                        (cons (cons Sym Act) x)))))
1184
1185   (set! action-table (make-vector nstates '()))
1186
1187   (do ((i 0 (+ i 1)))  ; i = state
1188       ((= i nstates))
1189     (let ((red (vector-ref reduction-table i)))
1190       (if (and red (>= (red-nreds red) 1))
1191           (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1192               (add-action i 'default (- (car (red-rules red))))
1193               (let ((k (vector-ref lookaheads (+ i 1))))
1194                 (let loop ((j (vector-ref lookaheads i)))
1195                   (if (< j k)
1196                       (let ((rule (- (vector-ref LAruleno j)))
1197                             (lav  (vector-ref LA j)))
1198                         (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1199                           (if (< token nterms)
1200                               (begin
1201                                 (let ((in-la-set? (modulo x 2)))
1202                                   (if (= in-la-set? 1)
1203                                       (add-action i token rule)))
1204                                 (if (= y (BITS-PER-WORD))
1205                                     (loop2 (+ token 1)
1206                                            (vector-ref lav (+ z 1))
1207                                            1
1208                                            (+ z 1))
1209                                     (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1210                         (loop (+ j 1)))))))))
1211
1212     (let ((shiftp (vector-ref shift-table i)))
1213       (if shiftp
1214           (let loop ((k (shift-shifts shiftp)))
1215             (if (pair? k)
1216                 (let* ((state (car k))
1217                        (symbol (vector-ref acces-symbol state)))
1218                   (if (>= symbol nvars)
1219                       (add-action i (- symbol nvars) state))
1220                   (loop (cdr k))))))))
1221
1222   (add-action final-state 0 'accept))
1223
1224 (define (compact-action-table)
1225   (define (most-common-action acts)
1226     (let ((accums '()))
1227       (let loop ((l acts))
1228         (if (pair? l)
1229             (let* ((x (cdar l))
1230                    (y (assv x accums)))
1231               (if (and (number? x) (< x 0))
1232                   (if y
1233                       (set-cdr! y (+ 1 (cdr y)))
1234                       (set! accums (cons `(,x . 1) accums))))
1235               (loop (cdr l)))))
1236
1237       (let loop ((l accums) (max 0) (sym #f))
1238         (if (null? l)
1239             sym
1240             (let ((x (car l)))
1241               (if (> (cdr x) max)
1242                   (loop (cdr l) (cdr x) (car x))
1243                   (loop (cdr l) max sym)))))))
1244
1245   (do ((i 0 (+ i 1)))
1246       ((= i nstates))
1247     (let ((acts (vector-ref action-table i)))
1248       (if (vector? (vector-ref reduction-table i))
1249           (let ((act (most-common-action acts)))
1250             (vector-set! action-table i
1251                          (cons `(default . ,(if act act 'error))
1252                                (filter (lambda (x)
1253                                          (not (eq? (cdr x) act)))
1254                                        acts))))
1255           (vector-set! action-table i
1256                        (cons `(default . *error*) acts))))))
1257
1258
1259 (define (output-action-table prefix)
1260   (display "(defconst ") (display prefix) (display "action-table") (newline)
1261   (display "  [") (newline)
1262   (do ((i 0 (+ i 1)))
1263       ((= i nstates))
1264     (display "     ")
1265     (write (vector-ref action-table i))
1266     (newline))
1267   (display "    ])") (newline)
1268   (newline))
1269
1270 (define (output-goto-table prefix)
1271   (display "(defconst ") (display prefix) (display "goto-table") (newline)
1272   (display "  [") (newline)
1273   (do ((i 0 (+ i 1)))
1274       ((= i nstates))
1275     (display "     ")
1276     (let ((shifts (vector-ref shift-table i)))
1277       (if shifts
1278           (begin
1279             (display "(")
1280             (let loop ((l (shift-shifts shifts)))
1281               (if (null? l)
1282                   (display ")")
1283                   (let* ((state (car l))
1284                          (symbol (vector-ref acces-symbol state)))
1285                     (if (< symbol nvars)
1286                         (display `(,symbol . ,state)))
1287                     (loop (cdr l))))))
1288           (display '())))
1289     (newline))
1290   (display "    ])") (newline)
1291   (newline))
1292
1293 (define (output-reduction-table gram/actions prefix)
1294   (display "(defconst ") (display prefix) (display "reduction-table") (newline)
1295   (display "  (vector") (newline)
1296   (display "    '()") (newline)
1297   (for-each
1298    (lambda (p)
1299      (let ((act (cdr p)))
1300        (display "    (lambda (stack sp goto-table $look)") (newline)
1301        (let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1302          (display "      (let* (")
1303          (if act
1304              (let loop ((i 1) (l rhs))
1305                (if (not (null? l))
1306                    (let ((rest (cdr l)))
1307                      (if (> i 1) (begin (newline) (display "             ")))
1308                      (display "($") (display (+ (- n i) 1)) (display " ")
1309                      (display "(aref stack (- sp ")
1310                      (display (- (* i 2) 1))
1311                      (display ")))")
1312                      (loop (+ i 1) rest)))))
1313          (display ")")
1314          (newline)
1315          (display "          ")
1316          (if (= nt 0)
1317              (display "(accept $1)")
1318              (begin
1319                (display "(lr-push stack (- sp ")
1320                (display (* 2 n))
1321                (display ") ")
1322                (display nt)
1323                (display " goto-table ")
1324                (write (cdr p))
1325                (display ")")))
1326          (display "))") (newline))))
1327    gram/Actions)
1328   (display "  ))") (newline)
1329   (newline))
1330
1331 (define (output-header header parser-prefix)
1332   (display header)
1333   (display "(require 'lr-driver)") (newline)
1334   (newline))
1335
1336 (define (output-footer footer)
1337   (display footer) (newline)
1338   (newline))
1339
1340 (define (output-parser-def parser-prefix prefix)
1341   (display "(defun ") (display parser-prefix) (display "parse") (display "(scanner errorhandler)") (newline)
1342   (display "  (lr-parse scanner errorhandler ") (newline)
1343   (display "    ") (display prefix) (display "action-table") (newline)
1344   (display "    ") (display prefix) (display "goto-table") (newline)
1345   (display "    ") (display prefix) (display "reduction-table") (newline)
1346   (display "    ") (display prefix) (display "token-defs))") (newline)
1347   (newline))
1348
1349 (define (output-token-defs terms prefix)
1350   (let loop ((i 0) (l terms))
1351     (if (pair? l)
1352         (let ((x (car l)))
1353           (display "(defconst ") (display prefix)
1354           (write x)
1355           (display #\tab)
1356           (display i)
1357           (display ")")
1358           (newline)
1359           (loop (+ i 1) (cdr l)))))
1360   (newline)
1361   (display "(defconst ") (display prefix) (display "token-defs") (newline)
1362   (display "  (list ") (newline)
1363   (let loop ((i 0) (l terms))
1364     (if (pair? l)
1365         (begin
1366           (display "   (cons ")
1367           (display i)
1368           (display " \"") (display (car l)) (display "\")")
1369           (newline)
1370           (loop (+ i 1) (cdr l)))))
1371   (display "  ))") (newline)
1372   (newline))
1373
1374 ;; --
1375
1376 (define (rewrite-grammar grammar proc)
1377
1378   (define eoi '*EOI*)
1379
1380   (if (not (pair? grammar))
1381       (error "Grammar definition must be a non-empty list")
1382       (let loop1 ((lst grammar) (rev-terms '()))
1383         (if (and (pair? lst) (not (pair? (car lst)))) ; definition d'un terminal?
1384             (let ((term (car lst)))
1385               (cond ((not (valid-terminal? term))
1386                      (error "Invalid terminal:" term))
1387                     ((member term rev-terms)
1388                      (error "Terminal previously defined:" term))
1389                     (else
1390                      (loop1 (cdr lst) (cons term rev-terms)))))
1391             (let loop2 ((lst lst) (rev-nonterm-defs '()))
1392               (if (pair? lst)
1393                   (let ((def (car lst)))
1394                     (if (not (pair? def))
1395                         (error "Nonterminal definition must be a non-empty list")
1396                         (let ((nonterm (car def)))
1397                           (cond ((not (valid-nonterminal? nonterm))
1398                                  (error "Invalid nonterminal:" nonterm))
1399                                 ((or (member nonterm rev-terms)
1400                                      (assoc nonterm rev-nonterm-defs))
1401                                  (error "Nonterminal previously defined:" nonterm))
1402                                 (else
1403                                  (loop2 (cdr lst)
1404                                         (cons def rev-nonterm-defs)))))))
1405                   (let* ((terms (cons eoi (reverse rev-terms)))
1406                          (nonterm-defs (reverse rev-nonterm-defs))
1407                          (nonterms (cons '*start* (map car nonterm-defs))))
1408                     (if (= (length nonterms) 1)
1409                         (error "Grammar must contain at least one nonterminal")
1410                         (let ((compiled-nonterminals
1411                                (map (lambda (nonterm-def)
1412                                       (rewrite-nonterm-def nonterm-def
1413                                                            terms
1414                                                            nonterms))
1415                                     (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1416                                           nonterm-defs))))
1417                           (proc terms
1418                                 nonterms
1419                                 (map (lambda (x) (cons (caaar x) (map cdar x)))
1420                                      compiled-nonterminals)
1421                                 (apply append compiled-nonterminals)))))))))))
1422
1423
1424 (define (rewrite-nonterm-def nonterm-def terms nonterms)
1425
1426   (define No-NT (length nonterms))
1427
1428   (define (encode x)
1429     (let ((PosInNT (pos-in-list x nonterms)))
1430       (if PosInNT
1431           PosInNT
1432           (let ((PosInT (pos-in-list x terms)))
1433             (if PosInT
1434                 (+ No-NT PosInT)
1435                 (error "undefined symbol : " x))))))
1436
1437   (if (not (pair? (cdr nonterm-def)))
1438       (error "At least one production needed for nonterminal" (car nonterm-def))
1439       (let ((name (symbol->string (car nonterm-def))))
1440         (let loop1 ((lst (cdr nonterm-def))
1441                     (i 1)
1442                     (rev-productions-and-actions '()))
1443           (if (not (pair? lst))
1444               (reverse rev-productions-and-actions)
1445               (let* ((rhs (car lst))
1446                      (rest (cdr lst))
1447                      (prod (map encode (cons (car nonterm-def) rhs))))
1448                 (for-each (lambda (x)
1449                             (if (not (or (member x terms) (member x nonterms)))
1450                                 (error "Invalid terminal or nonterminal" x)))
1451                           rhs)
1452                 (if (and (pair? rest)
1453                          (eq? (car rest) ':)
1454                          (pair? (cdr rest)))
1455                     (loop1 (cddr rest)
1456                            (+ i 1)
1457                            (cons (cons prod (cadr rest))
1458                                  rev-productions-and-actions))
1459                     (let* ((rhs-length (length rhs))
1460                            (action
1461                             (cons 'VECTOR
1462                                  (cons (list 'QUOTE (string->symbol
1463                                                      (string-append
1464                                                       name
1465                                                       "-"
1466                                                       (number->string i))))
1467                                        (let loop-j ((j 1))
1468                                          (if (> j rhs-length)
1469                                              '()
1470                                              (cons (string->symbol
1471                                                     (string-append
1472                                                      "$"
1473                                                      (number->string j)))
1474                                                    (loop-j (+ j 1)))))))))
1475                       (loop1 rest
1476                              (+ i 1)
1477                              (cons (cons prod action)
1478                                    rev-productions-and-actions))))))))))
1479
1480 (define (valid-nonterminal? x)
1481   (symbol? x))
1482
1483 (define (valid-terminal? x)
1484   (symbol? x))              ; DB
1485
1486 ;; ---------------------------------------------------------------------- ;;
1487 ;; Miscellaneous                                                          ;;
1488 ;; ---------------------------------------------------------------------- ;;
1489 (define (pos-in-list x lst)
1490   (let loop ((lst lst) (i 0))
1491     (cond ((not (pair? lst))    #f)
1492           ((equal? (car lst) x) i)
1493           (else                 (loop (cdr lst) (+ i 1))))))
1494
1495 (define (sunion lst1 lst2)              ; union of sorted lists
1496   (let loop ((L1 lst1)
1497              (L2 lst2))
1498     (cond ((null? L1)    L2)
1499           ((null? L2)    L1)
1500           (else
1501            (let ((x (car L1)) (y (car L2)))
1502              (cond
1503               ((> x y)
1504                (cons y (loop L1 (cdr L2))))
1505               ((< x y)
1506                (cons x (loop (cdr L1) L2)))
1507               (else
1508                (loop (cdr L1) L2))
1509               ))))))
1510
1511 (define (sinsert elem lst)
1512   (let loop ((l1 lst))
1513     (if (null? l1)
1514         (cons elem l1)
1515         (let ((x (car l1)))
1516           (cond ((< elem x)
1517                  (cons elem l1))
1518                 ((> elem x)
1519                  (cons x (loop (cdr l1))))
1520                 (else
1521                  l1))))))
1522
1523 (define (filter p lst)
1524   (let loop ((l lst))
1525     (if (null? l)
1526         '()
1527         (let ((x (car l)) (y (cdr l)))
1528         (if (p x)
1529             (cons x (loop y))
1530             (loop y))))))
1531
1532 ;; ---------------------------------------------------------------------- ;;
1533 ;; Debugging tools ...                                                    ;;
1534 ;; ---------------------------------------------------------------------- ;;
1535 (define the-terminals #f)
1536 (define the-nonterminals #f)
1537
1538 (define (print-item item-no)
1539   (let loop ((i item-no))
1540     (let ((v (vector-ref ritem i)))
1541       (if (>= v 0)
1542           (loop (+ i 1))
1543           (let* ((rlno    (- v))
1544                  (nt      (vector-ref rlhs rlno)))
1545             (display (vector-ref the-nonterminals nt)) (display " --> ")
1546             (let loop ((i (vector-ref rrhs rlno)))
1547               (let ((v (vector-ref ritem i)))
1548                 (if (= i item-no)
1549                     (display ". "))
1550                 (if (>= v 0)
1551                     (begin
1552                       (print-symbol v)
1553                       (display " ")
1554                       (loop (+ i 1)))
1555                     (begin
1556                       (display "   (rule ")
1557                       (display (- v))
1558                       (display ")")
1559                       (newline))))))))))
1560
1561 (define (print-symbol n)
1562   (display (if (>= n nvars)
1563                (vector-ref the-terminals (- n nvars))
1564                (vector-ref the-nonterminals n))))
1565
1566 (define (print-states)
1567   (define (print-action act)
1568     (cond
1569      ((eq? act '*error*)
1570       (display " : Error"))
1571      ((eq? act 'accept)
1572       (display " : Accept input"))
1573      ((< act 0)
1574       (display " : reduce using rule ")
1575       (display (- act)))
1576      (else
1577       (display " : shift and goto state ")
1578       (display act)))
1579     (newline)
1580     #t)
1581
1582   (define (print-actions acts)
1583     (let loop ((l acts))
1584       (if (null? l)
1585           #t
1586           (let ((sym (caar l))
1587                 (act (cdar l)))
1588             (display "   ")
1589             (cond
1590              ((eq? sym 'default)
1591               (display "default action"))
1592              (else
1593               (print-symbol (+ sym nvars))))
1594             (print-action act)
1595             (loop (cdr l))))))
1596
1597   (if (not action-table)
1598       (begin
1599         (display "No generated parser available!")
1600         (newline)
1601         #f)
1602       (begin
1603         (display "State table") (newline)
1604         (display "-----------") (newline) (newline)
1605
1606         (let loop ((l first-state))
1607           (if (null? l)
1608               #t
1609               (let* ((core  (car l))
1610                      (i     (core-number core))
1611                      (items (core-items core))
1612                      (actions (vector-ref action-table i)))
1613                 (display "state ") (display i) (newline)
1614                 (newline)
1615                 (for-each (lambda (x) (display "   ") (print-item x))
1616                           items)
1617                 (newline)
1618                 (print-actions actions)
1619                 (newline)
1620                 (loop (cdr l))))))))
1621
1622
1623