Fix a bug related to SETQ which DO* uncovered

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 7b8c39f..cb89dfc 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -26,36 +26,47 @@
 (progn
   (eval-when-compile
     (%compile-defmacro 'defmacro
 (progn
   (eval-when-compile
     (%compile-defmacro 'defmacro

-                       '(lambda (name args &rest body)
-                         `(progn
-                            (eval-when-compile
-                              (%compile-defmacro ',name
-                                                 '(lambda ,(mapcar (lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
+                       '(function
+                         (lambda (name args &rest body)
+                          `(eval-when-compile
+                             (%compile-defmacro ',name
+                                                '(function
+                                                  (lambda ,(mapcar #'(lambda (x)
+                                                                       (if (eq x '&body)
+                                                                           '&rest
+                                                                           x))

                                                                    args)
                                                                    args)

-                                                   ,@body)))
-                            ',name))))
+                                                   ,@body))))))))

 
 

+  (defmacro declaim (&rest decls)
+    `(eval-when-compile
+       ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
+
+  (declaim (constant nil t) (special t nil))

   (setq nil 'nil)
   (setq nil 'nil)

+  (js-vset "nil" nil)

   (setq t 't)
 
   (setq t 't)
 

+  (defmacro lambda (args &body body)
+    `(function (lambda ,args ,@body)))
+

   (defmacro when (condition &body body)
     `(if ,condition (progn ,@body) nil))
 
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 
   (defmacro when (condition &body body)
     `(if ,condition (progn ,@body) nil))
 
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 

-  (defmacro defvar (name value)
+  (defmacro defvar (name value &optional docstring)

     `(progn
     `(progn

-       (unless (boundp ',name)
-        (setq ,name ,value))
+       (declaim (special ,name))
+       (unless (boundp ',name) (setq ,name ,value))
+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
        ',name))
 

-  (defmacro defparameter (name value)
+  (defmacro defparameter (name value &optional docstring)

     `(progn
        (setq ,name ,value)
     `(progn
        (setq ,name ,value)

+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
   (defmacro named-lambda (name args &rest body)
        ',name))
 
   (defmacro named-lambda (name args &rest body)

@@ -67,13 +78,12 @@
   (defmacro defun (name args &rest body)
     `(progn
        (fset ',name
   (defmacro defun (name args &rest body)
     `(progn
        (fset ',name

-             (named-lambda ,(symbol-name name)
-                 ,args
-               (block ,name ,@body)))
+             (named-lambda ,(symbol-name name) ,args
+               ,@(if (and (stringp (car body)) (not (null (cdr body))))
+                     `(,(car body) (block ,name ,@(cdr body)))
+                     `((block ,name ,@body)))))

        ',name))
 
        ',name))
 

-  (defvar *package* (new))
-

   (defun null (x)
     (eq x nil))
 
   (defun null (x)
     (eq x nil))
 

@@ -83,17 +93,6 @@
   (defmacro while (condition &body body)
     `(block nil (%while ,condition ,@body)))
 
   (defmacro while (condition &body body)
     `(block nil (%while ,condition ,@body)))
 

-  (defun internp (name)
-    (in name *package*))
-
-  (defun intern (name)
-    (if (internp name)
-        (oget *package* name)
-        (oset *package* name (make-symbol name))))
-
-  (defun find-symbol (name)
-    (oget *package* name))
-

   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
     (setq *gensym-counter* (+ *gensym-counter* 1))
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
     (setq *gensym-counter* (+ *gensym-counter* 1))

@@ -104,8 +103,6 @@
 
   ;; Basic functions
   (defun = (x y) (= x y))
 
   ;; Basic functions
   (defun = (x y) (= x y))

-  (defun + (x y) (+ x y))
-  (defun - (x y) (- x y))

   (defun * (x y) (* x y))
   (defun / (x y) (/ x y))
   (defun 1+ (x) (+ x 1))
   (defun * (x y) (* x y))
   (defun / (x y) (/ x y))
   (defun 1+ (x) (+ x 1))

@@ -119,7 +116,11 @@
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))

-  (defun car (x) (car x))
+
+  (defun car (x)
+    "Return the CAR part of a cons, or NIL if X is null."
+    (car x))
+

   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))
   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))

@@ -232,7 +233,6 @@
     `(prog1 (progn ,form1 ,result) ,@body)))
 
 
     `(prog1 (progn ,form1 ,result) ,@body)))
 
 

-

 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 (defun ensure-list (x)
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 (defun ensure-list (x)

@@ -252,6 +252,18 @@
 ;;; constructions.
 #+ecmalisp
 (progn
 ;;; constructions.
 #+ecmalisp
 (progn

+  (defun + (&rest args)
+    (let ((r 0))
+      (dolist (x args r)
+       (incf r x))))
+
+  (defun - (x &rest others)
+    (if (null others)
+       (- x)
+       (let ((r x))
+         (dolist (y others r)
+           (decf r y)))))
+

   (defun append-two (list1 list2)
     (if (null list1)
         list2
   (defun append-two (list1 list2)
     (if (null list1)
         list2

@@ -270,6 +282,53 @@
   (defun reverse (list)
     (revappend list '()))
 
   (defun reverse (list)
     (revappend list '()))
 

+  (defmacro psetq (&rest pairs)
+    (let ( ;; For each pair, we store here a list of the form
+         ;; (VARIABLE GENSYM VALUE).
+         (assignments '()))
+      (while t
+       (cond
+         ((null pairs) (return))
+         ((null (cdr pairs))
+          (error "Odd paris in PSETQ"))
+         (t
+          (let ((variable (car pairs))
+                (value (cadr pairs)))
+            (push `(,variable ,(gensym) ,value)  assignments)
+            (setq pairs (cddr pairs))))))
+      (setq assignments (reverse assignments))
+      ;;
+      `(let ,(mapcar #'cdr assignments)
+        (setq ,@(!reduce #'append (mapcar #'butlast assignments) '())))))
+
+  (defmacro do (varlist endlist &body body)
+    `(block nil
+       (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+        (while t
+          (when ,(car endlist)
+            (return (progn ,(cdr endlist))))
+          (tagbody ,@body)
+          (psetq
+           ,@(apply #'append
+                    (mapcar (lambda (v)
+                              (and (consp (cddr v))
+                                   (list (first v) (third v))))
+                            varlist)))))))
+
+  (defmacro do* (varlist endlist &body body)
+    `(block nil
+       (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+        (while t
+          (when ,(car endlist)
+            (return (progn ,(cdr endlist))))
+          (tagbody ,@body)
+          (setq
+           ,@(apply #'append
+                    (mapcar (lambda (v)
+                              (and (consp (cddr v))
+                                   (list (first v) (third v))))
+                            varlist)))))))
+

   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))
   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))

@@ -278,9 +337,13 @@
       l))
 
   (defun length (seq)
       l))
 
   (defun length (seq)

-    (if (stringp seq)
-        (string-length seq)
-        (list-length seq)))
+    (cond
+      ((stringp seq)
+       (string-length seq))
+      ((arrayp seq)
+       (oget seq "length"))
+      ((listp seq)
+       (list-length seq))))

 
   (defun concat-two (s1 s2)
     (concat-two s1 s2))
 
   (defun concat-two (s1 s2)
     (concat-two s1 s2))

@@ -424,6 +487,11 @@
           (setq alist (cdr alist))))
     (car alist))
 
           (setq alist (cdr alist))))
     (car alist))
 

+  (defun string (x)
+    (cond ((stringp x) x)
+          ((symbolp x) (symbol-name x))
+          (t (char-to-string x))))
+

   (defun string= (s1 s2)
     (equal s1 s2))
 
   (defun string= (s1 s2)
     (equal s1 s2))
 

@@ -438,7 +506,132 @@
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))

-    nil))
+    nil)
+
+  (defun documentation (x type)
+    "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
+    (ecase type
+      (function
+       (let ((func (fdefinition x)))
+         (oget func "docstring")))
+      (variable
+       (unless (symbolp x)
+         (error "Wrong argument type! it should be a symbol"))
+       (oget x "vardoc"))))
+
+  ;; Packages
+
+  (defvar *package-list* nil)
+
+  (defun list-all-packages ()
+    *package-list*)
+
+  (defun make-package (name &optional use)
+    (let ((package (new))
+          (use (mapcar #'find-package-or-fail use)))
+      (oset package "packageName" name)
+      (oset package "symbols" (new))
+      (oset package "exports" (new))
+      (oset package "use" use)
+      (push package *package-list*)
+      package))
+
+  (defun packagep (x)
+    (and (objectp x) (in "symbols" x)))
+
+  (defun find-package (package-designator)
+    (when (packagep package-designator)
+      (return-from find-package package-designator))
+    (let ((name (string package-designator)))
+      (dolist (package *package-list*)
+        (when (string= (package-name package) name)
+          (return package)))))
+
+  (defun find-package-or-fail (package-designator)
+    (or (find-package package-designator)
+        (error "Package unknown.")))
+
+  (defun package-name (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "packageName")))
+
+  (defun %package-symbols (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "symbols")))
+
+  (defun package-use-list (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "use")))
+
+  (defun %package-external-symbols (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "exports")))
+
+  (defvar *common-lisp-package*
+    (make-package "CL"))
+
+  (defvar *user-package*
+    (make-package "CL-USER" (list *common-lisp-package*)))
+
+  (defvar *keyword-package*
+    (make-package "KEYWORD"))
+
+  (defun keywordp (x)
+    (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
+
+  (defvar *package* *common-lisp-package*)
+
+  (defmacro in-package (package-designator)
+    `(eval-when-compile
+       (setq *package* (find-package-or-fail ,package-designator))))
+
+  ;; This function is used internally to initialize the CL package
+  ;; with the symbols built during bootstrap.
+  (defun %intern-symbol (symbol)
+    (let ((symbols (%package-symbols *common-lisp-package*)))
+      (oset symbol "package" *common-lisp-package*)
+      (oset symbols (symbol-name symbol) symbol)))
+
+  (defun %find-symbol (name package)
+    (let ((package (find-package-or-fail package)))
+      (let ((symbols (%package-symbols package)))
+        (if (in name symbols)
+            (cons (oget symbols name) t)
+            (dolist (used (package-use-list package) (cons nil nil))
+              (let ((exports (%package-external-symbols used)))
+                (when (in name exports)
+                  (return-from %find-symbol
+                    (cons (oget exports name) t)))))))))
+
+  (defun find-symbol (name &optional (package *package*))
+    (car (%find-symbol name package)))
+
+  (defun intern (name &optional (package *package*))
+    (let ((package (find-package-or-fail package)))
+      (let ((result (%find-symbol name package)))
+        (if (cdr result)
+            (car result)
+            (let ((symbols (%package-symbols package)))
+              (oget symbols name)
+              (let ((symbol (make-symbol name)))
+                (oset symbol "package" package)
+                (when (eq package *keyword-package*)
+                  (oset symbol "value" symbol)
+                  (export (list symbol) package))
+                (oset symbols name symbol)))))))
+
+  (defun symbol-package (symbol)
+    (unless (symbolp symbol)
+      (error "it is not a symbol"))
+    (oget symbol "package"))
+
+  (defun export (symbols &optional (package *package*))
+    (let ((exports (%package-external-symbols package)))
+      (dolist (symb symbols t)
+        (oset exports (symbol-name symb) symb))))
+
+  (defun get-universal-time ()
+    (+ (get-unix-time) 2208988800)))

 
 
 ;;; The compiler offers some primitives and special forms which are
 
 
 ;;; The compiler offers some primitives and special forms which are

@@ -458,10 +651,8 @@
   (defun concat-two (s1 s2)
     (concatenate 'string s1 s2))
 
   (defun concat-two (s1 s2)
     (concatenate 'string s1 s2))
 

-  (defun setcar (cons new)
-    (setf (car cons) new))
-  (defun setcdr (cons new)
-    (setf (cdr cons) new)))
+  (defun aset (array idx value)
+    (setf (aref array idx) value)))

 
 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
 ;;; from here, this code will compile on both. We define some helper
 
 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
 ;;; from here, this code will compile on both. We define some helper

@@ -496,6 +687,36 @@
 (defun mapconcat (func list)
   (join (mapcar func list)))
 
 (defun mapconcat (func list)
   (join (mapcar func list)))
 

+(defun vector-to-list (vector)
+  (let ((list nil)
+       (size (length vector)))
+    (dotimes (i size (reverse list))
+      (push (aref vector i) list))))
+
+(defun list-to-vector (list)
+  (let ((v (make-array (length list)))
+       (i 0))
+    (dolist (x list v)
+      (aset v i x)
+      (incf i))))
+
+#+ecmalisp
+(progn
+  (defun values-list (list)
+    (values-array (list-to-vector list)))
+
+  (defun values (&rest args)
+    (values-list args))
+
+  (defmacro multiple-value-bind (variables value-from &body body)
+    `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
+                            ,@body)
+       ,value-from))
+
+  (defmacro multiple-value-list (value-from)
+    `(multiple-value-call #'list ,value-from)))
+
+

 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
 ;;; of this function are available, because the Ecmalisp version is
 ;;; very slow and bootstraping was annoying.
 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
 ;;; of this function are available, because the Ecmalisp version is
 ;;; very slow and bootstraping was annoying.

@@ -564,7 +785,16 @@
 (progn
   (defun prin1-to-string (form)
     (cond
 (progn
   (defun prin1-to-string (form)
     (cond

-      ((symbolp form) (symbol-name form))
+      ((symbolp form)
+       (if (cdr (%find-symbol (symbol-name form) *package*))
+           (symbol-name form)
+           (let ((package (symbol-package form))
+                 (name (symbol-name form)))
+             (concat (cond
+                       ((null package) "#")
+                       ((eq package (find-package "KEYWORD")) "")
+                       (t (package-name package)))
+                     ":" name))))

       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)

@@ -579,7 +809,11 @@
                  (if (null (cdr last))
                      (prin1-to-string (car last))
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                  (if (null (cdr last))
                      (prin1-to-string (car last))
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))

-               ")"))))
+               ")"))
+      ((arrayp form)
+       (concat "#" (prin1-to-string (vector-to-list form))))
+      ((packagep form)
+       (concat "#<PACKAGE " (package-name form) ">"))))

 
   (defun write-line (x)
     (write-string x)
 
   (defun write-line (x)
     (write-string x)

@@ -610,7 +844,7 @@
 (defun %read-char (stream)
   (and (< (cdr stream) (length (car stream)))
        (prog1 (char (car stream) (cdr stream))
 (defun %read-char (stream)
   (and (< (cdr stream) (length (car stream)))
        (prog1 (char (car stream) (cdr stream))

-         (setcdr stream (1+ (cdr stream))))))
+         (rplacd stream (1+ (cdr stream))))))

 
 (defun whitespacep (ch)
   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 
 (defun whitespacep (ch)
   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))

@@ -680,6 +914,8 @@
   (ecase (%read-char stream)
     (#\'
      (list 'function (ls-read stream)))
   (ecase (%read-char stream)
     (#\'
      (list 'function (ls-read stream)))

+    (#\( (list-to-vector (%read-list stream)))
+    (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))

     (#\\
      (let ((cname
             (concat (string (%read-char stream))
     (#\\
      (let ((cname
             (concat (string (%read-char stream))

@@ -700,12 +936,48 @@
          (t
           (error "Unknown reader form.")))))))
 
          (t
           (error "Unknown reader form.")))))))
 

-(defvar *eof* (make-symbol "EOF"))
+;;; Parse a string of the form NAME, PACKAGE:NAME or
+;;; PACKAGE::NAME and return the name. If the string is of the
+;;; form 1) or 3), but the symbol does not exist, it will be created
+;;; and interned in that package.
+(defun read-symbol (string)
+  (let ((size (length string))
+        package name internalp index)
+    (setq index 0)
+    (while (and (< index size)
+                (not (char= (char string index) #\:)))
+      (incf index))
+    (cond
+      ;; No package prefix
+      ((= index size)
+       (setq name string)
+       (setq package *package*)
+       (setq internalp t))
+      (t
+       ;; Package prefix
+       (if (zerop index)
+           (setq package "KEYWORD")
+           (setq package (string-upcase (subseq string 0 index))))
+       (incf index)
+       (when (char= (char string index) #\:)
+         (setq internalp t)
+         (incf index))
+       (setq name (subseq string index))))
+    ;; Canonalize symbol name and package
+    (setq name (string-upcase name))
+    (setq package (find-package package))
+    ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
+    ;; external symbol from PACKAGE.
+    (if (or internalp (eq package (find-package "KEYWORD")))
+        (intern name package)
+        (find-symbol name package))))
+
+(defvar *eof* (gensym))

 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
   (let ((ch (%peek-char stream)))
     (cond
 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
   (let ((ch (%peek-char stream)))
     (cond

-      ((null ch)
+      ((or (null ch) (char= ch #\)))

        *eof*)
       ((char= ch #\()
        (%read-char stream)
        *eof*)
       ((char= ch #\()
        (%read-char stream)

@@ -730,7 +1002,7 @@
        (let ((string (read-until stream #'terminalp)))
          (if (every #'digit-char-p string)
              (parse-integer string)
        (let ((string (read-until stream #'terminalp)))
          (if (every #'digit-char-p string)
              (parse-integer string)

-             (intern (string-upcase string))))))))
+             (read-symbol string)))))))

 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))

@@ -743,18 +1015,32 @@
 ;;; too. The respective real functions are defined in the target (see
 ;;; the beginning of this file) as well as some primitive functions.
 
 ;;; too. The respective real functions are defined in the target (see
 ;;; the beginning of this file) as well as some primitive functions.
 

-(defvar *compilation-unit-checks* '())
+;;; A Form can return a multiple values object calling VALUES, like
+;;; values(arg1, arg2, ...). It will work in any context, as well as
+;;; returning an individual object. However, if the special variable
+;;; `*multiple-value-p*' is NIL, is granted that only the primary
+;;; value will be used, so we can optimize to avoid the VALUES
+;;; function call.
+(defvar *multiple-value-p* nil)

 
 

-(defun make-binding (name type translation declared)
-  (list name type translation declared))
+
+(defun make-binding (name type value &optional declarations)
+  (list name type value declarations))

 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))
 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))

-(defun binding-translation (b) (third b))
-(defun binding-declared (b)
-  (and b (fourth b)))
-(defun mark-binding-as-declared (b)
-  (setcar (cdddr b) t))
+(defun binding-value (b) (third b))
+(defun binding-declarations (b) (fourth b))
+
+(defun set-binding-value (b value)
+  (rplaca (cddr b) value))
+
+(defun set-binding-declarations (b value)
+  (rplaca (cdddr b) value))
+
+(defun push-binding-declaration (decl b)
+  (set-binding-declarations b (cons decl (binding-declarations b))))
+

 
 (defun make-lexenv ()
   (list nil nil nil nil))
 
 (defun make-lexenv ()
   (list nil nil nil nil))

@@ -764,14 +1050,10 @@
 
 (defun push-to-lexenv (binding lexenv namespace)
   (ecase namespace
 
 (defun push-to-lexenv (binding lexenv namespace)
   (ecase namespace

-    (variable
-     (setcar lexenv (cons binding (car lexenv))))
-    (function
-     (setcar (cdr lexenv) (cons binding (cadr lexenv))))
-    (block
-     (setcar (cddr lexenv) (cons binding (caddr lexenv))))
-    (gotag
-     (setcar (cdddr lexenv) (cons binding (cadddr lexenv))))))
+    (variable   (rplaca        lexenv  (cons binding (car lexenv))))
+    (function   (rplaca   (cdr lexenv) (cons binding (cadr lexenv))))
+    (block      (rplaca  (cddr lexenv) (cons binding (caddr lexenv))))
+    (gotag      (rplaca (cdddr lexenv) (cons binding (cadddr lexenv))))))

 
 (defun extend-lexenv (bindings lexenv namespace)
   (let ((env (copy-lexenv lexenv)))
 
 (defun extend-lexenv (bindings lexenv namespace)
   (let ((env (copy-lexenv lexenv)))

@@ -787,24 +1069,17 @@
 
 (defvar *environment* (make-lexenv))
 
 
 (defvar *environment* (make-lexenv))
 

-(defun clear-undeclared-global-bindings ()
-  (setq *environment*
-       (mapcar (lambda (namespace)
-                 (remove-if-not #'binding-declared namespace))
-               *environment*)))
-
-

 (defvar *variable-counter* 0)
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defvar *variable-counter* 0)
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 

-(defun translate-variable (symbol env)
-  (binding-translation (lookup-in-lexenv symbol env 'variable)))
+(defun translate-variable (symbol)
+  (binding-value (lookup-in-lexenv symbol *environment* 'variable)))

 
 

-(defun extend-local-env (args env)
-  (let ((new (copy-lexenv env)))
+(defun extend-local-env (args)
+  (let ((new (copy-lexenv *environment*)))

     (dolist (symbol args new)
     (dolist (symbol args new)

-      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))
+      (let ((b (make-binding symbol 'variable (gvarname symbol))))

         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations
         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations

@@ -821,33 +1096,54 @@
 
 (defun %compile-defmacro (name lambda)
   (toplevel-compilation (ls-compile `',name))
 
 (defun %compile-defmacro (name lambda)
   (toplevel-compilation (ls-compile `',name))

-  (push-to-lexenv (make-binding name 'macro lambda t) *environment* 'function))
+  (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function)
+  name)
+
+(defun global-binding (name type namespace)
+  (or (lookup-in-lexenv name *environment* namespace)
+      (let ((b (make-binding name type nil)))
+        (push-to-lexenv b *environment* namespace)
+        b)))
+
+(defun claimp (symbol namespace claim)
+  (let ((b (lookup-in-lexenv symbol *environment* namespace)))
+    (and b (member claim (binding-declarations b)))))
+
+(defun !proclaim (decl)
+  (case (car decl)
+    (special
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'variable 'variable)))
+         (push-binding-declaration 'special b))))
+    (notinline
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'function 'function)))
+         (push-binding-declaration 'notinline b))))
+    (constant
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'variable 'variable)))
+         (push-binding-declaration 'constant b))))))

 
 

-(defvar *compilations* nil)
+#+ecmalisp
+(fset 'proclaim #'!proclaim)
+
+;;; Special forms

 
 

-(defun ls-compile-block (sexps env)
-  (join-trailing
-   (remove-if #'null-or-empty-p
-              (mapcar (lambda (x) (ls-compile x env)) sexps))
-   (concat ";" *newline*)))
+(defvar *compilations* nil)

 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and
   ;; @body. The body can access to the local environment through the
 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and
   ;; @body. The body can access to the local environment through the

-  ;; variable ENV.
-  `(push (list ',name (lambda (env ,@args) (block ,name ,@body)))
+  ;; variable *ENVIRONMENT*.
+  `(push (list ',name (lambda ,args (block ,name ,@body)))

          *compilations*))
 
 (define-compilation if (condition true false)
          *compilations*))
 
 (define-compilation if (condition true false)

-  (concat "("
-          (ls-compile condition env) " !== " (ls-compile nil)
-          " ? "
-          (ls-compile true env)
-          " : "
-          (ls-compile false env)
+  (concat "(" (ls-compile condition) " !== " (ls-compile nil)
+          " ? " (ls-compile true *multiple-value-p*)
+          " : " (ls-compile false *multiple-value-p*)

           ")"))
 
           ")"))
 

-

 (defvar *lambda-list-keywords* '(&optional &rest))
 
 (defun list-until-keyword (list)
 (defvar *lambda-list-keywords* '(&optional &rest))
 
 (defun list-until-keyword (list)

@@ -870,84 +1166,129 @@
       (error "Bad lambda-list"))
     (car rest)))
 
       (error "Bad lambda-list"))
     (car rest)))
 

-(define-compilation lambda (lambda-list &rest body)
+(defun lambda-docstring-wrapper (docstring &rest strs)
+  (if docstring
+      (js!selfcall
+        "var func = " (join strs) ";" *newline*
+        "func.docstring = '" docstring "';" *newline*
+        "return func;" *newline*)
+      (join strs)))
+
+(defun lambda-check-argument-count
+    (n-required-arguments n-optional-arguments rest-p)
+  ;; Note: Remember that we assume that the number of arguments of a
+  ;; call is at least 1 (the values argument).
+  (let ((min (1+ n-required-arguments))
+        (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
+    (block nil
+      ;; Special case: a positive exact number of arguments.
+      (when (and (< 1 min) (eql min max))
+        (return (concat "checkArgs(arguments, " (integer-to-string min) ");" *newline*)))
+      ;; General case:
+      (concat
+       (if (< 1 min)
+           (concat "checkArgsAtLeast(arguments, " (integer-to-string min) ");" *newline*)
+           "")
+       (if (numberp max)
+           (concat "checkArgsAtMost(arguments, " (integer-to-string max) ");" *newline*)
+           "")))))
+
+(defun compile-lambda (lambda-list body)

   (let ((required-arguments (lambda-list-required-arguments lambda-list))
         (optional-arguments (lambda-list-optional-arguments lambda-list))
   (let ((required-arguments (lambda-list-required-arguments lambda-list))
         (optional-arguments (lambda-list-optional-arguments lambda-list))

-        (rest-argument (lambda-list-rest-argument lambda-list)))
+        (rest-argument (lambda-list-rest-argument lambda-list))
+        documentation)
+    ;; Get the documentation string for the lambda function
+    (when (and (stringp (car body))
+               (not (null (cdr body))))
+      (setq documentation (car body))
+      (setq body (cdr body)))

     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))

-          (new-env (extend-local-env
-                    (append (ensure-list rest-argument)
-                            required-arguments
-                            optional-arguments)
-                    env)))
-      (concat "(function ("
-              (join (mapcar (lambda (x)
-                              (translate-variable x new-env))
-                            (append required-arguments optional-arguments))
-                    ",")
-              "){" *newline*
-              ;; Check number of arguments
-              (indent
-               (if required-arguments
-                   (concat "if (arguments.length < " (integer-to-string n-required-arguments)
-                           ") throw 'too few arguments';" *newline*)
-                   "")
-               (if (not rest-argument)
-                   (concat "if (arguments.length > "
-                           (integer-to-string (+ n-required-arguments n-optional-arguments))
-                           ") throw 'too many arguments';" *newline*)
-                   "")
-               ;; Optional arguments
-               (if optional-arguments
-                   (concat "switch(arguments.length){" *newline*
-                           (let ((optional-and-defaults
-                                  (lambda-list-optional-arguments-with-default lambda-list))
-                                 (cases nil)
-                                 (idx 0))
-                             (progn
-                               (while (< idx n-optional-arguments)
-                                 (let ((arg (nth idx optional-and-defaults)))
-                                   (push (concat "case "
-                                                 (integer-to-string (+ idx n-required-arguments)) ":" *newline*
-                                                 (translate-variable (car arg) new-env)
-                                                 "="
-                                                 (ls-compile (cadr arg) new-env)
-                                                 ";" *newline*)
-                                         cases)
-                                   (incf idx)))
-                                    (push (concat "default: break;" *newline*) cases)
-                                    (join (reverse cases))))
-                           "}" *newline*)
-                   "")
-               ;; &rest/&body argument
-               (if rest-argument
-                   (let ((js!rest (translate-variable rest-argument new-env)))
-                     (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
-                             "for (var i = arguments.length-1; i>="
-                             (integer-to-string (+ n-required-arguments n-optional-arguments))
-                             "; i--)" *newline*
-                             (indent js!rest " = "
-                                     "{car: arguments[i], cdr: ") js!rest "};"
-                                     *newline*))
-                   "")
-               ;; Body
-               (concat (ls-compile-block (butlast body) new-env)
-                       "return " (ls-compile (car (last body)) new-env) ";")) *newline*
-              "})"))))
-
-(define-compilation setq (var val)
-  (let ((b (lookup-in-lexenv var env 'variable)))
-    (if (eq (binding-type b) 'lexical-variable)
-        (concat (binding-translation b) " = " (ls-compile val env))
-        (ls-compile `(set ',var ,val) env))))
+          (*environment* (extend-local-env
+                          (append (ensure-list rest-argument)
+                                  required-arguments
+                                  optional-arguments))))
+      (lambda-docstring-wrapper
+       documentation
+       "(function ("
+       (join (cons "values"
+                   (mapcar #'translate-variable
+                           (append required-arguments optional-arguments)))
+             ",")
+       "){" *newline*
+       (indent
+        ;; Check number of arguments
+        (lambda-check-argument-count n-required-arguments
+                                     n-optional-arguments
+                                     rest-argument)
+        ;; Optional arguments
+        (if optional-arguments
+            (concat "switch(arguments.length-1){" *newline*
+                    (let ((optional-and-defaults
+                           (lambda-list-optional-arguments-with-default lambda-list))
+                          (cases nil)
+                          (idx 0))
+                      (progn
+                        (while (< idx n-optional-arguments)
+                          (let ((arg (nth idx optional-and-defaults)))
+                            (push (concat "case "
+                                          (integer-to-string (+ idx n-required-arguments)) ":" *newline*
+                                          (translate-variable (car arg))
+                                          "="
+                                          (ls-compile (cadr arg))
+                                          ";" *newline*)
+                                  cases)
+                            (incf idx)))
+                        (push (concat "default: break;" *newline*) cases)
+                        (join (reverse cases))))
+                    "}" *newline*)
+            "")
+        ;; &rest/&body argument
+        (if rest-argument
+            (let ((js!rest (translate-variable rest-argument)))
+              (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
+                      "for (var i = arguments.length-1; i>="
+                      (integer-to-string (+ 1 n-required-arguments n-optional-arguments))
+                      "; i--)" *newline*
+                      (indent js!rest " = "
+                              "{car: arguments[i], cdr: ") js!rest "};"
+                      *newline*))
+            "")
+        ;; Body
+        (let ((*multiple-value-p* t)) (ls-compile-block body t)))
+       "})"))))
+
+
+(defun setq-pair (var val)
+  (let ((b (lookup-in-lexenv var *environment* 'variable)))
+    (if (and (eq (binding-type b) 'variable)
+             (not (member 'special (binding-declarations b)))
+             (not (member 'constant (binding-declarations b))))
+        (concat (binding-value b) " = " (ls-compile val))
+        (ls-compile `(set ',var ,val)))))
+
+(define-compilation setq (&rest pairs)
+  (let ((result ""))
+    (while t
+      (cond
+       ((null pairs) (return))
+       ((null (cdr pairs))
+        (error "Odd paris in SETQ"))
+       (t
+        (concatf result
+          (concat (setq-pair (car pairs) (cadr pairs))
+                  (if (null (cddr pairs)) "" ", ")))
+        (setq pairs (cddr pairs)))))
+    (concat "(" result ")")))

 
 ;;; FFI Variable accessors
 (define-compilation js-vref (var)
   var)
 
 (define-compilation js-vset (var val)
 
 ;;; FFI Variable accessors
 (define-compilation js-vref (var)
   var)
 
 (define-compilation js-vset (var val)

-  (concat "(" var " = " (ls-compile val env) ")"))
+  (concat "(" var " = " (ls-compile val) ")"))
+

 
 
 ;;; Literals
 
 
 ;;; Literals

@@ -981,159 +1322,235 @@
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
               (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
               (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")

-                 #+ecmalisp (ls-compile `(intern ,(symbol-name sexp)))))
+                 #+ecmalisp
+                  (let ((package (symbol-package sexp)))
+                    (if (null package)
+                        (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
+                        (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))

           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))
     ((consp sexp)
           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))
     ((consp sexp)

-     (let ((c (concat "{car: " (literal (car sexp) t) ", "
-                     "cdr: " (literal (cdr sexp) t) "}")))
+     (let* ((head (butlast sexp))
+            (tail (last sexp))
+            (c (concat "QIList("
+                       (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
+                       (literal (car tail) t)
+                       ","
+                       (literal (cdr tail) t)
+                       ")")))

        (if recursive
           c
           (let ((v (genlit)))
        (if recursive
           c
           (let ((v (genlit)))

-            (toplevel-compilation (concat "var " v " = " c))
-            v))))))
+             (toplevel-compilation (concat "var " v " = " c))
+             v))))
+    ((arrayp sexp)
+     (let ((elements (vector-to-list sexp)))
+       (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
+        (if recursive
+            c
+            (let ((v (genlit)))
+              (toplevel-compilation (concat "var " v " = " c))
+              v)))))))

 
 (define-compilation quote (sexp)
   (literal sexp))
 
 
 (define-compilation quote (sexp)
   (literal sexp))
 

-

 (define-compilation %while (pred &rest body)
   (js!selfcall
 (define-compilation %while (pred &rest body)
   (js!selfcall

-    "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*
-    (indent (ls-compile-block body env))
+    "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
+    (indent (ls-compile-block body))

     "}"
     "return " (ls-compile nil) ";" *newline*))
 
 (define-compilation function (x)
   (cond
     ((and (listp x) (eq (car x) 'lambda))
     "}"
     "return " (ls-compile nil) ";" *newline*))
 
 (define-compilation function (x)
   (cond
     ((and (listp x) (eq (car x) 'lambda))

-     (ls-compile x env))
+     (compile-lambda (cadr x) (cddr x)))

     ((symbolp x)
     ((symbolp x)

-     (ls-compile `(symbol-function ',x))
-     ;; TODO: Add lexical functions
-     ;;(lookup-function-translation x env)
-     )))
+     (ls-compile `(symbol-function ',x)))))

 
 

+(defvar *compiling-file* nil)

 (define-compilation eval-when-compile (&rest body)
 (define-compilation eval-when-compile (&rest body)

-  (eval (cons 'progn body))
-  nil)
+  (if *compiling-file*
+      (progn
+        (eval (cons 'progn body))
+        nil)
+      (ls-compile `(progn ,@body))))

 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args
 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args

-     (ls-compile ,form env)))
+     (ls-compile ,form)))

 
 (define-compilation progn (&rest body)
 
 (define-compilation progn (&rest body)

-  (js!selfcall
-    (ls-compile-block (butlast body) env)
-    "return " (ls-compile (car (last body)) env) ";" *newline*))
-
+  (if (null (cdr body))
+      (ls-compile (car body) *multiple-value-p*)
+      (js!selfcall (ls-compile-block body t))))
+
+(defun special-variable-p (x)
+  (and (claimp x 'variable 'special) t))
+
+;;; Wrap CODE to restore the symbol values of the dynamic
+;;; bindings. BINDINGS is a list of pairs of the form
+;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
+;;; name to initialize the symbol value and where to stored
+;;; the old value.
+(defun let-binding-wrapper (bindings body)
+  (when (null bindings)
+    (return-from let-binding-wrapper body))
+  (concat
+   "try {" *newline*
+   (indent "var tmp;" *newline*
+           (mapconcat
+            (lambda (b)
+              (let ((s (ls-compile `(quote ,(car b)))))
+                (concat "tmp = " s ".value;" *newline*
+                        s ".value = " (cdr b) ";" *newline*
+                        (cdr b) " = tmp;" *newline*)))
+            bindings)
+           body *newline*)
+   "}" *newline*
+   "finally {"  *newline*
+   (indent
+    (mapconcat (lambda (b)
+                 (let ((s (ls-compile `(quote ,(car b)))))
+                   (concat s ".value" " = " (cdr b) ";" *newline*)))
+               bindings))
+   "}" *newline*))

 
 

-(defun dynamic-binding-wrapper (bindings body)
-  (if (null bindings)
-      body
-      (concat
-       "try {" *newline*
-       (indent
-        "var tmp;" *newline*
-        (join
-         (mapcar (lambda (b)
+(define-compilation let (bindings &rest body)
+  (let* ((bindings (mapcar #'ensure-list bindings))
+         (variables (mapcar #'first bindings))
+         (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
+         (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
+         (dynamic-bindings))
+    (concat "(function("
+            (join (mapcar (lambda (x)
+                            (if (special-variable-p x)
+                                (let ((v (gvarname x)))
+                                  (push (cons x v) dynamic-bindings)
+                                  v)
+                                (translate-variable x)))
+                          variables)
+                  ",")
+            "){" *newline*
+            (let ((body (ls-compile-block body t)))
+              (indent (let-binding-wrapper dynamic-bindings body)))
+            "})(" (join cvalues ",") ")")))
+
+
+;;; Return the code to initialize BINDING, and push it extending the
+;;; current lexical environment if the variable is not special.
+(defun let*-initialize-value (binding)
+  (let ((var (first binding))
+        (value (second binding)))
+    (if (special-variable-p var)
+        (concat (ls-compile `(setq ,var ,value)) ";" *newline*)
+        (let* ((v (gvarname var))
+               (b (make-binding var 'variable v)))
+          (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*)
+            (push-to-lexenv b *environment* 'variable))))))
+
+;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
+;;; DOES NOT generate code to initialize the value of the symbols,
+;;; unlike let-binding-wrapper.
+(defun let*-binding-wrapper (symbols body)
+  (when (null symbols)
+    (return-from let*-binding-wrapper body))
+  (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
+                       (remove-if-not #'special-variable-p symbols))))
+    (concat
+     "try {" *newline*
+     (indent
+      (mapconcat (lambda (b)

                    (let ((s (ls-compile `(quote ,(car b)))))
                    (let ((s (ls-compile `(quote ,(car b)))))

-                     (concat "tmp = " s ".value;" *newline*
-                             s ".value = " (cdr b) ";" *newline*
-                             (cdr b) " = tmp;" *newline*)))
-                 bindings))
-        body)
-       "}" *newline*
-       "finally {"  *newline*
-       (indent
-        (join-trailing
-         (mapcar (lambda (b)
+                     (concat "var " (cdr b) " = " s ".value;" *newline*)))
+                 store)
+      body)
+     "}" *newline*
+     "finally {" *newline*
+     (indent
+      (mapconcat (lambda (b)

                    (let ((s (ls-compile `(quote ,(car b)))))
                    (let ((s (ls-compile `(quote ,(car b)))))

-                     (concat s ".value" " = " (cdr b))))
-                 bindings)
-         (concat ";" *newline*)))
-       "}" *newline*)))
+                     (concat s ".value" " = " (cdr b) ";" *newline*)))
+                 store))
+     "}" *newline*)))

 
 

-
-(define-compilation let (bindings &rest body)
-  (let ((bindings (mapcar #'ensure-list bindings)))
-    (let ((variables (mapcar #'first bindings))
-          (values    (mapcar #'second bindings)))
-      (let ((new-env (extend-local-env (remove-if #'boundp variables) env))
-            (dynamic-bindings))
-        (concat "(function("
-                (join (mapcar (lambda (x)
-                                (if (boundp x)
-                                    (let ((v (gvarname x)))
-                                      (push (cons x v) dynamic-bindings)
-                                      v)
-                                    (translate-variable x new-env)))
-                              variables)
-                      ",")
-                "){" *newline*
-                (let ((body
-                       (concat (ls-compile-block (butlast body) new-env)
-                               "return " (ls-compile (car (last body)) new-env)
-                               ";" *newline*)))
-                  (indent (dynamic-binding-wrapper dynamic-bindings body)))
-                "})(" (join (mapcar (lambda (x) (ls-compile x env))
-                                    values)
-                            ",")
-                ")")))))
+(define-compilation let* (bindings &rest body)
+  (let ((bindings (mapcar #'ensure-list bindings))
+        (*environment* (copy-lexenv *environment*)))
+    (js!selfcall
+      (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
+            (body (concat (mapconcat #'let*-initialize-value bindings)
+                          (ls-compile-block body t))))
+        (let*-binding-wrapper specials body)))))

 
 
 (defvar *block-counter* 0)
 
 (define-compilation block (name &rest body)
 
 
 (defvar *block-counter* 0)
 
 (define-compilation block (name &rest body)

-  (let ((tr (integer-to-string (incf *block-counter*))))
-    (let ((b (make-binding name 'block tr t)))
-      (js!selfcall
-        "try {" *newline*
-        (indent "return " (ls-compile `(progn ,@body)
-                                      (extend-lexenv (list b) env 'block))
-                ";" *newline*)
-        "}" *newline*
-        "catch (cf){" *newline*
-        "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
-        "        return cf.value;" *newline*
-        "    else" *newline*
-        "        throw cf;" *newline*
-        "}" *newline*))))
+  (let* ((tr (integer-to-string (incf *block-counter*)))
+         (b (make-binding name 'block tr)))
+    (when *multiple-value-p*
+      (push-binding-declaration 'multiple-value b))
+    (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
+           (cbody (ls-compile-block body t)))
+      (if (member 'used (binding-declarations b))
+          (js!selfcall
+            "try {" *newline*
+            (indent cbody)
+            "}" *newline*
+            "catch (cf){" *newline*
+            "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
+            (if *multiple-value-p*
+                "        return values.apply(this, forcemv(cf.values));"
+                "        return cf.values;")
+            *newline*
+            "    else" *newline*
+            "        throw cf;" *newline*
+            "}" *newline*)
+          (js!selfcall cbody)))))

 
 (define-compilation return-from (name &optional value)
 
 (define-compilation return-from (name &optional value)

-  (let ((b (lookup-in-lexenv name env 'block)))
-    (if b
-        (js!selfcall
-          "throw ({"
-          "type: 'block', "
-          "id: " (binding-translation b) ", "
-          "value: " (ls-compile value env) ", "
-          "message: 'Return from unknown block " (symbol-name name) ".'"
-          "})")
-        (error (concat "Unknown block `" (symbol-name name) "'.")))))
-
+  (let* ((b (lookup-in-lexenv name *environment* 'block))
+         (multiple-value-p (member 'multiple-value (binding-declarations b))))
+    (when (null b)
+      (error (concat "Unknown block `" (symbol-name name) "'.")))
+    (push-binding-declaration 'used b)
+    (js!selfcall
+      (if multiple-value-p
+          (concat "var values = mv;" *newline*)
+          "")
+      "throw ({"
+      "type: 'block', "
+      "id: " (binding-value b) ", "
+      "values: " (ls-compile value multiple-value-p) ", "
+      "message: 'Return from unknown block " (symbol-name name) ".'"
+      "})")))

 
 (define-compilation catch (id &rest body)
   (js!selfcall
 
 (define-compilation catch (id &rest body)
   (js!selfcall

-    "var id = " (ls-compile id env) ";" *newline*
+    "var id = " (ls-compile id) ";" *newline*

     "try {" *newline*
     "try {" *newline*

-    (indent "return " (ls-compile `(progn ,@body))
-            ";" *newline*)
+    (indent (ls-compile-block body t)) *newline*

     "}" *newline*
     "catch (cf){" *newline*
     "    if (cf.type == 'catch' && cf.id == id)" *newline*
     "}" *newline*
     "catch (cf){" *newline*
     "    if (cf.type == 'catch' && cf.id == id)" *newline*

-    "        return cf.value;" *newline*
+    (if *multiple-value-p*
+        "        return values.apply(this, forcemv(cf.values));"
+        "        return pv.apply(this, forcemv(cf.values));")
+    *newline*

     "    else" *newline*
     "        throw cf;" *newline*
     "}" *newline*))
 
     "    else" *newline*
     "        throw cf;" *newline*
     "}" *newline*))
 

-(define-compilation throw (id &optional value)
+(define-compilation throw (id value)

   (js!selfcall
   (js!selfcall

+    "var values = mv;" *newline*

     "throw ({"
     "type: 'catch', "
     "throw ({"
     "type: 'catch', "

-    "id: " (ls-compile id env) ", "
-    "value: " (ls-compile value env) ", "
+    "id: " (ls-compile id) ", "
+    "values: " (ls-compile value t) ", "

     "message: 'Throw uncatched.'"
     "})"))
 
     "message: 'Throw uncatched.'"
     "})"))
 

@@ -1144,29 +1561,29 @@
 (defun go-tag-p (x)
   (or (integerp x) (symbolp x)))
 
 (defun go-tag-p (x)
   (or (integerp x) (symbolp x)))
 

-(defun declare-tagbody-tags (env tbidx body)
+(defun declare-tagbody-tags (tbidx body)

   (let ((bindings
          (mapcar (lambda (label)
                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
   (let ((bindings
          (mapcar (lambda (label)
                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))

-                     (make-binding label 'gotag (list tbidx tagidx) t)))
+                     (make-binding label 'gotag (list tbidx tagidx))))

                  (remove-if-not #'go-tag-p body))))
                  (remove-if-not #'go-tag-p body))))

-    (extend-lexenv bindings env 'gotag)))
+    (extend-lexenv bindings *environment* 'gotag)))

 
 (define-compilation tagbody (&rest body)
   ;; Ignore the tagbody if it does not contain any go-tag. We do this
   ;; because 1) it is easy and 2) many built-in forms expand to a
   ;; implicit tagbody, so we save some space.
   (unless (some #'go-tag-p body)
 
 (define-compilation tagbody (&rest body)
   ;; Ignore the tagbody if it does not contain any go-tag. We do this
   ;; because 1) it is easy and 2) many built-in forms expand to a
   ;; implicit tagbody, so we save some space.
   (unless (some #'go-tag-p body)

-    (return-from tagbody (ls-compile `(progn ,@body nil) env)))
+    (return-from tagbody (ls-compile `(progn ,@body nil))))

   ;; The translation assumes the first form in BODY is a label
   (unless (go-tag-p (car body))
     (push (gensym "START") body))
   ;; Tagbody compilation
   (let ((tbidx (integer-to-string *tagbody-counter*)))
   ;; The translation assumes the first form in BODY is a label
   (unless (go-tag-p (car body))
     (push (gensym "START") body))
   ;; Tagbody compilation
   (let ((tbidx (integer-to-string *tagbody-counter*)))

-    (let ((env (declare-tagbody-tags env tbidx body))
+    (let ((*environment* (declare-tagbody-tags tbidx body))

           initag)
           initag)

-      (let ((b (lookup-in-lexenv (first body) env 'gotag)))
-        (setq initag (second (binding-translation b))))
+      (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
+        (setq initag (second (binding-value b))))

       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*
       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*

@@ -1178,9 +1595,9 @@
                                   (dolist (form (cdr body) content)
                                     (concatf content
                                       (if (not (go-tag-p form))
                                   (dolist (form (cdr body) content)
                                     (concatf content
                                       (if (not (go-tag-p form))

-                                          (indent (ls-compile form env) ";" *newline*)
-                                          (let ((b (lookup-in-lexenv form env 'gotag)))
-                                            (concat "case " (second (binding-translation b)) ":" *newline*)))))
+                                          (indent (ls-compile form) ";" *newline*)
+                                          (let ((b (lookup-in-lexenv form *environment* 'gotag)))
+                                            (concat "case " (second (binding-value b)) ":" *newline*)))))

                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))
                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))

@@ -1195,7 +1612,7 @@
         "return " (ls-compile nil) ";" *newline*))))
 
 (define-compilation go (label)
         "return " (ls-compile nil) ";" *newline*))))
 
 (define-compilation go (label)

-  (let ((b (lookup-in-lexenv label env 'gotag))
+  (let ((b (lookup-in-lexenv label *environment* 'gotag))

         (n (cond
              ((symbolp label) (symbol-name label))
              ((integerp label) (integer-to-string label)))))
         (n (cond
              ((symbolp label) (symbol-name label))
              ((integerp label) (integer-to-string label)))))

@@ -1203,23 +1620,46 @@
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "

-          "id: " (first (binding-translation b)) ", "
-          "label: " (second (binding-translation b)) ", "
+          "id: " (first (binding-value b)) ", "
+          "label: " (second (binding-value b)) ", "

           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))
 
           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))
 

-

 (define-compilation unwind-protect (form &rest clean-up)
   (js!selfcall
     "var ret = " (ls-compile nil) ";" *newline*
     "try {" *newline*
 (define-compilation unwind-protect (form &rest clean-up)
   (js!selfcall
     "var ret = " (ls-compile nil) ";" *newline*
     "try {" *newline*

-    (indent "ret = " (ls-compile form env) ";" *newline*)
+    (indent "ret = " (ls-compile form) ";" *newline*)

     "} finally {" *newline*
     "} finally {" *newline*

-    (indent (ls-compile-block clean-up env))
+    (indent (ls-compile-block clean-up))

     "}" *newline*
     "return ret;" *newline*))
 
     "}" *newline*
     "return ret;" *newline*))
 

+(define-compilation multiple-value-call (func-form &rest forms)
+  (js!selfcall
+    "var func = " (ls-compile func-form) ";" *newline*
+    "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
+    "return "
+    (js!selfcall
+      "var values = mv;" *newline*
+      "var vs;" *newline*
+      (mapconcat (lambda (form)
+                   (concat "vs = " (ls-compile form t) ";" *newline*
+                           "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
+                           (indent "args = args.concat(vs);" *newline*)
+                           "else" *newline*
+                           (indent "args.push(vs);" *newline*)))
+                 forms)
+      "return func.apply(window, args);" *newline*) ";" *newline*))
+
+(define-compilation multiple-value-prog1 (first-form &rest forms)
+  (js!selfcall
+    "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
+    (ls-compile-block forms)
+    "return args;" *newline*))
+
+

 
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.
 
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.

@@ -1258,10 +1698,19 @@
 
 ;;; Primitives
 
 
 ;;; Primitives
 

+(defvar *builtins* nil)
+
+(defmacro define-raw-builtin (name args &body body)
+  ;; Creates a new primitive function `name' with parameters args and
+  ;; @body. The body can access to the local environment through the
+  ;; variable *ENVIRONMENT*.
+  `(push (list ',name (lambda ,args (block ,name ,@body)))
+         *builtins*))
+

 (defmacro define-builtin (name args &body body)
   `(progn
 (defmacro define-builtin (name args &body body)
   `(progn

-     (define-compilation ,name ,args
-       (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env))) args)
+     (define-raw-builtin ,name ,args
+       (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)

          ,@body))))
 
 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
          ,@body))))
 
 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.

@@ -1281,22 +1730,90 @@
                decls)
      (concat "return " (progn ,@body) ";" *newline*)))
 
                decls)
      (concat "return " (progn ,@body) ";" *newline*)))
 

+;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
+;;; a variable which holds a list of forms. It will compile them and
+;;; store the result in some Javascript variables. BODY is evaluated
+;;; with ARGS bound to the list of these variables to generate the
+;;; code which performs the transformation on these variables.
+
+(defun variable-arity-call (args function)
+  (unless (consp args)
+    (error "ARGS must be a non-empty list"))
+  (let ((counter 0)
+        (variables '())
+        (prelude ""))
+    (dolist (x args)
+      (let ((v (concat "x" (integer-to-string (incf counter)))))
+        (push v variables)
+        (concatf prelude
+                 (concat "var " v " = " (ls-compile x) ";" *newline*
+                         "if (typeof " v " !== 'number') throw 'Not a number!';"
+                         *newline*))))
+    (js!selfcall prelude (funcall function (reverse variables)))))
+
+
+(defmacro variable-arity (args &body body)
+  (unless (symbolp args)
+    (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
+  `(variable-arity-call ,args
+                        (lambda (,args)
+                          (concat "return " ,@body ";" *newline*))))
+

 (defun num-op-num (x op y)
   (type-check (("x" "number" x) ("y" "number" y))
     (concat "x" op "y")))
 
 (defun num-op-num (x op y)
   (type-check (("x" "number" x) ("y" "number" y))
     (concat "x" op "y")))
 

-(define-builtin + (x y) (num-op-num x "+" y))
-(define-builtin - (x y) (num-op-num x "-" y))
-(define-builtin * (x y) (num-op-num x "*" y))
-(define-builtin / (x y) (num-op-num x "/" y))
+(define-raw-builtin + (&rest numbers)
+  (if (null numbers)
+      "0"
+      (variable-arity numbers
+       (join numbers "+"))))
+
+(define-raw-builtin - (x &rest others)
+  (let ((args (cons x others)))
+    (variable-arity args
+      (if (null others)
+         (concat "-" (car args))
+         (join args "-")))))
+
+(define-raw-builtin * (&rest numbers)
+  (if (null numbers)
+      "1"
+      (variable-arity numbers
+       (join numbers "*"))))
+
+(define-raw-builtin / (x &rest others)
+  (let ((args (cons x others)))
+    (variable-arity args
+      (if (null others)
+         (concat "1 /" (car args))
+         (join args "/")))))

 
 (define-builtin mod (x y) (num-op-num x "%" y))
 
 
 (define-builtin mod (x y) (num-op-num x "%" y))
 

-(define-builtin < (x y)  (js!bool (num-op-num x "<" y)))
-(define-builtin > (x y)  (js!bool (num-op-num x ">" y)))
-(define-builtin = (x y)  (js!bool (num-op-num x "==" y)))
-(define-builtin <= (x y) (js!bool (num-op-num x "<=" y)))
-(define-builtin >= (x y) (js!bool (num-op-num x ">=" y)))
+
+(defun comparison-conjuntion (vars op)
+  (cond
+    ((null (cdr vars))
+     "true")
+    ((null (cddr vars))
+     (concat (car vars) op (cadr vars)))
+    (t
+     (concat (car vars) op (cadr vars)
+            " && "
+            (comparison-conjuntion (cdr vars) op)))))
+
+(defmacro define-builtin-comparison (op sym)
+  `(define-raw-builtin ,op (x &rest args)
+     (let ((args (cons x args)))
+       (variable-arity args
+        (js!bool (comparison-conjuntion args ,sym))))))
+
+(define-builtin-comparison > ">")
+(define-builtin-comparison < "<")
+(define-builtin-comparison >= ">=")
+(define-builtin-comparison <= "<=")
+(define-builtin-comparison = "==")

 
 (define-builtin numberp (x)
   (js!bool (concat "(typeof (" x ") == \"number\")")))
 
 (define-builtin numberp (x)
   (js!bool (concat "(typeof (" x ") == \"number\")")))

@@ -1328,13 +1845,13 @@
     (ls-compile nil)
     ": tmp.cdr;" *newline*))
 
     (ls-compile nil)
     ": tmp.cdr;" *newline*))
 

-(define-builtin setcar (x new)
+(define-builtin rplaca (x new)

   (type-check (("x" "object" x))
   (type-check (("x" "object" x))

-    (concat "(x.car = " new ")")))
+    (concat "(x.car = " new ", x)")))

 
 

-(define-builtin setcdr (x new)
+(define-builtin rplacd (x new)

   (type-check (("x" "object" x))
   (type-check (("x" "object" x))

-    (concat "(x.cdr = " new ")")))
+    (concat "(x.cdr = " new ", x)")))

 
 (define-builtin symbolp (x)
   (js!bool
 
 (define-builtin symbolp (x)
   (js!bool

@@ -1353,7 +1870,7 @@
   (concat "(" symbol ").value = " value))
 
 (define-builtin fset (symbol value)
   (concat "(" symbol ").value = " value))
 
 (define-builtin fset (symbol value)

-  (concat "(" symbol ").function = " value))
+  (concat "(" symbol ").fvalue = " value))

 
 (define-builtin boundp (x)
   (js!bool (concat "(" x ".value !== undefined)")))
 
 (define-builtin boundp (x)
   (js!bool (concat "(" x ".value !== undefined)")))

@@ -1368,7 +1885,7 @@
 (define-builtin symbol-function (x)
   (js!selfcall
     "var symbol = " x ";" *newline*
 (define-builtin symbol-function (x)
   (js!selfcall
     "var symbol = " x ";" *newline*

-    "var func = symbol.function;" *newline*
+    "var func = symbol.fvalue;" *newline*

     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
     "return func;" *newline*))
 
     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
     "return func;" *newline*))
 

@@ -1378,11 +1895,10 @@
 (define-builtin lambda-code (x)
   (concat "(" x ").toString()"))
 
 (define-builtin lambda-code (x)
   (concat "(" x ").toString()"))
 

-

 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 
 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 

-(define-builtin string (x)
+(define-builtin char-to-string (x)

   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 
   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 

@@ -1397,13 +1913,13 @@
   (type-check (("x" "string" x))
     "x.length"))
 
   (type-check (("x" "string" x))
     "x.length"))
 

-(define-compilation slice (string a &optional b)
+(define-raw-builtin slice (string a &optional b)

   (js!selfcall
   (js!selfcall

-    "var str = " (ls-compile string env) ";" *newline*
-    "var a = " (ls-compile a env) ";" *newline*
+    "var str = " (ls-compile string) ";" *newline*
+    "var a = " (ls-compile a) ";" *newline*

     "var b;" *newline*
     (if b
     "var b;" *newline*
     (if b

-        (concat "b = " (ls-compile b env) ";" *newline*)
+        (concat "b = " (ls-compile b) ";" *newline*)

         "")
     "return str.slice(a,b);" *newline*))
 
         "")
     "return str.slice(a,b);" *newline*))
 

@@ -1417,27 +1933,25 @@
                ("string2" "string" string2))
     "string1.concat(string2)"))
 
                ("string2" "string" string2))
     "string1.concat(string2)"))
 

-(define-compilation funcall (func &rest args)
-  (concat "(" (ls-compile func env) ")("
-          (join (mapcar (lambda (x)
-                          (ls-compile x env))
-                        args)
+(define-raw-builtin funcall (func &rest args)
+  (concat "(" (ls-compile func) ")("
+          (join (cons (if *multiple-value-p* "values" "pv")
+                      (mapcar #'ls-compile args))

                 ", ")
           ")"))
 
                 ", ")
           ")"))
 

-(define-compilation apply (func &rest args)
+(define-raw-builtin apply (func &rest args)

   (if (null args)
   (if (null args)

-      (concat "(" (ls-compile func env) ")()")
+      (concat "(" (ls-compile func) ")()")

       (let ((args (butlast args))
             (last (car (last args))))
         (js!selfcall
       (let ((args (butlast args))
             (last (car (last args))))
         (js!selfcall

-          "var f = " (ls-compile func env) ";" *newline*
-          "var args = [" (join (mapcar (lambda (x)
-                                         (ls-compile x env))
-                                       args)
+          "var f = " (ls-compile func) ";" *newline*
+          "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
+                                     (mapcar #'ls-compile args))

                                ", ")
           "];" *newline*
                                ", ")
           "];" *newline*

-          "var tail = (" (ls-compile last env) ");" *newline*
+          "var tail = (" (ls-compile last) ");" *newline*

           "while (tail != " (ls-compile nil) "){" *newline*
           "    args.push(tail.car);" *newline*
           "    tail = tail.cdr;" *newline*
           "while (tail != " (ls-compile nil) "){" *newline*
           "    args.push(tail.car);" *newline*
           "    tail = tail.cdr;" *newline*

@@ -1446,13 +1960,24 @@
 
 (define-builtin js-eval (string)
   (type-check (("string" "string" string))
 
 (define-builtin js-eval (string)
   (type-check (("string" "string" string))

-    "eval.apply(window, [string])"))
+    (if *multiple-value-p*
+        (js!selfcall
+          "var v = eval.apply(window, [string]);" *newline*
+          "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
+          (indent "v = [v];" *newline*
+                  "v['multiple-value'] = true;" *newline*)
+          "}" *newline*
+          "return values.apply(this, v);" *newline*)
+        "eval.apply(window, [string])")))

 
 (define-builtin error (string)
   (js!selfcall "throw " string ";" *newline*))
 
 (define-builtin new () "{}")
 
 
 (define-builtin error (string)
   (js!selfcall "throw " string ";" *newline*))
 
 (define-builtin new () "{}")
 

+(define-builtin objectp (x)
+  (js!bool (concat "(typeof (" x ") === 'object')")))
+

 (define-builtin oget (object key)
   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*
 (define-builtin oget (object key)
   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*

@@ -1471,6 +1996,45 @@
   (type-check (("x" "string" x))
     "lisp.write(x)"))
 
   (type-check (("x" "string" x))
     "lisp.write(x)"))
 

+(define-builtin make-array (n)
+  (js!selfcall
+    "var r = [];" *newline*
+    "for (var i = 0; i < " n "; i++)" *newline*
+    (indent "r.push(" (ls-compile nil) ");" *newline*)
+    "return r;" *newline*))
+
+(define-builtin arrayp (x)
+  (js!bool
+   (js!selfcall
+     "var x = " x ";" *newline*
+     "return typeof x === 'object' && 'length' in x;")))
+
+(define-builtin aref (array n)
+  (js!selfcall
+    "var x = " "(" array ")[" n "];" *newline*
+    "if (x === undefined) throw 'Out of range';" *newline*
+    "return x;" *newline*))
+
+(define-builtin aset (array n value)
+  (js!selfcall
+    "var x = " array ";" *newline*
+    "var i = " n ";" *newline*
+    "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
+    "return x[i] = " value ";" *newline*))
+
+(define-builtin get-unix-time ()
+  (concat "(Math.round(new Date() / 1000))"))
+
+(define-builtin values-array (array)
+  (if *multiple-value-p*
+      (concat "values.apply(this, " array ")")
+      (concat "pv.apply(this, " array ")")))
+
+(define-raw-builtin values (&rest args)
+  (if *multiple-value-p*
+      (concat "values(" (join (mapcar #'ls-compile args) ", ") ")")
+      (concat "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
+

 (defun macro (x)
   (and (symbolp x)
        (let ((b (lookup-in-lexenv x *environment* 'function)))
 (defun macro (x)
   (and (symbolp x)
        (let ((b (lookup-in-lexenv x *environment* 'function)))

@@ -1480,46 +2044,94 @@
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding

-        (apply (eval (binding-translation macro-binding)) (cdr form))
+        (let ((expander (binding-value macro-binding)))
+          (when (listp expander)
+            (let ((compiled (eval expander)))
+              ;; The list representation are useful while
+              ;; bootstrapping, as we can dump the definition of the
+              ;; macros easily, but they are slow because we have to
+              ;; evaluate them and compile them now and again. So, let
+              ;; us replace the list representation version of the
+              ;; function with the compiled one.
+              ;;
+              #+ecmalisp (set-binding-value macro-binding compiled)
+              (setq expander compiled)))
+          (apply expander (cdr form)))

         form)))
 
         form)))
 

-(defun compile-funcall (function args env)
-  (concat (ls-compile `#',function) "("
-          (join (mapcar (lambda (x) (ls-compile x env)) args)
-                ", ")
-          ")"))
+(defun compile-funcall (function args)
+  (let ((values-funcs (if *multiple-value-p* "values" "pv")))
+    (if (and (symbolp function)
+             #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
+             #+common-lisp t)
+        (concat (ls-compile `',function) ".fvalue("
+                (join (cons values-funcs (mapcar #'ls-compile args))
+                      ", ")
+                ")")
+        (concat (ls-compile `#',function) "("
+                (join (cons values-funcs (mapcar #'ls-compile args))
+                      ", ")
+                ")"))))
+
+(defun ls-compile-block (sexps &optional return-last-p)
+  (if return-last-p
+      (concat (ls-compile-block (butlast sexps))
+              "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
+      (join-trailing
+       (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
+       (concat ";" *newline*))))
+
+(defun ls-compile (sexp &optional multiple-value-p)
+  (let ((*multiple-value-p* multiple-value-p))
+    (cond
+      ((symbolp sexp)
+       (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
+         (cond
+           ((and b (not (member 'special (binding-declarations b))))
+            (binding-value b))
+           ((or (keywordp sexp)
+                (member 'constant (binding-declarations b)))
+            (concat (ls-compile `',sexp) ".value"))
+           (t
+            (ls-compile `(symbol-value ',sexp))))))
+      ((integerp sexp) (integer-to-string sexp))
+      ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
+      ((arrayp sexp) (literal sexp))
+      ((listp sexp)
+       (let ((name (car sexp))
+             (args (cdr sexp)))
+         (cond
+           ;; Special forms
+           ((assoc name *compilations*)
+            (let ((comp (second (assoc name *compilations*))))
+              (apply comp args)))
+           ;; Built-in functions
+           ((and (assoc name *builtins*)
+                 (not (claimp name 'function 'notinline)))
+            (let ((comp (second (assoc name *builtins*))))
+              (apply comp args)))
+           (t
+            (if (macro name)
+                (ls-compile (ls-macroexpand-1 sexp) multiple-value-p)
+                (compile-funcall name args))))))
+      (t
+       (error "How should I compile this?")))))

 
 

-(defun ls-compile (sexp &optional (env (make-lexenv)))
-  (cond
-    ((symbolp sexp)
-     (let ((b (lookup-in-lexenv sexp env 'variable)))
-       (if (eq (binding-type b) 'lexical-variable)
-           (binding-translation b)
-           (ls-compile `(symbol-value ',sexp) env))))
-    ((integerp sexp) (integer-to-string sexp))
-    ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
-    ((listp sexp)
-     (if (assoc (car sexp) *compilations*)
-         (let ((comp (second (assoc (car sexp) *compilations*))))
-           (apply comp env (cdr sexp)))
-         (if (macro (car sexp))
-             (ls-compile (ls-macroexpand-1 sexp) env)
-             (compile-funcall (car sexp) (cdr sexp) env))))))
-
-(defun ls-compile-toplevel (sexp)
-  (setq *toplevel-compilations* nil)
-  (cond
-    ((and (consp sexp) (eq (car sexp) 'progn))
-     (let ((subs (mapcar #'ls-compile-toplevel (cdr sexp))))
-       (join (remove-if #'null-or-empty-p subs))))
-    (t
-     (let ((code (ls-compile sexp)))
-       (prog1
-           (concat (join-trailing (get-toplevel-compilations) (concat ";" *newline*))
-                   (if code
-                       (concat code ";" *newline*)
-                       ""))
-         (setq *toplevel-compilations* nil))))))
+(defun ls-compile-toplevel (sexp &optional multiple-value-p)
+  (let ((*toplevel-compilations* nil))
+    (cond
+      ((and (consp sexp) (eq (car sexp) 'progn))
+       (let ((subs (mapcar (lambda (s)
+                             (ls-compile-toplevel s t))
+                           (cdr sexp))))
+         (join (remove-if #'null-or-empty-p subs))))
+      (t
+       (let ((code (ls-compile sexp multiple-value-p)))
+         (concat (join-trailing (get-toplevel-compilations)
+                                (concat ";" *newline*))
+                 (if code
+                     (concat code ";" *newline*)
+                     "")))))))

 
 
 ;;; Once we have the compiler, we define the runtime environment and
 
 
 ;;; Once we have the compiler, we define the runtime environment and

@@ -1528,29 +2140,40 @@
 
 #+ecmalisp
 (progn
 
 #+ecmalisp
 (progn

-  (defmacro with-compilation-unit (&body body)
-    `(prog1
-         (progn
-           (setq *compilation-unit-checks* nil)
-           (clear-undeclared-global-bindings)
-           ,@body)
-       (dolist (check *compilation-unit-checks*)
-         (funcall check))))
-

   (defun eval (x)
   (defun eval (x)

-    (let ((code
-           (with-compilation-unit
-               (ls-compile-toplevel x))))
-      (js-eval code)))
+    (js-eval (ls-compile-toplevel x t)))
+
+  (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
+            = > >= and append apply aref arrayp aset assoc atom block boundp
+            boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
+            cddr cdr cdr char char-code char= code-char cond cons consp copy-list
+            decf declaim defparameter defun defmacro defvar digit-char-p
+            disassemble do do* documentation dolist dotimes ecase eq eql equal
+           error eval every export fdefinition find-package find-symbol first
+           fourth fset funcall function functionp gensym get-universal-time go
+           identity if in-package incf integerp integerp intern keywordp lambda
+           last length let let* list-all-packages list listp make-array
+           make-package make-symbol mapcar member minusp mod multiple-value-bind
+            multiple-value-call multiple-value-list multiple-value-prog1 nil not
+            nth nthcdr null numberp or package-name package-use-list packagep
+            plusp prin1-to-string print proclaim prog1 prog2 progn psetq push
+            quote remove remove-if remove-if-not return return-from revappend
+            reverse rplaca rplacd second set setq some string-upcase string
+            string= stringp subseq symbol-function symbol-name symbol-package
+            symbol-plist symbol-value symbolp t tagbody third throw truncate
+            unless unwind-protect values values-list variable warn when write-line
+            write-string zerop))
+
+  (setq *package* *user-package*)

 
   (js-eval "var lisp")
   (js-vset "lisp" (new))
   (js-vset "lisp.read" #'ls-read-from-string)
   (js-vset "lisp.print" #'prin1-to-string)
   (js-vset "lisp.eval" #'eval)
 
   (js-eval "var lisp")
   (js-vset "lisp" (new))
   (js-vset "lisp.read" #'ls-read-from-string)
   (js-vset "lisp.print" #'prin1-to-string)
   (js-vset "lisp.eval" #'eval)

-  (js-vset "lisp.compile" #'ls-compile-toplevel)
+  (js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))

   (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
   (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))

-  (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str))))
+  (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))

 
   ;; Set the initial global environment to be equal to the host global
   ;; environment at this point of the compilation.
 
   ;; Set the initial global environment to be equal to the host global
   ;; environment at this point of the compilation.

@@ -1558,9 +2181,7 @@
     (toplevel-compilation
      (ls-compile
       `(progn
     (toplevel-compilation
      (ls-compile
       `(progn

-         ,@(mapcar (lambda (s)
-                     `(oset *package* ,(symbol-name (car s))
-                            (js-vref ,(cdr s))))
+         ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))

                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
          (setq *environment* ',*environment*)
                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
          (setq *environment* ',*environment*)

@@ -1586,19 +2207,17 @@
         seq)))
 
   (defun ls-compile-file (filename output)
         seq)))
 
   (defun ls-compile-file (filename output)

-    (setq *compilation-unit-checks* nil)
-    (with-open-file (out output :direction :output :if-exists :supersede)
-      (let* ((source (read-whole-file filename))
-             (in (make-string-stream source)))
-        (loop
-           for x = (ls-read in)
-           until (eq x *eof*)
-           for compilation = (ls-compile-toplevel x)
-           when (plusp (length compilation))
-           do (write-string compilation out))
-        (dolist (check *compilation-unit-checks*)
-          (funcall check))
-        (setq *compilation-unit-checks* nil))))
+    (let ((*compiling-file* t))
+      (with-open-file (out output :direction :output :if-exists :supersede)
+        (write-string (read-whole-file "prelude.js") out)
+        (let* ((source (read-whole-file filename))
+               (in (make-string-stream source)))
+          (loop
+             for x = (ls-read in)
+             until (eq x *eof*)
+             for compilation = (ls-compile-toplevel x)
+             when (plusp (length compilation))
+             do (write-string compilation out))))))

 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))
 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))