Different quote compilation in CL and ecmalisp

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index c3f8868..30649d2 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -1,6 +1,6 @@
 ;;; ecmalisp.lisp ---
 
 ;;; ecmalisp.lisp ---
 

-;; Copyright (C) 2012 David Vazquez
+;; Copyright (C) 2012, 2013 David Vazquez

 ;; Copyright (C) 2012 Raimon Grau
 
 ;; This program is free software: you can redistribute it and/or
 ;; Copyright (C) 2012 Raimon Grau
 
 ;; This program is free software: you can redistribute it and/or

@@ -21,25 +21,26 @@
 ;;; as well as funcalls and macroexpansion, but no functions. So, we
 ;;; define the Lisp world from scratch. This code has to define enough
 ;;; language to the compiler to be able to run.
 ;;; as well as funcalls and macroexpansion, but no functions. So, we
 ;;; define the Lisp world from scratch. This code has to define enough
 ;;; language to the compiler to be able to run.

+

 #+ecmalisp
 (progn
 #+ecmalisp
 (progn

- (eval-when-compile
-   (%compile-defmacro 'defmacro
-                      '(lambda (name args &rest body)
-                        `(eval-when-compile
-                           (%compile-defmacro ',name
-                                              '(lambda ,(mapcar (lambda (x)
-                                                                  (if (eq x '&body)
-                                                                      '&rest
-                                                                      x))
-                                                                args)
-                                                ,@body))))))
-
- (defmacro %defvar (name value)
-   `(progn
-      (eval-when-compile
-        (%compile-defvar ',name))
-      (setq ,name ,value)))
+  (eval-when-compile
+    (%compile-defmacro 'defmacro
+                       '(lambda (name args &rest body)
+                         `(eval-when-compile
+                            (%compile-defmacro ',name
+                                              '(lambda ,(mapcar (lambda (x)
+                                                                   (if (eq x '&body)
+                                                                       '&rest
+                                                                       x))
+                                                                 args)
+                                                 ,@body))))))
+
+  (defmacro %defvar (name value)
+    `(progn
+       (eval-when-compile
+         (%compile-defvar ',name))
+       (setq ,name ,value)))

 
   (defmacro defvar (name &optional value)
     `(%defvar ,name ,value))
 
   (defmacro defvar (name &optional value)
     `(%defvar ,name ,value))

@@ -47,7 +48,7 @@
   (defmacro named-lambda (name args &rest body)
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))
   (defmacro named-lambda (name args &rest body)
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))

-         (set ,x "fname" ,name)
+         (oset ,x "fname" ,name)

          ,x)))
 
   (defmacro %defun (name args &rest body)
          ,x)))
 
   (defmacro %defun (name args &rest body)

@@ -55,74 +56,77 @@
        (eval-when-compile
          (%compile-defun ',name))
        (fsetq ,name (named-lambda ,(symbol-name name) ,args
        (eval-when-compile
          (%compile-defun ',name))
        (fsetq ,name (named-lambda ,(symbol-name name) ,args

-                      ,@body))))
+                      (block ,name ,@body)))))

 
   (defmacro defun (name args &rest body)
     `(%defun ,name ,args ,@body))
 
 
   (defmacro defun (name args &rest body)
     `(%defun ,name ,args ,@body))
 

- (defvar *package* (new))
-
- (defvar nil (make-symbol "NIL"))
- (set *package* "NIL" nil)
-
- (defvar t (make-symbol "T"))
- (set *package* "T" t)
-
- (defun null (x)
-   (eq x nil))
-
- (defun internp (name)
-   (in name *package*))
-
- (defun intern (name)
-   (if (internp name)
-       (get *package* name)
-       (set *package* name (make-symbol name))))
-
- (defun find-symbol (name)
-   (get *package* name))
-
- (defvar *gensym-counter* 0)
- (defun gensym (&optional (prefix "G"))
-   (setq *gensym-counter* (+ *gensym-counter* 1))
-   (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
-
- ;; 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 1- (x) (- x 1))
- (defun zerop (x) (= x 0))
- (defun truncate (x y) (floor (/ x y)))
-
- (defun eql (x y) (eq x y))
-
- (defun not (x) (if x nil t))
-
- (defun cons (x y ) (cons x y))
- (defun consp (x) (consp x))
- (defun car (x) (car x))
- (defun cdr (x) (cdr x))
- (defun caar (x) (car (car x)))
- (defun cadr (x) (car (cdr x)))
- (defun cdar (x) (cdr (car x)))
- (defun cddr (x) (cdr (cdr x)))
- (defun caddr (x) (car (cdr (cdr x))))
- (defun cdddr (x) (cdr (cdr (cdr x))))
- (defun cadddr (x) (car (cdr (cdr (cdr x)))))
- (defun first (x) (car x))
- (defun second (x) (cadr x))
- (defun third (x) (caddr x))
- (defun fourth (x) (cadddr x))
-
- (defun list (&rest args) args)
- (defun atom (x)
-   (not (consp x)))
-
- ;; Basic macros
+  (defvar *package* (new))
+
+  (defvar nil 'nil)
+  (defvar t 't)
+
+  (defun null (x)
+    (eq x nil))
+
+  (defmacro return (&optional value)
+    `(return-from nil ,value))
+
+  (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))
+    (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
+
+  ;; 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 1- (x) (- x 1))
+  (defun zerop (x) (= x 0))
+  (defun truncate (x y) (floor (/ x y)))
+
+  (defun eql (x y) (eq x y))
+
+  (defun not (x) (if x nil t))
+
+  (defun cons (x y ) (cons x y))
+  (defun consp (x) (consp x))
+  (defun car (x) (car x))
+  (defun cdr (x) (cdr x))
+  (defun caar (x) (car (car x)))
+  (defun cadr (x) (car (cdr x)))
+  (defun cdar (x) (cdr (car x)))
+  (defun cddr (x) (cdr (cdr x)))
+  (defun caddr (x) (car (cdr (cdr x))))
+  (defun cdddr (x) (cdr (cdr (cdr x))))
+  (defun cadddr (x) (car (cdr (cdr (cdr x)))))
+  (defun first (x) (car x))
+  (defun second (x) (cadr x))
+  (defun third (x) (caddr x))
+  (defun fourth (x) (cadddr x))
+
+  (defun list (&rest args) args)
+  (defun atom (x)
+    (not (consp x)))
+
+  ;; Basic macros

 
   (defmacro incf (x &optional (delta 1))
     `(setq ,x (+ ,x ,delta)))
 
   (defmacro incf (x &optional (delta 1))
     `(setq ,x (+ ,x ,delta)))

@@ -130,56 +134,59 @@
   (defmacro decf (x &optional (delta 1))
     `(setq ,x (- ,x ,delta)))
 
   (defmacro decf (x &optional (delta 1))
     `(setq ,x (- ,x ,delta)))
 

- (defmacro push (x place)
-   `(setq ,place (cons ,x ,place)))
-
- (defmacro when (condition &body body)
-   `(if ,condition (progn ,@body) nil))
-
- (defmacro unless (condition &body body)
-   `(if ,condition nil (progn ,@body)))
-
- (defmacro dolist (iter &body body)
-   (let ((var (first iter))
-         (g!list (gensym)))
-     `(let ((,g!list ,(second iter))
-            (,var nil))
-        (while ,g!list
-          (setq ,var (car ,g!list))
-          ,@body
-          (setq ,g!list (cdr ,g!list))))))
-
- (defmacro dotimes (iter &body body)
-   (let ((g!to (gensym))
-         (var (first iter))
-         (to (second iter))
-         (result (third iter)))
-     `(let ((,var 0)
-            (,g!to ,to))
-        (while (< ,var ,g!to)
-          ,@body
-          (incf ,var))
-        ,result)))
-
- (defmacro cond (&rest clausules)
-   (if (null clausules)
-       nil
-       (if (eq (caar clausules) t)
-           `(progn ,@(cdar clausules))
-           `(if ,(caar clausules)
-                (progn ,@(cdar clausules))
-                (cond ,@(cdr clausules))))))
-
- (defmacro case (form &rest clausules)
-   (let ((!form (gensym)))
-     `(let ((,!form ,form))
-        (cond
-          ,@(mapcar (lambda (clausule)
-                      (if (eq (car clausule) t)
-                          clausule
-                          `((eql ,!form ,(car clausule))
-                            ,@(cdr clausule))))
-                    clausules)))))
+  (defmacro push (x place)
+    `(setq ,place (cons ,x ,place)))
+
+  (defmacro when (condition &body body)
+    `(if ,condition (progn ,@body) nil))
+
+  (defmacro unless (condition &body body)
+    `(if ,condition nil (progn ,@body)))
+
+  (defmacro dolist (iter &body body)
+    (let ((var (first iter))
+          (g!list (gensym)))
+      `(block nil
+         (let ((,g!list ,(second iter))
+               (,var nil))
+           (%while ,g!list
+                   (setq ,var (car ,g!list))
+                   (tagbody ,@body)
+                   (setq ,g!list (cdr ,g!list)))
+           ,(third iter)))))
+
+  (defmacro dotimes (iter &body body)
+    (let ((g!to (gensym))
+          (var (first iter))
+          (to (second iter))
+          (result (third iter)))
+      `(block nil
+         (let ((,var 0)
+               (,g!to ,to))
+           (%while (< ,var ,g!to)
+                   (tagbody ,@body)
+                   (incf ,var))
+           ,result))))
+
+  (defmacro cond (&rest clausules)
+    (if (null clausules)
+        nil
+        (if (eq (caar clausules) t)
+            `(progn ,@(cdar clausules))
+            `(if ,(caar clausules)
+                 (progn ,@(cdar clausules))
+                 (cond ,@(cdr clausules))))))
+
+  (defmacro case (form &rest clausules)
+    (let ((!form (gensym)))
+      `(let ((,!form ,form))
+         (cond
+           ,@(mapcar (lambda (clausule)
+                       (if (eq (car clausule) t)
+                           clausule
+                           `((eql ,!form ',(car clausule))
+                             ,@(cdr clausule))))
+                     clausules)))))

 
   (defmacro ecase (form &rest clausules)
     `(case ,form
 
   (defmacro ecase (form &rest clausules)
     `(case ,form

@@ -210,11 +217,18 @@
          `(let ((,g ,(car forms)))
             (if ,g ,g (or ,@(cdr forms))))))))
 
          `(let ((,g ,(car forms)))
             (if ,g ,g (or ,@(cdr forms))))))))
 

-   (defmacro prog1 (form &body body)
-   (let ((value (gensym)))
-     `(let ((,value ,form))
-        ,@body
-        ,value))))
+  (defmacro prog1 (form &body body)
+    (let ((value (gensym)))
+      `(let ((,value ,form))
+         ,@body
+         ,value)))
+
+  (defmacro prog2 (form1 result &body body)
+    `(prog1 (progn ,form1 ,result) ,@body))
+
+
+
+)

 
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.

@@ -254,13 +268,14 @@
   (defun append (&rest lists)
     (!reduce #'append-two lists '()))
 
   (defun append (&rest lists)
     (!reduce #'append-two lists '()))
 

-  (defun reverse-aux (list acc)
-    (if (null list)
-        acc
-        (reverse-aux (cdr list) (cons (car list) acc))))
+  (defun revappend (list1 list2)
+    (while list1
+      (push (car list1) list2)
+      (setq list1 (cdr list1)))
+    list2)

 
   (defun reverse (list)
 
   (defun reverse (list)

-    (reverse-aux list '()))
+    (revappend list '()))

 
   (defun list-length (list)
     (let ((l 0))
 
   (defun list-length (list)
     (let ((l 0))

@@ -283,6 +298,11 @@
         (cons (funcall func (car list))
               (mapcar func (cdr list)))))
 
         (cons (funcall func (car list))
               (mapcar func (cdr list)))))
 

+  (defun identity (x) x)
+
+  (defun copy-list (x)
+    (mapcar #'identity x))
+

   (defun code-char (x) x)
   (defun char-code (x) x)
   (defun char= (x y) (= x y))
   (defun code-char (x) x)
   (defun char-code (x) x)
   (defun char= (x y) (= x y))

@@ -296,29 +316,29 @@
   (defun listp (x)
     (or (consp x) (null x)))
 
   (defun listp (x)
     (or (consp x) (null x)))
 

+  (defun nthcdr (n list)
+    (while (and (plusp n) list)
+      (setq n (1- n))
+      (setq list (cdr list)))
+    list)
+

   (defun nth (n list)
   (defun nth (n list)

-    (cond
-      ((null list) list)
-      ((zerop n) (car list))
-      (t (nth (1- n) (cdr list)))))
+    (car (nthcdr n list)))

 
   (defun last (x)
 
   (defun last (x)

-    (if (consp (cdr x))
-        (last (cdr x))
-        x))
+    (while (consp (cdr x))
+      (setq x (cdr x)))
+    x)

 
   (defun butlast (x)
     (and (consp (cdr x))
          (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)
 
   (defun butlast (x)
     (and (consp (cdr x))
          (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)

-    (cond
-      ((null list)
-       nil)
-      ((eql x (car list))
-       list)
-      (t
-       (member x (cdr list)))))
+    (while list
+      (when (eql x (car list))
+        (return list))
+      (setq list (cdr list))))

 
   (defun remove (x list)
     (cond
 
   (defun remove (x list)
     (cond

@@ -354,12 +374,12 @@
 
   (defun subseq (seq a &optional b)
     (cond
 
   (defun subseq (seq a &optional b)
     (cond

-     ((stringp seq)
-      (if b
-          (slice seq a b)
-          (slice seq a)))
-     (t
-      (error "Unsupported argument."))))
+      ((stringp seq)
+       (if b
+           (slice seq a b)
+           (slice seq a)))
+      (t
+       (error "Unsupported argument."))))

 
   (defun parse-integer (string)
     (let ((value 0)
 
   (defun parse-integer (string)
     (let ((value 0)

@@ -370,25 +390,46 @@
         (incf index))
       value))
 
         (incf index))
       value))
 

-  (defun every (function seq)
-    ;; string
-    (let ((ret t)
-          (index 0)
-          (size (length seq)))
-      (while (and ret (< index size))
-        (unless (funcall function (char seq index))
-          (setq ret nil))
-        (incf index))
-      ret))
+  (defun some (function seq)
+    (cond
+      ((stringp seq)
+       (let ((index 0)
+             (size (length seq)))
+         (while (< index size)
+           (when (funcall function (char seq index))
+             (return-from some t))
+           (incf index))
+         nil))
+      ((listp seq)
+       (dolist (x seq nil)
+         (when (funcall function x)
+           (return t))))
+      (t
+       (error "Unknown sequence."))))

 
 

-  (defun assoc (x alist)
+  (defun every (function seq)

     (cond
     (cond

-      ((null alist)
-       nil)
-      ((eql x (caar alist))
-       (car alist))
+      ((stringp seq)
+       (let ((index 0)
+             (size (length seq)))
+         (while (< index size)
+           (unless (funcall function (char seq index))
+             (return-from every nil))
+           (incf index))
+         t))
+      ((listp seq)
+       (dolist (x seq t)
+         (unless (funcall function x)
+           (return))))

       (t
       (t

-       (assoc x (cdr alist)))))
+       (error "Unknown sequence."))))
+
+  (defun assoc (x alist)
+    (while alist
+      (if (eql x (caar alist))
+          (return)
+          (setq alist (cdr alist))))
+    (car alist))

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

@@ -426,6 +467,9 @@
 (defun concat (&rest strs)
   (!reduce #'concat-two strs ""))
 
 (defun concat (&rest strs)
   (!reduce #'concat-two strs ""))
 

+(defmacro concatf (variable &body form)
+  `(setq ,variable (concat ,variable (progn ,@form))))
+

 ;;; Concatenate a list of strings, with a separator
 (defun join (list &optional (separator ""))
   (cond
 ;;; Concatenate a list of strings, with a separator
 (defun join (list &optional (separator ""))
   (cond

@@ -443,25 +487,42 @@
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 

-;;; Like CONCAT, but prefix each line with four spaces.
+(defun mapconcat (func list)
+  (join (mapcar func list)))
+
+;;; 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.
+
+#+ecmalisp

 (defun indent (&rest string)
 (defun indent (&rest string)

-  (let ((input (!reduce #'concat string "")))
+  (let ((input (join string)))

     (let ((output "")
           (index 0)
           (size (length input)))
     (let ((output "")
           (index 0)
           (size (length input)))

-      (when (plusp size)
-        (setq output "    "))
+      (when (plusp (length input)) (concatf output "    "))

       (while (< index size)
       (while (< index size)

-        (setq output
-              (concat output
-                      (if (and (char= (char input index) #\newline)
-                               (< index (1- size))
-                               (not (char= (char input (1+ index)) #\newline)))
-                          (concat (string #\newline) "    ")
-                          (subseq input index (1+ index)))))
+        (let ((str
+               (if (and (char= (char input index) #\newline)
+                        (< index (1- size))
+                        (not (char= (char input (1+ index)) #\newline)))
+                   (concat (string #\newline) "    ")
+                   (string (char input index)))))
+          (concatf output str))

         (incf index))
       output)))
 
         (incf index))
       output)))
 

+#+common-lisp
+(defun indent (&rest string)
+  (with-output-to-string (*standard-output*)
+    (with-input-from-string (input (join string))
+      (loop
+         for line = (read-line input nil)
+         while line
+         do (write-string "    ")
+         do (write-line line)))))
+
+

 (defun integer-to-string (x)
   (cond
     ((zerop x)
 (defun integer-to-string (x)
   (cond
     ((zerop x)

@@ -476,27 +537,42 @@
        (join (mapcar (lambda (d) (string (char "0123456789" d)))
                      digits))))))
 
        (join (mapcar (lambda (d) (string (char "0123456789" d)))
                      digits))))))
 

+
+;;; Wrap X with a Javascript code to convert the result from
+;;; Javascript generalized booleans to T or NIL.
+(defun js!bool (x)
+  (concat "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
+
+;;; Concatenate the arguments and wrap them with a self-calling
+;;; Javascript anonymous function. It is used to make some Javascript
+;;; statements valid expressions and provide a private scope as well.
+;;; It could be defined as function, but we could do some
+;;; preprocessing in the future.
+(defmacro js!selfcall (&body body)
+  `(concat "(function(){" *newline* (indent ,@body) "})()"))
+
+

 ;;; Printer
 
 #+ecmalisp
 (progn
 ;;; Printer
 
 #+ecmalisp
 (progn

-  (defun print-to-string (form)
+  (defun prin1-to-string (form)

     (cond
       ((symbolp form) (symbol-name form))
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
     (cond
       ((symbolp form) (symbol-name form))
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)

-       (let ((name (get form "fname")))
+       (let ((name (oget form "fname")))

          (if name
              (concat "#<FUNCTION " name ">")
              (concat "#<FUNCTION>"))))
       ((listp form)
        (concat "("
          (if name
              (concat "#<FUNCTION " name ">")
              (concat "#<FUNCTION>"))))
       ((listp form)
        (concat "("

-               (join-trailing (mapcar #'print-to-string (butlast form)) " ")
+               (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")

                (let ((last (last form)))
                  (if (null (cdr last))
                (let ((last (last form)))
                  (if (null (cdr last))

-                     (print-to-string (car last))
-                     (concat (print-to-string (car last)) " . " (print-to-string (cdr last)))))
+                     (prin1-to-string (car last))
+                     (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))

                ")"))))
 
   (defun write-line (x)
                ")"))))
 
   (defun write-line (x)

@@ -505,7 +581,8 @@
     x)
 
   (defun print (x)
     x)
 
   (defun print (x)

-    (write-line (print-to-string x))))
+    (write-line (prin1-to-string x))
+    x))

 
 
 ;;;; Reader
 
 
 ;;;; Reader

@@ -658,11 +735,8 @@
 
 (defvar *compilation-unit-checks* '())
 
 
 (defvar *compilation-unit-checks* '())
 

-(defvar *env* '())
-(defvar *fenv* '())
-
-(defun make-binding (name type js declared)
-  (list name type js declared))
+(defun make-binding (name type translation declared)
+  (list name type translation declared))

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

@@ -672,19 +746,58 @@
 (defun mark-binding-as-declared (b)
   (setcar (cdddr b) t))
 
 (defun mark-binding-as-declared (b)
   (setcar (cdddr b) t))
 

+(defun make-lexenv ()
+  (list nil nil nil nil))
+
+(defun copy-lexenv (lexenv)
+  (copy-list lexenv))
+
+(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))))))
+
+(defun extend-lexenv (bindings lexenv namespace)
+  (let ((env (copy-lexenv lexenv)))
+    (dolist (binding (reverse bindings) env)
+      (push-to-lexenv binding env namespace))))
+
+(defun lookup-in-lexenv (name lexenv namespace)
+  (assoc name (ecase namespace
+                (variable (first lexenv))
+                (function (second lexenv))
+                (block (third lexenv))
+                (gotag (fourth 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*))))
 
 (defun lookup-variable (symbol env)
 (defvar *variable-counter* 0)
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defun lookup-variable (symbol env)

-  (or (assoc symbol env)
-      (assoc symbol *env*)
+  (or (lookup-in-lexenv symbol env 'variable)
+      (lookup-in-lexenv symbol *environment* 'variable)

       (let ((name (symbol-name symbol))
       (let ((name (symbol-name symbol))

-            (binding (make-binding symbol 'variable (gvarname symbol) nil)))
-        (push binding *env*)
+            (binding (make-binding symbol 'special-variable (gvarname symbol) nil)))
+        (push-to-lexenv binding *environment* 'variable)

         (push (lambda ()
         (push (lambda ()

-                (unless (binding-declared (assoc symbol *env*))
-                  (error (concat "Undefined variable `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'variable)))
+                 (unless (binding-declared b)
+                     (error (concat "Undefined variable `" name "'")))))

               *compilation-unit-checks*)
         binding)))
 
               *compilation-unit-checks*)
         binding)))
 

@@ -692,25 +805,26 @@
   (binding-translation (lookup-variable symbol env)))
 
 (defun extend-local-env (args env)
   (binding-translation (lookup-variable symbol env)))
 
 (defun extend-local-env (args env)

-  (append (mapcar (lambda (symbol)
-                    (make-binding symbol 'variable (gvarname symbol) t))
-                  args)
-          env))
+  (let ((new (copy-lexenv env)))
+    (dolist (symbol args new)
+      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))
+        (push-to-lexenv b new 'variable)))))

 
 (defvar *function-counter* 0)
 (defun lookup-function (symbol env)
 
 (defvar *function-counter* 0)
 (defun lookup-function (symbol env)

-  (or (assoc symbol env)
-      (assoc symbol *fenv*)
+  (or (lookup-in-lexenv symbol env 'function)
+      (lookup-in-lexenv symbol *environment* 'function)

       (let ((name (symbol-name symbol))
             (binding
              (make-binding symbol
                            'function
                            (concat "f" (integer-to-string (incf *function-counter*)))
                            nil)))
       (let ((name (symbol-name symbol))
             (binding
              (make-binding symbol
                            'function
                            (concat "f" (integer-to-string (incf *function-counter*)))
                            nil)))

-        (push binding *fenv*)
+        (push-to-lexenv binding *environment* 'function)

         (push (lambda ()
         (push (lambda ()

-                (unless (binding-declared (assoc symbol *fenv*))
-                  (error (concat "Undefined function `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'function)))
+                 (unless (binding-declared b)
+                   (error (concat "Undefined function `" name "'")))))

               *compilation-unit-checks*)
         binding)))
 
               *compilation-unit-checks*)
         binding)))
 

@@ -720,43 +834,43 @@
 (defvar *toplevel-compilations* nil)
 
 (defun %compile-defvar (name)
 (defvar *toplevel-compilations* nil)
 
 (defun %compile-defvar (name)

-  (let ((b (lookup-variable name *env*)))
+  (let ((b (lookup-variable name *environment*)))

     (mark-binding-as-declared b)
     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 
 (defun %compile-defun (name)
     (mark-binding-as-declared b)
     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 
 (defun %compile-defun (name)

-  (let ((b (lookup-function name *fenv*)))
+  (let ((b (lookup-function name *environment*)))

     (mark-binding-as-declared b)
     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 
 (defun %compile-defmacro (name lambda)
     (mark-binding-as-declared b)
     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 
 (defun %compile-defmacro (name lambda)

-  (push (make-binding name 'macro lambda t) *fenv*))
+  (push-to-lexenv (make-binding name 'macro lambda t) *environment* 'function))

 
 (defvar *compilations* nil)
 
 
 (defvar *compilations* nil)
 

-(defun ls-compile-block (sexps env fenv)
+(defun ls-compile-block (sexps env)

   (join-trailing
    (remove-if (lambda (x)
                 (or (null x)
                     (and (stringp x)
                          (zerop (length x)))))
   (join-trailing
    (remove-if (lambda (x)
                 (or (null x)
                     (and (stringp x)
                          (zerop (length x)))))

-              (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
+              (mapcar (lambda (x) (ls-compile x env))  sexps))

    (concat ";" *newline*)))
 
 (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.
    (concat ";" *newline*)))
 
 (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 fenv ,@args) ,@body))
+  `(push (list ',name (lambda (env ,@args) (block ,name ,@body)))

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

-          (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
+          (ls-compile condition env) " !== " (ls-compile nil)

           " ? "
           " ? "

-          (ls-compile true env fenv)
+          (ls-compile true env)

           " : "
           " : "

-          (ls-compile false env fenv)
+          (ls-compile false env)

           ")"))
 
 
           ")"))
 
 

@@ -824,7 +938,7 @@
                                                  (integer-to-string (+ idx n-required-arguments)) ":" *newline*
                                                  (lookup-variable-translation (car arg) new-env)
                                                  "="
                                                  (integer-to-string (+ idx n-required-arguments)) ":" *newline*
                                                  (lookup-variable-translation (car arg) new-env)
                                                  "="

-                                                 (ls-compile (cadr arg) new-env fenv)
+                                                 (ls-compile (cadr arg) new-env)

                                                  ";" *newline*)
                                          cases)
                                    (incf idx)))
                                                  ";" *newline*)
                                          cases)
                                    (incf idx)))

@@ -835,7 +949,7 @@
                ;; &rest/&body argument
                (if rest-argument
                    (let ((js!rest (lookup-variable-translation rest-argument new-env)))
                ;; &rest/&body argument
                (if rest-argument
                    (let ((js!rest (lookup-variable-translation rest-argument new-env)))

-                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
+                     (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*
                              "for (var i = arguments.length-1; i>="
                              (integer-to-string (+ n-required-arguments n-optional-arguments))
                              "; i--)" *newline*

@@ -844,19 +958,27 @@
                                      *newline*))
                    "")
                ;; Body
                                      *newline*))
                    "")
                ;; Body

-               (concat (ls-compile-block (butlast body) new-env fenv)
-                       "return " (ls-compile (car (last body)) new-env fenv) ";")) *newline*
+               (concat (ls-compile-block (butlast body) new-env)
+                       "return " (ls-compile (car (last body)) new-env) ";")) *newline*

               "})"))))
 
 (define-compilation fsetq (var val)
               "})"))))
 
 (define-compilation fsetq (var val)

-  (concat (lookup-function-translation var fenv)
+  (concat (lookup-function-translation var env)

           " = "
           " = "

-          (ls-compile val env fenv)))
+          (ls-compile val env)))

 
 (define-compilation setq (var val)
 
 (define-compilation setq (var val)

-  (concat (lookup-variable-translation var env)
-          " = "
-           (ls-compile val env fenv)))
+  (let ((b (lookup-variable var env)))
+    (ecase (binding-type b)
+      (lexical-variable (concat (binding-translation b) " = " (ls-compile val env)))
+      (special-variable (ls-compile `(set ',var ,val) env)))))
+
+;;; FFI Variable accessors
+(define-compilation js-vref (var)
+  var)
+(define-compilation js-vset (var val)
+  (concat "(" var " = " (ls-compile val env) ")"))
+

 
 ;;; Literals
 (defun escape-string (string)
 
 ;;; Literals
 (defun escape-string (string)

@@ -874,40 +996,56 @@
       (incf index))
     output))
 
       (incf index))
     output))
 

-(defun literal->js (sexp)
+
+(defvar *literal-symbols* nil)
+(defvar *literal-counter* 0)
+
+(defun genlit ()
+  (concat "l" (integer-to-string (incf *literal-counter*))))
+
+(defun literal (sexp &optional recursive)

   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))

-    ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
-    ((consp sexp) (concat "{car: "
-                          (literal->js (car sexp))
-                          ", cdr: "
-                          (literal->js (cdr sexp)) "}"))))
-
-(defvar *literal-counter* 0)
-(defun literal (form)
-  (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
-    (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
-    var))
+    ((symbolp sexp)
+     #+common-lisp
+     (or (cdr (assoc sexp *literal-symbols*))
+        (let ((v (genlit))
+              (s (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
+          (push (cons sexp v) *literal-symbols*)
+          (push (concat "var " v " = " s) *toplevel-compilations*)
+          v))
+     #+ecmalisp
+     (let ((v (genlit)))
+       (push (concat "var " v " = " (ls-compile `(intern ,(symbol-name sexp))))
+             *toplevel-compilations*)
+       v))
+    ((consp sexp)
+     (let ((c (concat "{car: " (literal (car sexp) t) ", "
+                     "cdr: " (literal (cdr sexp) t) "}")))
+       (if recursive
+          c
+          (let ((v (genlit)))
+            (push (concat "var " v " = " c) *toplevel-compilations*)
+            v))))))

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

-(define-compilation while (pred &rest body)
-  (concat "(function(){" *newline*
-          (indent "while("
-                  (ls-compile pred env fenv)
-                  " !== "
-                  (ls-compile nil nil nil) "){" *newline*
-                  (indent (ls-compile-block body env fenv)))
-          "}})()"))
+
+(define-compilation %while (pred &rest body)
+  (js!selfcall
+    "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*
+    (indent (ls-compile-block body env))
+    "}"
+    "return " (ls-compile nil) ";" *newline*))

 
 (define-compilation function (x)
   (cond
     ((and (listp x) (eq (car x) 'lambda))
 
 (define-compilation function (x)
   (cond
     ((and (listp x) (eq (car x) 'lambda))

-     (ls-compile x env fenv))
+     (ls-compile x env))

     ((symbolp x)
     ((symbolp x)

-     (lookup-function-translation x fenv))))
+     (lookup-function-translation x env))))

 
 (define-compilation eval-when-compile (&rest body)
   (eval (cons 'progn body))
 
 (define-compilation eval-when-compile (&rest body)
   (eval (cons 'progn body))

@@ -915,13 +1053,12 @@
 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args
 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args

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

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

-  (concat "(function(){" *newline*
-          (indent (ls-compile-block (butlast body) env fenv)
-                  "return " (ls-compile (car (last body)) env fenv) ";" *newline*)
-          "})()"))
+  (js!selfcall
+    (ls-compile-block (butlast body) env)
+    "return " (ls-compile (car (last body)) env) ";" *newline*))

 
 (define-compilation let (bindings &rest body)
   (let ((bindings (mapcar #'ensure-list bindings)))
 
 (define-compilation let (bindings &rest body)
   (let ((bindings (mapcar #'ensure-list bindings)))

@@ -934,14 +1071,153 @@
                               variables)
                       ",")
                 "){" *newline*
                               variables)
                       ",")
                 "){" *newline*

-                (indent (ls-compile-block (butlast body) new-env fenv)
-                        "return " (ls-compile (car (last body)) new-env fenv)
+                (indent (ls-compile-block (butlast body) new-env)
+                        "return " (ls-compile (car (last body)) new-env)

                         ";" *newline*)
                         ";" *newline*)

-                "})(" (join (mapcar (lambda (x) (ls-compile x env fenv))
+                "})(" (join (mapcar (lambda (x) (ls-compile x env))

                                     values)
                             ",")
                 ")")))))
 
                                     values)
                             ",")
                 ")")))))
 

+
+(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*))))
+
+(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) "'.")))))
+
+
+(define-compilation catch (id &rest body)
+  (js!selfcall
+    "var id = " (ls-compile id env) ";" *newline*
+    "try {" *newline*
+    (indent "return " (ls-compile `(progn ,@body))
+            ";" *newline*)
+    "}" *newline*
+    "catch (cf){" *newline*
+    "    if (cf.type == 'catch' && cf.id == id)" *newline*
+    "        return cf.value;" *newline*
+    "    else" *newline*
+    "        throw cf;" *newline*
+    "}" *newline*))
+
+(define-compilation throw (id &optional value)
+  (js!selfcall
+    "throw ({"
+    "type: 'catch', "
+    "id: " (ls-compile id env) ", "
+    "value: " (ls-compile value env) ", "
+    "message: 'Throw uncatched.'"
+    "})"))
+
+
+(defvar *tagbody-counter* 0)
+(defvar *go-tag-counter* 0)
+
+(defun go-tag-p (x)
+  (or (integerp x) (symbolp x)))
+
+(defun declare-tagbody-tags (env tbidx body)
+  (let ((bindings
+         (mapcar (lambda (label)
+                   (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
+                     (make-binding label 'gotag (list tbidx tagidx) t)))
+                 (remove-if-not #'go-tag-p body))))
+    (extend-lexenv bindings env '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)
+    (return-from tagbody (ls-compile `(progn ,@body nil) env)))
+  ;; 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))
+          initag)
+      (let ((b (lookup-in-lexenv (first body) env 'gotag)))
+        (setq initag (second (binding-translation b))))
+      (js!selfcall
+        "var tagbody_" tbidx " = " initag ";" *newline*
+        "tbloop:" *newline*
+        "while (true) {" *newline*
+        (indent "try {" *newline*
+                (indent (let ((content ""))
+                          (concat "switch(tagbody_" tbidx "){" *newline*
+                                  "case " initag ":" *newline*
+                                  (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*)))))
+                                  "default:" *newline*
+                                  "    break tbloop;" *newline*
+                                  "}" *newline*)))
+                "}" *newline*
+                "catch (jump) {" *newline*
+                "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
+                "        tagbody_" tbidx " = jump.label;" *newline*
+                "    else" *newline*
+                "        throw(jump);" *newline*
+                "}" *newline*)
+        "}" *newline*
+        "return " (ls-compile nil) ";" *newline*))))
+
+(define-compilation go (label)
+  (let ((b (lookup-in-lexenv label env 'gotag))
+        (n (cond
+             ((symbolp label) (symbol-name label))
+             ((integerp label) (integer-to-string label)))))
+    (if b
+        (js!selfcall
+          "throw ({"
+          "type: 'tagbody', "
+          "id: " (first (binding-translation b)) ", "
+          "label: " (second (binding-translation b)) ", "
+          "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*
+    (indent "ret = " (ls-compile form env) ";" *newline*)
+    "} finally {" *newline*
+    (indent (ls-compile-block clean-up env))
+    "}" *newline*
+    "return ret;" *newline*))
+
+

 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.
 (defun backquote-expand-1 (form)
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.
 (defun backquote-expand-1 (form)

@@ -981,30 +1257,25 @@
 
 (defmacro define-builtin (name args &body body)
   `(define-compilation ,name ,args
 
 (defmacro define-builtin (name args &body body)
   `(define-compilation ,name ,args

-     (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env fenv))) args)
+     (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env))) args)

        ,@body)))
 
        ,@body)))
 

-(defun compile-bool (x)
-  (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
-

 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
 (defmacro type-check (decls &body body)
 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
 (defmacro type-check (decls &body body)

-  `(concat "(function(){" *newline*
-           (indent ,@(mapcar (lambda (decl)
-                               `(concat "var " ,(first decl) " = " ,(third decl) ";" *newline*))
-                             decls)
-
-                   ,@(mapcar (lambda (decl)
-                               `(concat "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
-                                        (indent "throw 'The value ' + "
-                                                ,(first decl)
-                                                " + ' is not a type "
-                                                ,(second decl)
-                                                ".';"
-                                                *newline*)))
-                             decls)
-                   (concat "return " (progn ,@body) ";" *newline*))
-           "})()"))
+  `(js!selfcall
+     ,@(mapcar (lambda (decl)
+                   `(concat "var " ,(first decl) " = " ,(third decl) ";" *newline*))
+                 decls)
+     ,@(mapcar (lambda (decl)
+                 `(concat "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
+                          (indent "throw 'The value ' + "
+                                  ,(first decl)
+                                  " + ' is not a type "
+                                  ,(second decl)
+                                  ".';"
+                                  *newline*)))
+               decls)
+     (concat "return " (progn ,@body) ";" *newline*)))

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

@@ -1017,14 +1288,14 @@
 
 (define-builtin mod (x y) (num-op-num x "%" y))
 
 
 (define-builtin mod (x y) (num-op-num x "%" y))
 

-(define-builtin < (x y)  (compile-bool (num-op-num x "<" y)))
-(define-builtin > (x y)  (compile-bool (num-op-num x ">" y)))
-(define-builtin = (x y)  (compile-bool (num-op-num x "==" y)))
-(define-builtin <= (x y) (compile-bool (num-op-num x "<=" y)))
-(define-builtin >= (x y) (compile-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)))
+(define-builtin >= (x y) (js!bool (num-op-num x ">=" y)))

 
 (define-builtin numberp (x)
 
 (define-builtin numberp (x)

-  (compile-bool (concat "(typeof (" x ") == \"number\")")))
+  (js!bool (concat "(typeof (" x ") == \"number\")")))

 
 (define-builtin floor (x)
   (type-check (("x" "number" x))
 
 (define-builtin floor (x)
   (type-check (("x" "number" x))

@@ -1032,27 +1303,24 @@
 
 (define-builtin cons (x y) (concat "({car: " x ", cdr: " y "})"))
 (define-builtin consp (x)
 
 (define-builtin cons (x y) (concat "({car: " x ", cdr: " y "})"))
 (define-builtin consp (x)

-  (compile-bool
-   (concat "(function(){" *newline*
-           (indent "var tmp = " x ";" *newline*
-                   "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)
-           "})()")))
+  (js!bool
+   (js!selfcall
+     "var tmp = " x ";" *newline*
+     "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))

 
 (define-builtin car (x)
 
 (define-builtin car (x)

-  (concat "(function(){" *newline*
-          (indent "var tmp = " x ";" *newline*
-                  "return tmp === " (ls-compile nil nil nil)
-                  "? " (ls-compile nil nil nil)
-                  ": tmp.car;" *newline*)
-          "})()"))
+  (js!selfcall
+    "var tmp = " x ";" *newline*
+    "return tmp === " (ls-compile nil)
+    "? " (ls-compile nil)
+    ": tmp.car;" *newline*))

 
 (define-builtin cdr (x)
 
 (define-builtin cdr (x)

-  (concat "(function(){" *newline*
-          (indent "var tmp = " x ";" *newline*
-                  "return tmp === " (ls-compile nil nil nil) "? "
-                  (ls-compile nil nil nil)
-                  ": tmp.cdr;" *newline*)
-          "})()"))
+  (js!selfcall
+    "var tmp = " x ";" *newline*
+    "return tmp === " (ls-compile nil) "? "
+    (ls-compile nil)
+    ": tmp.cdr;" *newline*))

 
 (define-builtin setcar (x new)
   (type-check (("x" "object" x))
 
 (define-builtin setcar (x new)
   (type-check (("x" "object" x))

@@ -1063,11 +1331,10 @@
     (concat "(x.cdr = " new ")")))
 
 (define-builtin symbolp (x)
     (concat "(x.cdr = " new ")")))
 
 (define-builtin symbolp (x)

-  (compile-bool
-   (concat "(function(){" *newline*
-           (indent "var tmp = " x ";" *newline*
-                   "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)
-           "})()")))
+  (js!bool
+   (js!selfcall
+     "var tmp = " x ";" *newline*
+     "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))

 
 (define-builtin make-symbol (name)
   (type-check (("name" "string" name))
 
 (define-builtin make-symbol (name)
   (type-check (("name" "string" name))

@@ -1076,15 +1343,24 @@
 (define-builtin symbol-name (x)
   (concat "(" x ").name"))
 
 (define-builtin symbol-name (x)
   (concat "(" x ").name"))
 

-(define-builtin eq    (x y) (compile-bool (concat "(" x " === " y ")")))
-(define-builtin equal (x y) (compile-bool (concat "(" x  " == " y ")")))
+(define-builtin set (symbol value)
+  (concat "(" symbol ").value =" value))
+
+(define-builtin symbol-value (x)
+  (concat "(" x ").value"))
+
+(define-builtin symbol-function (x)
+  (concat "(" x ").function"))
+
+(define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
+(define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))

 
 (define-builtin string (x)
   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 
 (define-builtin stringp (x)
 
 (define-builtin string (x)
   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 
 (define-builtin stringp (x)

-  (compile-bool (concat "(typeof(" x ") == \"string\")")))
+  (js!bool (concat "(typeof(" x ") == \"string\")")))

 
 (define-builtin string-upcase (x)
   (type-check (("x" "string" x))
 
 (define-builtin string-upcase (x)
   (type-check (("x" "string" x))

@@ -1095,15 +1371,14 @@
     "x.length"))
 
 (define-compilation slice (string a &optional b)
     "x.length"))
 
 (define-compilation slice (string a &optional b)

-  (concat "(function(){" *newline*
-          (indent "var str = " (ls-compile string env fenv) ";" *newline*
-                  "var a = " (ls-compile a env fenv) ";" *newline*
-                  "var b;" *newline*
-                  (if b
-                      (concat "b = " (ls-compile b env fenv) ";" *newline*)
-                      "")
-                  "return str.slice(a,b);" *newline*)
-          "})()"))
+  (js!selfcall
+    "var str = " (ls-compile string env) ";" *newline*
+    "var a = " (ls-compile a env) ";" *newline*
+    "var b;" *newline*
+    (if b
+        (concat "b = " (ls-compile b env) ";" *newline*)
+        "")
+    "return str.slice(a,b);" *newline*))

 
 (define-builtin char (string index)
   (type-check (("string" "string" string)
 
 (define-builtin char (string index)
   (type-check (("string" "string" string)

@@ -1116,109 +1391,121 @@
     "string1.concat(string2)"))
 
 (define-compilation funcall (func &rest args)
     "string1.concat(string2)"))
 
 (define-compilation funcall (func &rest args)

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

           (join (mapcar (lambda (x)
           (join (mapcar (lambda (x)

-                          (ls-compile x env fenv))
+                          (ls-compile x env))

                         args)
                 ", ")
           ")"))
 
 (define-compilation apply (func &rest args)
   (if (null args)
                         args)
                 ", ")
           ")"))
 
 (define-compilation apply (func &rest args)
   (if (null args)

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

       (let ((args (butlast args))
             (last (car (last args))))
       (let ((args (butlast args))
             (last (car (last args))))

-        (concat "(function(){" *newline*
-                (indent "var f = " (ls-compile func env fenv) ";" *newline*
-                        "var args = [" (join (mapcar (lambda (x)
-                                                       (ls-compile x env fenv))
-                                                     args)
-                                             ", ")
-                        "];" *newline*
-                        "var tail = (" (ls-compile last env fenv) ");" *newline*
-                        (indent "while (tail != " (ls-compile nil env fenv) "){" *newline*
-                                "    args.push(tail.car);" *newline*
-                                "    tail = tail.cdr;" *newline*
-                                "}" *newline*
-                                "return f.apply(this, args);" *newline*)
-                        "})()")))))
+        (js!selfcall
+          "var f = " (ls-compile func env) ";" *newline*
+          "var args = [" (join (mapcar (lambda (x)
+                                         (ls-compile x env))
+                                       args)
+                               ", ")
+          "];" *newline*
+          "var tail = (" (ls-compile last env) ");" *newline*
+          "while (tail != " (ls-compile nil) "){" *newline*
+          "    args.push(tail.car);" *newline*
+          "    tail = tail.cdr;" *newline*
+          "}" *newline*
+          "return f.apply(this, args);" *newline*))))

 
 (define-builtin js-eval (string)
   (type-check (("string" "string" string))
     "eval.apply(window, [string])"))
 
 (define-builtin error (string)
 
 (define-builtin js-eval (string)
   (type-check (("string" "string" string))
     "eval.apply(window, [string])"))
 
 (define-builtin error (string)

-  (concat "(function (){ throw " string "; })()"))
+  (js!selfcall "throw " string ";" *newline*))

 
 (define-builtin new () "{}")
 
 
 (define-builtin new () "{}")
 

-(define-builtin get (object key)
-  (concat "(function(){" *newline*
-          (indent "var tmp = " "(" object ")[" key "];" *newline*
-                  "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;" *newline*)
-          "})()"))
+(define-builtin oget (object key)
+  (js!selfcall
+    "var tmp = " "(" object ")[" key "];" *newline*
+    "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))

 
 

-(define-builtin set (object key value)
+(define-builtin oset (object key value)

   (concat "((" object ")[" key "] = " value ")"))
 
 (define-builtin in (key object)
   (concat "((" object ")[" key "] = " value ")"))
 
 (define-builtin in (key object)

-  (compile-bool (concat "((" key ") in (" object "))")))
+  (js!bool (concat "((" key ") in (" object "))")))

 
 (define-builtin functionp (x)
 
 (define-builtin functionp (x)

-  (compile-bool (concat "(typeof " x " == 'function')")))
+  (js!bool (concat "(typeof " x " == 'function')")))

 
 (define-builtin write-string (x)
   (type-check (("x" "string" x))
     "lisp.write(x)"))
 
 (defun macrop (x)
 
 (define-builtin write-string (x)
   (type-check (("x" "string" x))
     "lisp.write(x)"))
 
 (defun macrop (x)

-  (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
+  (and (symbolp x) (eq (binding-type (lookup-function x *environment*)) 'macro)))

 
 

-(defun ls-macroexpand-1 (form env fenv)
+(defun ls-macroexpand-1 (form env)

   (if (macrop (car form))
   (if (macrop (car form))

-      (let ((binding (lookup-function (car form) *env*)))
+      (let ((binding (lookup-function (car form) *environment*)))

         (if (eq (binding-type binding) 'macro)
             (apply (eval (binding-translation binding)) (cdr form))
             form))
       form))
 
         (if (eq (binding-type binding) 'macro)
             (apply (eval (binding-translation binding)) (cdr form))
             form))
       form))
 

-(defun compile-funcall (function args env fenv)
+(defun compile-funcall (function args env)

   (cond
     ((symbolp function)
   (cond
     ((symbolp function)

-     (concat (lookup-function-translation function fenv)
+     (concat (lookup-function-translation function env)

              "("
              "("

-             (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
+             (join (mapcar (lambda (x) (ls-compile x env)) args)

                    ", ")
              ")"))
     ((and (listp function) (eq (car function) 'lambda))
                    ", ")
              ")"))
     ((and (listp function) (eq (car function) 'lambda))

-     (concat "(" (ls-compile function env fenv) ")("
-             (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
+     (concat "(" (ls-compile function env) ")("
+             (join (mapcar (lambda (x) (ls-compile x env)) args)

                    ", ")
              ")"))
     (t
      (error (concat "Invalid function designator " (symbol-name function))))))
 
                    ", ")
              ")"))
     (t
      (error (concat "Invalid function designator " (symbol-name function))))))
 

-(defun ls-compile (sexp env fenv)
+(defun ls-compile (sexp &optional (env (make-lexenv)))

   (cond
   (cond

-    ((symbolp sexp) (lookup-variable-translation sexp env))
+    ((symbolp sexp)
+     (let ((b (lookup-variable sexp env)))
+       (ecase (binding-type b)
+        (lexical-variable
+         (binding-translation b))
+        (special-variable
+          (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*))))
     ((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 fenv (cdr sexp)))
+           (apply comp env (cdr sexp)))

          (if (macrop (car sexp))
          (if (macrop (car sexp))

-             (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
-             (compile-funcall (car sexp) (cdr sexp) env fenv))))))
+             (ls-compile (ls-macroexpand-1 sexp env) env)
+             (compile-funcall (car sexp) (cdr sexp) env))))))

 
 (defun ls-compile-toplevel (sexp)
 
 (defun ls-compile-toplevel (sexp)

-  (setq *toplevel-compilations* nil)
-  (let ((code (ls-compile sexp nil nil)))
-    (prog1
-        (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
-                              *toplevel-compilations*))
-                code)
-      (setq *toplevel-compilations* nil))))
+  (cond
+    ((and (consp sexp) (eq (car sexp) 'progn))
+     (let ((subs (mapcar 'ls-compile-toplevel (cdr sexp))))
+       (join-trailing
+       (remove-if (lambda (s) (or (null s) (equal s "")))
+                  subs)
+       (concat ";" *newline*))))
+    (t
+     (setq *toplevel-compilations* nil)
+     (let ((code (ls-compile sexp)))
+       (prog1
+          (concat (join-trailing *toplevel-compilations*
+                                 (concat ";" *newline*))
+                  code)
+        (setq *toplevel-compilations* nil))))))

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

@@ -1227,46 +1514,47 @@
 
 #+ecmalisp
 (progn
 
 #+ecmalisp
 (progn

- (defmacro with-compilation-unit (&body body)
-   `(prog1
-        (progn
-          (setq *compilation-unit-checks* nil)
-          (setq *env* (remove-if-not #'binding-declared *env*))
-          (setq *fenv* (remove-if-not #'binding-declared *fenv*))
-          ,@body)
-      (dolist (check *compilation-unit-checks*)
-        (funcall check))))
-
- (defun eval (x)
-   (let ((code
-          (with-compilation-unit
-              (ls-compile-toplevel x))))
-     (js-eval code)))
-
- ;; Set the initial global environment to be equal to the host global
- ;; environment at this point of the compilation.
- (eval-when-compile
-   (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
-         (c2 (ls-compile `(setq *env* ',*env*) nil nil))
-         (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
-         (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
-         (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil))
-         (c6 (ls-compile `(setq *gensym-counter* ',*gensym-counter*) nil nil)))
-     (setq *toplevel-compilations*
-           (append *toplevel-compilations* (list c1 c2 c3 c4 c5 c6)))))
-
- (js-eval
-  (concat "var lisp = {};"
-          "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
-          "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
-          "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
-          "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
-          "lisp.evalString = function(str){" *newline*
-          "   return lisp.eval(lisp.read(str));" *newline*
-          "}" *newline*
-          "lisp.compileString = function(str){" *newline*
-          "   return lisp.compile(lisp.read(str));" *newline*
-          "}" *newline*)))
+  (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)
+    (let ((code
+           (with-compilation-unit
+               (ls-compile-toplevel x))))
+      (js-eval code)))
+
+  ;; Set the initial global environment to be equal to the host global
+  ;; environment at this point of the compilation.
+  (eval-when-compile
+    (let ((tmp (ls-compile
+                `(progn
+                   (setq *environment* ',*environment*)
+                   (setq *variable-counter* ',*variable-counter*)
+                   (setq *function-counter* ',*function-counter*)
+                   (setq *literal-counter* ',*literal-counter*)
+                   (setq *gensym-counter* ',*gensym-counter*)
+                   (setq *block-counter* ',*block-counter*)
+                  ,@(mapcar (lambda (s)
+                              `(oset *package* ,(symbol-name (car s))
+                                     (js-vref ,(cdr s))))
+                            *literal-symbols*)))))
+      (setq *toplevel-compilations*
+            (append *toplevel-compilations* (list tmp)))))
+
+  (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.evalString" (lambda (str) (eval (ls-read-from-string str))))
+  (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str)))))

 
 
 ;;; Finally, we provide a couple of functions to easily bootstrap
 
 
 ;;; Finally, we provide a couple of functions to easily bootstrap

@@ -1281,7 +1569,6 @@
         seq)))
 
   (defun ls-compile-file (filename output)
         seq)))
 
   (defun ls-compile-file (filename output)

-    (setq *env* nil *fenv* nil)

     (setq *compilation-unit-checks* nil)
     (with-open-file (out output :direction :output :if-exists :supersede)
       (let* ((source (read-whole-file filename))
     (setq *compilation-unit-checks* nil)
     (with-open-file (out output :direction :output :if-exists :supersede)
       (let* ((source (read-whole-file filename))

@@ -1297,8 +1584,11 @@
         (setq *compilation-unit-checks* nil))))
 
   (defun bootstrap ()
         (setq *compilation-unit-checks* nil))))
 
   (defun bootstrap ()

+    (setq *environment* (make-lexenv))
+    (setq *literal-symbols* nil)

     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0
     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0

-          *literal-counter* 0)
+          *literal-counter* 0
+          *block-counter* 0)

     (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))
     (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))