further ecmascript work

* libguile/vm-i-system.c (drop, return): Declare drop and return as
  popping one arg from the stack.

* module/language/ghil/compile-glil.scm:
* module/language/glil/compile-assembly.scm (make-meta): Adjust so that
  we declare 'drop and 'return calls as popping one arg from the stack.

* module/language/ecmascript/compile-ghil.scm (comp, comp-body): Flesh
  out a bit more. Most significantly, scoping within functions obeys
  javascript semantics better, modulo bits about with() forms.

* module/language/ecmascript/impl.scm: Define some runtime helper
  routines.
* module/language/Makefile.am (SOURCES): Add impl.scm.

* module/language/ecmascript/parse.scm (parse-ecmascript): Minor tweaks.

* module/language/ecmascript/tokenize.scm (read-identifier): Identifiers
  now read as symbols, not strings.

libguile/vm-i-system.c

@@ -64,7 +64,7 @@ VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
 {
   DROP ();
   NEXT;
@@ -971,7 +971,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
     }
 }
 
-VM_DEFINE_INSTRUCTION (48, return, "return", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
 {
  vm_return:
   EXIT_HOOK ();

module/language/Makefile.am

@@ -4,6 +4,7 @@ SOURCES=ghil.scm glil.scm assembly.scm \
 	ecmascript/tokenize.scm
 	ecmascript/spec.scm
 	ecmascript/compile-ghil.scm
+	ecmascript/impl.scm
 # unfortunately, the one that we want to compile can't yet be compiled
 # -- too many local vars, or something.
 NOCOMP_SOURCES = ecmascript/parse.scm

module/language/ecmascript/compile-ghil.scm

@@ -21,6 +21,7 @@
 
 (define-module (language ecmascript compile-ghil)
   #:use-module (language ghil)
+  #:use-module (ice-9 receive)
   #:use-module (system base pmatch)
   #:export (compile-ghil))
 
@@ -37,6 +38,11 @@
 	 (and (not (null? props))
               props))))
 
+(define-macro (@impl e l sym . args)
+  `(make-ghil-call ,e ,l
+                   (ghil-var-at-module! ,e '(language ecmascript impl) ',sym #t)
+                   (list ,@(map (lambda (x) `(comp x ,e)) ,args))))
+
 (define (comp x e)
   (let ((l (location x)))
     (pmatch x
@@ -60,21 +66,80 @@
       ((* ,a ,b)
        (make-ghil-inline e l 'mul (list (comp a e) (comp b e))))
       ((ref ,id)
-       (make-ghil-ref e l (ghil-var-for-ref! e (string->symbol id))))
+       (make-ghil-ref e l (ghil-var-for-ref! e id)))
-      ((define ,id ,val)
+      ((var ,id ,val)
-       (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) (string->symbol id))
+       (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) id)
                          (comp val e)))
       ((begin . ,forms)
        (make-ghil-begin e l (map (lambda (x) (comp x e)) forms)))
       ((lambda ,formals ,body)
-       (call-with-ghil-environment e formals
+       (call-with-ghil-environment e '(%args)
          (lambda (env vars)
-           (make-ghil-lambda env l vars #f '() (comp body env)))))
+           (make-ghil-lambda env l vars #t '()
+                             (comp-body env l body formals '%args)))))
       ((call ,proc ,args)
        (make-ghil-call e l (comp proc e) (map (lambda (x) (comp x e)) args)))
+      ((return ,expr)
+       (make-ghil-inline e l 'return (list (comp expr e))))
       (else
        (error "compilation not yet implemented:" x)))))
 
-
+(define (comp-body env loc body formals %args)
-
+  (define (process)
-
+    (let lp ((in body) (out '()) (rvars (reverse formals)))
+      (pmatch in
+        (((var ,x) . ,rest)
+         (lp rest
+             out
+             (if (memq x rvars) rvars (cons x rvars))))
+        (((var ,x ,y) . ,rest)
+         (lp rest
+             `((= (ref ,x) ,y) . ,out)
+             (if (memq x rvars) rvars (cons x 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)
+    (call-with-ghil-bindings env (reverse rvars)
+      (lambda (vars)
+        (let ((%argv (assq-ref (ghil-env-table env) %args)))
+          (make-ghil-begin
+           env loc
+           `(,@(map (lambda (f)
+                      (make-ghil-if
+                       env loc
+                       (make-ghil-inline
+                        env loc 'null?
+                        (list (make-ghil-ref env loc %argv)))
+                       (make-ghil-begin env loc '())
+                       (make-ghil-begin
+                        env loc
+                        (list (make-ghil-set
+                               env loc
+                               (ghil-var-for-ref! env f)
+                               (make-ghil-inline
+                                env loc 'car
+                                (list (make-ghil-ref env loc %argv))))
+                              (make-ghil-set
+                               env loc %argv
+                               (make-ghil-inline
+                                env loc 'cdr
+                                (list (make-ghil-ref env loc %argv))))))))
+                    formals)
+             ;; fixme: here check for too many args
+             ,(comp out env))))))))

module/language/ecmascript/impl.scm

@@ -0,0 +1,184 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ecmascript impl)
+  #:use-modules (oop goops)
+  #:export (*undefined*
+            <js-object>
+            pget 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))
+
+(define *undefined* ((@@ (oop goops) make-unbound)))
+
+(define NaN +nan.0)
+(define Infinity +inf.0)
+
+(define-class <js-object> ()
+  (prototype #:getter js-prototype #:init-keyword #:prototype
+             #:init-value #f)
+  (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))
+
+(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 (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 (has-property? (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 (pdel (o <js-object>) p)
+  (if (prop-has-attr? o p 'DontDelete)
+      #f
+      (begin
+        (pput o p *undefined*)
+        #t)))
+
+(define (object->string o error?)
+  (let ((toString (pget o 'toString)))
+    (if (procedure? toString)
+        (let ((x (toString o)))
+          (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 (valueOf o)))
+          (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)
+  (let ((v (object->string o #f)))
+    (if (is-a? x <js-object>)
+        (object->number o #t)
+        x)))
+              
+(define (object->value/number o)
+  (let ((v (object->number o #f)))
+    (if (is-a? x <js-object>)
+        (object->string o #t)
+        x)))
+              
+(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*) (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 o))
+        ((string? x) (string->number x))
+        (else (throw 'TypeError o '->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)))

module/language/ecmascript/parse.scm

@@ -30,6 +30,9 @@
 (define (read-ecmascript/1 port)
   (parse-ecmascript (make-tokenizer/1 port) pk))
 
+(define *eof-object*
+  (call-with-input-string "" read-char))
+
 (define parse-ecmascript
   (lalr-parser
    ;; terminal (i.e. input) token types
@@ -45,7 +48,7 @@
 
 
    (Program (SourceElements) -> $1
-            (*eoi*) -> (call-with-input-string "" read-char))
+            (*eoi*) -> *eof-object*)
 
    ;;
    ;; Verily, here we define statements. Expressions are defined
@@ -55,8 +58,8 @@
    (SourceElement (Statement) -> $1
                   (FunctionDeclaration) -> $1)
 
-   (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda () ,$6))
+   (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(var ,$2 (lambda () ,$6))
-                        (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda ,$4 ,$7)))
+                        (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)

module/language/ecmascript/tokenize.scm

@@ -225,7 +225,7 @@
                  => (lambda (x) `(,x . #f)))
                 ((assoc-ref *future-reserved-words* word)
                  (error "word is reserved for the future, dude." word))
-                (else `(Identifier . ,word))))
+                (else `(Identifier . ,(string->symbol word)))))
         (begin (read-char port)
                (lp (peek-char port) (cons c chars))))))
 

module/language/ghil/compile-glil.scm

@@ -107,8 +107,8 @@
 ;;;
 
 (define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 0))
+(define *ia-drop* (make-glil-call 'drop 1))
-(define *ia-return* (make-glil-call 'return 0))
+(define *ia-return* (make-glil-call 'return 1))
 
 (define (make-label) (gensym ":L"))
 
@@ -299,7 +299,7 @@
                                (push-call! #f 'dup '()))
                            (push-branch! #f 'br-if L1)
                            (if (not drop)
-                               (push-call! #f 'drop '()))
+                               (push-code! loc (make-glil-call 'drop 1)))
                            (lp (cdr exps)))))))))
 
 	((<ghil-begin> env loc exps)

module/language/glil/compile-assembly.scm

@@ -75,7 +75,7 @@
        (make-glil-program 0 0 0 0 '()
                           (list
                            (make-glil-const `(,bindings ,sources ,@tail))
-                           (make-glil-call 'return 0))))))
+                           (make-glil-call 'return 1))))))
 
 ;; A functional stack of names of live variables.
 (define (make-open-binding name ext? index)