summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/Makefile.am7
-rw-r--r--module/language/ecmascript/parse-lalr.scm1730
-rw-r--r--module/language/ecmascript/parse.scm332
-rw-r--r--module/language/ecmascript/tokenize.scm467
4 files changed, 2535 insertions, 1 deletions
diff --git a/module/language/Makefile.am b/module/language/Makefile.am
index ebaeb98bc..f7c97fcf6 100644
--- a/module/language/Makefile.am
+++ b/module/language/Makefile.am
@@ -1,4 +1,9 @@
SUBDIRS=scheme ghil glil assembly bytecode objcode value
-SOURCES=ghil.scm glil.scm assembly.scm
+SOURCES=ghil.scm glil.scm assembly.scm \
+ ecmascript/parse-lalr.scm \
+ ecmascript/tokenize.scm
+# unfortunately, the one that we want to compile can't yet be compiled
+# -- too many local vars, or something.
+NOCOMP_SOURCES = ecmascript/parse.scm
modpath = language
include $(top_srcdir)/am/guilec
diff --git a/module/language/ecmascript/parse-lalr.scm b/module/language/ecmascript/parse-lalr.scm
new file mode 100644
index 000000000..6378d087c
--- /dev/null
+++ b/module/language/ecmascript/parse-lalr.scm
@@ -0,0 +1,1730 @@
+;; (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 program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+;; ---------------------------------------------------------------------- ;;
+#!
+;;; 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
diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm
new file mode 100644
index 000000000..ebc7eaae8
--- /dev/null
+++ b/module/language/ecmascript/parse.scm
@@ -0,0 +1,332 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ecmascript parse)
+ #:use-module (language ecmascript parse-lalr)
+ #:use-module (language ecmascript tokenize)
+ #:export (read-ecmascript read-ecmascript/1 parse-ecmascript))
+
+(define (read-ecmascript port)
+ (parse-ecmascript (make-tokenizer port) pk))
+
+(define (read-ecmascript/1 port)
+ (parse-ecmascript (make-tokenizer/1 port) pk))
+
+(define parse-ecmascript
+ (lalr-parser
+ ;; terminal (i.e. input) token types
+ (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma <
+ > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ?
+ colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /=
+
+ break else new var case finally return void catch for switch while
+ continue function this with default if throw delete in try do
+ instanceof typeof null true false
+
+ Identifier StringLiteral NumericLiteral RegexpLiteral)
+
+
+ (Program (SourceElements) -> $1
+ (*eoi*) -> (call-with-input-string "" read-char))
+
+ ;;
+ ;; Verily, here we define statements. Expressions are defined
+ ;; afterwards.
+ ;;
+
+ (SourceElement (Statement) -> $1
+ (FunctionDeclaration) -> $1)
+
+ (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda () ,@$6))
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda ,$4 ,@$7)))
+ (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,@$5)
+ (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,@$6)
+ (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$3 ,@$6)
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$4 ,@$7))
+ (FormalParameterList (Identifier) -> `(,$1)
+ (FormalParameterList comma Identifier) -> `(,@$1 ,$3))
+ (SourceElements (SourceElement) -> $1
+ (SourceElements SourceElement) -> (if (and (pair? $1) (eq? (car $1) 'begin))
+ `(begin ,@(cdr $1) ,$2)
+ `(begin ,$1 ,$2)))
+ (FunctionBody (SourceElements) -> $1)
+
+ (Statement (Block) -> $1
+ (VariableStatement) -> $1
+ (EmptyStatement) -> $1
+ (ExpressionStatement) -> $1
+ (IfStatement) -> $1
+ (IterationStatement) -> $1
+ (ContinueStatement) -> $1
+ (BreakStatement) -> $1
+ (ReturnStatement) -> $1
+ (WithStatement) -> $1
+ (LabelledStatement) -> $1
+ (SwitchStatement) -> $1
+ (ThrowStatement) -> $1
+ (TryStatement) -> $1)
+
+ (Block (lbrace StatementList rbrace) -> `(block ,$2))
+ (StatementList (Statement) -> $1
+ (StatementList Statement) -> (if (and (pair? $1) (eq? (car $1) 'begin))
+ `(begin ,@(cdr $1) ,$2)
+ `(begin ,$1 ,$2)))
+
+ (VariableStatement (var VariableDeclarationList) -> `(var ,@$2))
+ (VariableDeclarationList (VariableDeclaration) -> `(,$1)
+ (VariableDeclarationList comma VariableDeclaration) -> `(,@$1 ,$2))
+ (VariableDeclarationListNoIn (VariableDeclarationNoIn) -> `(,$1)
+ (VariableDeclarationListNoIn comma VariableDeclarationNoIn) -> `(,@$1 ,$2))
+ (VariableDeclaration (Identifier) -> `(,$1)
+ (Identifier Initialiser) -> `(,$1 ,$2))
+ (VariableDeclarationNoIn (Identifier) -> `(,$1)
+ (Identifier Initialiser) -> `(,$1 ,$2))
+ (Initialiser (= AssignmentExpression) -> $1)
+ (InitialiserNoIn (= AssignmentExpressionNoIn) -> $1)
+
+ (EmptyStatement (semicolon) -> '(begin))
+
+ (ExpressionStatement (Expression semicolon) -> $1)
+
+ (IfStatement (if lparen Expression rparen Statement else Statement) -> `(if ,$3 ,$5 ,$7)
+ (if lparen Expression rparen Statement) -> `(if ,$3 ,$5))
+
+ (IterationStatement (do Statement while lparen Expression rparen semicolon) -> `(do ,$2 ,$5)
+
+ (while lparen Expression rparen Statement) -> `(while ,$3 ,$5)
+
+ (for lparen semicolon semicolon rparen Statement) -> `(for #f #f #f ,$6)
+ (for lparen semicolon semicolon Expression rparen Statement) -> `(for #f #f ,$5 ,$7)
+ (for lparen semicolon Expression semicolon rparen Statement) -> `(for #f ,$4 #f ,$7)
+ (for lparen semicolon Expression semicolon Expression rparen Statement) -> `(for #f ,$4 ,$6 ,$8)
+
+ (for lparen ExpressionNoIn semicolon semicolon rparen Statement) -> `(for ,$3 #f #f ,$7)
+ (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) -> `(for ,$3 #f ,$6 ,$8)
+ (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) -> `(for ,$3 ,$5 #f ,$8)
+ (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for ,$3 ,$5 ,$7 ,$9)
+
+ (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) -> `(for (var ,$4) #f #f ,$8)
+ (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) -> `(for (var ,$4) #f ,$7 ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) -> `(for (var ,$4) ,$6 #f ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for (var ,$4) ,$6 ,$8 ,$10)
+
+ (for lparen LeftHandSideExpression in Expression rparen Statement) -> `(for-in ,$3 ,$5 ,$7)
+ (for lparen var VariableDeclarationNoIn in Expression rparen Statement) -> `(for-in ,$4 ,$6 ,$8))
+
+ (ContinueStatement (continue Identifier semicolon) -> `(continue ,$2)
+ (continue semicolon) -> `(continue))
+
+ (BreakStatement (break Identifier semicolon) -> `(break ,$2)
+ (break semicolon) -> `(break))
+
+ (ReturnStatement (return Expression semicolon) -> `(return ,$2)
+ (return semicolon) -> `(return))
+
+ (WithStatement (with lparen Expression rparen Statement) -> `(with ,$3 ,$5))
+
+ (SwitchStatement (switch lparen Expression rparen CaseBlock) -> `(switch ,$3 ,@$5))
+ (CaseBlock (lbrace rbrace) -> '()
+ (lbrace CaseClauses rbrace) -> $2
+ (lbrace CaseClauses DefaultClause rbrace) -> `(,@$2 ,@$3)
+ (lbrace DefaultClause rbrace) -> `(,$2)
+ (lbrace DefaultClause CaseClauses rbrace) -> `(,@$2 ,@$3))
+ (CaseClauses (CaseClause) -> `(,$1)
+ (CaseClauses CaseClause) -> `(,@$1 ,$2))
+ (CaseClause (case Expression colon) -> `(case ,$2)
+ (case Expression colon StatementList) -> `(case ,$2 ,$4))
+ (DefaultClause (default colon) -> `(default)
+ (default colon StatementList) -> `(default ,$3))
+
+ (LabelledStatement (Identifier colon Statement) -> `(label ,$1 ,$3))
+
+ (ThrowStatement (throw Expression semicolon) -> `(throw ,$2))
+
+ (TryStatement (try Block Catch) -> `(try ,$2 ,$3 #f)
+ (try Block Finally) -> `(try ,$2 #f ,$3)
+ (try Block Catch Finally) -> `(try ,$2 ,$3 ,$4))
+ (Catch (catch lparen Identifier rparen Block) -> `(catch ,$3 ,$5))
+ (Finally (finally Block) -> `(finally ,$2))
+
+ ;;
+ ;; As promised, expressions. We build up to Expression bottom-up, so
+ ;; as to get operator precedence right.
+ ;;
+
+ (PrimaryExpression (this) -> '(this)
+ (null) -> 'null
+ (true) -> #t
+ (false) -> #f
+ (Identifier) -> `(ref ,$1)
+ (StringLiteral) -> `(string ,$1)
+ (RegexpLiteral) -> `(regexp ,$1)
+ (NumericLiteral) -> `(number ,$1)
+ (ArrayLiteral) -> $1
+ (ObjectLiteral) -> $1
+ (lparen Expression rparen) -> $2)
+
+ (ArrayLiteral (lbracket rbracket) -> '(array)
+ (lbracket Elision rbracket) -> '(array)
+ (lbracket ElementList rbracket) -> `(array ,@$2)
+ (lbracket ElementList comma rbracket) -> `(array ,@$2)
+ (lbracket ElementList comma Elision rbracket) -> `(array ,@$2))
+ (ElementList (AssignmentExpression) -> `(,$1)
+ (Elision AssignmentExpression) -> `(,$2)
+ (ElementList comma AssignmentExpression) -> `(,@$1 ,$3)
+ (ElementList comma Elision AssignmentExpression) -> `(,@$1 ,$4))
+ (Elision (comma) -> #f
+ (Elision comma) -> #f)
+
+ (ObjectLiteral (lbrace rbrace) -> `(object)
+ (lbrace PropertyNameAndValueList rbrace) -> `(object ,@$2))
+ (PropertyNameAndValueList (PropertyName colon AssignmentExpression) -> `((,$1 . ,$3))
+ (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) -> `(,@$1 (,$3 . ,$5)))
+ (PropertyName (Identifier) -> `(ref ,$1)
+ (StringLiteral) -> `(string ,$1)
+ (NumericLiteral) -> `(number ,$1))
+
+ (MemberExpression (PrimaryExpression) -> $1
+ (FunctionExpression) -> $1
+ (MemberExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3)
+ (MemberExpression dot Identifier) -> `(pref ,$1 ,$3)
+ (new MemberExpression Arguments) -> `(new ,$2 ,$3))
+
+ (NewExpression (MemberExpression) -> $1
+ (new NewExpression) -> `(new ,$2))
+
+ (CallExpression (MemberExpression Arguments) -> `(call ,$1 ,$2)
+ (CallExpression Arguments) -> `(call ,$1 ,$2)
+ (CallExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3)
+ (CallExpression dot Identifier) -> `(pref ,$1 ,$3))
+ (Arguments (lparen rparen) -> '()
+ (lparen ArgumentList rparen) -> $2)
+ (ArgumentList (AssignmentExpression) -> `(,$1)
+ (ArgumentList comma AssignmentExpression) -> `(,@$1 ,$3))
+
+ (LeftHandSideExpression (NewExpression) -> $1
+ (CallExpression) -> $1)
+
+ (PostfixExpression (LeftHandSideExpression) -> $1
+ (LeftHandSideExpression ++) -> `(postinc ,$1)
+ (LeftHandSideExpression --) -> `(postdec ,$1))
+
+ (UnaryExpression (PostfixExpression) -> $1
+ (delete UnaryExpression) -> `(delete ,$2)
+ (void UnaryExpression) -> `(void ,$2)
+ (typeof UnaryExpression) -> `(typeof ,$2)
+ (++ UnaryExpression) -> `(preinc ,$2)
+ (-- UnaryExpression) -> `(predec ,$2)
+ (+ UnaryExpression) -> `(+ ,$2)
+ (- UnaryExpression) -> `(- ,$2)
+ (~ UnaryExpression) -> `(~ ,$2)
+ (! UnaryExpression) -> `(! ,$2))
+
+ (MultiplicativeExpression (UnaryExpression) -> $1
+ (MultiplicativeExpression * UnaryExpression) -> `(* ,$1 ,$3)
+ (MultiplicativeExpression / UnaryExpression) -> `(/ ,$1 ,$3)
+ (MultiplicativeExpression % UnaryExpression) -> `(% ,$1 ,$3))
+
+ (AdditiveExpression (MultiplicativeExpression) -> $1
+ (AdditiveExpression + MultiplicativeExpression) -> `(+ ,$1 ,$3)
+ (AdditiveExpression - MultiplicativeExpression) -> `(- ,$1 ,$3))
+
+ (ShiftExpression (AdditiveExpression) -> $1
+ (ShiftExpression << MultiplicativeExpression) -> `(<< ,$1 ,$3)
+ (ShiftExpression >> MultiplicativeExpression) -> `(>> ,$1 ,$3)
+ (ShiftExpression >>> MultiplicativeExpression) -> `(>>> ,$1 ,$3))
+
+ (RelationalExpression (ShiftExpression) -> $1
+ (RelationalExpression < ShiftExpression) -> `(< ,$1 ,$3)
+ (RelationalExpression > ShiftExpression) -> `(> ,$1 ,$3)
+ (RelationalExpression <= ShiftExpression) -> `(<= ,$1 ,$3)
+ (RelationalExpression >= ShiftExpression) -> `(>= ,$1 ,$3)
+ (RelationalExpression instanceof ShiftExpression) -> `(instanceof ,$1 ,$3)
+ (RelationalExpression in ShiftExpression) -> `(in ,$1 ,$3))
+
+ (RelationalExpressionNoIn (ShiftExpression) -> $1
+ (RelationalExpressionNoIn < ShiftExpression) -> `(< ,$1 ,$3)
+ (RelationalExpressionNoIn > ShiftExpression) -> `(> ,$1 ,$3)
+ (RelationalExpressionNoIn <= ShiftExpression) -> `(<= ,$1 ,$3)
+ (RelationalExpressionNoIn >= ShiftExpression) -> `(>= ,$1 ,$3)
+ (RelationalExpressionNoIn instanceof ShiftExpression) -> `(instanceof ,$1 ,$3))
+
+ (EqualityExpression (RelationalExpression) -> $1
+ (EqualityExpression == RelationalExpression) -> `(== ,$1 ,$3)
+ (EqualityExpression != RelationalExpression) -> `(!= ,$1 ,$3)
+ (EqualityExpression === RelationalExpression) -> `(=== ,$1 ,$3)
+ (EqualityExpression !== RelationalExpression) -> `(!== ,$1 ,$3))
+
+ (EqualityExpressionNoIn (RelationalExpressionNoIn) -> $1
+ (EqualityExpressionNoIn == RelationalExpressionNoIn) -> `(== ,$1 ,$3)
+ (EqualityExpressionNoIn != RelationalExpressionNoIn) -> `(!= ,$1 ,$3)
+ (EqualityExpressionNoIn === RelationalExpressionNoIn) -> `(=== ,$1 ,$3)
+ (EqualityExpressionNoIn !== RelationalExpressionNoIn) -> `(!== ,$1 ,$3))
+
+ (BitwiseANDExpression (EqualityExpression) -> $1
+ (BitwiseANDExpression & EqualityExpression) -> `(& ,$1 ,$3))
+ (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) -> $1
+ (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) -> `(& ,$1 ,$3))
+
+ (BitwiseXORExpression (BitwiseANDExpression) -> $1
+ (BitwiseXORExpression ^ BitwiseANDExpression) -> `(^ ,$1 ,$3))
+ (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) -> $1
+ (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) -> `(^ ,$1 ,$3))
+
+ (BitwiseORExpression (BitwiseXORExpression) -> $1
+ (BitwiseORExpression bor BitwiseXORExpression) -> `(bor ,$1 ,$3))
+ (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) -> $1
+ (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) -> `(bor ,$1 ,$3))
+
+ (LogicalANDExpression (BitwiseORExpression) -> $1
+ (LogicalANDExpression && BitwiseORExpression) -> `(and ,$1 ,$3))
+ (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) -> $1
+ (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) -> `(and ,$1 ,$3))
+
+ (LogicalORExpression (LogicalANDExpression) -> $1
+ (LogicalORExpression or LogicalANDExpression) -> `(or ,$1 ,$3))
+ (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) -> $1
+ (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) -> `(or ,$1 ,$3))
+
+ (ConditionalExpression (LogicalORExpression) -> $1
+ (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) -> `(if ,$1 ,$3 ,$5))
+ (ConditionalExpressionNoIn (LogicalORExpressionNoIn) -> $1
+ (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) -> `(if ,$1 ,$3 ,$5))
+
+ (AssignmentExpression (ConditionalExpression) -> $1
+ (LeftHandSideExpression AssignmentOperator AssignmentExpression) -> `(,$2 ,$1 ,$3))
+ (AssignmentExpressionNoIn (ConditionalExpressionNoIn) -> $1
+ (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) -> `(,$2 ,$1 ,$3))
+ (AssignmentOperator (=) -> '=
+ (*=) -> '=
+ (/=) -> '/=
+ (%=) -> '%=
+ (+=) -> '+=
+ (-=) -> '-=
+ (<<=) -> '<<=
+ (>>=) -> '>>=
+ (>>>=) -> '>>>=
+ (&=) -> '&=
+ (^=) -> '^=
+ (bor=) -> 'bor=)
+
+ (Expression (AssignmentExpression) -> $1
+ (Expression comma AssignmentExpression) -> `(begin ,$1 ,$3))
+ (ExpressionNoIn (AssignmentExpressionNoIn) -> $1
+ (ExpressionNoIn comma AssignmentExpressionNoIn) -> `(begin ,$1 ,$3))))
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
new file mode 100644
index 000000000..7a716e0d6
--- /dev/null
+++ b/module/language/ecmascript/tokenize.scm
@@ -0,0 +1,467 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ecmascript tokenize)
+ #:use-module (ice-9 rdelim)
+ #:use-module ((srfi srfi-1) #:select (unfold-right))
+ #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
+
+;; taken from SSAX, sorta
+(define (read-until delims port)
+ (if (eof-object? (peek-char port))
+ (error "EOF while reading a token")
+ (let ((token (read-delimited delims port 'peek)))
+ (if (eof-object? (peek-char port))
+ (error "EOF while reading a token")
+ token))))
+
+(define (char-hex? c)
+ (and (not (eof-object? c))
+ (or (char-numeric? c)
+ (memv c '(#\a #\b #\c #\d #\e #\f))
+ (memv c '(#\A #\B #\C #\D #\E #\F)))))
+
+(define (digit->number c)
+ (- (char->integer c) (char->integer #\0)))
+
+(define (hex->number c)
+ (if (char-numeric? c)
+ (digit->number c)
+ (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
+
+(define (read-slash port div?)
+ (let* ((c0 (read-char port))
+ (c1 (peek-char port)))
+ (cond
+ ((eof-object? c1)
+ ;; hmm. error if we're not looking for a div? ?
+ '(/ . #f))
+ ((char=? c1 #\/)
+ (read-line port)
+ (next-token port div?))
+ ((char=? c1 #\*)
+ (read-char port)
+ (let lp ((c (read-char port)))
+ (cond
+ ((eof-object? c) (error "EOF while in multi-line comment"))
+ ((char=? c #\*)
+ (if (eqv? (peek-char port) #\/)
+ (begin
+ (read-char port)
+ (next-token port div?))
+ (lp (read-char port))))
+ (else
+ (lp (read-char port))))))
+ (div?
+ (case c1
+ ((#\=) (read-char port) `(/= . #f))
+ (else `(/ . #f))))
+ (else
+ (read-regexp port)))))
+
+(define (read-regexp port)
+ ;; first slash already read
+ (let ((terms (string #\/ #\\ #\nl #\cr)))
+ (let lp ((str (read-until terms port)) (head ""))
+ (let ((terminator (peek-char port)))
+ (cond
+ ((char=? terminator #\/)
+ (read-char port)
+ ;; flags
+ (let lp ((c (peek-char port)) (flags '()))
+ (if (or (eof-object? c)
+ (not (or (char-alphabetic? c)
+ (char-numeric? c)
+ (char=? c #\$)
+ (char=? c #\_))))
+ `(RegexpLiteral . (,(string-append head str) . ,(reverse flags)))
+ (begin (read-char port)
+ (lp (peek-char port) (cons c flags))))))
+ ((char=? terminator #\\)
+ (read-char port)
+ (let ((echar (read-char port)))
+ (lp (read-until terms port)
+ (string-append head str (string #\\ echar)))))
+ (else
+ (error "regexp literals may not contain newlines" str)))))))
+
+(define (read-string port)
+ (let ((c (read-char port)))
+ (let ((terms (string c #\\ #\nl #\cr)))
+ (define (read-escape port)
+ (let ((c (read-char port)))
+ (case c
+ ((#\' #\" #\\) c)
+ ((#\b) #\bs)
+ ((#\f) #\np)
+ ((#\n) #\nl)
+ ((#\r) #\cr)
+ ((#\t) #\tab)
+ ((#\v) #\vt)
+ ((#\0)
+ (let ((next (peek-char port)))
+ (cond ((eof-object? next) #\nul)
+ ((char-numeric? next)
+ (error "octal escape sequences are not supported"))
+ (else #\nul))))
+ ((#\x)
+ (let* ((a (read-char port))
+ (b (read-char port)))
+ (cond
+ ((and (char-hex? a) (char-hex? b))
+ (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
+ (else
+ (error "bad hex character escape" a b)))))
+ ((#\u)
+ (error "unicode not supported"))
+ (else
+ c))))
+ (let lp ((str (read-until terms port)))
+ (let ((terminator (peek-char port)))
+ (cond
+ ((char=? terminator c)
+ (read-char port)
+ str)
+ ((char=? terminator #\\)
+ (read-char port)
+ (let ((echar (read-escape port)))
+ (lp (string-append str (string echar)
+ (read-until terms port)))))
+ (else
+ (error "string literals may not contain newlines" str))))))))
+
+(define *keywords*
+ '(("break" . break)
+ ("else" . else)
+ ("new" . new)
+ ("var" . var)
+ ("case" . case)
+ ("finally" . finally)
+ ("return" . return)
+ ("void" . void)
+ ("catch" . catch)
+ ("for" . for)
+ ("switch" . switch)
+ ("while" . while)
+ ("continue" . continue)
+ ("function" . function)
+ ("this" . this)
+ ("with" . with)
+ ("default" . default)
+ ("if" . if)
+ ("throw" . throw)
+ ("delete" . delete)
+ ("in" . in)
+ ("try" . try)
+ ("do" . do)
+ ("instanceof" . instanceof)
+ ("typeof" . typeof)
+
+ ;; these aren't exactly keywords, but hey
+ ("null" . null)
+ ("true" . true)
+ ("false" . false)))
+
+(define *future-reserved-words*
+ '(("abstract" . abstract)
+ ("enum" . enum)
+ ("int" . int)
+ ("short" . short)
+ ("boolean" . boolean)
+ ("export" . export)
+ ("interface" . interface)
+ ("static" . static)
+ ("byte" . byte)
+ ("extends" . extends)
+ ("long" . long)
+ ("super" . super)
+ ("char" . char)
+ ("final" . final)
+ ("native" . native)
+ ("synchronized" . synchronized)
+ ("class" . class)
+ ("float" . float)
+ ("package" . package)
+ ("throws" . throws)
+ ("const" . const)
+ ("goto" . goto)
+ ("private" . private)
+ ("transient" . transient)
+ ("debugger" . debugger)
+ ("implements" . implements)
+ ("protected" . protected)
+ ("volatile" . volatile)
+ ("double" . double)
+ ("import" . import)
+ ("public" . public)))
+
+(define (read-identifier port)
+ (let lp ((c (peek-char port)) (chars '()))
+ (if (or (eof-object? c)
+ (not (or (char-alphabetic? c)
+ (char-numeric? c)
+ (char=? c #\$)
+ (char=? c #\_))))
+ (let ((word (list->string (reverse chars))))
+ (cond ((assoc-ref *keywords* word)
+ => (lambda (x) `(,x . #f)))
+ ((assoc-ref *future-reserved-words* word)
+ (error "word is reserved for the future, dude." word))
+ (else `(Identifier . ,word))))
+ (begin (read-char port)
+ (lp (peek-char port) (cons c chars))))))
+
+(define (read-numeric port)
+ (let* ((c0 (if (char=? (peek-char port) #\.)
+ #\0
+ (read-char port)))
+ (c1 (peek-char port)))
+ (cond
+ ((eof-object? c1) (digit->number c0))
+ ((and (char=? c0 #\0) (char=? c1 #\x))
+ (read-char port)
+ (let ((c (peek-char port)))
+ (if (not (char-hex? c))
+ (error "bad digit reading hexadecimal number" c))
+ (let lp ((c c) (acc 0))
+ (cond ((char-hex? c)
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 16 acc) (hex->number c))))
+ (else
+ acc)))))
+ ((and (char=? c0 #\0) (char-numeric? c1))
+ (let lp ((c c1) (acc 0))
+ (cond ((eof-object? c) acc)
+ ((char-numeric? c)
+ (if (or (char=? c #\8) (char=? c #\9))
+ (error "invalid digit in octal sequence" c))
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 8 acc) (digit->number c))))
+ (else
+ acc))))
+ (else
+ (let lp ((c1 c1) (acc (digit->number c0)))
+ (cond
+ ((eof-object? c1) acc)
+ ((char-numeric? c1)
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 10 acc) (digit->number c1))))
+ ((or (char=? c1 #\e) (char=? c1 #\E))
+ (read-char port)
+ (let ((add (let ((c (peek-char port)))
+ (cond ((eof-object? c) (error "error reading exponent: EOF"))
+ ((char=? c #\+) (read-char port) +)
+ ((char=? c #\-) (read-char port) -)
+ ((char-numeric? c) +)
+ (else (error "error reading exponent: non-digit"
+ c))))))
+ (let lp ((c (peek-char port)) (e 0))
+ (cond ((and (not (eof-object? c)) (char-numeric? c))
+ (read-char port)
+ (lp (peek-char port) (add (* 10 e) (digit->number c))))
+ (else
+ (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
+ ((char=? c1 #\.)
+ (read-char port)
+ (let lp2 ((c (peek-char port)) (dec 0.0) (n -1))
+ (cond ((and (not (eof-object? c)) (char-numeric? c))
+ (read-char port)
+ (lp2 (peek-char port)
+ (+ dec (* (digit->number c) (expt 10 n)))
+ (1- n)))
+ (else
+ ;; loop back to catch an exponential part
+ (lp c (+ acc dec))))))
+ (else
+ acc)))))))
+
+(define *punctuation*
+ '(("{" . lbrace)
+ ("}" . rbrace)
+ ("(" . lparen)
+ (")" . rparen)
+ ("[" . lbracket)
+ ("]" . rbracket)
+ ("." . dot)
+ (";" . semicolon)
+ ("," . comma)
+ ("<" . <)
+ (">" . >)
+ ("<=" . <=)
+ (">=" . >=)
+ ("==" . ==)
+ ("!=" . !=)
+ ("===" . ===)
+ ("!==" . !==)
+ ("+" . +)
+ ("-" . -)
+ ("*" . *)
+ ("%" . %)
+ ("++" . ++)
+ ("--" . --)
+ ("<<" . <<)
+ (">>" . >>)
+ (">>>" . >>>)
+ ("&" . &)
+ ("|" . bor)
+ ("^" . ^)
+ ("!" . !)
+ ("~" . ~)
+ ("&&" . &&)
+ ("||" . or)
+ ("?" . ?)
+ (":" . colon)
+ ("=" . =)
+ ("+=" . +=)
+ ("-=" . -=)
+ ("*=" . *=)
+ ("%=" . %=)
+ ("<<=" . <<=)
+ (">>=" . >>=)
+ (">>>=" . >>>=)
+ ("&=" . &=)
+ ("|=" . bor=)
+ ("^=" . ^=)))
+
+(define *div-punctuation*
+ '(("/" . /)
+ ("/=" . /=)))
+
+;; node ::= (char (symbol | #f) node*)
+(define read-punctuation
+ (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
+ (cond ((null? puncs)
+ nodes)
+ ((assv-ref nodes (string-ref (caar puncs) 0))
+ => (lambda (node-tail)
+ (if (= (string-length (caar puncs)) 1)
+ (set-car! node-tail (cdar puncs))
+ (set-cdr! node-tail
+ (lp (cdr node-tail)
+ `((,(substring (caar puncs) 1)
+ . ,(cdar puncs))))))
+ (lp nodes (cdr puncs))))
+ (else
+ (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
+ puncs))))))
+ (lambda (port)
+ (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
+ (cond
+ ((assv-ref tree c)
+ => (lambda (node-tail)
+ (read-char port)
+ (lp (peek-char port) (cdr node-tail) (car node-tail))))
+ (candidate
+ `(,candidate . #f))
+ (else
+ (error "bad syntax: character not allowed" c)))))))
+
+(define (next-token port div?)
+ (let ((c (peek-char port)))
+ (case c
+ ((#\ht #\vt #\np #\space)
+ ; whitespace
+ (read-char port)
+ (next-token port div?))
+ ((#\newline #\cr)
+ ; line break
+ (read-char port)
+ (next-token port div?))
+ ((#\/)
+ ;; division, single comment, double comment, or regexp
+ (read-slash port div?))
+ ((#\" #\')
+ ; string literal
+ `(StringLiteral . ,(read-string port)))
+ (else
+ (cond
+ ((eof-object? c)
+ '*eoi*)
+ ((or (char-alphabetic? c)
+ (char=? c #\$)
+ (char=? c #\_))
+ ;; reserved word or identifier
+ (read-identifier port))
+ ((char-numeric? c)
+ ;; numeric -- also accept . FIXME, requires lookahead
+ `(NumericLiteral . ,(read-numeric port)))
+ (else
+ ;; punctuation
+ (read-punctuation port)))))))
+
+(define (make-tokenizer port)
+ (let ((div? #f))
+ (lambda ()
+ (let ((tok (next-token port div?)))
+ (set! div? (and (pair? tok) (eq? (car tok) 'identifier)))
+ tok))))
+
+(define (make-tokenizer/1 port)
+ (let ((div? #f)
+ (eoi? #f)
+ (stack '()))
+ (lambda ()
+ (if eoi?
+ '*eoi*
+ (let ((tok (next-token port div?)))
+ (case (if (pair? tok) (car tok) tok)
+ ((lparen)
+ (set! stack (cons 'lparen stack)))
+ ((rparen)
+ (if (and (pair? stack) (eq? (car stack) 'lparen))
+ (set! stack (cdr stack))
+ (error "unexpected right parenthesis")))
+ ((lbracket)
+ (set! stack (cons 'lbracket stack)))
+ ((rbracket)
+ (if (and (pair? stack) (eq? (car stack) 'lbracket))
+ (set! stack (cdr stack))
+ (error "unexpected right bracket" stack)))
+ ((lbrace)
+ (set! stack (cons 'lbrace stack)))
+ ((rbrace)
+ (if (and (pair? stack) (eq? (car stack) 'lbrace))
+ (set! stack (cdr stack))
+ (error "unexpected right brace" stack)))
+ ((semicolon)
+ (set! eoi? (null? stack))))
+ (set! div? (and (pair? tok) (eq? (car tok) 'identifier)))
+ tok)))))
+
+(define (tokenize port)
+ (let ((next (make-tokenizer port)))
+ (let lp ((out '()))
+ (let ((tok (next)))
+ (if (eq? tok '*eoi*)
+ (reverse! out)
+ (lp (cons tok out)))))))
+
+(define (tokenize/1 port)
+ (let ((next (make-tokenizer/1 port)))
+ (let lp ((out '()))
+ (let ((tok (next)))
+ (if (eq? tok '*eoi*)
+ (reverse! out)
+ (lp (cons tok out)))))))
+