diff options
Diffstat (limited to 'module/language/ecmascript')
-rw-r--r-- | module/language/ecmascript/array.scm | 121 | ||||
-rw-r--r-- | module/language/ecmascript/base.scm | 251 | ||||
-rw-r--r-- | module/language/ecmascript/compile-tree-il.scm | 576 | ||||
-rw-r--r-- | module/language/ecmascript/function.scm | 78 | ||||
-rw-r--r-- | module/language/ecmascript/impl.scm | 169 | ||||
-rw-r--r-- | module/language/ecmascript/parse.scm | 352 | ||||
-rw-r--r-- | module/language/ecmascript/spec.scm | 37 | ||||
-rw-r--r-- | module/language/ecmascript/tokenize.scm | 513 |
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))))))) + |