Support for docstrings and DOCUMENTATION function

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 7b8c39f..b072d9b 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -26,17 +26,15 @@
 (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))
-                                                                   args)
-                                                   ,@body)))
-                            ',name))))
+                       '(%lambda (name args &rest body)
+                         `(eval-when-compile
+                            (%compile-defmacro ',name
+                                               '(%lambda ,(mapcar (lambda (x)
+                                                                    (if (eq x '&body)
+                                                                        '&rest
+                                                                        x))
+                                                                  args)
+                                                 ,@body))))))

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

@@ -47,17 +45,26 @@
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 

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

     `(progn
        (unless (boundp ',name)
         (setq ,name ,value))
     `(progn
        (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))
 
        ',name))
 

+  (defmacro lambda (args &rest body)
+    (if (stringp (car body))
+        `(let ((func (%lambda ,args ,@(cdr body))))
+           (oset func "docstring" ,(car body))
+           func)
+        `(%lambda ,args ,@body)))
+

   (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)))

@@ -67,9 +74,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
+               ,@(when (stringp (car body)) `(,(car body)))
+               (block ,name
+                 ,@(if (stringp (car body))
+                       (cdr body)
+                       body))))

        ',name))
 
   (defvar *package* (new))
        ',name))
 
   (defvar *package* (new))

@@ -119,7 +129,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)))

@@ -438,8 +452,19 @@
 
   (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"))))
+  )

 
 ;;; The compiler offers some primitives and special forms which are
 ;;; not found in Common Lisp, for instance, while. So, we grow Common
 
 ;;; The compiler offers some primitives and special forms which are
 ;;; not found in Common Lisp, for instance, while. So, we grow Common

@@ -461,7 +486,10 @@
   (defun setcar (cons new)
     (setf (car cons) new))
   (defun setcdr (cons new)
   (defun setcar (cons new)
     (setf (car cons) new))
   (defun setcdr (cons new)

-    (setf (cdr cons) new)))
+    (setf (cdr cons) new))
+
+  (defmacro %lambda (lambda-list &rest body)
+    `(lambda ,lambda-list ,@body)))

 
 ;;; 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

@@ -750,7 +778,7 @@
 
 (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-value (b) (third b))

 (defun binding-declared (b)
   (and b (fourth b)))
 (defun mark-binding-as-declared (b)
 (defun binding-declared (b)
   (and b (fourth b)))
 (defun mark-binding-as-declared (b)

@@ -764,14 +792,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   (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)))
 
 (defun extend-lexenv (bindings lexenv namespace)
   (let ((env (copy-lexenv lexenv)))

@@ -785,6 +809,7 @@
                 (block (third lexenv))
                 (gotag (fourth lexenv)))))
 
                 (block (third lexenv))
                 (gotag (fourth lexenv)))))
 

+(defvar *global-environment* (make-lexenv))

 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()
 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()

@@ -798,11 +823,11 @@
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (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)
       (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))
         (push-to-lexenv b new 'variable)))))
     (dolist (symbol args new)
       (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))
         (push-to-lexenv b new 'variable)))))

@@ -825,29 +850,27 @@
 
 (defvar *compilations* nil)
 
 
 (defvar *compilations* nil)
 

-(defun ls-compile-block (sexps env)
-  (join-trailing
-   (remove-if #'null-or-empty-p
-              (mapcar (lambda (x) (ls-compile x env)) sexps))
-   (concat ";" *newline*)))
+(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))) ";")
+      (join-trailing
+       (remove-if #'null-or-empty-p (mapcar #'ls-compile 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
 
 (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)
+          " : " (ls-compile false)

           ")"))
 
           ")"))
 

-

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

@@ -870,20 +893,18 @@
       (error "Bad lambda-list"))
     (car rest)))
 
       (error "Bad lambda-list"))
     (car rest)))
 

-(define-compilation lambda (lambda-list &rest body)
+(define-compilation %lambda (lambda-list &rest body)

   (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)))
     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
   (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)))
     (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)))
+          (*environment* (extend-local-env
+                          (append (ensure-list rest-argument)
+                                  required-arguments
+                                  optional-arguments))))

       (concat "(function ("
       (concat "(function ("

-              (join (mapcar (lambda (x)
-                              (translate-variable x new-env))
+              (join (mapcar #'translate-variable

                             (append required-arguments optional-arguments))
                     ",")
               "){" *newline*
                             (append required-arguments optional-arguments))
                     ",")
               "){" *newline*

@@ -910,44 +931,43 @@
                                  (let ((arg (nth idx optional-and-defaults)))
                                    (push (concat "case "
                                                  (integer-to-string (+ idx n-required-arguments)) ":" *newline*
                                  (let ((arg (nth idx optional-and-defaults)))
                                    (push (concat "case "
                                                  (integer-to-string (+ idx n-required-arguments)) ":" *newline*

-                                                 (translate-variable (car arg) new-env)
+                                                 (translate-variable (car arg))

                                                  "="
                                                  "="

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

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

-                                    (push (concat "default: break;" *newline*) cases)
-                                    (join (reverse cases))))
+                               (push (concat "default: break;" *newline*) cases)
+                               (join (reverse cases))))

                            "}" *newline*)
                    "")
                ;; &rest/&body argument
                (if rest-argument
                            "}" *newline*)
                    "")
                ;; &rest/&body argument
                (if rest-argument

-                   (let ((js!rest (translate-variable rest-argument new-env)))
+                   (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 (+ n-required-arguments n-optional-arguments))
                              "; i--)" *newline*
                              (indent js!rest " = "
                                      "{car: arguments[i], cdr: ") js!rest "};"
                      (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*))
+                             *newline*))

                    "")
                ;; Body
                    "")
                ;; Body

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

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

-  (let ((b (lookup-in-lexenv var env 'variable)))
+  (let ((b (lookup-in-lexenv var *environment* 'variable)))

     (if (eq (binding-type b) 'lexical-variable)
     (if (eq (binding-type b) 'lexical-variable)

-        (concat (binding-translation b) " = " (ls-compile val env))
-        (ls-compile `(set ',var ,val) env))))
+        (concat (binding-value b) " = " (ls-compile val))
+        (ls-compile `(set ',var ,val)))))

 
 ;;; 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

@@ -997,23 +1017,19 @@
 (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))
+     (ls-compile x))

     ((symbolp x)
     ((symbolp x)

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

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

@@ -1021,13 +1037,10 @@
 
 (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*))
-
+  (js!selfcall (ls-compile-block body t)))

 
 (defun dynamic-binding-wrapper (bindings body)
   (if (null bindings)
 
 (defun dynamic-binding-wrapper (bindings body)
   (if (null bindings)

@@ -1060,7 +1073,8 @@
   (let ((bindings (mapcar #'ensure-list bindings)))
     (let ((variables (mapcar #'first bindings))
           (values    (mapcar #'second bindings)))
   (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))
+      (let ((cvalues (mapcar #'ls-compile values))
+            (*environment* (extend-local-env (remove-if #'boundp variables)))

             (dynamic-bindings))
         (concat "(function("
                 (join (mapcar (lambda (x)
             (dynamic-bindings))
         (concat "(function("
                 (join (mapcar (lambda (x)

@@ -1068,19 +1082,13 @@
                                     (let ((v (gvarname x)))
                                       (push (cons x v) dynamic-bindings)
                                       v)
                                     (let ((v (gvarname x)))
                                       (push (cons x v) dynamic-bindings)
                                       v)

-                                    (translate-variable x new-env)))
+                                    (translate-variable x)))

                               variables)
                       ",")
                 "){" *newline*
                               variables)
                       ",")
                 "){" *newline*

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

                   (indent (dynamic-binding-wrapper dynamic-bindings body)))
                   (indent (dynamic-binding-wrapper dynamic-bindings body)))

-                "})(" (join (mapcar (lambda (x) (ls-compile x env))
-                                    values)
-                            ",")
-                ")")))))
+                "})(" (join cvalues ",") ")")))))

 
 
 (defvar *block-counter* 0)
 
 
 (defvar *block-counter* 0)

@@ -1090,9 +1098,8 @@
     (let ((b (make-binding name 'block tr t)))
       (js!selfcall
         "try {" *newline*
     (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*)
+        (let ((*environment* (extend-lexenv (list b) *environment* 'block)))
+          (indent "return " (ls-compile `(progn ,@body)) ";" *newline*))

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

@@ -1102,13 +1109,13 @@
         "}" *newline*))))
 
 (define-compilation return-from (name &optional value)
         "}" *newline*))))
 
 (define-compilation return-from (name &optional value)

-  (let ((b (lookup-in-lexenv name env 'block)))
+  (let ((b (lookup-in-lexenv name *environment* 'block)))

     (if b
         (js!selfcall
           "throw ({"
           "type: 'block', "
     (if b
         (js!selfcall
           "throw ({"
           "type: 'block', "

-          "id: " (binding-translation b) ", "
-          "value: " (ls-compile value env) ", "
+          "id: " (binding-value b) ", "
+          "value: " (ls-compile value) ", "

           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")
         (error (concat "Unknown block `" (symbol-name name) "'.")))))
           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")
         (error (concat "Unknown block `" (symbol-name name) "'.")))))

@@ -1116,7 +1123,7 @@
 
 (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*
     (indent "return " (ls-compile `(progn ,@body))
             ";" *newline*)
     "try {" *newline*
     (indent "return " (ls-compile `(progn ,@body))
             ";" *newline*)

@@ -1132,8 +1139,8 @@
   (js!selfcall
     "throw ({"
     "type: 'catch', "
   (js!selfcall
     "throw ({"
     "type: 'catch', "

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

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

@@ -1144,29 +1151,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*))))
                      (make-binding label 'gotag (list tbidx tagidx) t)))
                  (remove-if-not #'go-tag-p 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)))
+    (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 +1185,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 +1202,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,8 +1210,8 @@
         (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 "'.")))))

@@ -1214,9 +1221,9 @@
   (js!selfcall
     "var ret = " (ls-compile nil) ";" *newline*
     "try {" *newline*
   (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*))
 

@@ -1261,7 +1268,7 @@
 (defmacro define-builtin (name args &body body)
   `(progn
      (define-compilation ,name ,args
 (defmacro define-builtin (name args &body body)
   `(progn
      (define-compilation ,name ,args

-       (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env))) 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.

@@ -1399,11 +1406,11 @@
 
 (define-compilation slice (string a &optional b)
   (js!selfcall
 
 (define-compilation slice (string a &optional b)
   (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*))
 

@@ -1418,26 +1425,22 @@
     "string1.concat(string2)"))
 
 (define-compilation funcall (func &rest args)
     "string1.concat(string2)"))
 
 (define-compilation funcall (func &rest args)

-  (concat "(" (ls-compile func env) ")("
-          (join (mapcar (lambda (x)
-                          (ls-compile x env))
-                        args)
+  (concat "(" (ls-compile func) ")("
+          (join (mapcar #'ls-compile args)

                 ", ")
           ")"))
 
 (define-compilation apply (func &rest args)
   (if (null args)
                 ", ")
           ")"))
 
 (define-compilation apply (func &rest 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 (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*

@@ -1480,46 +1483,45 @@
 (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))
+        (apply (eval (binding-value macro-binding)) (cdr form))

         form)))
 
         form)))
 

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

   (concat (ls-compile `#',function) "("
   (concat (ls-compile `#',function) "("

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

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

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

   (cond
     ((symbolp sexp)
   (cond
     ((symbolp sexp)

-     (let ((b (lookup-in-lexenv sexp env 'variable)))
+     (let ((b (lookup-in-lexenv sexp *environment* 'variable)))

        (if (eq (binding-type b) 'lexical-variable)
        (if (eq (binding-type b) 'lexical-variable)

-           (binding-translation b)
-           (ls-compile `(symbol-value ',sexp) env))))
+           (binding-value b)
+           (ls-compile `(symbol-value ',sexp)))))

     ((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 (cdr sexp)))
+           (apply comp (cdr sexp)))

          (if (macro (car sexp))
          (if (macro (car sexp))

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

 
 (defun ls-compile-toplevel (sexp)
 
 (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))))))
+  (let ((*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)))
+         (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