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