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