(define-compilation progn (&rest body)
(if (null (cdr body))
(ls-compile (car body) *multiple-value-p*)
- `(code "("
- ,@(interleave
- (append (mapcar #'ls-compile (butlast body))
- (list (ls-compile (car (last body)) t)))
- ",")
- ")")))
+ `(progn
+ ,@(append (mapcar #'ls-compile (butlast body))
+ (list (ls-compile (car (last body)) t))))))
(define-compilation macrolet (definitions &rest body)
(let ((*environment* (copy-lexenv *environment*)))
"})")))
(define-compilation catch (id &rest body)
- (js!selfcall
- "var id = " (ls-compile id) ";"
- "try {"
- `(code ,(ls-compile-block body t))
- "}"
- "catch (cf){"
- " if (cf.type == 'catch' && cf.id == id)"
- (if *multiple-value-p*
- " return values.apply(this, forcemv(cf.values));"
- " return pv.apply(this, forcemv(cf.values));")
-
- " else"
- " throw cf;"
- "}" ))
+ (js!selfcall*
+ `(var (|id| ,(ls-compile id)))
+ `(try
+ ,(ls-compile-block body t))
+ `(catch (|cf|)
+ (if (and (== (get |cf| |type|) "catch")
+ (== (get |cf| |id|) |id|))
+ ,(if *multiple-value-p*
+ `(return (call (get |values| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|))))
+ `(return (call (get |pv| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|)))))
+ (throw |cf|)))))
(define-compilation throw (id value)
- (js!selfcall
- "var values = mv;"
- "throw ({"
- "type: 'catch', "
- "id: " (ls-compile id) ", "
- "values: " (ls-compile value t) ", "
- "message: 'Throw uncatched.'"
- "})"))
+ (js!selfcall*
+ `(var (|values| |mv|))
+ `(throw (object
+ |type| "catch"
+ |id| ,(ls-compile id)
+ |values| ,(ls-compile value t)
+ |message| "Throw uncatched."))))
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))
"})" )))
(define-compilation unwind-protect (form &rest clean-up)
- (js!selfcall
- "var ret = " (ls-compile nil) ";"
- "try {"
- `(code "ret = " ,(ls-compile form) ";" )
- "} finally {"
- `(code ,(ls-compile-block clean-up))
- "}"
- "return ret;" ))
+ (js!selfcall*
+ `(var (|ret| ,(ls-compile nil)))
+ `(try
+ (= |ret| ,(ls-compile form)))
+ `(finally
+ ,(ls-compile-block clean-up))
+ `(return |ret|)))
(define-compilation multiple-value-call (func-form &rest forms)
(js!selfcall
(prelude '()))
(dolist (x args)
(cond
- ((floatp x) (push (float-to-string x) fargs))
- ((numberp x) (push (integer-to-string x) fargs))
- (t (let ((v (code "x" (incf counter))))
+ ((or (floatp x) (numberp x)) (push x fargs))
+ (t (let ((v (make-symbol (code "x" (incf counter)))))
(push v fargs)
(push `(code "var " ,v " = " ,(ls-compile x) ";"
"if (typeof " ,v " !== 'number') throw 'Not a number!';")
(define-raw-builtin + (&rest numbers)
(if (null numbers)
- "0"
+ 0
(variable-arity numbers
- `(code ,@(interleave numbers "+")))))
+ `(+ ,@numbers))))
(define-raw-builtin - (x &rest others)
(let ((args (cons x others)))
- (variable-arity args
- (if (null others)
- `(code "-" ,(car args))
- `(code ,@(interleave args "-"))))))
+ (variable-arity args `(- ,@args))))
(define-raw-builtin * (&rest numbers)
(if (null numbers)
- "1"
- (variable-arity numbers
- `(code ,@(interleave numbers "*")))))
+ 1
+ (variable-arity numbers `(* ,@numbers))))
(define-raw-builtin / (x &rest others)
(let ((args (cons x others)))
(variable-arity args
(if (null others)
- `(code "1 /" ,(car args))
- `(code ,@(interleave args "/"))))))
+ `(/ 1 ,(car args))
+ (reduce (lambda (x y) `(/ ,x ,y))
+ args)))))
(define-builtin mod (x y) (num-op-num x "%" y))
(defun comparison-conjuntion (vars op)
(cond
((null (cdr vars))
- "true")
+ 'true)
((null (cddr vars))
- `(code ,(car vars) ,op ,(cadr vars)))
+ `(,op ,(car vars) ,(cadr vars)))
(t
- `(code ,(car vars) ,op ,(cadr vars)
- " && "
- ,(comparison-conjuntion (cdr vars) op)))))
+ `(and (,op ,(car vars) ,(cadr vars))
+ ,(comparison-conjuntion (cdr vars) op)))))
(defmacro define-builtin-comparison (op sym)
`(define-raw-builtin ,op (x &rest args)
(let ((args (cons x args)))
(variable-arity args
- (js!bool (comparison-conjuntion args ,sym))))))
+ (js!bool (comparison-conjuntion args ',sym))))))
-(define-builtin-comparison > ">")
-(define-builtin-comparison < "<")
-(define-builtin-comparison >= ">=")
-(define-builtin-comparison <= "<=")
-(define-builtin-comparison = "==")
-(define-builtin-comparison /= "!=")
+(define-builtin-comparison > >)
+(define-builtin-comparison < <)
+(define-builtin-comparison >= >=)
+(define-builtin-comparison <= <=)
+(define-builtin-comparison = ==)
+(define-builtin-comparison /= !=)
(define-builtin numberp (x)
- (js!bool `(code "(typeof (" ,x ") == \"number\")")))
+ (js!bool `(== (typeof ,x) "number")))
(define-builtin floor (x)
(type-check (("x" "number" x))
"make_lisp_string(x.toString())"))
(define-builtin cons (x y)
- `(code "({car: " ,x ", cdr: " ,y "})"))
+ `(object "car" ,x "cdr" ,y))
(define-builtin consp (x)
(js!bool
"return (typeof tmp == 'object' && 'car' in tmp);" )))
(define-builtin car (x)
- (js!selfcall
- "var tmp = " x ";"
- "return tmp === " (ls-compile nil)
- "? " (ls-compile nil)
- ": tmp.car;" ))
+ (js!selfcall*
+ `(var (tmp ,x))
+ `(return (if (=== tmp ,(ls-compile nil))
+ ,(ls-compile nil)
+ (get tmp "car")))))
(define-builtin cdr (x)
- (js!selfcall
- "var tmp = " x ";"
- "return tmp === " (ls-compile nil) "? "
- (ls-compile nil)
- ": tmp.cdr;" ))
+ (js!selfcall*
+ `(var (tmp ,x))
+ `(return (if (=== tmp ,(ls-compile nil))
+ ,(ls-compile nil)
+ (get tmp "cdr")))))
(define-builtin rplaca (x new)
(type-check (("x" "object" x))
`(code "(x.cdr = " ,new ", x)")))
(define-builtin symbolp (x)
- (js!bool `(code "(" ,x " instanceof Symbol)")))
+ (js!bool `(instanceof ,x |Symbol|)))
(define-builtin make-symbol (name)
- `(code "(new Symbol(" ,name "))"))
+ `(new (call |Symbol| ,name)))
(define-builtin symbol-name (x)
- `(code "(" ,x ").name"))
+ `(get ,x "name"))
(define-builtin set (symbol value)
`(code "(" ,symbol ").value = " ,value))