summaryrefslogtreecommitdiff
path: root/module/language/ecmascript/parse-lalr.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/ecmascript/parse-lalr.scm')
-rw-r--r--module/language/ecmascript/parse-lalr.scm1731
1 files changed, 0 insertions, 1731 deletions
diff --git a/module/language/ecmascript/parse-lalr.scm b/module/language/ecmascript/parse-lalr.scm
deleted file mode 100644
index b702511ca..000000000
--- a/module/language/ecmascript/parse-lalr.scm
+++ /dev/null
@@ -1,1731 +0,0 @@
-;; (language ecmascript parse-lalr) -- yacc's parser generator, in Guile
-;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc.
-;; Copyright (C) 1996-2002 Dominique Boucher
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-
-;; ---------------------------------------------------------------------- ;;
-#!
-;;; Commentary:
-This file contains yet another LALR(1) parser generator written in
-Scheme. In contrast to other such parser generators, this one
-implements a more efficient algorithm for computing the lookahead sets.
-The algorithm is the same as used in Bison (GNU yacc) and is described
-in the following paper:
-
-"Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and
-T. Pennello, TOPLAS, vol. 4, no. 4, october 1982.
-
-As a consequence, it is not written in a fully functional style.
-In fact, much of the code is a direct translation from C to Scheme
-of the Bison sources.
-
-@section Defining a parser
-
-The module @code{(language ecmascript parse-lalr)} declares a macro
-called @code{lalr-parser}:
-
-@lisp
- (lalr-parser tokens rules ...)
-@end lisp
-
-This macro, when given appropriate arguments, generates an LALR(1)
-syntax analyzer. The macro accepts at least two arguments. The first
-is a list of symbols which represent the terminal symbols of the
-grammar. The remaining arguments are the grammar production rules.
-
-@section Running the parser
-
-The parser generated by the @code{lalr-parser} macro is a function that
-takes two parameters. The first parameter is a lexical analyzer while
-the second is an error procedure.
-
-The lexical analyzer is zero-argument function (a thunk)
-invoked each time the parser needs to look-ahead in the token stream.
-A token is usually a pair whose @code{car} is the symbol corresponding to
-the token (the same symbol as used in the grammar definition). The
-@code{cdr} of the pair is the semantic value associated with the token. For
-example, a string token would have the @code{car} set to @code{'string}
-while the @code{cdr} is set to the string value @code{"hello"}.
-
-Once the end of file is encountered, the lexical analyzer must always
-return the symbol @code{'*eoi*} each time it is invoked.
-
-The error procedure must be a function that accepts at least two
-parameters.
-
-@section The grammar format
-
-The grammar is specified by first giving the list of terminals and the
-list of non-terminal definitions. Each non-terminal definition
-is a list where the first element is the non-terminal and the other
-elements are the right-hand sides (lists of grammar symbols). In
-addition to this, each rhs can be followed by a semantic action.
-
-For example, consider the following (yacc) grammar for a very simple
-expression language:
-@example
- e : e '+' t
- | e '-' t
- | t
- ;
- t : t '*' f
- : t '/' f
- | f
- ;
- f : ID
- ;
-@end example
-The same grammar, written for the scheme parser generator, would look
-like this (with semantic actions)
-@lisp
-(define expr-parser
- (lalr-parser
- ; Terminal symbols
- (ID + - * /)
- ; Productions
- (e (e + t) -> (+ $1 $3)
- (e - t) -> (- $1 $3)
- (t) -> $1)
- (t (t * f) -> (* $1 $3)
- (t / f) -> (/ $1 $3)
- (f) -> $1)
- (f (ID) -> $1)))
-@end lisp
-In semantic actions, the symbol @code{$n} refers to the synthesized
-attribute value of the nth symbol in the production. The value
-associated with the non-terminal on the left is the result of
-evaluating the semantic action (it defaults to @code{#f}).
-
-The above grammar implicitly handles operator precedences. It is also
-possible to explicitly assign precedences and associativity to
-terminal symbols and productions a la Yacc. Here is a modified
-(and augmented) version of the grammar:
-@lisp
-(define expr-parser
- (lalr-parser
- ; Terminal symbols
- (ID
- (left: + -)
- (left: * /)
- (nonassoc: uminus))
- (e (e + e) -> (+ $1 $3)
- (e - e) -> (- $1 $3)
- (e * e) -> (* $1 $3)
- (e / e) -> (/ $1 $3)
- (- e (prec: uminus)) -> (- $2)
- (ID) -> $1)))
-@end lisp
-The @code{left:} directive is used to specify a set of left-associative
-operators of the same precedence level, the @code{right:} directive for
-right-associative operators, and @code{nonassoc:} for operators that
-are not associative. Note the use of the (apparently) useless
-terminal @code{uminus}. It is only defined in order to assign to the
-penultimate rule a precedence level higher than that of @code{*} and
-@code{/}. The @code{prec:} directive can only appear as the last element of a
-rule. Finally, note that precedence levels are incremented from
-left to right, i.e. the precedence level of @code{+} and @code{-} is less
-than the precedence level of @code{*} and @code{/} since the formers appear
-first in the list of terminal symbols (token definitions).
-
-@section A final note on conflict resolution
-
-Conflicts in the grammar are handled in a conventional way.
-In the absence of precedence directives,
-Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce
-conflicts are resolved by choosing the rule listed first in the
-grammar definition.
-
-You can print the states of the generated parser by evaluating
-@code{(print-states)}. The format of the output is similar to the one
-produced by bison when given the -v command-line option.
-;;; Code:
-!#
-
-;;; ---------- SYSTEM DEPENDENT SECTION -----------------
-;; put in a module by Richard Todd
-(define-module (language ecmascript parse-lalr)
- #:export (lalr-parser
- print-states))
-
-;; this code is by Thien-Thi Nguyen, found in a google search
-(begin
- (defmacro def-macro (form . body)
- `(defmacro ,(car form) ,(cdr form) ,@body))
- (def-macro (BITS-PER-WORD) 28)
- (def-macro (lalr-error msg obj) `(throw 'lalr-error ,msg ,obj))
- (def-macro (logical-or x . y) `(logior ,x ,@y)))
-
-;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------
-
-;; - Macros pour la gestion des vecteurs de bits
-
-(def-macro (set-bit v b)
- `(let ((x (quotient ,b (BITS-PER-WORD)))
- (y (expt 2 (remainder ,b (BITS-PER-WORD)))))
- (vector-set! ,v x (logical-or (vector-ref ,v x) y))))
-
-(def-macro (bit-union v1 v2 n)
- `(do ((i 0 (+ i 1)))
- ((= i ,n))
- (vector-set! ,v1 i (logical-or (vector-ref ,v1 i)
- (vector-ref ,v2 i)))))
-
-;; - Macro pour les structures de donnees
-
-(def-macro (new-core) `(make-vector 4 0))
-(def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n))
-(def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s))
-(def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n))
-(def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i))
-(def-macro (core-number c) `(vector-ref ,c 0))
-(def-macro (core-acc-sym c) `(vector-ref ,c 1))
-(def-macro (core-nitems c) `(vector-ref ,c 2))
-(def-macro (core-items c) `(vector-ref ,c 3))
-
-(def-macro (new-shift) `(make-vector 3 0))
-(def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x))
-(def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x))
-(def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x))
-(def-macro (shift-number s) `(vector-ref ,s 0))
-(def-macro (shift-nshifts s) `(vector-ref ,s 1))
-(def-macro (shift-shifts s) `(vector-ref ,s 2))
-
-(def-macro (new-red) `(make-vector 3 0))
-(def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x))
-(def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x))
-(def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x))
-(def-macro (red-number c) `(vector-ref ,c 0))
-(def-macro (red-nreds c) `(vector-ref ,c 1))
-(def-macro (red-rules c) `(vector-ref ,c 2))
-
-
-
-(def-macro (new-set nelem)
- `(make-vector ,nelem 0))
-
-
-(def-macro (vector-map f v)
- `(let ((vm-n (- (vector-length ,v) 1)))
- (let loop ((vm-low 0) (vm-high vm-n))
- (if (= vm-low vm-high)
- (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low))
- (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
- (loop vm-low vm-middle)
- (loop (+ vm-middle 1) vm-high))))))
-
-
-;; - Constantes
-(define STATE-TABLE-SIZE 1009)
-
-
-;; - Tableaux
-(define rrhs #f)
-(define rlhs #f)
-(define ritem #f)
-(define nullable #f)
-(define derives #f)
-(define fderives #f)
-(define firsts #f)
-(define kernel-base #f)
-(define kernel-end #f)
-(define shift-symbol #f)
-(define shift-set #f)
-(define red-set #f)
-(define state-table #f)
-(define acces-symbol #f)
-(define reduction-table #f)
-(define shift-table #f)
-(define consistent #f)
-(define lookaheads #f)
-(define LA #f)
-(define LAruleno #f)
-(define lookback #f)
-(define goto-map #f)
-(define from-state #f)
-(define to-state #f)
-(define includes #f)
-(define F #f)
-(define action-table #f)
-
-;; - Variables
-(define nitems #f)
-(define nrules #f)
-(define nvars #f)
-(define nterms #f)
-(define nsyms #f)
-(define nstates #f)
-(define first-state #f)
-(define last-state #f)
-(define final-state #f)
-(define first-shift #f)
-(define last-shift #f)
-(define first-reduction #f)
-(define last-reduction #f)
-(define nshifts #f)
-(define maxrhs #f)
-(define ngotos #f)
-(define token-set-size #f)
-
-(define (gen-tables! tokens gram)
- (initialize-all)
- (rewrite-grammar
- tokens
- gram
- (lambda (terms terms/prec vars gram gram/actions)
- (set! the-terminals/prec (list->vector terms/prec))
- (set! the-terminals (list->vector terms))
- (set! the-nonterminals (list->vector vars))
- (set! nterms (length terms))
- (set! nvars (length vars))
- (set! nsyms (+ nterms nvars))
- (let ((no-of-rules (length gram/actions))
- (no-of-items (let loop ((l gram/actions) (count 0))
- (if (null? l)
- count
- (loop (cdr l) (+ count (length (caar l))))))))
- (pack-grammar no-of-rules no-of-items gram)
- (set-derives)
- (set-nullable)
- (generate-states)
- (lalr)
- (build-tables)
- (compact-action-table terms)
- gram/actions))))
-
-
-(define (initialize-all)
- (set! rrhs #f)
- (set! rlhs #f)
- (set! ritem #f)
- (set! nullable #f)
- (set! derives #f)
- (set! fderives #f)
- (set! firsts #f)
- (set! kernel-base #f)
- (set! kernel-end #f)
- (set! shift-symbol #f)
- (set! shift-set #f)
- (set! red-set #f)
- (set! state-table (make-vector STATE-TABLE-SIZE '()))
- (set! acces-symbol #f)
- (set! reduction-table #f)
- (set! shift-table #f)
- (set! consistent #f)
- (set! lookaheads #f)
- (set! LA #f)
- (set! LAruleno #f)
- (set! lookback #f)
- (set! goto-map #f)
- (set! from-state #f)
- (set! to-state #f)
- (set! includes #f)
- (set! F #f)
- (set! action-table #f)
- (set! nstates #f)
- (set! first-state #f)
- (set! last-state #f)
- (set! final-state #f)
- (set! first-shift #f)
- (set! last-shift #f)
- (set! first-reduction #f)
- (set! last-reduction #f)
- (set! nshifts #f)
- (set! maxrhs #f)
- (set! ngotos #f)
- (set! token-set-size #f)
- (set! rule-precedences '()))
-
-
-(define (pack-grammar no-of-rules no-of-items gram)
- (set! nrules (+ no-of-rules 1))
- (set! nitems no-of-items)
- (set! rlhs (make-vector nrules #f))
- (set! rrhs (make-vector nrules #f))
- (set! ritem (make-vector (+ 1 nitems) #f))
-
- (let loop ((p gram) (item-no 0) (rule-no 1))
- (if (not (null? p))
- (let ((nt (caar p)))
- (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
- (if (null? prods)
- (loop (cdr p) it-no2 rl-no2)
- (begin
- (vector-set! rlhs rl-no2 nt)
- (vector-set! rrhs rl-no2 it-no2)
- (let loop3 ((rhs (car prods)) (it-no3 it-no2))
- (if (null? rhs)
- (begin
- (vector-set! ritem it-no3 (- rl-no2))
- (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
- (begin
- (vector-set! ritem it-no3 (car rhs))
- (loop3 (cdr rhs) (+ it-no3 1))))))))))))
-
-
-;; Fonction set-derives
-;; --------------------
-(define (set-derives)
- (define delts (make-vector (+ nrules 1) 0))
- (define dset (make-vector nvars -1))
-
- (let loop ((i 1) (j 0)) ; i = 0
- (if (< i nrules)
- (let ((lhs (vector-ref rlhs i)))
- (if (>= lhs 0)
- (begin
- (vector-set! delts j (cons i (vector-ref dset lhs)))
- (vector-set! dset lhs j)
- (loop (+ i 1) (+ j 1)))
- (loop (+ i 1) j)))))
-
- (set! derives (make-vector nvars 0))
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
- (if (< j 0)
- s
- (let ((x (vector-ref delts j)))
- (loop2 (cdr x) (cons (car x) s)))))))
- (vector-set! derives i q)
- (loop (+ i 1))))))
-
-
-
-(define (set-nullable)
- (set! nullable (make-vector nvars #f))
- (let ((squeue (make-vector nvars #f))
- (rcount (make-vector (+ nrules 1) 0))
- (rsets (make-vector nvars #f))
- (relts (make-vector (+ nitems nvars 1) #f)))
- (let loop ((r 0) (s2 0) (p 0))
- (let ((*r (vector-ref ritem r)))
- (if *r
- (if (< *r 0)
- (let ((symbol (vector-ref rlhs (- *r))))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s2 symbol)
- (loop (+ r 1) (+ s2 1) p))))
- (let loop2 ((r1 r) (any-tokens #f))
- (let* ((symbol (vector-ref ritem r1)))
- (if (> symbol 0)
- (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
- (if (not any-tokens)
- (let ((ruleno (- symbol)))
- (let loop3 ((r2 r) (p2 p))
- (let ((symbol (vector-ref ritem r2)))
- (if (> symbol 0)
- (begin
- (vector-set! rcount ruleno
- (+ (vector-ref rcount ruleno) 1))
- (vector-set! relts p2
- (cons (vector-ref rsets symbol)
- ruleno))
- (vector-set! rsets symbol p2)
- (loop3 (+ r2 1) (+ p2 1)))
- (loop (+ r2 1) s2 p2)))))
- (loop (+ r1 1) s2 p))))))
- (let loop ((s1 0) (s3 s2))
- (if (< s1 s3)
- (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
- (if p
- (let* ((x (vector-ref relts p))
- (ruleno (cdr x))
- (y (- (vector-ref rcount ruleno) 1)))
- (vector-set! rcount ruleno y)
- (if (= y 0)
- (let ((symbol (vector-ref rlhs ruleno)))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s4 symbol)
- (loop2 (car x) (+ s4 1)))
- (loop2 (car x) s4)))
- (loop2 (car x) s4))))
- (loop (+ s1 1) s4)))))))))
-
-
-
-; Fonction set-firsts qui calcule un tableau de taille
-; nvars et qui donne, pour chaque non-terminal X, une liste des
-; non-terminaux pouvant apparaitre au debut d'une derivation a
-; partir de X.
-
-(define (set-firsts)
- (set! firsts (make-vector nvars '()))
-
- ;; -- initialization
- (let loop ((i 0))
- (if (< i nvars)
- (let loop2 ((sp (vector-ref derives i)))
- (if (null? sp)
- (loop (+ i 1))
- (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
- (if (< -1 sym nvars)
- (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
- (loop2 (cdr sp)))))))
-
- ;; -- reflexive and transitive closure
- (let loop ((continue #t))
- (if continue
- (let loop2 ((i 0) (cont #f))
- (if (>= i nvars)
- (loop cont)
- (let* ((x (vector-ref firsts i))
- (y (let loop3 ((l x) (z x))
- (if (null? l)
- z
- (loop3 (cdr l)
- (sunion (vector-ref firsts (car l)) z))))))
- (if (equal? x y)
- (loop2 (+ i 1) cont)
- (begin
- (vector-set! firsts i y)
- (loop2 (+ i 1) #t))))))))
-
- (let loop ((i 0))
- (if (< i nvars)
- (begin
- (vector-set! firsts i (sinsert i (vector-ref firsts i)))
- (loop (+ i 1))))))
-
-
-
-
-; Fonction set-fderives qui calcule un tableau de taille
-; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
-; etre derivees a partir de ce non-terminal. (se sert de firsts)
-
-(define (set-fderives)
- (set! fderives (make-vector nvars #f))
-
- (set-firsts)
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
- (if (null? l)
- fd
- (loop2 (cdr l)
- (sunion (vector-ref derives (car l)) fd))))))
- (vector-set! fderives i x)
- (loop (+ i 1))))))
-
-
-; Fonction calculant la fermeture d'un ensemble d'items LR0
-; ou core est une liste d'items
-
-(define (closure core)
- ;; Initialization
- (define ruleset (make-vector nrules #f))
-
- (let loop ((csp core))
- (if (not (null? csp))
- (let ((sym (vector-ref ritem (car csp))))
- (if (< -1 sym nvars)
- (let loop2 ((dsp (vector-ref fderives sym)))
- (if (not (null? dsp))
- (begin
- (vector-set! ruleset (car dsp) #t)
- (loop2 (cdr dsp))))))
- (loop (cdr csp)))))
-
- (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
- (if (< ruleno nrules)
- (if (vector-ref ruleset ruleno)
- (let ((itemno (vector-ref rrhs ruleno)))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (and (pair? c)
- (< (car c) itemno))
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
- (loop (+ ruleno 1) csp itemsetv))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (pair? c)
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (reverse itemsetv2))))))
-
-
-
-(define (allocate-item-sets)
- (set! kernel-base (make-vector nsyms 0))
- (set! kernel-end (make-vector nsyms #f)))
-
-
-(define (allocate-storage)
- (allocate-item-sets)
- (set! red-set (make-vector (+ nrules 1) 0)))
-
-;; --
-
-
-(define (initialize-states)
- (let ((p (new-core)))
- (set-core-number! p 0)
- (set-core-acc-sym! p #f)
- (set-core-nitems! p 1)
- (set-core-items! p '(0))
-
- (set! first-state (list p))
- (set! last-state first-state)
- (set! nstates 1)))
-
-
-
-(define (generate-states)
- (allocate-storage)
- (set-fderives)
- (initialize-states)
- (let loop ((this-state first-state))
- (if (pair? this-state)
- (let* ((x (car this-state))
- (is (closure (core-items x))))
- (save-reductions x is)
- (new-itemsets is)
- (append-states)
- (if (> nshifts 0)
- (save-shifts x))
- (loop (cdr this-state))))))
-
-
-;; Fonction calculant les symboles sur lesquels il faut "shifter"
-;; et regroupe les items en fonction de ces symboles
-
-(define (new-itemsets itemset)
- ;; - Initialization
- (set! shift-symbol '())
- (let loop ((i 0))
- (if (< i nsyms)
- (begin
- (vector-set! kernel-end i '())
- (loop (+ i 1)))))
-
- (let loop ((isp itemset))
- (if (pair? isp)
- (let* ((i (car isp))
- (sym (vector-ref ritem i)))
- (if (>= sym 0)
- (begin
- (set! shift-symbol (sinsert sym shift-symbol))
- (let ((x (vector-ref kernel-end sym)))
- (if (null? x)
- (begin
- (vector-set! kernel-base sym (cons (+ i 1) x))
- (vector-set! kernel-end sym (vector-ref kernel-base sym)))
- (begin
- (set-cdr! x (list (+ i 1)))
- (vector-set! kernel-end sym (cdr x)))))))
- (loop (cdr isp)))))
-
- (set! nshifts (length shift-symbol)))
-
-
-
-(define (get-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (key (let loop ((isp1 isp) (k 0))
- (if (null? isp1)
- (modulo k STATE-TABLE-SIZE)
- (loop (cdr isp1) (+ k (car isp1))))))
- (sp (vector-ref state-table key)))
- (if (null? sp)
- (let ((x (new-state sym)))
- (vector-set! state-table key (list x))
- (core-number x))
- (let loop ((sp1 sp))
- (if (and (= n (core-nitems (car sp1)))
- (let loop2 ((i1 isp) (t (core-items (car sp1))))
- (if (and (pair? i1)
- (= (car i1)
- (car t)))
- (loop2 (cdr i1) (cdr t))
- (null? i1))))
- (core-number (car sp1))
- (if (null? (cdr sp1))
- (let ((x (new-state sym)))
- (set-cdr! sp1 (list x))
- (core-number x))
- (loop (cdr sp1))))))))
-
-
-(define (new-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (p (new-core)))
- (set-core-number! p nstates)
- (set-core-acc-sym! p sym)
- (if (= sym nvars) (set! final-state nstates))
- (set-core-nitems! p n)
- (set-core-items! p isp)
- (set-cdr! last-state (list p))
- (set! last-state (cdr last-state))
- (set! nstates (+ nstates 1))
- p))
-
-
-;; --
-
-(define (append-states)
- (set! shift-set
- (let loop ((l (reverse shift-symbol)))
- (if (null? l)
- '()
- (cons (get-state (car l)) (loop (cdr l)))))))
-
-;; --
-
-(define (save-shifts core)
- (let ((p (new-shift)))
- (set-shift-number! p (core-number core))
- (set-shift-nshifts! p nshifts)
- (set-shift-shifts! p shift-set)
- (if last-shift
- (begin
- (set-cdr! last-shift (list p))
- (set! last-shift (cdr last-shift)))
- (begin
- (set! first-shift (list p))
- (set! last-shift first-shift)))))
-
-(define (save-reductions core itemset)
- (let ((rs (let loop ((l itemset))
- (if (null? l)
- '()
- (let ((item (vector-ref ritem (car l))))
- (if (< item 0)
- (cons (- item) (loop (cdr l)))
- (loop (cdr l))))))))
- (if (pair? rs)
- (let ((p (new-red)))
- (set-red-number! p (core-number core))
- (set-red-nreds! p (length rs))
- (set-red-rules! p rs)
- (if last-reduction
- (begin
- (set-cdr! last-reduction (list p))
- (set! last-reduction (cdr last-reduction)))
- (begin
- (set! first-reduction (list p))
- (set! last-reduction first-reduction)))))))
-
-
-;; --
-
-(define (lalr)
- (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
- (set-accessing-symbol)
- (set-shift-table)
- (set-reduction-table)
- (set-max-rhs)
- (initialize-LA)
- (set-goto-map)
- (initialize-F)
- (build-relations)
- (digraph includes)
- (compute-lookaheads))
-
-(define (set-accessing-symbol)
- (set! acces-symbol (make-vector nstates #f))
- (let loop ((l first-state))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! acces-symbol (core-number x) (core-acc-sym x))
- (loop (cdr l))))))
-
-(define (set-shift-table)
- (set! shift-table (make-vector nstates #f))
- (let loop ((l first-shift))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! shift-table (shift-number x) x)
- (loop (cdr l))))))
-
-(define (set-reduction-table)
- (set! reduction-table (make-vector nstates #f))
- (let loop ((l first-reduction))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! reduction-table (red-number x) x)
- (loop (cdr l))))))
-
-(define (set-max-rhs)
- (let loop ((p 0) (curmax 0) (length 0))
- (let ((x (vector-ref ritem p)))
- (if x
- (if (>= x 0)
- (loop (+ p 1) curmax (+ length 1))
- (loop (+ p 1) (max curmax length) 0))
- (set! maxrhs curmax)))))
-
-(define (initialize-LA)
- (define (last l)
- (if (null? (cdr l))
- (car l)
- (last (cdr l))))
-
- (set! consistent (make-vector nstates #f))
- (set! lookaheads (make-vector (+ nstates 1) #f))
-
- (let loop ((count 0) (i 0))
- (if (< i nstates)
- (begin
- (vector-set! lookaheads i count)
- (let ((rp (vector-ref reduction-table i))
- (sp (vector-ref shift-table i)))
- (if (and rp
- (or (> (red-nreds rp) 1)
- (and sp
- (not
- (< (vector-ref acces-symbol
- (last (shift-shifts sp)))
- nvars)))))
- (loop (+ count (red-nreds rp)) (+ i 1))
- (begin
- (vector-set! consistent i #t)
- (loop count (+ i 1))))))
-
- (begin
- (vector-set! lookaheads nstates count)
- (let ((c (max count 1)))
- (set! LA (make-vector c #f))
- (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
- (set! LAruleno (make-vector c -1))
- (set! lookback (make-vector c #f)))
- (let loop ((i 0) (np 0))
- (if (< i nstates)
- (if (vector-ref consistent i)
- (loop (+ i 1) np)
- (let ((rp (vector-ref reduction-table i)))
- (if rp
- (let loop2 ((j (red-rules rp)) (np2 np))
- (if (null? j)
- (loop (+ i 1) np2)
- (begin
- (vector-set! LAruleno np2 (car j))
- (loop2 (cdr j) (+ np2 1)))))
- (loop (+ i 1) np))))))))))
-
-
-(define (set-goto-map)
- (set! goto-map (make-vector (+ nvars 1) 0))
- (let ((temp-map (make-vector (+ nvars 1) 0)))
- (let loop ((ng 0) (sp first-shift))
- (if (pair? sp)
- (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
- (if (pair? i)
- (let ((symbol (vector-ref acces-symbol (car i))))
- (if (< symbol nvars)
- (begin
- (vector-set! goto-map symbol
- (+ 1 (vector-ref goto-map symbol)))
- (loop2 (cdr i) (+ ng2 1)))
- (loop2 (cdr i) ng2)))
- (loop ng2 (cdr sp))))
-
- (let loop ((k 0) (i 0))
- (if (< i nvars)
- (begin
- (vector-set! temp-map i k)
- (loop (+ k (vector-ref goto-map i)) (+ i 1)))
-
- (begin
- (do ((i 0 (+ i 1)))
- ((>= i nvars))
- (vector-set! goto-map i (vector-ref temp-map i)))
-
- (set! ngotos ng)
- (vector-set! goto-map nvars ngotos)
- (vector-set! temp-map nvars ngotos)
- (set! from-state (make-vector ngotos #f))
- (set! to-state (make-vector ngotos #f))
-
- (do ((sp first-shift (cdr sp)))
- ((null? sp))
- (let* ((x (car sp))
- (state1 (shift-number x)))
- (do ((i (shift-shifts x) (cdr i)))
- ((null? i))
- (let* ((state2 (car i))
- (symbol (vector-ref acces-symbol state2)))
- (if (< symbol nvars)
- (let ((k (vector-ref temp-map symbol)))
- (vector-set! temp-map symbol (+ k 1))
- (vector-set! from-state k state1)
- (vector-set! to-state k state2))))))))))))))
-
-
-(define (map-goto state symbol)
- (let loop ((low (vector-ref goto-map symbol))
- (high (- (vector-ref goto-map (+ symbol 1)) 1)))
- (if (> low high)
- (begin
- (display (list "Error in map-goto" state symbol) (current-error-port))
- (newline (current-error-port))
- 0)
- (let* ((middle (quotient (+ low high) 2))
- (s (vector-ref from-state middle)))
- (cond
- ((= s state)
- middle)
- ((< s state)
- (loop (+ middle 1) high))
- (else
- (loop low (- middle 1))))))))
-
-
-(define (initialize-F)
- (set! F (make-vector ngotos #f))
- (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
-
- (let ((reads (make-vector ngotos #f)))
-
- (let loop ((i 0) (rowp 0))
- (if (< i ngotos)
- (let* ((rowf (vector-ref F rowp))
- (stateno (vector-ref to-state i))
- (sp (vector-ref shift-table stateno)))
- (if sp
- (let loop2 ((j (shift-shifts sp)) (edges '()))
- (if (pair? j)
- (let ((symbol (vector-ref acces-symbol (car j))))
- (if (< symbol nvars)
- (if (vector-ref nullable symbol)
- (loop2 (cdr j) (cons (map-goto stateno symbol)
- edges))
- (loop2 (cdr j) edges))
- (begin
- (set-bit rowf (- symbol nvars))
- (loop2 (cdr j) edges))))
- (if (pair? edges)
- (vector-set! reads i (reverse edges))))))
- (loop (+ i 1) (+ rowp 1)))))
- (digraph reads)))
-
-(define (add-lookback-edge stateno ruleno gotono)
- (let ((k (vector-ref lookaheads (+ stateno 1))))
- (let loop ((found #f) (i (vector-ref lookaheads stateno)))
- (if (and (not found) (< i k))
- (if (= (vector-ref LAruleno i) ruleno)
- (loop #t i)
- (loop found (+ i 1)))
-
- (if (not found)
- (begin (display "Error in add-lookback-edge : " (current-error-port))
- (display (list stateno ruleno gotono) (current-error-port))
- (newline (current-error-port)))
- (vector-set! lookback i
- (cons gotono (vector-ref lookback i))))))))
-
-
-(define (transpose r-arg n)
- (let ((new-end (make-vector n #f))
- (new-R (make-vector n #f)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((x (list 'bidon)))
- (vector-set! new-R i x)
- (vector-set! new-end i x)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((sp (vector-ref r-arg i)))
- (if (pair? sp)
- (let loop ((sp2 sp))
- (if (pair? sp2)
- (let* ((x (car sp2))
- (y (vector-ref new-end x)))
- (set-cdr! y (cons i (cdr y)))
- (vector-set! new-end x (cdr y))
- (loop (cdr sp2))))))))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! new-R i (cdr (vector-ref new-R i))))
-
- new-R))
-
-
-
-(define (build-relations)
-
- (define (get-state stateno symbol)
- (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
- (stno stateno))
- (if (null? j)
- stno
- (let ((st2 (car j)))
- (if (= (vector-ref acces-symbol st2) symbol)
- st2
- (loop (cdr j) st2))))))
-
- (set! includes (make-vector ngotos #f))
- (do ((i 0 (+ i 1)))
- ((= i ngotos))
- (let ((state1 (vector-ref from-state i))
- (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
- (let loop ((rulep (vector-ref derives symbol1))
- (edges '()))
- (if (pair? rulep)
- (let ((*rulep (car rulep)))
- (let loop2 ((rp (vector-ref rrhs *rulep))
- (stateno state1)
- (states (list state1)))
- (let ((*rp (vector-ref ritem rp)))
- (if (> *rp 0)
- (let ((st (get-state stateno *rp)))
- (loop2 (+ rp 1) st (cons st states)))
- (begin
-
- (if (not (vector-ref consistent stateno))
- (add-lookback-edge stateno *rulep i))
-
- (let loop2 ((done #f)
- (stp (cdr states))
- (rp2 (- rp 1))
- (edgp edges))
- (if (not done)
- (let ((*rp (vector-ref ritem rp2)))
- (if (< -1 *rp nvars)
- (loop2 (not (vector-ref nullable *rp))
- (cdr stp)
- (- rp2 1)
- (cons (map-goto (car stp) *rp) edgp))
- (loop2 #t stp rp2 edgp)))
-
- (loop (cdr rulep) edgp))))))))
- (vector-set! includes i edges)))))
- (set! includes (transpose includes ngotos)))
-
-
-
-(define (compute-lookaheads)
- (let ((n (vector-ref lookaheads nstates)))
- (let loop ((i 0))
- (if (< i n)
- (let loop2 ((sp (vector-ref lookback i)))
- (if (pair? sp)
- (let ((LA-i (vector-ref LA i))
- (F-j (vector-ref F (car sp))))
- (bit-union LA-i F-j token-set-size)
- (loop2 (cdr sp)))
- (loop (+ i 1))))))))
-
-
-
-(define (digraph relation)
- (define infinity (+ ngotos 2))
- (define INDEX (make-vector (+ ngotos 1) 0))
- (define VERTICES (make-vector (+ ngotos 1) 0))
- (define top 0)
- (define R relation)
-
- (define (traverse i)
- (set! top (+ 1 top))
- (vector-set! VERTICES top i)
- (let ((height top))
- (vector-set! INDEX i height)
- (let ((rp (vector-ref R i)))
- (if (pair? rp)
- (let loop ((rp2 rp))
- (if (pair? rp2)
- (let ((j (car rp2)))
- (if (= 0 (vector-ref INDEX j))
- (traverse j))
- (if (> (vector-ref INDEX i)
- (vector-ref INDEX j))
- (vector-set! INDEX i (vector-ref INDEX j)))
- (let ((F-i (vector-ref F i))
- (F-j (vector-ref F j)))
- (bit-union F-i F-j token-set-size))
- (loop (cdr rp2))))))
- (if (= (vector-ref INDEX i) height)
- (let loop ()
- (let ((j (vector-ref VERTICES top)))
- (set! top (- top 1))
- (vector-set! INDEX j infinity)
- (if (not (= i j))
- (begin
- (bit-union (vector-ref F i)
- (vector-ref F j)
- token-set-size)
- (loop)))))))))
-
- (let loop ((i 0))
- (if (< i ngotos)
- (begin
- (if (and (= 0 (vector-ref INDEX i))
- (pair? (vector-ref R i)))
- (traverse i))
- (loop (+ i 1))))))
-
-
-;; ---------------------------------------------------------------------- ;;
-;; operator precedence management ;;
-;; ---------------------------------------------------------------------- ;;
-
-; a vector of precedence descriptors where each element
-; is of the form (terminal type precedence)
-(define the-terminals/prec #f) ; terminal symbols with precedence
-; the precedence is an integer >= 0
-(define (get-symbol-precedence sym)
- (caddr (vector-ref the-terminals/prec sym)))
-; the operator type is either 'none, 'left, 'right, or 'nonassoc
-(define (get-symbol-assoc sym)
- (cadr (vector-ref the-terminals/prec sym)))
-
-(define rule-precedences '())
-(define (add-rule-precedence! rule sym)
- (set! rule-precedences
- (cons (cons rule sym) rule-precedences)))
-
-(define (get-rule-precedence ruleno)
- (cond
- ((assq ruleno rule-precedences)
- => (lambda (p)
- (get-symbol-precedence (cdr p))))
- (else
- ;; process the rule symbols from left to right
- (let loop ((i (vector-ref rrhs ruleno))
- (prec 0))
- (let ((item (vector-ref ritem i)))
- ;; end of rule
- (if (< item 0)
- prec
- (let ((i1 (+ i 1)))
- (if (>= item nvars)
- ;; it's a terminal symbol
- (loop i1 (get-symbol-precedence (- item nvars)))
- (loop i1 prec)))))))))
-
-;; ---------------------------------------------------------------------- ;;
-;; Build the various tables ;;
-;; ---------------------------------------------------------------------- ;;
-(define (build-tables)
-
- (define (resolve-conflict sym rule)
- (let ((sym-prec (get-symbol-precedence sym))
- (sym-assoc (get-symbol-assoc sym))
- (rule-prec (get-rule-precedence rule)))
- (cond
- ((> sym-prec rule-prec) 'shift)
- ((< sym-prec rule-prec) 'reduce)
- ((eq? sym-assoc 'left) 'reduce)
- ((eq? sym-assoc 'right) 'shift)
- (else 'shift))))
-
- ;; --- Add an action to the action table ------------------------------ ;;
- (define (add-action St Sym Act)
- (let* ((x (vector-ref action-table St))
- (y (assv Sym x)))
- (if y
- (if (not (= Act (cdr y)))
- ;; -- there is a conflict
- (begin
- (if (and (<= (cdr y) 0)
- (<= Act 0))
- ;; --- reduce/reduce conflict ----------------------- ;;
- (begin
- (display "%% Reduce/Reduce conflict " (current-error-port))
- (display "(reduce " (current-error-port))
- (display (- Act) (current-error-port))
- (display ", reduce " (current-error-port))
- (display (- (cdr y)) (current-error-port))
- (display ") on " (current-error-port))
- (print-symbol (+ Sym nvars) (current-error-port))
- (display " in state " (current-error-port))
- (display St (current-error-port))
- (newline (current-error-port))
- (set-cdr! y (max (cdr y) Act)))
- ;; --- shift/reduce conflict ------------------------ ;;
- ;; can we resolve the conflict using precedences?
- (case (resolve-conflict Sym (- (cdr y)))
- ;; -- shift
- ((shift)
- (set-cdr! y Act))
- ;; -- reduce
- ((reduce)
- #f) ; well, nothing to do...
- ;; -- signal a conflict!
- (else
- (display "%% Shift/Reduce conflict " (current-error-port))
- (display "(shift " (current-error-port))
- (display Act (current-error-port))
- (display ", reduce " (current-error-port))
- (display (- (cdr y)) (current-error-port))
- (display ") on " (current-error-port))
- (print-symbol (+ Sym nvars) (current-error-port))
- (display " in state " (current-error-port))
- (display St (current-error-port))
- (newline (current-error-port))
- (set-cdr! y Act))))))
-
- (vector-set! action-table St (cons (cons Sym Act) x)))))
-
- (set! action-table (make-vector nstates '()))
-
- (do ((i 0 (+ i 1))) ; i = state
- ((= i nstates))
- (let ((red (vector-ref reduction-table i)))
- (if (and red (>= (red-nreds red) 1))
- (if (and (= (red-nreds red) 1) (vector-ref consistent i))
- (add-action i 'default (- (car (red-rules red))))
- (let ((k (vector-ref lookaheads (+ i 1))))
- (let loop ((j (vector-ref lookaheads i)))
- (if (< j k)
- (let ((rule (- (vector-ref LAruleno j)))
- (lav (vector-ref LA j)))
- (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
- (if (< token nterms)
- (begin
- (let ((in-la-set? (modulo x 2)))
- (if (= in-la-set? 1)
- (add-action i token rule)))
- (if (= y (BITS-PER-WORD))
- (loop2 (+ token 1)
- (vector-ref lav (+ z 1))
- 1
- (+ z 1))
- (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
- (loop (+ j 1)))))))))
-
- (let ((shiftp (vector-ref shift-table i)))
- (if shiftp
- (let loop ((k (shift-shifts shiftp)))
- (if (pair? k)
- (let* ((state (car k))
- (symbol (vector-ref acces-symbol state)))
- (if (>= symbol nvars)
- (add-action i (- symbol nvars) state))
- (loop (cdr k))))))))
-
- (add-action final-state 0 'accept))
-
-(define (compact-action-table terms)
- (define (most-common-action acts)
- (let ((accums '()))
- (let loop ((l acts))
- (if (pair? l)
- (let* ((x (cdar l))
- (y (assv x accums)))
- (if (and (number? x) (< x 0))
- (if y
- (set-cdr! y (+ 1 (cdr y)))
- (set! accums (cons `(,x . 1) accums))))
- (loop (cdr l)))))
-
- (let loop ((l accums) (max 0) (sym #f))
- (if (null? l)
- sym
- (let ((x (car l)))
- (if (> (cdr x) max)
- (loop (cdr l) (cdr x) (car x))
- (loop (cdr l) max sym)))))))
-
- (define (translate-terms acts)
- (map (lambda (act)
- (cons (list-ref terms (car act))
- (cdr act)))
- acts))
-
- (do ((i 0 (+ i 1)))
- ((= i nstates))
- (let ((acts (vector-ref action-table i)))
- (if (vector? (vector-ref reduction-table i))
- (let ((act (most-common-action acts)))
- (vector-set! action-table i
- (cons `(*default* . ,(if act act 'error))
- (translate-terms
- (lalr-filter (lambda (x)
- (not (eq? (cdr x) act)))
- acts)))))
- (vector-set! action-table i
- (cons `(*default* . *error*)
- (translate-terms acts)))))))
-
-
-
-;; --
-
-(define (rewrite-grammar tokens grammar k)
-
- (define eoi '*eoi*)
-
- (define (check-terminal term terms)
- (cond
- ((not (valid-terminal? term))
- (lalr-error "invalid terminal: " term))
- ((member term terms)
- (lalr-error "duplicate definition of terminal: " term))))
-
- (define (prec->type prec)
- (cdr (assq prec '((left: . left)
- (right: . right)
- (nonassoc: . nonassoc)))))
-
- (cond
- ;; --- a few error conditions ---------------------------------------- ;;
- ((not (list? tokens))
- (lalr-error "Invalid token list: " tokens))
- ((not (pair? grammar))
- (lalr-error "Grammar definition must have a non-empty list of productions" '()))
-
- (else
- ;; --- check the terminals ---------------------------------------- ;;
- (let loop1 ((lst tokens)
- (rev-terms '())
- (rev-terms/prec '())
- (prec-level 0))
- (if (pair? lst)
- (let ((term (car lst)))
- (cond
- ((pair? term)
- (if (and (memq (car term) '(left: right: nonassoc:))
- (not (null? (cdr term))))
- (let ((prec (+ prec-level 1))
- (optype (prec->type (car term))))
- (let loop-toks ((l (cdr term))
- (rev-terms rev-terms)
- (rev-terms/prec rev-terms/prec))
- (if (null? l)
- (loop1 (cdr lst) rev-terms rev-terms/prec prec)
- (let ((term (car l)))
- (check-terminal term rev-terms)
- (loop-toks
- (cdr l)
- (cons term rev-terms)
- (cons (list term optype prec) rev-terms/prec))))))
-
- (lalr-error "invalid operator precedence specification: " term)))
-
- (else
- (check-terminal term rev-terms)
- (loop1 (cdr lst)
- (cons term rev-terms)
- (cons (list term 'none 0) rev-terms/prec)
- prec-level))))
-
- ;; --- check the grammar rules ------------------------------ ;;
- (let loop2 ((lst grammar) (rev-nonterm-defs '()))
- (if (pair? lst)
- (let ((def (car lst)))
- (if (not (pair? def))
- (lalr-error "Nonterminal definition must be a non-empty list" '())
- (let ((nonterm (car def)))
- (cond ((not (valid-nonterminal? nonterm))
- (lalr-error "Invalid nonterminal:" nonterm))
- ((or (member nonterm rev-terms)
- (assoc nonterm rev-nonterm-defs))
- (lalr-error "Nonterminal previously defined:" nonterm))
- (else
- (loop2 (cdr lst)
- (cons def rev-nonterm-defs)))))))
- (let* ((terms (cons eoi (reverse rev-terms)))
- (terms/prec (cons '(eoi none 0) (reverse rev-terms/prec)))
- (nonterm-defs (reverse rev-nonterm-defs))
- (nonterms (cons '*start* (map car nonterm-defs))))
- (if (= (length nonterms) 1)
- (lalr-error "Grammar must contain at least one nonterminal" '())
- (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) -> $1)
- nonterm-defs))
- (ruleno 0)
- (comp-defs '()))
- (if (pair? defs)
- (let* ((nonterm-def (car defs))
- (compiled-def (rewrite-nonterm-def
- nonterm-def
- ruleno
- terms nonterms)))
- (loop-defs (cdr defs)
- (+ ruleno (length compiled-def))
- (cons compiled-def comp-defs)))
-
- (let ((compiled-nonterm-defs (reverse comp-defs)))
- (k terms
- terms/prec
- nonterms
- (map (lambda (x) (cons (caaar x) (map cdar x)))
- compiled-nonterm-defs)
- (apply append compiled-nonterm-defs))))))))))))))
-
-
-(define *arrow* '->)
-
-(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
-
- (define No-NT (length nonterms))
-
- (define (encode x)
- (let ((PosInNT (pos-in-list x nonterms)))
- (if PosInNT
- PosInNT
- (let ((PosInT (pos-in-list x terms)))
- (if PosInT
- (+ No-NT PosInT)
- (lalr-error "undefined symbol : " x))))))
-
- (define (process-prec-directive rhs ruleno)
- (let loop ((l rhs))
- (if (null? l)
- '()
- (let ((first (car l))
- (rest (cdr l)))
- (cond
- ((or (member first terms) (member first nonterms))
- (cons first (loop rest)))
- ((and (pair? first)
- (eq? (car first) 'prec:))
- (pair? (cdr first))
- (if (and (pair? (cdr first))
- (member (cadr first) terms))
- (if (null? (cddr first))
- (begin
- (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
- (loop rest))
- (lalr-error "prec: directive should be at end of rule: " rhs))
- (lalr-error "Invalid prec: directive: " first)))
- (else
- (lalr-error "Invalid terminal or nonterminal: " first)))))))
-
-
- (if (not (pair? (cdr nonterm-def)))
- (lalr-error "At least one production needed for nonterminal" (car nonterm-def))
- (let ((name (symbol->string (car nonterm-def))))
- (let loop1 ((lst (cdr nonterm-def))
- (i 1)
- (rev-productions-and-actions '()))
- (if (not (pair? lst))
- (reverse rev-productions-and-actions)
- (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
- (rest (cdr lst))
- (prod (map encode (cons (car nonterm-def) rhs))))
- (for-each (lambda (x)
- (if (not (or (member x terms) (member x nonterms)))
- (lalr-error "Invalid terminal or nonterminal" x)))
- rhs)
- (if (and (pair? rest)
- (eq? (car rest) *arrow*)
- (pair? (cdr rest)))
- (loop1 (cddr rest)
- (+ i 1)
- (cons (cons prod (cadr rest))
- rev-productions-and-actions))
- (let* ((rhs-length (length rhs))
- (action
- (cons 'vector
- (cons (list 'quote (string->symbol
- (string-append
- name
- "-"
- (number->string i))))
- (let loop-j ((j 1))
- (if (> j rhs-length)
- '()
- (cons (string->symbol
- (string-append
- "$"
- (number->string j)))
- (loop-j (+ j 1)))))))))
- (loop1 rest
- (+ i 1)
- (cons (cons prod action)
- rev-productions-and-actions))))))))))
-
-(define (valid-nonterminal? x)
- (symbol? x))
-
-(define (valid-terminal? x)
- (symbol? x)) ; DB
-
-;; ---------------------------------------------------------------------- ;;
-;; Miscellaneous ;;
-;; ---------------------------------------------------------------------- ;;
-(define (pos-in-list x lst)
- (let loop ((lst lst) (i 0))
- (cond ((not (pair? lst)) #f)
- ((equal? (car lst) x) i)
- (else (loop (cdr lst) (+ i 1))))))
-
-(define (sunion lst1 lst2) ; union of sorted lists
- (let loop ((L1 lst1)
- (L2 lst2))
- (cond ((null? L1) L2)
- ((null? L2) L1)
- (else
- (let ((x (car L1)) (y (car L2)))
- (cond
- ((> x y)
- (cons y (loop L1 (cdr L2))))
- ((< x y)
- (cons x (loop (cdr L1) L2)))
- (else
- (loop (cdr L1) L2))
- ))))))
-
-(define (sinsert elem lst)
- (let loop ((l1 lst))
- (if (null? l1)
- (cons elem l1)
- (let ((x (car l1)))
- (cond ((< elem x)
- (cons elem l1))
- ((> elem x)
- (cons x (loop (cdr l1))))
- (else
- l1))))))
-
-(define (lalr-filter p lst)
- (let loop ((l lst))
- (if (null? l)
- '()
- (let ((x (car l)) (y (cdr l)))
- (if (p x)
- (cons x (loop y))
- (loop y))))))
-
-;; ---------------------------------------------------------------------- ;;
-;; Debugging tools ... ;;
-;; ---------------------------------------------------------------------- ;;
-(define the-terminals #f) ; names of terminal symbols
-(define the-nonterminals #f) ; non-terminals
-
-(define (print-item item-no)
- (let loop ((i item-no))
- (let ((v (vector-ref ritem i)))
- (if (>= v 0)
- (loop (+ i 1))
- (let* ((rlno (- v))
- (nt (vector-ref rlhs rlno)))
- (display (vector-ref the-nonterminals nt)) (display " --> ")
- (let loop ((i (vector-ref rrhs rlno)))
- (let ((v (vector-ref ritem i)))
- (if (= i item-no)
- (display ". "))
- (if (>= v 0)
- (begin
- (print-symbol v)
- (display " ")
- (loop (+ i 1)))
- (begin
- (display " (rule ")
- (display (- v))
- (display ")")
- (newline))))))))))
-
-(define (print-symbol n . port)
- (display (if (>= n nvars)
- (vector-ref the-terminals (- n nvars))
- (vector-ref the-nonterminals n))
- (if (null? port)
- (current-output-port)
- (car port))))
-
-(define (print-states)
-"Print the states of a generated parser."
- (define (print-action act)
- (cond
- ((eq? act '*error*)
- (display " : Error"))
- ((eq? act 'accept)
- (display " : Accept input"))
- ((< act 0)
- (display " : reduce using rule ")
- (display (- act)))
- (else
- (display " : shift and goto state ")
- (display act)))
- (newline)
- #t)
-
- (define (print-actions acts)
- (let loop ((l acts))
- (if (null? l)
- #t
- (let ((sym (caar l))
- (act (cdar l)))
- (display " ")
- (cond
- ((eq? sym 'default)
- (display "default action"))
- (else
- (if (number? sym)
- (print-symbol (+ sym nvars))
- (display sym))))
- (print-action act)
- (loop (cdr l))))))
-
- (if (not action-table)
- (begin
- (display "No generated parser available!")
- (newline)
- #f)
- (begin
- (display "State table") (newline)
- (display "-----------") (newline) (newline)
-
- (let loop ((l first-state))
- (if (null? l)
- #t
- (let* ((core (car l))
- (i (core-number core))
- (items (core-items core))
- (actions (vector-ref action-table i)))
- (display "state ") (display i) (newline)
- (newline)
- (for-each (lambda (x) (display " ") (print-item x))
- items)
- (newline)
- (print-actions actions)
- (newline)
- (loop (cdr l))))))))
-
-
-
-;; ---------------------------------------------------------------------- ;;
-
-(define build-goto-table
- (lambda ()
- `(vector
- ,@(map
- (lambda (shifts)
- (list 'quote
- (if shifts
- (let loop ((l (shift-shifts shifts)))
- (if (null? l)
- '()
- (let* ((state (car l))
- (symbol (vector-ref acces-symbol state)))
- (if (< symbol nvars)
- (cons `(,symbol . ,state)
- (loop (cdr l)))
- (loop (cdr l))))))
- '())))
- (vector->list shift-table)))))
-
-
-(define build-reduction-table
- (lambda (gram/actions)
- `(vector
- '()
- ,@(map
- (lambda (p)
- (let ((act (cdr p)))
- `(lambda (___stack ___sp ___goto-table ___k)
- ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
- `(let* (,@(if act
- (let loop ((i 1) (l rhs))
- (if (pair? l)
- (let ((rest (cdr l)))
- (cons
- `(,(string->symbol
- (string-append
- "$"
- (number->string
- (+ (- n i) 1))))
- (vector-ref ___stack (- ___sp ,(- (* i 2) 1))))
- (loop (+ i 1) rest)))
- '()))
- '()))
- ,(if (= nt 0)
- '$1
- `(___push ___stack (- ___sp ,(* 2 n))
- ,nt ___goto-table ,(cdr p) ___k)))))))
-
- gram/actions))))
-
-
-;; @section (api "API")
-
-(define-macro (lalr-parser tokens . rules)
- (let* ((gram/actions (gen-tables! tokens rules))
- (code
- `(letrec ((___max-stack-size 500)
-
- (___atable ',action-table)
- (___gtable ,(build-goto-table))
- (___grow-stack (lambda (stack)
- ;; make a new stack twice as big as the original
- (let ((new-stack (make-vector (* 2 (vector-length stack)) #f)))
- ;; then copy the elements...
- (let loop ((i (- (vector-length stack) 1)))
- (if (< i 0)
- new-stack
- (begin
- (vector-set! new-stack i (vector-ref stack i))
- (loop (- i 1))))))))
-
- (___push (lambda (stack sp new-cat goto-table lval k)
- (let* ((state (vector-ref stack sp))
- (new-state (cdr (assq new-cat (vector-ref goto-table state))))
- (new-sp (+ sp 2))
- (stack (if (< new-sp (vector-length stack))
- stack
- (___grow-stack stack))))
- (vector-set! stack new-sp new-state)
- (vector-set! stack (- new-sp 1) lval)
- (k stack new-sp))))
-
- (___action (lambda (x l)
- (let ((y (assq x l)))
- (if y (cdr y) (cdar l)))))
-
- (___rtable ,(build-reduction-table gram/actions)))
-
- (lambda (lexerp errorp)
-
- (let ((stack (make-vector ___max-stack-size 0)))
- (let loop ((stack stack) (sp 0) (input (lexerp)))
- (let* ((state (vector-ref stack sp))
- (i (if (pair? input) (car input) input))
- (attr (if (pair? input) (cdr input) #f))
- (act (___action i (vector-ref ___atable state))))
-
- (if (not (symbol? i))
- (errorp "PARSE ERROR: invalid token: " input))
-
- (cond
-
- ;; Input succesfully parsed
- ((eq? act 'accept)
- (vector-ref stack 1))
-
- ;; Syntax error in input
- ((eq? act '*error*)
- (if (eq? i '*eoi*)
- (errorp "PARSE ERROR : unexpected end of input ")
- (errorp "PARSE ERROR : unexpected token : " input)))
-
- ;; Shift current token on top of the stack
- ((>= act 0)
- (let ((stack (if (< (+ sp 2) (vector-length stack))
- stack
- (___grow-stack stack))))
- (vector-set! stack (+ sp 1) attr)
- (vector-set! stack (+ sp 2) act)
- (loop stack (+ sp 2) (lexerp))))
-
- ;; Reduce by rule (- act)
- (else
- ((vector-ref ___rtable (- act))
- stack sp ___gtable
- (lambda (stack sp)
- (loop stack sp input))))))))))))
- code))
-
-;; arch-tag: 4FE771DE-F56D-11D8-8B77-000A95B4C7DC