;;; compiler.lisp ---
-;; copyright (C) 2012, 2013 David Vazquez
+;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
;; JSCL is free software: you can redistribute it and/or
(/debug "loading compiler.lisp!")
+(define-js-macro selfcall (&body body)
+ `(call (function () ,@body)))
+
+(define-js-macro bool (expr)
+ `(if ,expr ,(ls-compile t) ,(ls-compile nil)))
+
+
;;; Translate the Lisp code to Javascript. It will compile the special
;;; forms. Some primitive functions are compiled as special forms
;;; too. The respective real functions are defined in the target (see
(js-expr arg)))))
args))
-;;; Wrap X with a Javascript code to convert the result from
-;;; Javascript generalized booleans to T or NIL.
-(defun js!bool (x)
- `(if ,x ,(ls-compile t) ,(ls-compile nil)))
-
;;; Concatenate the arguments and wrap them with a self-calling
;;; Javascript anonymous function. It is used to make some Javascript
;;; statements valid expressions and provide a private scope as well.
(defmacro js!selfcall (&body body)
``(call (function nil (code ,,@body))))
-(defmacro js!selfcall* (&body body)
- ``(call (function nil ,,@body)))
-
;;; Like CODE, but prefix each line with four spaces. Two versions
;;; of this function are available, because the Ecmalisp version is
(defun lambda-name/docstring-wrapper (name docstring code)
(if (or name docstring)
- (js!selfcall*
- `(var (func ,code))
- (when name `(= (get func "fname") ,name))
- (when docstring `(= (get func "docstring") ,docstring))
- `(return func))
+ `(selfcall
+ (var (func ,code))
+ ,(when name `(= (get func "fname") ,name))
+ ,(when docstring `(= (get func "docstring") ,docstring))
+ (return func))
code))
(defun lambda-check-argument-count
(let ((head (butlast cons))
(tail (last cons)))
`(call |QIList|
- ,@(mapcar (lambda (x) `(code ,(literal x t))) head)
- (code ,(literal (car tail) t))
- (code ,(literal (cdr tail) t)))))
+ ,@(mapcar (lambda (x) (literal x t)) head)
+ ,(literal (car tail) t)
+ ,(literal (cdr tail) t))))
(defun dump-array (array)
(let ((elements (vector-to-list array)))
- (list-to-vector (mapcar (lambda (x) `(code ,(literal x)))
- elements))))
+ (list-to-vector (mapcar #'literal elements))))
(defun dump-string (string)
`(call |make_lisp_string| ,string))
(defun literal (sexp &optional recursive)
(cond
- ((integerp sexp) (integer-to-string sexp))
- ((floatp sexp) (float-to-string sexp))
- ((characterp sexp) (js-escape-string (string sexp)))
+ ((integerp sexp) sexp)
+ ((floatp sexp) sexp)
+ ((characterp sexp)
+ ;; TODO: Remove selfcall after migration
+ `(selfcall (return ,(string sexp))))
(t
(or (cdr (assoc sexp *literal-table* :test #'eql))
(let ((dumped (typecase sexp
(if (and recursive (not (symbolp sexp)))
dumped
(let ((jsvar (genlit)))
- (push (cons sexp jsvar) *literal-table*)
- (toplevel-compilation `(code "var " ,jsvar " = " ,dumped))
+ (push (cons sexp (make-symbol jsvar)) *literal-table*)
+ (toplevel-compilation `(var (,(make-symbol jsvar) ,dumped)))
(when (keywordp sexp)
- (toplevel-compilation `(code ,jsvar ".value = " ,jsvar)))
- jsvar)))))))
+ (toplevel-compilation `(= ,(get (make-symbol jsvar) "value") ,(make-symbol jsvar))))
+ (make-symbol jsvar))))))))
(define-compilation quote (sexp)
(literal sexp))
(define-compilation %while (pred &rest body)
- (js!selfcall*
- `(while (!== ,(ls-compile pred) ,(ls-compile nil))
- 0 ; TODO: Force
+ `(selfcall
+ (while (!== ,(ls-compile pred) ,(ls-compile nil))
+ 0 ; TODO: Force
; braces. Unnecesary when code
; is gone
- ,(ls-compile-block body))
- `(return ,(ls-compile nil))))
+ ,(ls-compile-block body))
+ (return ,(ls-compile nil))))
(define-compilation function (x)
(cond
(extend-lexenv (mapcar #'make-function-binding fnames)
*environment*
'function)))
- (js!selfcall*
- `(progn
- ,@(mapcar (lambda (func)
- `(var (,(make-symbol (translate-function (car func)))
- ,(compile-lambda (cadr func)
- `((block ,(car func) ,@(cddr func)))))))
- definitions))
- (ls-compile-block body t))))
+ `(selfcall
+ ,@(mapcar (lambda (func)
+ `(var (,(make-symbol (translate-function (car func)))
+ ,(compile-lambda (cadr func)
+ `((block ,(car func) ,@(cddr func)))))))
+ definitions)
+ ,(ls-compile-block body t))))
(defvar *compiling-file* nil)
;; unique identifier of the block as exception. We can't use the
;; variable name itself, because it could not to be unique, so we
;; capture it in a closure.
- (js!selfcall*
- (when multiple-value-p
- `(var (|values| |mv|)))
- `(throw
- (object
- "type" "block"
- "id" ,(make-symbol (binding-value b))
- "values" ,(ls-compile value multiple-value-p)
- "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
+ `(selfcall
+ ,(when multiple-value-p `(var (|values| |mv|)))
+ (throw
+ (object
+ "type" "block"
+ "id" ,(make-symbol (binding-value b))
+ "values" ,(ls-compile value multiple-value-p)
+ "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
(define-compilation catch (id &rest body)
- (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|)))))
+ `(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 (object
- |type| "catch"
- |id| ,(ls-compile id)
- |values| ,(ls-compile value t)
- |message| "Throw uncatched."))))
+ `(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)))
initag)
(let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
(setq initag (second (binding-value b))))
- (js!selfcall*
+ `(selfcall
;; TAGBODY branch to take
- `(var (,(make-symbol branch) ,initag))
- `(var (,(make-symbol tbidx) #()))
- `(label tbloop
- (while true
- (try
- (switch ,(make-symbol branch)
- ,@(with-collect
- (collect `(case ,initag))
- (dolist (form (cdr body))
- (if (go-tag-p form)
- (let ((b (lookup-in-lexenv form *environment* 'gotag)))
- (collect `(case ,(second (binding-value b)))))
- (progn
- (collect (ls-compile form))
- ;; TEMPORAL!
- (collect '(code ";"))))))
- default
- (break tbloop)))
- (catch (jump)
- (if (and (== (get jump "type") "tagbody")
- (== (get jump "id") ,(make-symbol tbidx)))
- (= ,(make-symbol branch) (get jump "label"))
- (throw jump)))))
- `(return ,(ls-compile nil))))))
+ (var (,(make-symbol branch) ,initag))
+ (var (,(make-symbol tbidx) #()))
+ (label tbloop
+ (while true
+ (try
+ (switch ,(make-symbol branch)
+ ,@(with-collect
+ (collect `(case ,initag))
+ (dolist (form (cdr body))
+ (if (go-tag-p form)
+ (let ((b (lookup-in-lexenv form *environment* 'gotag)))
+ (collect `(case ,(second (binding-value b)))))
+ (progn
+ (collect (ls-compile form))
+ ;; TEMPORAL!
+ (collect '(code ";"))))))
+ default
+ (break tbloop)))
+ (catch (jump)
+ (if (and (== (get jump "type") "tagbody")
+ (== (get jump "id") ,(make-symbol tbidx)))
+ (= ,(make-symbol branch) (get jump "label"))
+ (throw jump)))))
+ (return ,(ls-compile nil))))))
(define-compilation go (label)
(let ((b (lookup-in-lexenv label *environment* 'gotag))
((integerp label) (integer-to-string label)))))
(when (null b)
(error "Unknown tag `~S'" label))
- (js!selfcall*
- `(throw
- (object
- "type" "tagbody"
- "id" ,(make-symbol (first (binding-value b)))
- "label" ,(second (binding-value b))
- "message" ,(concat "Attempt to GO to non-existing tag " n))))))
+ `(selfcall
+ (throw
+ (object
+ "type" "tagbody"
+ "id" ,(make-symbol (first (binding-value b)))
+ "label" ,(second (binding-value b))
+ "message" ,(concat "Attempt to GO to non-existing tag " n))))))
(define-compilation unwind-protect (form &rest clean-up)
- (js!selfcall*
- `(var (|ret| ,(ls-compile nil)))
- `(try
- (= |ret| ,(ls-compile form)))
- `(finally
- ,(ls-compile-block clean-up))
- `(return |ret|)))
+ `(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*
- `(var (func ,(ls-compile func-form)))
- `(var (args ,(vector (if *multiple-value-p* '|values| '|pv|) 0)))
- `(return
- ,(js!selfcall*
- `(var (|values| |mv|))
- `(var vs)
- `(progn
- ,@(with-collect
- (dolist (form forms)
- (collect `(= vs ,(ls-compile form t)))
- (collect `(if (and (=== (typeof vs) "object")
- (in "multiple-value" vs))
- (= args (call (get args "concat") vs))
- (call (get args "push") vs))))))
- `(= (property args 1) (- (property args "length") 2))
- `(return (call (get func "apply") |window| args))))))
+ `(selfcall
+ (var (func ,(ls-compile func-form)))
+ (var (args ,(vector (if *multiple-value-p* '|values| '|pv|) 0)))
+ (return
+ (selfcall
+ (var (|values| |mv|))
+ (var vs)
+ (progn
+ ,@(with-collect
+ (dolist (form forms)
+ (collect `(= vs ,(ls-compile form t)))
+ (collect `(if (and (=== (typeof vs) "object")
+ (in "multiple-value" vs))
+ (= args (call (get args "concat") vs))
+ (call (get args "push") vs))))))
+ (= (property args 1) (- (property args "length") 2))
+ (return (call (get func "apply") |window| args))))))
(define-compilation multiple-value-prog1 (first-form &rest forms)
- (js!selfcall
- "var args = " (ls-compile first-form *multiple-value-p*) ";"
- (ls-compile-block forms)
- "return args;" ))
+ `(selfcall
+ (var (args ,(ls-compile first-form *multiple-value-p*)))
+ ;; TODO: Interleave is temporal
+ (progn ,@(interleave (mapcar #'ls-compile forms)
+ '(code ";")
+ t))
+ (return args)))
(define-transformation backquote (form)
(bq-completely-process form))
(let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
,@body)))
-;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
-(defmacro type-check (decls &body body)
- `(js!selfcall
- ,@(mapcar (lambda (decl)
- `(let ((name ,(first decl))
- (value ,(third decl)))
- `(code "var " ,name " = " ,value ";" )))
- decls)
- ,@(mapcar (lambda (decl)
- `(let ((name ,(first decl))
- (type ,(second decl)))
- `(code "if (typeof " ,name " != '" ,type "')"
- (code "throw 'The value ' + "
- ,name
- " + ' is not a type "
- ,type
- ".';"
- ))))
- decls)
- `(code "return " ,,@body ";" )))
-
;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
;;; a variable which holds a list of forms. It will compile them and
;;; store the result in some Javascript variables. BODY is evaluated
;;; with ARGS bound to the list of these variables to generate the
;;; code which performs the transformation on these variables.
-
(defun variable-arity-call (args function)
(unless (consp args)
(error "ARGS must be a non-empty list"))
(fargs '())
(prelude '()))
(dolist (x args)
- (cond
- ((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!';")
- prelude)))))
- (js!selfcall
- `(code ,@(reverse prelude))
- (funcall function (reverse fargs)))))
+ (if (or (floatp x) (numberp x))
+ (push x fargs)
+ (let ((v (make-symbol (concat "x" (integer-to-string (incf counter))))))
+ (push v fargs)
+ (push `(var (,v ,(ls-compile x)))
+ prelude)
+ (push `(if (!= (typeof ,v) "number")
+ (throw "Not a number!"))
+ prelude))))
+ `(selfcall
+ (progn ,@(reverse prelude))
+ ,(funcall function (reverse fargs)))))
(defmacro variable-arity (args &body body)
(unless (symbolp args)
(error "`~S' is not a symbol." args))
- `(variable-arity-call ,args
- (lambda (,args)
- `(code "return " ,,@body ";" ))))
-
-(defun num-op-num (x op y)
- (type-check (("x" "number" x) ("y" "number" y))
- `(code "x" ,op "y")))
+ `(variable-arity-call ,args (lambda (,args) `(return ,,@body))))
(define-raw-builtin + (&rest numbers)
(if (null numbers)
(reduce (lambda (x y) `(/ ,x ,y))
args)))))
-(define-builtin mod (x y) (num-op-num x "%" y))
+(define-builtin mod (x y)
+ `(% ,x ,y))
(defun comparison-conjuntion (vars op)
`(define-raw-builtin ,op (x &rest args)
(let ((args (cons x args)))
(variable-arity args
- (js!bool (comparison-conjuntion args ',sym))))))
+ `(bool ,(comparison-conjuntion args ',sym))))))
(define-builtin-comparison > >)
(define-builtin-comparison < <)
(define-builtin-comparison /= !=)
(define-builtin numberp (x)
- (js!bool `(== (typeof ,x) "number")))
+ `(bool (== (typeof ,x) "number")))
(define-builtin floor (x)
- (type-check (("x" "number" x))
- "Math.floor(x)"))
+ `(call (get |Math| |floor|) ,x))
(define-builtin expt (x y)
- (type-check (("x" "number" x)
- ("y" "number" y))
- "Math.pow(x, y)"))
+ `(call (get |Math| |pow|) ,x ,y))
(define-builtin float-to-string (x)
- (type-check (("x" "number" x))
- "make_lisp_string(x.toString())"))
+ `(call |make_lisp_string| (call (get ,x |toString|))))
(define-builtin cons (x y)
`(object "car" ,x "cdr" ,y))
(define-builtin consp (x)
- (js!bool
- (js!selfcall*
- `(var (tmp ,x))
- `(return (and (== (typeof tmp) "object")
- (in "car" tmp))))))
+ `(selfcall
+ (var (tmp ,x))
+ (return (bool (and (== (typeof tmp) "object")
+ (in "car" tmp))))))
(define-builtin car (x)
- (js!selfcall*
- `(var (tmp ,x))
- `(return (if (=== tmp ,(ls-compile nil))
- ,(ls-compile nil)
- (get tmp "car")))))
+ `(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 (if (=== tmp ,(ls-compile nil))
- ,(ls-compile nil)
- (get tmp "cdr")))))
+ `(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.car = " ,new ", x)")))
+ `(= (get ,x "car") ,new))
(define-builtin rplacd (x new)
- (type-check (("x" "object" x))
- `(code "(x.cdr = " ,new ", x)")))
+ `(= (get ,x "cdr") ,new))
(define-builtin symbolp (x)
- (js!bool `(instanceof ,x |Symbol|)))
+ `(bool (instanceof ,x |Symbol|)))
(define-builtin make-symbol (name)
`(new (call |Symbol| ,name)))
`(= (get ,symbol "fvalue") ,value))
(define-builtin boundp (x)
- (js!bool `(!== (get ,x "value") undefined)))
+ `(bool (!== (get ,x "value") undefined)))
(define-builtin fboundp (x)
- (js!bool `(!== (get ,x "fvalue") undefined)))
+ `(bool (!== (get ,x "fvalue") undefined)))
(define-builtin symbol-value (x)
- (js!selfcall*
- `(var (symbol ,x)
- (value (get symbol "value")))
- `(if (=== value undefined)
- (throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
- `(return value)))
+ `(selfcall
+ (var (symbol ,x)
+ (value (get symbol "value")))
+ (if (=== value undefined)
+ (throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
+ (return value)))
(define-builtin symbol-function (x)
- (js!selfcall*
- `(var (symbol ,x)
- (func (get symbol "fvalue")))
- `(if (=== func undefined)
- (throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
- `(return func)))
+ `(selfcall
+ (var (symbol ,x)
+ (func (get symbol "fvalue")))
+ (if (=== func undefined)
+ (throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
+ (return func)))
(define-builtin symbol-plist (x)
`(or (get ,x "plist") ,(ls-compile nil)))
`(call |make_lisp_string| (call (get ,x "toString"))))
(define-builtin eq (x y)
- (js!bool `(=== ,x ,y)))
+ `(bool (=== ,x ,y)))
(define-builtin char-code (x)
- (type-check (("x" "string" x))
- "char_to_codepoint(x)"))
+ `(call |char_to_codepoint| ,x))
(define-builtin code-char (x)
- (type-check (("x" "number" x))
- "char_from_codepoint(x)"))
+ `(call |char_from_codepoint| ,x))
(define-builtin characterp (x)
- (js!bool
- (js!selfcall*
- `(var (x ,x))
- `(return (and (== (typeof x) "string")
- (or (== (get x "length") 1)
- (== (get x "length") 2)))))))
+ `(selfcall
+ (var (x ,x))
+ (return (bool
+ (and (== (typeof x) "string")
+ (or (== (get x "length") 1)
+ (== (get x "length") 2)))))))
(define-builtin char-upcase (x)
`(call |safe_char_upcase| ,x))
`(call |safe_char_downcase| ,x))
(define-builtin stringp (x)
- (js!bool
- (js!selfcall*
- `(var (x ,x))
- `(return (and (and (===(typeof x) "object")
- (in "length" x))
- (== (get x "stringp") 1))))))
+ `(selfcall
+ (var (x ,x))
+ (return (bool
+ (and (and (===(typeof x) "object")
+ (in "length" x))
+ (== (get x "stringp") 1))))))
(define-raw-builtin funcall (func &rest args)
- (js!selfcall*
- `(var (f ,(ls-compile func)))
- `(return (call (if (=== (typeof f) "function")
- f
- (get f "fvalue"))
- ,@(list* (if *multiple-value-p* '|values| '|pv|)
- (length args)
- (mapcar #'ls-compile args))))))
+ `(selfcall
+ (var (f ,(ls-compile func)))
+ (return (call (if (=== (typeof f) "function")
+ f
+ (get f "fvalue"))
+ ,@(list* (if *multiple-value-p* '|values| '|pv|)
+ (length args)
+ (mapcar #'ls-compile args))))))
(define-raw-builtin apply (func &rest args)
(if (null args)
(ls-compile func)
(let ((args (butlast args))
(last (car (last args))))
- (js!selfcall*
- `(var (f ,(ls-compile func)))
- `(var (args ,(list-to-vector
+ `(selfcall
+ (var (f ,(ls-compile func)))
+ (var (args ,(list-to-vector
(list* (if *multiple-value-p* '|values| '|pv|)
(length args)
(mapcar #'ls-compile args)))))
- `(var (tail ,(ls-compile last)))
- `(while (!= tail ,(ls-compile nil))
+ (var (tail ,(ls-compile last)))
+ (while (!= tail ,(ls-compile nil))
(call (get args "push") (get tail "car"))
(post++ (property args 1))
(= tail (get tail "cdr")))
- `(return (call (get (if (=== (typeof f) "function")
+ (return (call (get (if (=== (typeof f) "function")
f
(get f "fvalue"))
"apply")
(define-builtin js-eval (string)
(if *multiple-value-p*
- (js!selfcall*
- `(var (v (call |globalEval| (call |xstring| ,string))))
- `(return (call (get |values| "apply") this (call |forcemv| v))))
+ `(selfcall
+ (var (v (call |globalEval| (call |xstring| ,string))))
+ (return (call (get |values| "apply") this (call |forcemv| v))))
`(call |globalEval| (call |xstring| ,string))))
(define-builtin %throw (string)
- (js!selfcall* `(throw ,string)))
+ `(selfcall (throw ,string)))
(define-builtin functionp (x)
- (js!bool `(=== (typeof ,x) "function")))
+ `(bool (=== (typeof ,x) "function")))
(define-builtin %write-string (x)
`(call (get |lisp| "write") ,x))
;;; future) structures.
(define-builtin storage-vector-p (x)
- (js!bool
- (js!selfcall*
- `(var (x ,x))
- `(return (and (=== (typeof x) "object") (in "length" x))))))
+ `(selfcall
+ (var (x ,x))
+ (return (bool (and (=== (typeof x) "object") (in "length" x))))))
(define-builtin make-storage-vector (n)
- (js!selfcall*
- `(var (r #()))
- `(= (get r "length") ,n)
- `(return r)))
+ `(selfcall
+ (var (r #()))
+ (= (get r "length") ,n)
+ (return r)))
(define-builtin storage-vector-size (x)
`(get ,x "length"))
`(= (get ,vector "length") ,new-size))
(define-builtin storage-vector-ref (vector n)
- (js!selfcall*
- `(var (x (property ,vector ,n)))
- `(if (=== x undefined) (throw "Out of range."))
- `(return x)))
+ `(selfcall
+ (var (x (property ,vector ,n)))
+ (if (=== x undefined) (throw "Out of range."))
+ (return x)))
(define-builtin storage-vector-set (vector n value)
- (js!selfcall*
- `(var (x ,vector))
- `(var (i ,n))
- `(if (or (< i 0) (>= i (get x "length")))
- (throw "Out of range."))
- `(return (= (property x i) ,value))))
+ `(selfcall
+ (var (x ,vector))
+ (var (i ,n))
+ (if (or (< i 0) (>= i (get x "length")))
+ (throw "Out of range."))
+ (return (= (property x i) ,value))))
(define-builtin concatenate-storage-vector (sv1 sv2)
- (js!selfcall*
- `(var (sv1 ,sv1))
- `(var (r (call (get sv1 "concat") ,sv2)))
- `(= (get r "type") (get sv1 "type"))
- `(= (get r "stringp") (get sv1 "stringp"))
- `(return r)))
+ `(selfcall
+ (var (sv1 ,sv1))
+ (var (r (call (get sv1 "concat") ,sv2)))
+ (= (get r "type") (get sv1 "type"))
+ (= (get r "stringp") (get sv1 "stringp"))
+ (return r)))
(define-builtin get-internal-real-time ()
`(call (get (new (call |Date|)) "getTime")))
'(object))
(define-raw-builtin oget* (object key &rest keys)
- (js!selfcall*
- `(progn
- (var (tmp (property ,(ls-compile object) (call |xstring| ,(ls-compile key)))))
- ,@(mapcar (lambda (key)
- `(progn
- (if (=== tmp undefined) (return ,(ls-compile nil)))
- (= tmp (property tmp (call |xstring| ,(ls-compile key))))))
- keys))
- `(return (if (=== tmp undefined) ,(ls-compile nil) tmp))))
+ `(selfcall
+ (progn
+ (var (tmp (property ,(ls-compile object) (call |xstring| ,(ls-compile key)))))
+ ,@(mapcar (lambda (key)
+ `(progn
+ (if (=== tmp undefined) (return ,(ls-compile nil)))
+ (= tmp (property tmp (call |xstring| ,(ls-compile key))))))
+ keys))
+ (return (if (=== tmp undefined) ,(ls-compile nil) tmp))))
(define-raw-builtin oset* (value object key &rest keys)
(let ((keys (cons key keys)))
- (js!selfcall*
- `(progn
- (var (obj ,(ls-compile object)))
- ,@(mapcar (lambda (key)
- `(progn
- (= obj (property obj (call |xstring| ,(ls-compile key))))
- (if (=== object undefined)
- (throw "Impossible to set object property."))))
- (butlast keys))
- (var (tmp
- (= (property obj (call |xstring| ,(ls-compile (car (last keys)))))
- ,(ls-compile value))))
- (return (if (=== tmp undefined)
- ,(ls-compile nil)
- tmp))))))
+ `(selfcall
+ (progn
+ (var (obj ,(ls-compile object)))
+ ,@(mapcar (lambda (key)
+ `(progn
+ (= obj (property obj (call |xstring| ,(ls-compile key))))
+ (if (=== object undefined)
+ (throw "Impossible to set object property."))))
+ (butlast keys))
+ (var (tmp
+ (= (property obj (call |xstring| ,(ls-compile (car (last keys)))))
+ ,(ls-compile value))))
+ (return (if (=== tmp undefined)
+ ,(ls-compile nil)
+ tmp))))))
(define-raw-builtin oget (object key &rest keys)
`(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys))))
(ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
(define-builtin objectp (x)
- (js!bool `(=== (typeof ,x) "object")))
+ `(bool (=== (typeof ,x) "object")))
(define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x))
(define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x))
(define-builtin in (key object)
- (js!bool `(in (call |xstring| ,key) ,object)))
+ `(bool (in (call |xstring| ,key) ,object)))
(define-builtin map-for-in (function object)
- (js!selfcall*
- `(var (f ,function)
- (g (if (=== (typeof f) "function") f (get f "fvalue")))
- (o ,object))
- `(for-in (key o)
- (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key")))
- `(return ,(ls-compile nil))))
+ `(selfcall
+ (var (f ,function)
+ (g (if (=== (typeof f) "function") f (get f "fvalue")))
+ (o ,object))
+ (for-in (key o)
+ (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key")))
+ (return ,(ls-compile nil))))
(define-compilation %js-vref (var)
`(call |js_to_lisp| ,(make-symbol var)))
(binding-value b))
((or (keywordp sexp)
(and b (member 'constant (binding-declarations b))))
- `(code ,(ls-compile `',sexp) ".value"))
+ `(get ,(ls-compile `',sexp) "value"))
(t
(ls-compile `(symbol-value ',sexp))))))
((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
(let ((form-string (prin1-to-string sexp)))
(format t "Compiling ~a..." (truncate-string form-string))))
(let ((code (ls-compile sexp multiple-value-p)))
- `(code
- ,@(interleave (get-toplevel-compilations) ";
-" t)
- ,(when code
- `(code ,code ";"))))))))
+ `(progn
+ ,@(interleave (get-toplevel-compilations) '(code ";
+") t)
+ (code ,code ";")))))))
(defun ls-compile-toplevel (sexp &optional multiple-value-p)
(with-output-to-string (*standard-output*)
projects / jscl.git / blobdiff