Export LAMBDA, no LAMBDA-CODE

Conflicts:
	ecmalisp.lisp

diff --combined ecmalisp.lisp
index 2e75d24,7e3cda3..bf96d3f
--- 1/ecmalisp.lisp
--- 2/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@@ -40,7 -40,7 +40,7 @@@
      `(eval-when-compile
         ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
  
 -  (declaim (constant nil t))
 +  (declaim (constant nil t) (special t nil))
    (setq nil 'nil)
    (setq t 't)
  
@@@ -52,7 -52,6 +52,7 @@@
  
    (defmacro defvar (name value &optional docstring)
      `(progn
 +       (declaim (special ,name))
         (unless (boundp ',name) (setq ,name ,value))
         ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
         ',name))
@@@ -1001,10 -1000,6 +1001,10 @@@
  
  (defun !proclaim (decl)
    (case (car decl)
 +    (special
 +     (dolist (name (cdr decl))
 +       (let ((b (global-binding name 'variable 'variable)))
 +         (push-binding-declaration 'special b))))
      (notinline
       (dolist (name (cdr decl))
         (let ((b (global-binding name 'function 'function)))
@@@ -1228,48 -1223,43 +1228,48 @@@
  (define-compilation progn (&rest body)
    (js!selfcall (ls-compile-block body t)))
  
 +
 +(defun restoring-dynamic-binding (bindings body)
 +  (concat
 +   "try {" *newline*
 +   (indent 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*))
 +
  (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*)))
 -
 +      (restoring-dynamic-binding
 +       bindings
 +       (concat "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*))))
  
  (define-compilation let (bindings &rest body)
    (let ((bindings (mapcar #'ensure-list bindings)))
      (let ((variables (mapcar #'first bindings))
            (values    (mapcar #'second bindings)))
        (let ((cvalues (mapcar #'ls-compile values))
 -            (*environment* (extend-local-env (remove-if #'boundp variables)))
 +            (*environment*
 +             (extend-local-env (remove-if (lambda (v)(claimp v 'variable 'special))
 +                                          variables)))
              (dynamic-bindings))
          (concat "(function("
                  (join (mapcar (lambda (x)
 -                                (if (boundp x)
 +                                (if (claimp x 'variable 'special)
                                      (let ((v (gvarname x)))
                                        (push (cons x v) dynamic-bindings)
                                        v)
@@@ -1282,29 -1272,6 +1282,29 @@@
                  "})(" (join cvalues ",") ")")))))
  
  
 +(defun let*-initialize (x)
 +  (let ((var (first x))
 +        (value (second x)))
 +    (if (claimp var 'variable 'special)
 +        (ls-compile `(setq ,var ,value))
 +        (let ((v (gvarname var)))
 +          (let ((b (make-binding var 'variable v)))
 +            (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*)
 +              (push-to-lexenv b *environment* 'variable)))))))
 +
 +(define-compilation let* (bindings &rest body)
 +  (let ((bindings (mapcar #'ensure-list bindings))
 +        (*environment* (copy-lexenv *environment*)))
 +    (js!selfcall
 +      (let ((body
 +             (concat (mapconcat #'let*-initialize bindings)
 +                     (ls-compile-block body t))))
 +        (if (some (lambda (b) (claimp (car b) 'variable 'special)) bindings)
 +            (restoring-dynamic-binding bindings body)
 +            body)))))
 +
 +
 +
  (defvar *block-counter* 0)
  
  (define-compilation block (name &rest body)
@@@ -1749,10 -1716,9 +1749,10 @@@
      ((symbolp sexp)
       (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
         (cond
 -         ((eq (binding-type b) 'lexical-variable)
 +         ((and b (not (member 'special (binding-declarations b))))
            (binding-value b))
 -         ((or (keywordp sexp) (claimp sexp 'variable 'constant))
 +         ((or (keywordp sexp)
 +              (member 'constant (binding-declarations b)))
            (concat (ls-compile `',sexp) ".value"))
           (t
            (ls-compile `(symbol-value ',sexp))))))
@@@ -1819,8 -1785,8 +1819,8 @@@
              documentation dolist dotimes ecase eq eql equal error eval
              every export fdefinition find-package find-symbol first
              fourth fset funcall function functionp gensym go identity
-             in-package incf integerp integerp intern keywordp
-             lambda-code last length let let* list-all-packages list listp
+             if in-package incf integerp integerp intern keywordp
 -            lambda-code last length let list-all-packages list listp
++            lambda last length let list-all-packages list listp
              make-package make-symbol mapcar member minusp mod nil not
              nth nthcdr null numberp or package-name package-use-list
              packagep plusp prin1-to-string print proclaim prog1 prog2