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
 312 (define (gen-lalr1 gram output-file header footer . opt)
 313   (initialize-all)
 314   (rewrite-grammar
 315    gram
 316    (lambda (terms vars gram gram/actions)
 317      (set! the-terminals (list->vector terms))
 318      (set! the-nonterminals (list->vector vars))
 319      (set! nterms (length terms))
 320      (set! nvars  (length vars))
 321      (set! nsyms  (+ nterms nvars))
 322      (let ((no-of-rules (length gram/actions))
 323            (no-of-items (let loop ((l gram/actions) (count 0))
 324                           (if (null? l)
 325                               count
 326                               (loop (cdr l) (+ count (length (caar l))))))))
 327        (pack-grammar no-of-rules no-of-items gram)
 328        (set-derives)
 329        (set-nullable)
 330        (generate-states)
 331        (lalr)
 332        (build-tables)
 333        (compact-action-table)
 334        (let* ((parser-name (if (and (pair? opt) (symbol? (car opt))) (car opt) #f))
 335               (prefix      (if parser-name
 336                                (string-append
 337                                 (symbol->string parser-name)
 338                                 ":")
 339                                ""))
 340               (parser-prefix (if parser-name
 341                                   (string-append (symbol->string parser-name) "-")
 342                                  "")))
 343          (with-output-to-file output-file
 344            (lambda ()
 345              (display "; *** Header ***")
 346              (newline)
 347              (output-header header parser-prefix)
 348              (display "; *** Token Definitions ***")
 349              (newline)
 350              (output-token-defs terms prefix)
 351              (display "; *** Action Table ***")
 352              (newline)
 353              (output-action-table prefix)
 354              (display "; *** Goto Table ***")
 355              (newline)
 356              (output-goto-table prefix)
 357              (display "; *** Reduction Table ***")
 358              (newline)
 359              (output-reduction-table gram/actions prefix)
 360              (display "; *** Parser Definition ***")
 361              (newline)
 362              (output-parser-def parser-prefix prefix)
 363              (display "; *** Footer ***")
 364              (newline)
 365              (output-footer footer)
 366              )))))))
 367
 368
 369 (define (initialize-all)
 370   (set! rrhs         #f)
 371   (set! rlhs         #f)
 372   (set! ritem        #f)
 373   (set! nullable     #f)
 374   (set! derives      #f)
 375   (set! fderives     #f)
 376   (set! firsts       #f)
 377   (set! kernel-base  #f)
 378   (set! kernel-end   #f)
 379   (set! shift-symbol #f)
 380   (set! shift-set    #f)
 381   (set! red-set      #f)
 382   (set! state-table  (make-vector STATE-TABLE-SIZE '()))
 383   (set! acces-symbol #f)
 384   (set! reduction-table #f)
 385   (set! shift-table  #f)
 386   (set! consistent   #f)
 387   (set! lookaheads   #f)
 388   (set! LA           #f)
 389   (set! LAruleno     #f)
 390   (set! lookback     #f)
 391   (set! goto-map     #f)
 392   (set! from-state   #f)
 393   (set! to-state     #f)
 394   (set! includes     #f)
 395   (set! F            #f)
 396   (set! action-table #f)
 397   (set! nstates         #f)
 398   (set! first-state     #f)
 399   (set! last-state      #f)
 400   (set! final-state     #f)
 401   (set! first-shift     #f)
 402   (set! last-shift      #f)
 403   (set! first-reduction #f)
 404   (set! last-reduction  #f)
 405   (set! nshifts         #f)
 406   (set! maxrhs          #f)
 407   (set! ngotos          #f)
 408   (set! token-set-size  #f))
 409
 410
 411 (define (pack-grammar no-of-rules no-of-items gram)
 412   (set! nrules (+  no-of-rules 1))
 413   (set! nitems no-of-items)
 414   (set! rlhs (make-vector nrules #f))
 415   (set! rrhs (make-vector nrules #f))
 416   (set! ritem (make-vector (+ 1 nitems) #f))
 417
 418   (let loop ((p gram) (item-no 0) (rule-no 1))
 419         (if (not (null? p))
 420         (let ((nt (caar p)))
 421           (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
 422                 (if (null? prods)
 423                 (loop (cdr p) it-no2 rl-no2)
 424                 (begin
 425                   (vector-set! rlhs rl-no2 nt)
 426                   (vector-set! rrhs rl-no2 it-no2)
 427                   (let loop3 ((rhs (car prods)) (it-no3 it-no2))
 428                         (if (null? rhs)
 429                         (begin
 430                           (vector-set! ritem it-no3 (- rl-no2))
 431                           (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
 432                         (begin
 433                           (vector-set! ritem it-no3 (car rhs))
 434                           (loop3 (cdr rhs) (+ it-no3 1))))))))))))
 435
 436
 437 ;; Fonction set-derives
 438 ;; --------------------
 439 (define (set-derives)
 440   (define delts (make-vector (+ nrules 1) 0))
 441   (define dset  (make-vector nvars -1))
 442
 443   (let loop ((i 1) (j 0))               ; i = 0
 444     (if (< i nrules)
 445         (let ((lhs (vector-ref rlhs i)))
 446           (if (>= lhs 0)
 447               (begin
 448                 (vector-set! delts j (cons i (vector-ref dset lhs)))
 449                 (vector-set! dset lhs j)
 450                 (loop (+ i 1) (+ j 1)))
 451               (loop (+ i 1) j)))))
 452
 453   (set! derives (make-vector nvars 0))
 454
 455   (let loop ((i 0))
 456     (if (< i nvars)
 457         (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
 458                    (if (< j 0)
 459                        s
 460                        (let ((x (vector-ref delts j)))
 461                          (loop2 (cdr x) (cons (car x) s)))))))
 462           (vector-set! derives i q)
 463           (loop (+ i 1))))))
 464
 465
 466
 467 (define (set-nullable)
 468   (set! nullable (make-vector nvars #f))
 469   (let ((squeue (make-vector nvars #f))
 470         (rcount (make-vector (+ nrules 1) 0))
 471         (rsets  (make-vector nvars #f))
 472         (relts  (make-vector (+ nitems nvars 1) #f)))
 473     (let loop ((r 0) (s2 0) (p 0))
 474       (let ((*r (vector-ref ritem r)))
 475         (if *r
 476             (if (< *r 0)
 477                 (let ((symbol (vector-ref rlhs (- *r))))
 478                   (if (and (>= symbol 0)
 479                            (not (vector-ref nullable symbol)))
 480                       (begin
 481                         (vector-set! nullable symbol #t)
 482                         (vector-set! squeue s2 symbol)
 483                         (loop (+ r 1) (+ s2 1) p))))
 484                 (let loop2 ((r1 r) (any-tokens #f))
 485                   (let* ((symbol (vector-ref ritem r1)))
 486                     (if (> symbol 0)
 487                         (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
 488                         (if (not any-tokens)
 489                             (let ((ruleno (- symbol)))
 490                               (let loop3 ((r2 r) (p2 p))
 491                                 (let ((symbol (vector-ref ritem r2)))
 492                                   (if (> symbol 0)
 493                                       (begin
 494                                         (vector-set! rcount ruleno
 495                                                      (+ (vector-ref rcount ruleno) 1))
 496                                         (vector-set! relts p2
 497                                                      (cons (vector-ref rsets symbol)
 498                                                            ruleno))
 499                                         (vector-set! rsets symbol p2)
 500                                         (loop3 (+ r2 1) (+ p2 1)))
 501                                       (loop (+ r2 1) s2 p2)))))
 502                             (loop (+ r1 1) s2 p))))))
 503             (let loop ((s1 0) (s3 s2))
 504               (if (< s1 s3)
 505                   (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
 506                     (if p
 507                         (let* ((x (vector-ref relts p))
 508                                (ruleno (cdr x))
 509                                (y (- (vector-ref rcount ruleno) 1)))
 510                           (vector-set! rcount ruleno y)
 511                           (if (= y 0)
 512                               (let ((symbol (vector-ref rlhs ruleno)))
 513                                 (if (and (>= symbol 0)
 514                                          (not (vector-ref nullable symbol)))
 515                                     (begin
 516                                       (vector-set! nullable symbol #t)
 517                                       (vector-set! squeue s4 symbol)
 518                                       (loop2 (car x) (+ s4 1)))
 519                                     (loop2 (car x) s4)))
 520                               (loop2 (car x) s4))))
 521                     (loop (+ s1 1) s4)))))))))
 522
 523
 524
 525 ; Fonction set-firsts qui calcule un tableau de taille
 526 ; nvars et qui donne, pour chaque non-terminal X, une liste des
 527 ; non-terminaux pouvant apparaitre au debut d'une derivation a
 528 ; partir de X.
 529
 530 (define (set-firsts)
 531   (set! firsts (make-vector nvars '()))
 532
 533   ;; -- initialization
 534   (let loop ((i 0))
 535     (if (< i nvars)
 536         (let loop2 ((sp (vector-ref derives i)))
 537           (if (null? sp)
 538               (loop (+ i 1))
 539               (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
 540                 (if (< -1 sym nvars)
 541                     (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
 542                 (loop2 (cdr sp)))))))
 543
 544   ;; -- reflexive and transitive closure
 545   (let loop ((continue #t))
 546     (if continue
 547         (let loop2 ((i 0) (cont #f))
 548           (if (>= i nvars)
 549               (loop cont)
 550               (let* ((x (vector-ref firsts i))
 551                      (y (let loop3 ((l x) (z x))
 552                           (if (null? l)
 553                               z
 554                               (loop3 (cdr l)
 555                                      (sunion (vector-ref firsts (car l)) z))))))
 556                 (if (equal? x y)
 557                     (loop2 (+ i 1) cont)
 558                     (begin
 559                       (vector-set! firsts i y)
 560                       (loop2 (+ i 1) #t))))))))
 561
 562   (let loop ((i 0))
 563     (if (< i nvars)
 564         (begin
 565           (vector-set! firsts i (sinsert i (vector-ref firsts i)))
 566           (loop (+ i 1))))))
 567
 568
 569
 570
 571 ; Fonction set-fderives qui calcule un tableau de taille
 572 ; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
 573 ; etre derivees a partir de ce non-terminal. (se sert de firsts)
 574
 575 (define (set-fderives)
 576   (set! fderives (make-vector nvars #f))
 577
 578   (set-firsts)
 579
 580   (let loop ((i 0))
 581     (if (< i nvars)
 582         (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
 583                    (if (null? l)
 584                        fd
 585                        (loop2 (cdr l)
 586                               (sunion (vector-ref derives (car l)) fd))))))
 587           (vector-set! fderives i x)
 588           (loop (+ i 1))))))
 589
 590
 591 ; Fonction calculant la fermeture d'un ensemble d'items LR0
 592 ; ou core est une liste d'items
 593
 594 (define (closure core)
 595   ;; Initialization
 596   (define ruleset (make-vector nrules #f))
 597
 598   (let loop ((csp core))
 599     (if (not (null? csp))
 600         (let ((sym (vector-ref ritem (car csp))))
 601           (if (< -1 sym nvars)
 602               (let loop2 ((dsp (vector-ref fderives sym)))
 603                 (if (not (null? dsp))
 604                     (begin
 605                       (vector-set! ruleset (car dsp) #t)
 606                       (loop2 (cdr dsp))))))
 607           (loop (cdr csp)))))
 608
 609   (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
 610     (if (< ruleno nrules)
 611         (if (vector-ref ruleset ruleno)
 612             (let ((itemno (vector-ref rrhs ruleno)))
 613               (let loop2 ((c csp) (itemsetv2 itemsetv))
 614                 (if (and (pair? c)
 615                          (< (car c) itemno))
 616                     (loop2 (cdr c) (cons (car c) itemsetv2))
 617                     (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
 618             (loop (+ ruleno 1) csp itemsetv))
 619         (let loop2 ((c csp) (itemsetv2 itemsetv))
 620           (if (pair? c)
 621               (loop2 (cdr c) (cons (car c) itemsetv2))
 622               (reverse itemsetv2))))))
 623
 624
 625
 626 (define (allocate-item-sets)
 627   (set! kernel-base (make-vector nsyms 0))
 628   (set! kernel-end  (make-vector nsyms #f)))
 629
 630
 631 (define (allocate-storage)
 632   (allocate-item-sets)
 633   (set! red-set (make-vector (+ nrules 1) 0)))
 634
 635 ;; --
 636
 637
 638 (define (initialize-states)
 639   (let ((p (new-core)))
 640     (set-core-number! p 0)
 641     (set-core-acc-sym! p #f)
 642     (set-core-nitems! p 1)
 643     (set-core-items! p '(0))
 644
 645     (set! first-state (list p))
 646     (set! last-state first-state)
 647     (set! nstates 1)))
 648
 649
 650
 651 (define (generate-states)
 652   (allocate-storage)
 653   (set-fderives)
 654   (initialize-states)
 655   (let loop ((this-state first-state))
 656     (if (pair? this-state)
 657         (let* ((x (car this-state))
 658                (is (closure (core-items x))))
 659           (save-reductions x is)
 660           (new-itemsets is)
 661           (append-states)
 662           (if (> nshifts 0)
 663               (save-shifts x))
 664           (loop (cdr this-state))))))
 665
 666
 667 ;; Fonction calculant les symboles sur lesquels il faut "shifter"
 668 ;; et regroupe les items en fonction de ces symboles
 669
 670 (define (new-itemsets itemset)
 671   ;; - Initialization
 672   (set! shift-symbol '())
 673   (let loop ((i 0))
 674     (if (< i nsyms)
 675         (begin
 676           (vector-set! kernel-end i '())
 677           (loop (+ i 1)))))
 678
 679   (let loop ((isp itemset))
 680     (if (pair? isp)
 681         (let* ((i (car isp))
 682                (sym (vector-ref ritem i)))
 683           (if (>= sym 0)
 684               (begin
 685                 (set! shift-symbol (sinsert sym shift-symbol))
 686                 (let ((x (vector-ref kernel-end sym)))
 687                   (if (null? x)
 688                       (begin
 689                         (vector-set! kernel-base sym (cons (+ i 1) x))
 690                         (vector-set! kernel-end sym (vector-ref kernel-base sym)))
 691                       (begin
 692                         (set-cdr! x (list (+ i 1)))
 693                         (vector-set! kernel-end sym (cdr x)))))))
 694           (loop (cdr isp)))))
 695
 696   (set! nshifts (length shift-symbol)))
 697
 698
 699
 700 (define (get-state sym)
 701   (let* ((isp  (vector-ref kernel-base sym))
 702          (n    (length isp))
 703          (key  (let loop ((isp1 isp) (k 0))
 704                  (if (null? isp1)
 705                      (modulo k STATE-TABLE-SIZE)
 706                      (loop (cdr isp1) (+ k (car isp1))))))
 707          (sp   (vector-ref state-table key)))
 708     (if (null? sp)
 709         (let ((x (new-state sym)))
 710           (vector-set! state-table key (list x))
 711           (core-number x))
 712         (let loop ((sp1 sp))
 713           (if (and (= n (core-nitems (car sp1)))
 714                    (let loop2 ((i1 isp) (t (core-items (car sp1))))
 715                      (if (and (pair? i1)
 716                               (= (car i1)
 717                                  (car t)))
 718                          (loop2 (cdr i1) (cdr t))
 719                          (null? i1))))
 720               (core-number (car sp1))
 721               (if (null? (cdr sp1))
 722                   (let ((x (new-state sym)))
 723                     (set-cdr! sp1 (list x))
 724                     (core-number x))
 725                   (loop (cdr sp1))))))))
 726
 727
 728 (define (new-state sym)
 729   (let* ((isp  (vector-ref kernel-base sym))
 730          (n    (length isp))
 731          (p    (new-core)))
 732     (set-core-number! p nstates)
 733     (set-core-acc-sym! p sym)
 734     (if (= sym nvars) (set! final-state nstates))
 735     (set-core-nitems! p n)
 736     (set-core-items! p isp)
 737     (set-cdr! last-state (list p))
 738     (set! last-state (cdr last-state))
 739     (set! nstates (+ nstates 1))
 740     p))
 741
 742
 743 ;; --
 744
 745 (define (append-states)
 746   (set! shift-set
 747         (let loop ((l (reverse shift-symbol)))
 748           (if (null? l)
 749               '()
 750               (cons (get-state (car l)) (loop (cdr l)))))))
 751
 752 ;; --
 753
 754 (define (save-shifts core)
 755   (let ((p (new-shift)))
 756         (set-shift-number! p (core-number core))
 757         (set-shift-nshifts! p nshifts)
 758         (set-shift-shifts! p shift-set)
 759         (if last-shift
 760         (begin
 761           (set-cdr! last-shift (list p))
 762           (set! last-shift (cdr last-shift)))
 763         (begin
 764           (set! first-shift (list p))
 765           (set! last-shift first-shift)))))
 766
 767 (define (save-reductions core itemset)
 768   (let ((rs (let loop ((l itemset))
 769               (if (null? l)
 770                   '()
 771                   (let ((item (vector-ref ritem (car l))))
 772                     (if (< item 0)
 773                         (cons (- item) (loop (cdr l)))
 774                         (loop (cdr l))))))))
 775     (if (pair? rs)
 776         (let ((p (new-red)))
 777           (set-red-number! p (core-number core))
 778           (set-red-nreds!  p (length rs))
 779           (set-red-rules!  p rs)
 780           (if last-reduction
 781               (begin
 782                 (set-cdr! last-reduction (list p))
 783                 (set! last-reduction (cdr last-reduction)))
 784               (begin
 785                 (set! first-reduction (list p))
 786                 (set! last-reduction first-reduction)))))))
 787
 788
 789 ;; --
 790
 791 (define (lalr)
 792   (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
 793   (set-accessing-symbol)
 794   (set-shift-table)
 795   (set-reduction-table)
 796   (set-max-rhs)
 797   (initialize-LA)
 798   (set-goto-map)
 799   (initialize-F)
 800   (build-relations)
 801   (digraph includes)
 802   (compute-lookaheads))
 803
 804 (define (set-accessing-symbol)
 805   (set! acces-symbol (make-vector nstates #f))
 806   (let loop ((l first-state))
 807     (if (pair? l)
 808         (let ((x (car l)))
 809           (vector-set! acces-symbol (core-number x) (core-acc-sym x))
 810           (loop (cdr l))))))
 811
 812 (define (set-shift-table)
 813   (set! shift-table (make-vector nstates #f))
 814   (let loop ((l first-shift))
 815     (if (pair? l)
 816         (let ((x (car l)))
 817           (vector-set! shift-table (shift-number x) x)
 818           (loop (cdr l))))))
 819
 820 (define (set-reduction-table)
 821   (set! reduction-table (make-vector nstates #f))
 822   (let loop ((l first-reduction))
 823     (if (pair? l)
 824         (let ((x (car l)))
 825           (vector-set! reduction-table (red-number x) x)
 826           (loop (cdr l))))))
 827
 828 (define (set-max-rhs)
 829   (let loop ((p 0) (curmax 0) (length 0))
 830     (let ((x (vector-ref ritem p)))
 831       (if x
 832           (if (>= x 0)
 833               (loop (+ p 1) curmax (+ length 1))
 834               (loop (+ p 1) (max curmax length) 0))
 835           (set! maxrhs curmax)))))
 836
 837 (define (initialize-LA)
 838   (define (last l)
 839     (if (null? (cdr l))
 840         (car l)
 841         (last (cdr l))))
 842
 843   (set! consistent (make-vector nstates #f))
 844   (set! lookaheads (make-vector (+ nstates 1) #f))
 845
 846   (let loop ((count 0) (i 0))
 847     (if (< i nstates)
 848         (begin
 849           (vector-set! lookaheads i count)
 850           (let ((rp (vector-ref reduction-table i))
 851                 (sp (vector-ref shift-table i)))
 852             (if (and rp
 853                      (or (> (red-nreds rp) 1)
 854                          (and sp
 855                               (not
 856                                (< (vector-ref acces-symbol
 857                                               (last (shift-shifts sp)))
 858                                   nvars)))))
 859                 (loop (+ count (red-nreds rp)) (+ i 1))
 860                 (begin
 861                   (vector-set! consistent i #t)
 862                   (loop count (+ i 1))))))
 863
 864         (begin
 865           (vector-set! lookaheads nstates count)
 866           (let ((c (max count 1)))
 867             (set! LA (make-vector c #f))
 868             (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
 869             (set! LAruleno (make-vector c -1))
 870             (set! lookback (make-vector c #f)))
 871           (let loop ((i 0) (np 0))
 872             (if (< i nstates)
 873                 (if (vector-ref consistent i)
 874                     (loop (+ i 1) np)
 875                     (let ((rp (vector-ref reduction-table i)))
 876                       (if rp
 877                           (let loop2 ((j (red-rules rp)) (np2 np))
 878                             (if (null? j)
 879                                 (loop (+ i 1) np2)
 880                                 (begin
 881                                   (vector-set! LAruleno np2 (car j))
 882                                   (loop2 (cdr j) (+ np2 1)))))
 883                           (loop (+ i 1) np))))))))))
 884
 885
 886 (define (set-goto-map)
 887   (set! goto-map (make-vector (+ nvars 1) 0))
 888   (let ((temp-map (make-vector (+ nvars 1) 0)))
 889     (let loop ((ng 0) (sp first-shift))
 890       (if (pair? sp)
 891           (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
 892             (if (pair? i)
 893                 (let ((symbol (vector-ref acces-symbol (car i))))
 894                   (if (< symbol nvars)
 895                       (begin
 896                         (vector-set! goto-map symbol
 897                                      (+ 1 (vector-ref goto-map symbol)))
 898                         (loop2 (cdr i) (+ ng2 1)))
 899                       (loop2 (cdr i) ng2)))
 900                 (loop ng2 (cdr sp))))
 901
 902           (let loop ((k 0) (i 0))
 903             (if (< i nvars)
 904                 (begin
 905                   (vector-set! temp-map i k)
 906                   (loop (+ k (vector-ref goto-map i)) (+ i 1)))
 907
 908                 (begin
 909                   (do ((i 0 (+ i 1)))
 910                       ((>= i nvars))
 911                     (vector-set! goto-map i (vector-ref temp-map i)))
 912
 913                   (set! ngotos ng)
 914                   (vector-set! goto-map nvars ngotos)
 915                   (vector-set! temp-map nvars ngotos)
 916                   (set! from-state (make-vector ngotos #f))
 917                   (set! to-state (make-vector ngotos #f))
 918
 919                   (do ((sp first-shift (cdr sp)))
 920                       ((null? sp))
 921                     (let* ((x (car sp))
 922                            (state1 (shift-number x)))
 923                       (do ((i (shift-shifts x) (cdr i)))
 924                           ((null? i))
 925                         (let* ((state2 (car i))
 926                                (symbol (vector-ref acces-symbol state2)))
 927                           (if (< symbol nvars)
 928                               (let ((k (vector-ref temp-map symbol)))
 929                                 (vector-set! temp-map symbol (+ k 1))
 930                                 (vector-set! from-state k state1)
 931                                 (vector-set! to-state k state2))))))))))))))
 932
 933
 934 (define (map-goto state symbol)
 935   (let loop ((low (vector-ref goto-map symbol))
 936              (high (- (vector-ref goto-map (+ symbol 1)) 1)))
 937     (if (> low high)
 938         (begin
 939           (display (list "Error in map-goto" state symbol)) (newline)
 940           0)
 941         (let* ((middle (quotient (+ low high) 2))
 942                (s (vector-ref from-state middle)))
 943           (cond
 944            ((= s state)
 945             middle)
 946            ((< s state)
 947             (loop (+ middle 1) high))
 948            (else
 949             (loop low (- middle 1))))))))
 950
 951
 952 (define (initialize-F)
 953   (set! F (make-vector ngotos #f))
 954   (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
 955
 956   (let ((reads (make-vector ngotos #f)))
 957
 958     (let loop ((i 0) (rowp 0))
 959       (if (< i ngotos)
 960           (let* ((rowf (vector-ref F rowp))
 961                  (stateno (vector-ref to-state i))
 962                  (sp (vector-ref shift-table stateno)))
 963             (if sp
 964                 (let loop2 ((j (shift-shifts sp)) (edges '()))
 965                   (if (pair? j)
 966                       (let ((symbol (vector-ref acces-symbol (car j))))
 967                         (if (< symbol nvars)
 968                             (if (vector-ref nullable symbol)
 969                                 (loop2 (cdr j) (cons (map-goto stateno symbol)
 970                                                      edges))
 971                                 (loop2 (cdr j) edges))
 972                             (begin
 973                               (set-bit rowf (- symbol nvars))
 974                               (loop2 (cdr j) edges))))
 975                       (if (pair? edges)
 976                           (vector-set! reads i (reverse edges))))))
 977               (loop (+ i 1) (+ rowp 1)))))
 978     (digraph reads)))
 979
 980 (define (add-lookback-edge stateno ruleno gotono)
 981   (let ((k (vector-ref lookaheads (+ stateno 1))))
 982     (let loop ((found #f) (i (vector-ref lookaheads stateno)))
 983       (if (and (not found) (< i k))
 984           (if (= (vector-ref LAruleno i) ruleno)
 985               (loop #t i)
 986               (loop found (+ i 1)))
 987
 988           (if (not found)
 989               (begin (display "Error in add-lookback-edge : ")
 990                      (display (list stateno ruleno gotono)) (newline))
 991               (vector-set! lookback i
 992                            (cons gotono (vector-ref lookback i))))))))
 993
 994
 995 (define (transpose r-arg n)
 996   (let ((new-end (make-vector n #f))
 997         (new-R  (make-vector n #f)))
 998     (do ((i 0 (+ i 1)))
 999         ((= i n))
1000       (let ((x (list 'bidon)))
1001         (vector-set! new-R i x)
1002         (vector-set! new-end i x)))
1003     (do ((i 0 (+ i 1)))
1004         ((= i n))
1005       (let ((sp (vector-ref r-arg i)))
1006         (if (pair? sp)
1007             (let loop ((sp2 sp))
1008               (if (pair? sp2)
1009                   (let* ((x (car sp2))
1010                          (y (vector-ref new-end x)))
1011                     (set-cdr! y (cons i (cdr y)))
1012                     (vector-set! new-end x (cdr y))
1013                     (loop (cdr sp2))))))))
1014     (do ((i 0 (+ i 1)))
1015         ((= i n))
1016       (vector-set! new-R i (cdr (vector-ref new-R i))))
1017
1018     new-R))
1019
1020
1021
1022 (define (build-relations)
1023
1024   (define (get-state stateno symbol)
1025     (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
1026                (stno stateno))
1027       (if (null? j)
1028           stno
1029           (let ((st2 (car j)))
1030             (if (= (vector-ref acces-symbol st2) symbol)
1031                 st2
1032                 (loop (cdr j) st2))))))
1033
1034   (set! includes (make-vector ngotos #f))
1035   (do ((i 0 (+ i 1)))
1036       ((= i ngotos))
1037     (let ((state1 (vector-ref from-state i))
1038           (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
1039       (let loop ((rulep (vector-ref derives symbol1))
1040                  (edges '()))
1041         (if (pair? rulep)
1042             (let ((*rulep (car rulep)))
1043               (let loop2 ((rp (vector-ref rrhs *rulep))
1044                           (stateno state1)
1045                           (states (list state1)))
1046                 (let ((*rp (vector-ref ritem rp)))
1047                   (if (> *rp 0)
1048                       (let ((st (get-state stateno *rp)))
1049                         (loop2 (+ rp 1) st (cons st states)))
1050                       (begin
1051
1052                         (if (not (vector-ref consistent stateno))
1053                             (add-lookback-edge stateno *rulep i))
1054
1055                         (let loop2 ((done #f)
1056                                     (stp (cdr states))
1057                                     (rp2 (- rp 1))
1058                                     (edgp edges))
1059                           (if (not done)
1060                               (let ((*rp (vector-ref ritem rp2)))
1061                                 (if (< -1 *rp nvars)
1062                                   (loop2 (not (vector-ref nullable *rp))
1063                                          (cdr stp)
1064                                          (- rp2 1)
1065                                          (cons (map-goto (car stp) *rp) edgp))
1066                                   (loop2 #t stp rp2 edgp)))
1067
1068                               (loop (cdr rulep) edgp))))))))
1069             (vector-set! includes i edges)))))
1070   (set! includes (transpose includes ngotos)))
1071
1072
1073
1074 (define (compute-lookaheads)
1075   (let ((n (vector-ref lookaheads nstates)))
1076     (let loop ((i 0))
1077       (if (< i n)
1078           (let loop2 ((sp (vector-ref lookback i)))
1079             (if (pair? sp)
1080                 (let ((LA-i (vector-ref LA i))
1081                       (F-j  (vector-ref F (car sp))))
1082                   (bit-union LA-i F-j token-set-size)
1083                   (loop2 (cdr sp)))
1084                 (loop (+ i 1))))))))
1085
1086
1087
1088 (define (digraph relation)
1089   (define infinity (+ ngotos 2))
1090   (define INDEX (make-vector (+ ngotos 1) 0))
1091   (define VERTICES (make-vector (+ ngotos 1) 0))
1092   (define top 0)
1093   (define R relation)
1094
1095   (define (traverse i)
1096     (set! top (+ 1 top))
1097     (vector-set! VERTICES top i)
1098     (let ((height top))
1099       (vector-set! INDEX i height)
1100       (let ((rp (vector-ref R i)))
1101         (if (pair? rp)
1102             (let loop ((rp2 rp))
1103               (if (pair? rp2)
1104                   (let ((j (car rp2)))
1105                     (if (= 0 (vector-ref INDEX j))
1106                         (traverse j))
1107                     (if (> (vector-ref INDEX i)
1108                            (vector-ref INDEX j))
1109                         (vector-set! INDEX i (vector-ref INDEX j)))
1110                     (let ((F-i (vector-ref F i))
1111                           (F-j (vector-ref F j)))
1112                       (bit-union F-i F-j token-set-size))
1113                     (loop (cdr rp2))))))
1114         (if (= (vector-ref INDEX i) height)
1115             (let loop ()
1116               (let ((j (vector-ref VERTICES top)))
1117                 (set! top (- top 1))
1118                 (vector-set! INDEX j infinity)
1119                 (if (not (= i j))
1120                     (begin
1121                       (bit-union (vector-ref F i)
1122                                  (vector-ref F j)
1123                                  token-set-size)
1124                       (loop)))))))))
1125
1126   (let loop ((i 0))
1127     (if (< i ngotos)
1128         (begin
1129           (if (and (= 0 (vector-ref INDEX i))
1130                    (pair? (vector-ref R i)))
1131               (traverse i))
1132           (loop (+ i 1))))))
1133
1134
1135 ;; --
1136
1137 (define (build-tables)
1138   (define (add-action St Sym Act)
1139     (let* ((x (vector-ref ACTION-TABLE St))
1140            (y (assv Sym x)))
1141       (if y
1142           (if (not (= Act (cdr y)))
1143               ;; -- there is a conflict
1144               (begin
1145                 (if (and (<= (cdr y) 0)
1146                          (<= Act 0))
1147                     (begin
1148                       (display "%% Reduce/Reduce conflict ")
1149                       (display "(reduce ") (display (- Act))
1150                       (display ", reduce ") (display (- (cdr y)))
1151                       (display ") on ") (print-symbol (+ Sym nvars))
1152                       (display " in state ") (display St)
1153                       (newline)
1154                       (set-cdr! y (max (cdr y) Act)))
1155                     (begin
1156                       (display "%% Shift/Reduce conflict ")
1157                       (display "(shift ") (display Act)
1158                       (display ", reduce ") (display (- (cdr y)))
1159                       (display ") on ") (print-symbol (+ Sym nvars))
1160                       (display " in state ") (display St)
1161                       (newline)
1162                       (set-cdr! y Act)))))
1163           (vector-set! ACTION-TABLE St
1164                        (cons (cons Sym Act) x)))))
1165
1166   (set! action-table (make-vector nstates '()))
1167
1168   (do ((i 0 (+ i 1)))  ; i = state
1169       ((= i nstates))
1170     (let ((red (vector-ref reduction-table i)))
1171       (if (and red (>= (red-nreds red) 1))
1172           (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1173               (add-action i 'default (- (car (red-rules red))))
1174               (let ((k (vector-ref lookaheads (+ i 1))))
1175                 (let loop ((j (vector-ref lookaheads i)))
1176                   (if (< j k)
1177                       (let ((rule (- (vector-ref LAruleno j)))
1178                             (lav  (vector-ref LA j)))
1179                         (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1180                           (if (< token nterms)
1181                               (begin
1182                                 (let ((in-la-set? (modulo x 2)))
1183                                   (if (= in-la-set? 1)
1184                                       (add-action i token rule)))
1185                                 (if (= y (BITS-PER-WORD))
1186                                     (loop2 (+ token 1)
1187                                            (vector-ref lav (+ z 1))
1188                                            1
1189                                            (+ z 1))
1190                                     (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1191                         (loop (+ j 1)))))))))
1192
1193     (let ((shiftp (vector-ref shift-table i)))
1194       (if shiftp
1195           (let loop ((k (shift-shifts shiftp)))
1196             (if (pair? k)
1197                 (let* ((state (car k))
1198                        (symbol (vector-ref acces-symbol state)))
1199                   (if (>= symbol nvars)
1200                       (add-action i (- symbol nvars) state))
1201                   (loop (cdr k))))))))
1202
1203   (add-action final-state 0 'accept))
1204
1205 (define (compact-action-table)
1206   (define (most-common-action acts)
1207     (let ((accums '()))
1208       (let loop ((l acts))
1209         (if (pair? l)
1210             (let* ((x (cdar l))
1211                    (y (assv x accums)))
1212               (if (and (number? x) (< x 0))
1213                   (if y
1214                       (set-cdr! y (+ 1 (cdr y)))
1215                       (set! accums (cons `(,x . 1) accums))))
1216               (loop (cdr l)))))
1217
1218       (let loop ((l accums) (max 0) (sym #f))
1219         (if (null? l)
1220             sym
1221             (let ((x (car l)))
1222               (if (> (cdr x) max)
1223                   (loop (cdr l) (cdr x) (car x))
1224                   (loop (cdr l) max sym)))))))
1225
1226   (do ((i 0 (+ i 1)))
1227       ((= i nstates))
1228     (let ((acts (vector-ref action-table i)))
1229       (if (vector? (vector-ref reduction-table i))
1230           (let ((act (most-common-action acts)))
1231             (vector-set! action-table i
1232                          (cons `(default . ,(if act act 'error))
1233                                (filter (lambda (x)
1234                                          (not (eq? (cdr x) act)))
1235                                        acts))))
1236           (vector-set! action-table i
1237                        (cons `(default . *error*) acts))))))
1238
1239
1240 (define (output-action-table prefix)
1241   (display "(defconst ") (display prefix) (display "action-table") (newline)
1242   (display "  [") (newline)
1243   (do ((i 0 (+ i 1)))
1244       ((= i nstates))
1245     (display "     ")
1246     (write (vector-ref action-table i))
1247     (newline))
1248   (display "    ])") (newline)
1249   (newline))
1250
1251 (define (output-goto-table prefix)
1252   (display "(defconst ") (display prefix) (display "goto-table") (newline)
1253   (display "  [") (newline)
1254   (do ((i 0 (+ i 1)))
1255       ((= i nstates))
1256     (display "     ")
1257     (let ((shifts (vector-ref shift-table i)))
1258       (if shifts
1259           (begin
1260             (display "(")
1261             (let loop ((l (shift-shifts shifts)))
1262               (if (null? l)
1263                   (display ")")
1264                   (let* ((state (car l))
1265                          (symbol (vector-ref acces-symbol state)))
1266                     (if (< symbol nvars)
1267                         (display `(,symbol . ,state)))
1268                     (loop (cdr l))))))
1269           (display '())))
1270     (newline))
1271   (display "    ])") (newline)
1272   (newline))
1273
1274 (define (output-reduction-table gram/actions prefix)
1275   (display "(defconst ") (display prefix) (display "reduction-table") (newline)
1276   (display "  (vector") (newline)
1277   (display "    '()") (newline)
1278   (for-each
1279    (lambda (p)
1280      (let ((act (cdr p)))
1281        (display "    (lambda (stack sp goto-table $look)") (newline)
1282        (let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1283          (display "      (let* (")
1284          (if act
1285              (let loop ((i 1) (l rhs))
1286                (if (not (null? l))
1287                    (let ((rest (cdr l)))
1288                      (if (> i 1) (begin (newline) (display "             ")))
1289                      (display "($") (display (+ (- n i) 1)) (display " ")
1290                      (display "(aref stack (- sp ")
1291                      (display (- (* i 2) 1))
1292                      (display ")))")
1293                      (loop (+ i 1) rest)))))
1294          (display ")")
1295          (newline)
1296          (display "          ")
1297          (if (= nt 0)
1298              (display "(accept $1)")
1299              (begin
1300                (display "(lr-push stack (- sp ")
1301                (display (* 2 n))
1302                (display ") ")
1303                (display nt)
1304                (display " goto-table ")
1305                (write (cdr p))
1306                (display ")")))
1307          (display "))") (newline))))
1308    gram/Actions)
1309   (display "  ))") (newline)
1310   (newline))
1311
1312 (define (output-header header parser-prefix)
1313   (display header)
1314   (display "(require 'lr-driver)") (newline)
1315   (newline))
1316
1317 (define (output-footer footer)
1318   (display footer) (newline)
1319   (newline))
1320
1321 (define (output-parser-def parser-prefix prefix)
1322   (display "(defun ") (display parser-prefix) (display "parse") (display "(scanner errorhandler)") (newline)
1323   (display "  (lr-parse scanner errorhandler ") (newline)
1324   (display "    ") (display prefix) (display "action-table") (newline)
1325   (display "    ") (display prefix) (display "goto-table") (newline)
1326   (display "    ") (display prefix) (display "reduction-table") (newline)
1327   (display "    ") (display prefix) (display "token-defs))") (newline)
1328   (newline))
1329
1330 (define (output-token-defs terms prefix)
1331   (let loop ((i 0) (l terms))
1332     (if (pair? l)
1333         (let ((x (car l)))
1334           (display "(defconst ") (display prefix)
1335           (write x)
1336           (display #\tab)
1337           (display i)
1338           (display ")")
1339           (newline)
1340           (loop (+ i 1) (cdr l)))))
1341   (newline)
1342   (display "(defconst ") (display prefix) (display "token-defs") (newline)
1343   (display "  (list ") (newline)
1344   (let loop ((i 0) (l terms))
1345     (if (pair? l)
1346         (begin
1347           (display "   (cons ")
1348           (display i)
1349           (display " \"") (display (car l)) (display "\")")
1350           (newline)
1351           (loop (+ i 1) (cdr l)))))
1352   (display "  ))") (newline)
1353   (newline))
1354
1355 ;; --
1356
1357 (define (rewrite-grammar grammar proc)
1358
1359   (define eoi '*EOI*)
1360
1361   (if (not (pair? grammar))
1362       (error "Grammar definition must be a non-empty list")
1363       (let loop1 ((lst grammar) (rev-terms '()))
1364         (if (and (pair? lst) (not (pair? (car lst)))) ; definition d'un terminal?
1365             (let ((term (car lst)))
1366               (cond ((not (valid-terminal? term))
1367                      (error "Invalid terminal:" term))
1368                     ((member term rev-terms)
1369                      (error "Terminal previously defined:" term))
1370                     (else
1371                      (loop1 (cdr lst) (cons term rev-terms)))))
1372             (let loop2 ((lst lst) (rev-nonterm-defs '()))
1373               (if (pair? lst)
1374                   (let ((def (car lst)))
1375                     (if (not (pair? def))
1376                         (error "Nonterminal definition must be a non-empty list")
1377                         (let ((nonterm (car def)))
1378                           (cond ((not (valid-nonterminal? nonterm))
1379                                  (error "Invalid nonterminal:" nonterm))
1380                                 ((or (member nonterm rev-terms)
1381                                      (assoc nonterm rev-nonterm-defs))
1382                                  (error "Nonterminal previously defined:" nonterm))
1383                                 (else
1384                                  (loop2 (cdr lst)
1385                                         (cons def rev-nonterm-defs)))))))
1386                   (let* ((terms (cons eoi (reverse rev-terms)))
1387                          (nonterm-defs (reverse rev-nonterm-defs))
1388                          (nonterms (cons '*start* (map car nonterm-defs))))
1389                     (if (= (length nonterms) 1)
1390                         (error "Grammar must contain at least one nonterminal")
1391                         (let ((compiled-nonterminals
1392                                (map (lambda (nonterm-def)
1393                                       (rewrite-nonterm-def nonterm-def
1394                                                            terms
1395                                                            nonterms))
1396                                     (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1397                                           nonterm-defs))))
1398                           (proc terms
1399                                 nonterms
1400                                 (map (lambda (x) (cons (caaar x) (map cdar x)))
1401                                      compiled-nonterminals)
1402                                 (apply append compiled-nonterminals)))))))))))
1403
1404
1405 (define (rewrite-nonterm-def nonterm-def terms nonterms)
1406
1407   (define No-NT (length nonterms))
1408
1409   (define (encode x)
1410     (let ((PosInNT (pos-in-list x nonterms)))
1411       (if PosInNT
1412           PosInNT
1413           (let ((PosInT (pos-in-list x terms)))
1414             (if PosInT
1415                 (+ No-NT PosInT)
1416                 (error "undefined symbol : " x))))))
1417
1418   (if (not (pair? (cdr nonterm-def)))
1419       (error "At least one production needed for nonterminal" (car nonterm-def))
1420       (let ((name (symbol->string (car nonterm-def))))
1421         (let loop1 ((lst (cdr nonterm-def))
1422                     (i 1)
1423                     (rev-productions-and-actions '()))
1424           (if (not (pair? lst))
1425               (reverse rev-productions-and-actions)
1426               (let* ((rhs (car lst))
1427                      (rest (cdr lst))
1428                      (prod (map encode (cons (car nonterm-def) rhs))))
1429                 (for-each (lambda (x)
1430                             (if (not (or (member x terms) (member x nonterms)))
1431                                 (error "Invalid terminal or nonterminal" x)))
1432                           rhs)
1433                 (if (and (pair? rest)
1434                          (eq? (car rest) ':)
1435                          (pair? (cdr rest)))
1436                     (loop1 (cddr rest)
1437                            (+ i 1)
1438                            (cons (cons prod (cadr rest))
1439                                  rev-productions-and-actions))
1440                     (let* ((rhs-length (length rhs))
1441                            (action
1442                             (cons 'VECTOR
1443                                  (cons (list 'QUOTE (string->symbol
1444                                                      (string-append
1445                                                       name
1446                                                       "-"
1447                                                       (number->string i))))
1448                                        (let loop-j ((j 1))
1449                                          (if (> j rhs-length)
1450                                              '()
1451                                              (cons (string->symbol
1452                                                     (string-append
1453                                                      "$"
1454                                                      (number->string j)))
1455                                                    (loop-j (+ j 1)))))))))
1456                       (loop1 rest
1457                              (+ i 1)
1458                              (cons (cons prod action)
1459                                    rev-productions-and-actions))))))))))
1460
1461 (define (valid-nonterminal? x)
1462   (symbol? x))
1463
1464 (define (valid-terminal? x)
1465   (symbol? x))              ; DB
1466
1467 ;; ---------------------------------------------------------------------- ;;
1468 ;; Miscellaneous                                                          ;;
1469 ;; ---------------------------------------------------------------------- ;;
1470 (define (pos-in-list x lst)
1471   (let loop ((lst lst) (i 0))
1472     (cond ((not (pair? lst))    #f)
1473           ((equal? (car lst) x) i)
1474           (else                 (loop (cdr lst) (+ i 1))))))
1475
1476 (define (sunion lst1 lst2)              ; union of sorted lists
1477   (let loop ((L1 lst1)
1478              (L2 lst2))
1479     (cond ((null? L1)    L2)
1480           ((null? L2)    L1)
1481           (else
1482            (let ((x (car L1)) (y (car L2)))
1483              (cond
1484               ((> x y)
1485                (cons y (loop L1 (cdr L2))))
1486               ((< x y)
1487                (cons x (loop (cdr L1) L2)))
1488               (else
1489                (loop (cdr L1) L2))
1490               ))))))
1491
1492 (define (sinsert elem lst)
1493   (let loop ((l1 lst))
1494     (if (null? l1)
1495         (cons elem l1)
1496         (let ((x (car l1)))
1497           (cond ((< elem x)
1498                  (cons elem l1))
1499                 ((> elem x)
1500                  (cons x (loop (cdr l1))))
1501                 (else
1502                  l1))))))
1503
1504 (define (filter p lst)
1505   (let loop ((l lst))
1506     (if (null? l)
1507         '()
1508         (let ((x (car l)) (y (cdr l)))
1509         (if (p x)
1510             (cons x (loop y))
1511             (loop y))))))
1512
1513 ;; ---------------------------------------------------------------------- ;;
1514 ;; Debugging tools ...                                                    ;;
1515 ;; ---------------------------------------------------------------------- ;;
1516 (define the-terminals #f)
1517 (define the-nonterminals #f)
1518
1519 (define (print-item item-no)
1520   (let loop ((i item-no))
1521     (let ((v (vector-ref ritem i)))
1522       (if (>= v 0)
1523           (loop (+ i 1))
1524           (let* ((rlno    (- v))
1525                  (nt      (vector-ref rlhs rlno)))
1526             (display (vector-ref the-nonterminals nt)) (display " --> ")
1527             (let loop ((i (vector-ref rrhs rlno)))
1528               (let ((v (vector-ref ritem i)))
1529                 (if (= i item-no)
1530                     (display ". "))
1531                 (if (>= v 0)
1532                     (begin
1533                       (print-symbol v)
1534                       (display " ")
1535                       (loop (+ i 1)))
1536                     (begin
1537                       (display "   (rule ")
1538                       (display (- v))
1539                       (display ")")
1540                       (newline))))))))))
1541
1542 (define (print-symbol n)
1543   (display (if (>= n nvars)
1544                (vector-ref the-terminals (- n nvars))
1545                (vector-ref the-nonterminals n))))
1546
1547 (define (print-states)
1548   (define (print-action act)
1549     (cond
1550      ((eq? act '*error*)
1551       (display " : Error"))
1552      ((eq? act 'accept)
1553       (display " : Accept input"))
1554      ((< act 0)
1555       (display " : reduce using rule ")
1556       (display (- act)))
1557      (else
1558       (display " : shift and goto state ")
1559       (display act)))
1560     (newline)
1561     #t)
1562
1563   (define (print-actions acts)
1564     (let loop ((l acts))
1565       (if (null? l)
1566           #t
1567           (let ((sym (caar l))
1568                 (act (cdar l)))
1569             (display "   ")
1570             (cond
1571              ((eq? sym 'default)
1572               (display "default action"))
1573              (else
1574               (print-symbol (+ sym nvars))))
1575             (print-action act)
1576             (loop (cdr l))))))
1577
1578   (if (not action-table)
1579       (begin
1580         (display "No generated parser available!")
1581         (newline)
1582         #f)
1583       (begin
1584         (display "State table") (newline)
1585         (display "-----------") (newline) (newline)
1586
1587         (let loop ((l first-state))
1588           (if (null? l)
1589               #t
1590               (let* ((core  (car l))
1591                      (i     (core-number core))
1592                      (items (core-items core))
1593                      (actions (vector-ref action-table i)))
1594                 (display "state ") (display i) (newline)
1595                 (newline)
1596                 (for-each (lambda (x) (display "   ") (print-item x))
1597                           items)
1598                 (newline)
1599                 (print-actions actions)
1600                 (newline)
1601                 (loop (cdr l))))))))
1602
1603
1604