,@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))
(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))
(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)))
(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)
",")
(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
(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