summaryrefslogtreecommitdiff
path: root/module/language/ecmascript
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/ecmascript')
-rw-r--r--module/language/ecmascript/array.scm121
-rw-r--r--module/language/ecmascript/base.scm251
-rw-r--r--module/language/ecmascript/compile-tree-il.scm576
-rw-r--r--module/language/ecmascript/function.scm78
-rw-r--r--module/language/ecmascript/impl.scm169
-rw-r--r--module/language/ecmascript/parse.scm352
-rw-r--r--module/language/ecmascript/spec.scm37
-rw-r--r--module/language/ecmascript/tokenize.scm513
8 files changed, 2097 insertions, 0 deletions
diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm
new file mode 100644
index 000000000..997034584
--- /dev/null
+++ b/module/language/ecmascript/array.scm
@@ -0,0 +1,121 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript array)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:use-module (language ecmascript function)
+ #:export (*array-prototype* new-array))
+
+
+(define-class <js-array-object> (<js-object>)
+ (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector))
+
+(define (new-array . vals)
+ (let ((o (make <js-array-object> #:class "Array"
+ #:prototype *array-prototype*)))
+ (pput o 'length (length vals))
+ (let ((vect (js-array-vector o)))
+ (let lp ((i 0) (vals vals))
+ (cond ((not (null? vals))
+ (vector-set! vect i (car vals))
+ (lp (1+ i) (cdr vals)))
+ (else o))))))
+
+(define *array-prototype* (make <js-object> #:class "Array"
+ #:value new-array
+ #:constructor new-array))
+
+(hashq-set! *program-wrappers* new-array *array-prototype*)
+
+(pput *array-prototype* 'prototype *array-prototype*)
+(pput *array-prototype* 'constructor new-array)
+
+(define-method (pget (o <js-array-object>) p)
+ (cond ((and (integer? p) (exact? p) (>= p 0))
+ (let ((v (js-array-vector o)))
+ (if (< p (vector-length v))
+ (vector-ref v p)
+ (next-method))))
+ ((or (and (symbol? p) (eq? p 'length))
+ (and (string? p) (string=? p "length")))
+ (vector-length (js-array-vector o)))
+ (else (next-method))))
+
+(define-method (pput (o <js-array-object>) p v)
+ (cond ((and (integer? p) (exact? p) (>= 0 p))
+ (let ((vect (js-array-vector o)))
+ (if (< p (vector-length vect))
+ (vector-set! vect p v)
+ ;; Fixme: round up to powers of 2?
+ (let ((new (make-vector (1+ p) 0)))
+ (vector-move-left! vect 0 (vector-length vect) new 0)
+ (set! (js-array-vector o) new)
+ (vector-set! new p v)))))
+ ((or (and (symbol? p) (eq? p 'length))
+ (and (string? p) (string=? p "length")))
+ (let ((vect (js-array-vector o)))
+ (let ((new (make-vector (->uint32 v) 0)))
+ (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v))
+ new 0)
+ (set! (js-array-vector o) new))))
+ (else (next-method))))
+
+(define-js-method *array-prototype* (toString)
+ (format #f "~A" (js-array-vector this)))
+
+(define-js-method *array-prototype* (concat . rest)
+ (let* ((len (apply + (->uint32 (pget this 'length))
+ (map (lambda (x) (->uint32 (pget x 'length)))
+ rest)))
+ (rv (make-vector len 0)))
+ (let lp ((objs (cons this rest)) (i 0))
+ (cond ((null? objs) (make <js-array-object> #:class "Array"
+ #:prototype *array-prototype*
+ #:vector rv))
+ ((is-a? (car objs) <js-array-object>)
+ (let ((v (js-array-vector (car objs))))
+ (vector-move-left! v 0 (vector-length v)
+ rv i)
+ (lp (cdr objs) (+ i (vector-length v)))))
+ (else
+ (error "generic array concats not yet implemented"))))))
+
+(define-js-method *array-prototype* (join . separator)
+ (let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
+ (if (< i 0)
+ (string-join l (if separator (->string (car separator)) ","))
+ (lp (1+ i)
+ (cons (->string (pget this i)) l)))))
+
+(define-js-method *array-prototype* (pop)
+ (let ((len (->uint32 (pget this 'length))))
+ (if (zero? len)
+ *undefined*
+ (let ((ret (pget this (1- len))))
+ (pput this 'length (1- len))
+ ret))))
+
+(define-js-method *array-prototype* (push . args)
+ (let lp ((args args))
+ (if (null? args)
+ (->uint32 (pget this 'length))
+ (begin (pput this (->uint32 (pget this 'length)) (car args))
+ (lp (cdr args))))))
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
new file mode 100644
index 000000000..fa6c85a33
--- /dev/null
+++ b/module/language/ecmascript/base.scm
@@ -0,0 +1,251 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2013, 2015 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript base)
+ #:use-module (oop goops)
+ #:export (*undefined* *this*
+ <js-object> *object-prototype*
+ js-prototype js-props js-prop-attrs js-value js-constructor js-class
+ pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel
+
+ object->string object->number object->value/string
+ object->value/number object->value
+
+ ->primitive ->boolean ->number ->integer ->int32 ->uint32
+ ->uint16 ->string ->object
+
+ call/this* call/this lambda/this define-js-method
+
+ new-object new))
+
+(define-class <undefined> ())
+
+(define *undefined* (make <undefined>))
+(define *this* (make-fluid))
+
+(define-class <js-object> ()
+ (prototype #:getter js-prototype #:init-keyword #:prototype
+ #:init-thunk (lambda () *object-prototype*))
+ (props #:getter js-props #:init-form (make-hash-table 7))
+ (prop-attrs #:getter js-prop-attrs #:init-value #f)
+ (value #:getter js-value #:init-value #f #:init-keyword #:value)
+ (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor)
+ (class #:getter js-class #:init-value "Object" #:init-keyword #:class))
+
+(define-method (prop-keys (o <js-object>))
+ (hash-map->list (lambda (k v) k) (js-props o)))
+
+(define-method (pget (o <js-object>) (p <string>))
+ (pget o (string->symbol p)))
+
+(define-method (pget (o <js-object>) p)
+ (let ((h (hashq-get-handle (js-props o) p)))
+ (if h
+ (cdr h)
+ (let ((proto (js-prototype o)))
+ (if proto
+ (pget proto p)
+ *undefined*)))))
+
+(define-method (prop-attrs (o <js-object>) p)
+ (or (let ((attrs (js-prop-attrs o)))
+ (and attrs (hashq-ref (js-prop-attrs o) p)))
+ (let ((proto (js-prototype o)))
+ (if proto
+ (prop-attrs proto p)
+ '()))))
+
+(define-method (prop-has-attr? (o <js-object>) p attr)
+ (memq attr (prop-attrs o p)))
+
+(define-method (pput (o <js-object>) p v)
+ (if (prop-has-attr? o p 'ReadOnly)
+ (throw 'ReferenceError o p)
+ (hashq-set! (js-props o) p v)))
+
+(define-method (pput (o <js-object>) (p <string>) v)
+ (pput o (string->symbol p) v))
+
+(define-method (pdel (o <js-object>) p)
+ (if (prop-has-attr? o p 'DontDelete)
+ #f
+ (begin
+ (pput o p *undefined*)
+ #t)))
+
+(define-method (pdel (o <js-object>) (p <string>) v)
+ (pdel o (string->symbol p)))
+
+(define-method (has-property? (o <js-object>) p)
+ (if (hashq-get-handle (js-props o) p)
+ #t
+ (let ((proto (js-prototype o)))
+ (if proto
+ (has-property? proto p)
+ #f))))
+
+(define (call/this* this f)
+ (with-fluid* *this* this f))
+
+(define-macro (call/this this f . args)
+ `(with-fluid* *this* ,this (lambda () (,f . ,args))))
+(define-macro (lambda/this formals . body)
+ `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body)))
+(define-macro (define-js-method object name-and-args . body)
+ `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body)))
+
+(define *object-prototype* #f)
+(set! *object-prototype* (make <js-object>))
+
+(define-js-method *object-prototype* (toString)
+ (format #f "[object ~A]" (js-class this)))
+(define-js-method *object-prototype* (toLocaleString . args)
+ ((pget *object-prototype* 'toString)))
+(define-js-method *object-prototype* (valueOf)
+ this)
+(define-js-method *object-prototype* (hasOwnProperty p)
+ (and (hashq-get-handle (js-props this) p) #t))
+(define-js-method *object-prototype* (isPrototypeOf v)
+ (eq? this (js-prototype v)))
+(define-js-method *object-prototype* (propertyIsEnumerable p)
+ (and (hashq-get-handle (js-props this) p)
+ (not (prop-has-attr? this p 'DontEnum))))
+
+(define (object->string o error?)
+ (let ((toString (pget o 'toString)))
+ (if (procedure? toString)
+ (let ((x (call/this o toString)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->number o error?)
+ (let ((valueOf (pget o 'valueOf)))
+ (if (procedure? valueOf)
+ (let ((x (call/this o valueOf)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->value/string o)
+ (if (is-a? o <js-object>)
+ (object->number o #t)
+ o))
+
+(define (object->value/number o)
+ (if (is-a? o <js-object>)
+ (object->string o #t)
+ o))
+
+(define (object->value o)
+ ;; FIXME: if it's a date, we should try numbers first
+ (object->value/string o))
+
+(define (->primitive x)
+ (if (is-a? x <js-object>)
+ (object->value x)
+ x))
+
+(define (->boolean x)
+ (not (or (not x) (null? x) (eq? x *undefined*)
+ (and (number? x) (or (zero? x) (nan? x)))
+ (and (string? x) (= (string-length x) 0)))))
+
+(define (->number x)
+ (cond ((number? x) x)
+ ((boolean? x) (if x 1 0))
+ ((null? x) 0)
+ ((eq? x *undefined*) +nan.0)
+ ((is-a? x <js-object>) (object->number x #t))
+ ((string? x) (string->number x))
+ (else (throw 'TypeError x '->number))))
+
+(define (->integer x)
+ (let ((n (->number x)))
+ (cond ((nan? n) 0)
+ ((zero? n) n)
+ ((inf? n) n)
+ (else (inexact->exact (round n))))))
+
+(define (->int32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
+ (if (negative? n)
+ (- m (ash 1 32))
+ m)))))
+
+(define (->uint32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 32)) (inexact->exact (round n))))))
+
+(define (->uint16 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 16)) (inexact->exact (round n))))))
+
+(define (->string x)
+ (cond ((eq? x *undefined*) "undefined")
+ ((null? x) "null")
+ ((boolean? x) (if x "true" "false"))
+ ((string? x) x)
+ ((number? x)
+ (cond ((nan? x) "NaN")
+ ((zero? x) "0")
+ ((inf? x) "Infinity")
+ (else (number->string x))))
+ (else (->string (object->value/string x)))))
+
+(define (->object x)
+ (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
+ ((null? x) (throw 'TypeError x '->object))
+ ((boolean? x) (make <js-object> #:prototype Boolean #:value x))
+ ((number? x) (make <js-object> #:prototype String #:value x))
+ ((string? x) (make <js-object> #:prototype Number #:value x))
+ (else x)))
+
+(define (new-object . pairs)
+ (let ((o (make <js-object>)))
+ (map (lambda (pair)
+ (pput o (car pair) (cdr pair)))
+ pairs)
+ o))
+(slot-set! *object-prototype* 'constructor new-object)
+
+(define-method (new o . initargs)
+ (let ((ctor (js-constructor o)))
+ (if (not ctor)
+ (throw 'TypeError 'new o)
+ (let ((o (make <js-object>
+ #:prototype (or (js-prototype o) *object-prototype*))))
+ (let ((new-o (call/this o apply ctor initargs)))
+ (if (is-a? new-o <js-object>)
+ new-o
+ o))))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
new file mode 100644
index 000000000..d61f7120d
--- /dev/null
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -0,0 +1,576 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2011, 2016 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript compile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 receive)
+ #:use-module (system base pmatch)
+ #:use-module (srfi srfi-1)
+ #:export (compile-tree-il))
+
+(define-syntax-rule (-> (type arg ...))
+ `(type ,arg ...))
+
+(define-syntax-rule (@implv sym)
+ (-> (@ '(language ecmascript impl) 'sym)))
+
+(define-syntax-rule (@impl sym arg ...)
+ (-> (call (@implv sym) arg ...)))
+
+(define (empty-lexical-environment)
+ '())
+
+(define (econs name gensym env)
+ (acons name (-> (lexical name gensym)) env))
+
+(define (lookup name env)
+ (or (assq-ref env name)
+ (-> (toplevel name))))
+
+(define (compile-tree-il exp env opts)
+ (values
+ (parse-tree-il
+ (-> (begin (@impl js-init)
+ (comp exp (empty-lexical-environment)))))
+ env
+ env))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+;; for emacs:
+;; (put 'pmatch/source 'scheme-indent-function 1)
+
+(define-syntax-rule (pmatch/source x clause ...)
+ (let ((x x))
+ (let ((res (pmatch x
+ clause ...)))
+ (let ((loc (location x)))
+ (if loc
+ (set-source-properties! res (location x))))
+ res)))
+
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+ (-> (abort (or (current-return-tag) (error "return outside function"))
+ (list expr)
+ (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+ (let ((tag (gensym "return")))
+ (parameterize ((current-return-tag
+ (-> (lexical 'return tag))))
+ (-> (let '(return) (list tag)
+ (list (-> (primcall 'make-prompt-tag)))
+ (-> (prompt #t
+ (current-return-tag)
+ (body-thunk)
+ (let ((val (gensym "val")))
+ (-> (lambda '()
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))))
+
+(define (comp x e)
+ (let ((l (location x)))
+ (define (let1 what proc)
+ (let ((sym (gensym)))
+ (-> (let (list sym) (list sym) (list what)
+ (proc sym)))))
+ (define (begin1 what proc)
+ (let1 what (lambda (v)
+ (-> (begin (proc v)
+ (-> (lexical v v)))))))
+ (pmatch/source x
+ (null
+ ;; FIXME, null doesn't have much relation to EOL...
+ (-> (const '())))
+ (true
+ (-> (const #t)))
+ (false
+ (-> (const #f)))
+ ((number ,num)
+ (-> (const num)))
+ ((string ,str)
+ (-> (const str)))
+ (this
+ (@impl get-this))
+ ((+ ,a)
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
+ ((- ,a)
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ ((~ ,a)
+ (@impl bitwise-not (comp a e)))
+ ((! ,a)
+ (@impl logical-not (comp a e)))
+ ((+ ,a ,b)
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
+ ((- ,a ,b)
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
+ ((/ ,a ,b)
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
+ ((* ,a ,b)
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
+ ((% ,a ,b)
+ (@impl mod (comp a e) (comp b e)))
+ ((<< ,a ,b)
+ (@impl shift (comp a e) (comp b e)))
+ ((>> ,a ,b)
+ (@impl shift (comp a e) (comp `(- ,b) e)))
+ ((< ,a ,b)
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
+ ((<= ,a ,b)
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
+ ((> ,a ,b)
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
+ ((>= ,a ,b)
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
+ ((in ,a ,b)
+ (@impl has-property? (comp a e) (comp b e)))
+ ((== ,a ,b)
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ ((!= ,a ,b)
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
+ ((=== ,a ,b)
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ ((!== ,a ,b)
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
+ ((& ,a ,b)
+ (@impl band (comp a e) (comp b e)))
+ ((^ ,a ,b)
+ (@impl bxor (comp a e) (comp b e)))
+ ((bor ,a ,b)
+ (@impl bior (comp a e) (comp b e)))
+ ((and ,a ,b)
+ (-> (if (@impl ->boolean (comp a e))
+ (comp b e)
+ (-> (const #f)))))
+ ((or ,a ,b)
+ (let1 (comp a e)
+ (lambda (v)
+ (-> (if (@impl ->boolean (-> (lexical v v)))
+ (-> (lexical v v))
+ (comp b e))))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (comp else e))))
+ ((if ,test ,then)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (@implv *undefined*))))
+ ((postinc (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set! (lookup foo e)
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((postdec (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set (lookup foo e)
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postdec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postdec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (inline
+ '- (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((preinc (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
+ v))))
+ ((preinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((preinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((predec (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (call (-> (primitive '-))
+ v
+ (-> (const 1))))))
+ v))))
+ ((predec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((predec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((ref ,id)
+ (lookup id e))
+ ((var . ,forms)
+ `(begin
+ ,@(map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define x (comp y e))))
+ ((,x)
+ (-> (define x (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms)))
+ ((begin)
+ (-> (void)))
+ ((begin ,form)
+ (comp form e))
+ ((begin . ,forms)
+ `(begin ,@(map (lambda (x) (comp x e)) forms)))
+ ((lambda ,formals ,body)
+ (let ((syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ formals)))
+ `(lambda ()
+ (lambda-case
+ ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
+ ,(with-return-prompt
+ (lambda ()
+ (comp-body e body formals syms))))))))
+ ((call/this ,obj ,prop . ,args)
+ (@impl call/this*
+ obj
+ (-> (lambda '()
+ `(lambda-case
+ ((() #f #f #f () ())
+ (call ,(@impl pget obj prop) ,@args)))))))
+ ((call (pref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(-> (const prop))
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call (aref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(comp prop e)
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call ,proc ,args)
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((return ,expr)
+ (return (comp expr e)))
+ ((array . ,args)
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((object . ,args)
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
+ ((pref ,obj ,prop)
+ (@impl pget
+ (comp obj e)
+ (-> (const prop))))
+ ((aref ,obj ,index)
+ (@impl pget
+ (comp obj e)
+ (comp index e)))
+ ((= (ref ,name) ,val)
+ (let ((v (lookup name e)))
+ (-> (begin
+ (-> (set! v (comp val e)))
+ v))))
+ ((= (pref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (-> (const prop))
+ (comp val e)))
+ ((= (aref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (comp prop e)
+ (comp val e)))
+ ((+= ,what ,val)
+ (comp `(= ,what (+ ,what ,val)) e))
+ ((-= ,what ,val)
+ (comp `(= ,what (- ,what ,val)) e))
+ ((/= ,what ,val)
+ (comp `(= ,what (/ ,what ,val)) e))
+ ((*= ,what ,val)
+ (comp `(= ,what (* ,what ,val)) e))
+ ((%= ,what ,val)
+ (comp `(= ,what (% ,what ,val)) e))
+ ((>>= ,what ,val)
+ (comp `(= ,what (>> ,what ,val)) e))
+ ((<<= ,what ,val)
+ (comp `(= ,what (<< ,what ,val)) e))
+ ((>>>= ,what ,val)
+ (comp `(= ,what (>>> ,what ,val)) e))
+ ((&= ,what ,val)
+ (comp `(= ,what (& ,what ,val)) e))
+ ((bor= ,what ,val)
+ (comp `(= ,what (bor ,what ,val)) e))
+ ((^= ,what ,val)
+ (comp `(= ,what (^ ,what ,val)) e))
+ ((new ,what ,args)
+ `(call ,(@implv new)
+ ,(comp what e)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((delete (pref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (-> (const prop))))
+ ((delete (aref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (comp prop e)))
+ ((void ,expr)
+ (-> (begin
+ (comp expr e)
+ (@implv *undefined*))))
+ ((typeof ,expr)
+ (@impl typeof
+ (comp expr e)))
+ ((do ,statement ,test)
+ (let ((%loop (gensym "%loop "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%loop %loop (econs '%continue %continue e))))
+ (-> (letrec '(%loop %continue) (list %loop %continue)
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (begin
+ (comp statement e)
+ (-> (call (-> (lexical '%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (call (-> (lexical '%loop %loop))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
+ ((while ,test ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
+
+ ((for ,init ,test ,inc ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
+ (-> (begin (comp (or init '(begin)) e)
+ (-> (call (-> (lexical '%continue %continue)))))))))))
+
+ ((for-in ,var ,object ,statement)
+ (let ((%enum (gensym "%enum "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%enum %enum (econs '%continue %continue e))))
+ (-> (letrec '(%enum %continue) (list %enum %continue)
+ (list (@impl make-enumerator (comp object e))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
+
+ ((block ,x)
+ (comp x e))
+ (else
+ (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals formal-syms)
+ (define (process)
+ (let lp ((in body) (out '()) (rvars '()))
+ (pmatch in
+ (((var (,x) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ out
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
+ (((var (,x ,y) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ `((= (ref ,x) ,y) . ,out)
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
+ (((var) . ,rest)
+ (lp rest out rvars))
+ ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+ (lp rest
+ (cons x out)
+ rvars))
+ ((,x . ,rest) (guard (pair? x))
+ (receive (sub-out rvars)
+ (lp x '() rvars)
+ (lp rest
+ (cons sub-out out)
+ rvars)))
+ ((,x . ,rest)
+ (lp rest
+ (cons x out)
+ rvars))
+ (()
+ (values (reverse! out)
+ rvars)))))
+ (receive (out rvars)
+ (process)
+ (let* ((names (reverse rvars))
+ (syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ names))
+ (e (fold econs (fold econs e formals formal-syms) names syms)))
+ (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
+ (comp out e))))))
diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm
new file mode 100644
index 000000000..710c5cb1c
--- /dev/null
+++ b/module/language/ecmascript/function.scm
@@ -0,0 +1,78 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript function)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:export (*function-prototype* *program-wrappers*))
+
+
+(define-class <js-program-wrapper> (<js-object>))
+
+(define *program-wrappers* (make-doubly-weak-hash-table 31))
+
+(define *function-prototype* (make <js-object> #:class "Function"
+ #:value (lambda args *undefined*)))
+
+(define-js-method *function-prototype* (toString)
+ (format #f "~A" (js-value this)))
+
+(define-js-method *function-prototype* (apply this-arg array)
+ (cond ((or (null? array) (eq? array *undefined*))
+ (call/this this-arg (js-value this)))
+ ((is-a? array <js-array-object>)
+ (call/this this-arg
+ (lambda ()
+ (apply (js-value this)
+ (vector->list (js-array-vector array))))))
+ (else
+ (throw 'TypeError 'apply array))))
+
+(define-js-method *function-prototype* (call this-arg . args)
+ (call/this this-arg
+ (lambda ()
+ (apply (js-value this) args))))
+
+(define-method (pget (o <applicable>) p)
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (pget wrapper p)
+ (pget *function-prototype* p))))
+
+(define-method (pput (o <applicable>) p v)
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (pput wrapper p v)
+ (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
+ #:prototype *function-prototype*)))
+ (hashq-set! *program-wrappers* o wrapper)
+ (pput wrapper p v)))))
+
+(define-method (js-prototype (o <applicable>))
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (js-prototype wrapper)
+ #f)))
+
+(define-method (js-constructor (o <applicable>))
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (js-constructor wrapper)
+ #f)))
diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm
new file mode 100644
index 000000000..27c077aed
--- /dev/null
+++ b/module/language/ecmascript/impl.scm
@@ -0,0 +1,169 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript impl)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:use-module (language ecmascript function)
+ #:use-module (language ecmascript array)
+ #:re-export (*undefined* *this* call/this*
+ pget pput pdel has-property?
+ ->boolean ->number
+ new-object new new-array)
+ #:export (js-init get-this
+ typeof
+ bitwise-not logical-not
+ shift
+ mod
+ band bxor bior
+ make-enumerator))
+
+
+(define-class <js-module-object> (<js-object>)
+ (module #:init-form (current-module) #:init-keyword #:module
+ #:getter js-module))
+(define-method (pget (o <js-module-object>) (p <string>))
+ (pget o (string->symbol p)))
+(define-method (pget (o <js-module-object>) (p <symbol>))
+ (let ((v (module-variable (js-module o) p)))
+ (if v
+ (variable-ref v)
+ (next-method))))
+(define-method (pput (o <js-module-object>) (p <string>) v)
+ (pput o (string->symbol p) v))
+(define-method (pput (o <js-module-object>) (p <symbol>) v)
+ (module-define! (js-module o) p v))
+(define-method (prop-attrs (o <js-module-object>) (p <symbol>))
+ (cond ((module-local-variable (js-module o) p) '())
+ ((module-variable (js-module o) p) '(DontDelete ReadOnly))
+ (else (next-method))))
+(define-method (prop-attrs (o <js-module-object>) (p <string>))
+ (prop-attrs o (string->symbol p)))
+(define-method (prop-keys (o <js-module-object>))
+ (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o)))
+ (next-method)))
+
+;; we could make a renamer, but having obj['foo-bar'] should be enough
+(define (js-require modstr)
+ (make <js-module-object> #:module
+ (resolve-interface (map string->symbol (string-split modstr #\.)))))
+
+(define-class <js-global-object> (<js-module-object>))
+(define-method (js-module (o <js-global-object>))
+ (current-module))
+
+(define (init-js-bindings! mod)
+ (module-define! mod 'NaN +nan.0)
+ (module-define! mod 'Infinity +inf.0)
+ (module-define! mod 'undefined *undefined*)
+ (module-define! mod 'require js-require)
+ ;; isNAN, isFinite, parseFloat, parseInt, eval
+ ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent
+ ;; Object Function Array String Boolean Number Date RegExp Error EvalError
+ ;; RangeError ReferenceError SyntaxError TypeError URIError
+ (module-define! mod 'Object *object-prototype*)
+ (module-define! mod 'Array *array-prototype*))
+
+(define (js-init)
+ (cond ((get-this))
+ (else
+ (fluid-set! *this* (make <js-global-object>))
+ (init-js-bindings! (current-module)))))
+
+(define (get-this)
+ (fluid-ref *this*))
+
+(define (typeof x)
+ (cond ((eq? x *undefined*) "undefined")
+ ((null? x) "object")
+ ((boolean? x) "boolean")
+ ((number? x) "number")
+ ((string? x) "string")
+ ((procedure? x) "function")
+ ((is-a? x <js-object>) "object")
+ (else "scm")))
+
+(define bitwise-not lognot)
+(define (logical-not x)
+ (not (->boolean (->primitive x))))
+
+(define shift ash)
+
+(define band logand)
+(define bxor logxor)
+(define bior logior)
+
+(define mod modulo)
+
+(define-method (+ (a <string>) (b <string>))
+ (string-append a b))
+
+(define-method (+ (a <string>) b)
+ (string-append a (->string b)))
+
+(define-method (+ a (b <string>))
+ (string-append (->string a) b))
+
+(define-method (+ a b)
+ (+ (->number a) (->number b)))
+
+(define-method (- a b)
+ (- (->number a) (->number b)))
+
+(define-method (* a b)
+ (* (->number a) (->number b)))
+
+(define-method (/ a b)
+ (/ (->number a) (->number b)))
+
+(define-method (< a b)
+ (< (->number a) (->number b)))
+(define-method (< (a <string>) (b <string>))
+ (string< a b))
+
+(define-method (<= a b)
+ (<= (->number a) (->number b)))
+(define-method (<= (a <string>) (b <string>))
+ (string<= a b))
+
+(define-method (>= a b)
+ (>= (->number a) (->number b)))
+(define-method (>= (a <string>) (b <string>))
+ (string>= a b))
+
+(define-method (> a b)
+ (> (->number a) (->number b)))
+(define-method (> (a <string>) (b <string>))
+ (string> a b))
+
+(define (obj-and-prototypes o)
+ (if o
+ (cons o (obj-and-prototypes (js-prototype o)))
+ '()))
+
+(define (make-enumerator obj)
+ (let ((props (make-hash-table 23)))
+ (for-each (lambda (o)
+ (for-each (lambda (k) (hashq-set! props k #t))
+ (prop-keys o)))
+ (obj-and-prototypes obj))
+ (apply new-array (filter (lambda (p)
+ (not (prop-has-attr? obj p 'DontEnum)))
+ (hash-map->list (lambda (k v) k) props)))))
diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm
new file mode 100644
index 000000000..be41e4b9c
--- /dev/null
+++ b/module/language/ecmascript/parse.scm
@@ -0,0 +1,352 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript parse)
+ #:use-module (system base lalr)
+ #:use-module (language ecmascript tokenize)
+ #:export (read-ecmascript read-ecmascript/1 make-parser))
+
+(define* (syntax-error message #:optional token)
+ (if (lexical-token? token)
+ (throw 'syntax-error #f message
+ (and=> (lexical-token-source token)
+ source-location->source-properties)
+ (or (lexical-token-value token)
+ (lexical-token-category token))
+ #f)
+ (throw 'syntax-error #f message #f token #f)))
+
+(define (read-ecmascript port)
+ (let ((parse (make-parser)))
+ (parse (make-tokenizer port) syntax-error)))
+
+(define (read-ecmascript/1 port)
+ (let ((parse (make-parser)))
+ (parse (make-tokenizer/1 port) syntax-error)))
+
+(define *eof-object*
+ (call-with-input-string "" read-char))
+
+(define (make-parser)
+ ;; Return a fresh ECMAScript parser. Parsers produced by `lalr-scm' are now
+ ;; stateful (e.g., they won't invoke the tokenizer any more once it has
+ ;; returned `*eoi*'), hence the need to instantiate new parsers.
+
+ (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*) : *eof-object*)
+
+ ;;
+ ;; Verily, here we define statements. Expressions are defined
+ ;; afterwards.
+ ;;
+
+ (SourceElement (Statement) : $1
+ (FunctionDeclaration) : $1)
+
+ (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) : `(var (,$2 (lambda () ,$6)))
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(var (,$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
+ () : '(begin))
+
+ (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) : $2)
+ (InitialiserNoIn (= AssignmentExpressionNoIn) : $2)
+
+ (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) : `(begin (var ,$4) (for-in (ref ,@$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) : 'true
+ (false) : 'false
+ (Identifier) : `(ref ,$1)
+ (StringLiteral) : `(string ,$1)
+ (RegexpLiteral) : `(regexp ,$1)
+ (NumericLiteral) : `(number ,$1)
+ (dot NumericLiteral) : `(number ,(string->number (string-append "." (number->string $2))))
+ (ArrayLiteral) : $1
+ (ObjectLiteral) : $1
+ (lparen Expression rparen) : $2)
+
+ (ArrayLiteral (lbracket rbracket) : '(array)
+ (lbracket Elision rbracket) : '(array ,@$2)
+ (lbracket ElementList rbracket) : `(array ,@$2)
+ (lbracket ElementList comma rbracket) : `(array ,@$2)
+ (lbracket ElementList comma Elision rbracket) : `(array ,@$2))
+ (ElementList (AssignmentExpression) : `(,$1)
+ (Elision AssignmentExpression) : `(,@$1 ,$2)
+ (ElementList comma AssignmentExpression) : `(,@$1 ,$3)
+ (ElementList comma Elision AssignmentExpression) : `(,@$1 ,@$3 ,$4))
+ (Elision (comma) : '((number 0))
+ (Elision comma) : `(,@$1 (number 0)))
+
+ (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) : $1
+ (StringLiteral) : (string->symbol $1)
+ (NumericLiteral) : $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/spec.scm b/module/language/ecmascript/spec.scm
new file mode 100644
index 000000000..9a4bfab24
--- /dev/null
+++ b/module/language/ecmascript/spec.scm
@@ -0,0 +1,37 @@
+;;; ECMAScript specification for Guile
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript spec)
+ #:use-module (system base language)
+ #:use-module (language ecmascript parse)
+ #:use-module (language ecmascript compile-tree-il)
+ #:export (ecmascript))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language ecmascript
+ #:title "ECMAScript"
+ #:reader (lambda (port env) (read-ecmascript/1 port))
+ #:compilers `((tree-il . ,compile-tree-il))
+ ;; a pretty-printer would be interesting.
+ #:printer write
+ )
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
new file mode 100644
index 000000000..8289b950c
--- /dev/null
+++ b/module/language/ecmascript/tokenize.scm
@@ -0,0 +1,513 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;;;; 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
+
+;;; Code:
+
+(define-module (language ecmascript tokenize)
+ #:use-module (ice-9 rdelim)
+ #:use-module ((srfi srfi-1) #:select (unfold-right))
+ #:use-module (system base lalr)
+ #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
+
+(define (syntax-error what loc form . args)
+ (throw 'syntax-error #f what
+ (and=> loc source-location->source-properties)
+ form #f args))
+
+(define (port-source-location port)
+ (make-source-location (port-filename port)
+ (port-line port)
+ (port-column port)
+ (false-if-exception (ftell port))
+ #f))
+
+;; taken from SSAX, sorta
+(define (read-until delims port loc)
+ (if (eof-object? (peek-char port))
+ (syntax-error "EOF while reading a token" loc #f)
+ (let ((token (read-delimited delims port 'peek)))
+ (if (eof-object? (peek-char port))
+ (syntax-error "EOF while reading a token" loc 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 loc div?)
+ (let ((c1 (begin
+ (read-char port)
+ (peek-char port))))
+ (cond
+ ((eof-object? c1)
+ ;; hmm. error if we're not looking for a div? ?
+ (make-lexical-token '/ loc #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)
+ (syntax-error "EOF while in multi-line comment" loc #f))
+ ((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) (make-lexical-token '/= loc #f))
+ (else (make-lexical-token '/ loc #f))))
+ (else
+ (read-regexp port loc)))))
+
+(define (read-regexp port loc)
+ ;; first slash already read
+ (let ((terms (string #\/ #\\ #\nl #\cr)))
+ (let lp ((str (read-until terms port loc)) (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 #\_))))
+ (make-lexical-token 'RegexpLiteral loc
+ (cons (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 loc)
+ (string-append head str (string #\\ echar)))))
+ (else
+ (syntax-error "regexp literals may not contain newlines"
+ loc str)))))))
+
+(define (read-string port loc)
+ (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)
+ (syntax-error "octal escape sequences are not supported"
+ loc #f))
+ (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
+ (syntax-error "bad hex character escape" loc (string a b))))))
+ ((#\u)
+ (let* ((a (read-char port))
+ (b (read-char port))
+ (c (read-char port))
+ (d (read-char port)))
+ (integer->char (string->number (string a b c d) 16))))
+ (else
+ c))))
+ (let lp ((str (read-until terms port loc)))
+ (let ((terminator (peek-char port)))
+ (cond
+ ((char=? terminator c)
+ (read-char port)
+ (make-lexical-token 'StringLiteral loc str))
+ ((char=? terminator #\\)
+ (read-char port)
+ (let ((echar (read-escape port)))
+ (lp (string-append str (string echar)
+ (read-until terms port loc)))))
+ (else
+ (syntax-error "string literals may not contain newlines"
+ loc 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 loc)
+ (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) (make-lexical-token x loc #f)))
+ ((assoc-ref *future-reserved-words* word)
+ (syntax-error "word is reserved for the future, dude."
+ loc word))
+ (else (make-lexical-token 'Identifier loc
+ (string->symbol word)))))
+ (begin (read-char port)
+ (lp (peek-char port) (cons c chars))))))
+
+(define (read-numeric port loc)
+ (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) (or (char=? c1 #\x) (char=? c1 #\X)))
+ (read-char port)
+ (let ((c (peek-char port)))
+ (if (not (char-hex? c))
+ (syntax-error "bad digit reading hexadecimal number"
+ loc 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))
+ (syntax-error "invalid digit in octal sequence"
+ loc 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)
+ (syntax-error "error reading exponent: EOF"
+ loc #f))
+ ((char=? c #\+) (read-char port) +)
+ ((char=? c #\-) (read-char port) -)
+ ((char-numeric? c) +)
+ (else
+ (syntax-error "error reading exponent: non-digit"
+ loc 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 (list (string-ref (caar puncs) 0) #f) nodes)
+ puncs))))))
+ (lambda (port loc)
+ (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
+ (make-lexical-token candidate loc #f))
+ (else
+ (syntax-error "bad syntax: character not allowed" loc c)))))))
+
+(define (next-token port div?)
+ (let ((c (peek-char port))
+ (loc (port-source-location port)))
+ (case c
+ ((#\ht #\vt #\np #\space #\x00A0) ; 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 loc div?))
+ ((#\" #\') ; string literal
+ (read-string port loc))
+ (else
+ (cond
+ ((eof-object? c)
+ '*eoi*)
+ ((or (char-alphabetic? c)
+ (char=? c #\$)
+ (char=? c #\_))
+ ;; reserved word or identifier
+ (read-identifier port loc))
+ ((char-numeric? c)
+ ;; numeric -- also accept . FIXME, requires lookahead
+ (make-lexical-token 'NumericLiteral loc (read-numeric port loc)))
+ (else
+ ;; punctuation
+ (read-punctuation port loc)))))))
+
+(define (make-tokenizer port)
+ (let ((div? #f))
+ (lambda ()
+ (let ((tok (next-token port div?)))
+ (set! div? (and (lexical-token? tok)
+ (let ((cat (lexical-token-category tok)))
+ (or (eq? cat 'Identifier)
+ (eq? cat 'NumericLiteral)
+ (eq? cat 'StringLiteral)))))
+ tok))))
+
+(define (make-tokenizer/1 port)
+ (let ((div? #f)
+ (eoi? #f)
+ (stack '()))
+ (lambda ()
+ (if eoi?
+ '*eoi*
+ (let ((tok (next-token port div?)))
+ (case (if (lexical-token? tok) (lexical-token-category tok) tok)
+ ((lparen)
+ (set! stack (cons tok stack)))
+ ((rparen)
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lparen))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right parenthesis"
+ (lexical-token-source tok)
+ #f)))
+ ((lbracket)
+ (set! stack (cons tok stack)))
+ ((rbracket)
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lbracket))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right bracket"
+ (lexical-token-source tok)
+ #f)))
+ ((lbrace)
+ (set! stack (cons tok stack)))
+ ((rbrace)
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lbrace))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right brace"
+ (lexical-token-source tok)
+ #f)))
+ ((semicolon)
+ (set! eoi? (null? stack))))
+ (set! div? (and (lexical-token? tok)
+ (let ((cat (lexical-token-category tok)))
+ (or (eq? cat 'Identifier)
+ (eq? cat 'NumericLiteral)
+ (eq? cat 'StringLiteral)))))
+ 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)))))))
+