Use special variable to fix nested toplevel compilation bug

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 071879e..07fe2f0 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -24,8 +24,6 @@
 
 #+ecmalisp
 (progn
-
-  'defmacro
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)
@@ -40,28 +38,42 @@
                                                    ,@body)))
                             ',name))))
 
+  (setq nil 'nil)
+  (setq t 't)
+
+  (defmacro when (condition &body body)
+    `(if ,condition (progn ,@body) nil))
+
+  (defmacro unless (condition &body body)
+    `(if ,condition nil (progn ,@body)))
+
   (defmacro defvar (name value)
     `(progn
+       (unless (boundp ',name)
+        (setq ,name ,value))
+       ',name))
+
+  (defmacro defparameter (name value)
+    `(progn
        (setq ,name ,value)
        ',name))
 
-  (defmacro named-lambda (name args &body body)
+  (defmacro named-lambda (name args &rest body)
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))
          (oset ,x "fname" ,name)
          ,x)))
 
-  (defmacro defun (name args &body body)
+  (defmacro defun (name args &rest body)
     `(progn
-       (fset ',name (named-lambda ,(symbol-name name) ,args
-                      (block ,name ,@body)))
+       (fset ',name
+             (named-lambda ,(symbol-name name)
+                 ,args
+               (block ,name ,@body)))
        ',name))
 
   (defvar *package* (new))
 
-  (defvar nil 'nil)
-  (defvar t 't)
-
   (defun null (x)
     (eq x nil))
 
@@ -87,6 +99,9 @@
     (setq *gensym-counter* (+ *gensym-counter* 1))
     (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
 
+  (defun boundp (x)
+    (boundp x))
+
   ;; Basic functions
   (defun = (x y) (= x y))
   (defun + (x y) (+ x y))
@@ -133,12 +148,6 @@
   (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)))
@@ -811,6 +820,7 @@
   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
 
 (defun %compile-defmacro (name lambda)
+  (toplevel-compilation (ls-compile `',name))
   (push-to-lexenv (make-binding name 'macro lambda t) *environment* 'function))
 
 (defvar *compilations* nil)
@@ -1018,20 +1028,55 @@
     (ls-compile-block (butlast body) env)
     "return " (ls-compile (car (last body)) env) ";" *newline*))
 
+
+(defun dynamic-binding-wrapper (bindings body)
+  (if (null bindings)
+      body
+      (concat
+       "try {" *newline*
+       (indent
+        "var tmp;" *newline*
+        (join
+         (mapcar (lambda (b)
+                   (let ((s (ls-compile `(quote ,(car b)))))
+                     (concat "tmp = " s ".value;" *newline*
+                             s ".value = " (cdr b) ";" *newline*
+                             (cdr b) " = tmp;" *newline*)))
+                 bindings))
+        body)
+       "}" *newline*
+       "finally {"  *newline*
+       (indent
+        (join-trailing
+         (mapcar (lambda (b)
+                   (let ((s (ls-compile `(quote ,(car b)))))
+                     (concat s ".value" " = " (cdr b))))
+                 bindings)
+         (concat ";" *newline*)))
+       "}" *newline*)))
+
+
 (define-compilation let (bindings &rest body)
   (let ((bindings (mapcar #'ensure-list bindings)))
     (let ((variables (mapcar #'first bindings))
           (values    (mapcar #'second bindings)))
-      (let ((new-env (extend-local-env variables env)))
+      (let ((new-env (extend-local-env (remove-if #'boundp variables) env))
+            (dynamic-bindings))
         (concat "(function("
                 (join (mapcar (lambda (x)
-                                (translate-variable x new-env))
+                                (if (boundp x)
+                                    (let ((v (gvarname x)))
+                                      (push (cons x v) dynamic-bindings)
+                                      v)
+                                    (translate-variable x new-env)))
                               variables)
                       ",")
                 "){" *newline*
-                (indent (ls-compile-block (butlast body) new-env)
-                        "return " (ls-compile (car (last body)) new-env)
-                        ";" *newline*)
+                (let ((body
+                       (concat (ls-compile-block (butlast body) new-env)
+                               "return " (ls-compile (car (last body)) new-env)
+                               ";" *newline*)))
+                  (indent (dynamic-binding-wrapper dynamic-bindings body)))
                 "})(" (join (mapcar (lambda (x) (ls-compile x env))
                                     values)
                             ",")
@@ -1305,10 +1350,13 @@
   (concat "(" x ").name"))
 
 (define-builtin set (symbol value)
-  (concat "(" symbol ").value =" value))
+  (concat "(" symbol ").value = " value))
 
 (define-builtin fset (symbol value)
-  (concat "(" symbol ").function =" value))
+  (concat "(" symbol ").function = " value))
+
+(define-builtin boundp (x)
+  (js!bool (concat "(" x ".value !== undefined)")))
 
 (define-builtin symbol-value (x)
   (js!selfcall
@@ -1459,19 +1507,18 @@
              (compile-funcall (car sexp) (cdr sexp) env))))))
 
 (defun ls-compile-toplevel (sexp)
-  (setq *toplevel-compilations* nil)
-  (cond
-    ((and (consp sexp) (eq (car sexp) 'progn))
-     (let ((subs (mapcar #'ls-compile-toplevel (cdr sexp))))
-       (join (remove-if #'null-or-empty-p subs))))
-    (t
-     (let ((code (ls-compile sexp)))
-       (prog1
-           (concat (join-trailing (get-toplevel-compilations) (concat ";" *newline*))
-                   (if code
-                       (concat code ";" *newline*)
-                       ""))
-         (setq *toplevel-compilations* nil))))))
+  (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