(defun gvarname (symbol)
(declare (ignore symbol))
- (code "v" (incf *variable-counter*)))
+ (incf *variable-counter*)
+ (concat "v" (integer-to-string *variable-counter*)))
(defun translate-variable (symbol)
(awhen (lookup-in-lexenv symbol *environment* 'variable)
(if (or name docstring)
(js!selfcall*
`(var (func ,code))
- (when name `(= (get func |fname|) ,name))
- (when docstring `(= (get func |docstring|) ,docstring))
+ (when name `(= (get func "fname") ,name))
+ (when docstring `(= (get func "docstring") ,docstring))
`(return func))
- `(code ,code)))
+ code))
(defun lambda-check-argument-count
(n-required-arguments n-optional-arguments rest-p)
(defvar *literal-counter* 0)
(defun genlit ()
- (code "l" (incf *literal-counter*)))
+ (incf *literal-counter*)
+ (concat "l" (integer-to-string *literal-counter*)))
(defun dump-symbol (symbol)
#-jscl
((and (listp x) (eq (car x) 'lambda))
(compile-lambda (cadr x) (cddr x)))
((and (listp x) (eq (car x) 'named-lambda))
- ;; TODO: destructuring-bind now! Do error checking manually is
- ;; very annoying.
- (let ((name (cadr x))
- (ll (caddr x))
- (body (cdddr x)))
+ (destructuring-bind (name ll &rest body) (cdr x)
(compile-lambda ll body
:name (symbol-name name)
:block name)))
(extend-lexenv (mapcar #'make-function-binding fnames)
*environment*
'function)))
- `(code "(function("
- ,@(interleave (mapcar #'translate-function fnames) ",")
- "){"
- ,(ls-compile-block body t)
- "})(" ,@(interleave cfuncs ",") ")")))
+ `(call (function ,(mapcar #'make-symbol (mapcar #'translate-function fnames))
+ ,(ls-compile-block body t))
+ ,@cfuncs)))
(define-compilation labels (definitions &rest body)
(let* ((fnames (mapcar #'car definitions))
(extend-lexenv (mapcar #'make-function-binding fnames)
*environment*
'function)))
- (js!selfcall
- `(code ,@(mapcar (lambda (func)
- `(code "var " ,(translate-function (car func))
- " = " ,(compile-lambda (cadr func)
- `((block ,(car func) ,@(cddr func))))
- ";" ))
- definitions))
+ (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))))
`(try
,(ls-compile-block body t))
`(catch (|cf|)
- (if (and (== (get |cf| |type|) "catch")
- (== (get |cf| |id|) |id|))
+ (if (and (== (get |cf| "type") "catch")
+ (== (get |cf| "id") |id|))
,(if *multiple-value-p*
- `(return (call (get |values| |apply|)
+ `(return (call (get |values| "apply")
this
- (call |forcemv| (get |cf| |values|))))
- `(return (call (get |pv| |apply|)
+ (call |forcemv| (get |cf| "values"))))
+ `(return (call (get |pv| "apply")
this
- (call |forcemv| (get |cf| |values|)))))
+ (call |forcemv| (get |cf| "values")))))
(throw |cf|)))))
(define-compilation throw (id value)
(define-builtin characterp (x)
(js!bool
- (js!selfcall
- "var x = " x ";"
- "return (typeof(" x ") == \"string\") && (x.length == 1 || x.length == 2);")))
+ (js!selfcall*
+ `(var (x ,x))
+ `(return (and (== (typeof x) "string")
+ (or (== (get x "length") 1)
+ (== (get x "length") 2)))))))
(define-builtin char-upcase (x)
`(call |safe_char_upcase| ,x))
(define-builtin stringp (x)
(js!bool
- (js!selfcall
- "var x = " x ";"
- "return typeof(x) == 'object' && 'length' in x && x.stringp == 1;")))
+ (js!selfcall*
+ `(var (x ,x))
+ `(return (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 (typeof f === 'function'? f: f.fvalue)("
- `(code
- ,@(interleave (list* (if *multiple-value-p* "values" "pv")
- (integer-to-string (length args))
- (mapcar #'ls-compile 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))))))
(define-raw-builtin apply (func &rest args)
(if (null args)
(define-builtin js-eval (string)
(if *multiple-value-p*
- (js!selfcall
- "var v = globalEval(xstring(" string "));"
- "return values.apply(this, forcemv(v));" )
- `(code "globalEval(xstring(" ,string "))")))
+ (js!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 ";" ))
+ (js!selfcall* `(throw ,string)))
(define-builtin functionp (x)
- (js!bool `(code "(typeof " ,x " == 'function')")))
+ (js!bool `(=== (typeof ,x) "function")))
(define-builtin %write-string (x)
- `(code "lisp.write(" ,x ")"))
+ `(call (get |lisp| "write") ,x))
(define-builtin /debug (x)
- `(code "console.log(xstring(" ,x "))"))
+ `(call (get |console| "log") (call |xstring| ,x)))
;;; Storage vectors. They are used to implement arrays and (in the
(define-builtin storage-vector-p (x)
(js!bool
- (js!selfcall
- "var x = " x ";"
- "return typeof x === 'object' && 'length' in x;")))
+ (js!selfcall*
+ `(var (x ,x))
+ `(return (and (=== (typeof x) "object") (in "length" x))))))
(define-builtin make-storage-vector (n)
- (js!selfcall
- "var r = [];"
- "r.length = " n ";"
- "return r;" ))
+ (js!selfcall*
+ `(var (r #()))
+ `(= (get r "length") ,n)
+ `(return r)))
(define-builtin storage-vector-size (x)
- `(code ,x ".length"))
+ `(get ,x "length"))
(define-builtin resize-storage-vector (vector new-size)
- `(code "(" ,vector ".length = " ,new-size ")"))
+ `(= (get ,vector "length") ,new-size))
(define-builtin storage-vector-ref (vector n)
- (js!selfcall
- "var x = " "(" vector ")[" n "];"
- "if (x === undefined) throw 'Out of range';"
- "return x;" ))
+ (js!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 (i < 0 || i >= x.length) throw 'Out of range';"
- "return x[i] = " 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))))
(define-builtin concatenate-storage-vector (sv1 sv2)
- (js!selfcall
- "var sv1 = " sv1 ";"
- "var r = sv1.concat(" sv2 ");"
- "r.type = sv1.type;"
- "r.stringp = sv1.stringp;"
- "return r;" ))
+ (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)))
(define-builtin get-internal-real-time ()
- "(new Date()).getTime()")
+ `(call (get (new (call |Date|)) "getTime")))
(define-builtin values-array (array)
(if *multiple-value-p*
- `(code "values.apply(this, " ,array ")")
- `(code "pv.apply(this, " ,array ")")))
+ `(call (get |values| "apply") this ,array)
+ `(call (get |pv| "apply") this ,array)))
(define-raw-builtin values (&rest args)
(if *multiple-value-p*
- `(code "values(" ,@(interleave (mapcar #'ls-compile args) ",") ")")
- `(code "pv(" ,@(interleave (mapcar #'ls-compile args) ", ") ")")))
-
+ `(call |values| ,@(mapcar #'ls-compile args))
+ `(call |pv| ,@(mapcar #'ls-compile args))))
;;; Javascript FFI
-(define-builtin new () "{}")
+(define-builtin new ()
+ '(object))
(define-raw-builtin oget* (object key &rest keys)
- (js!selfcall
- "var tmp = (" (ls-compile object) ")[xstring(" (ls-compile key) ")];"
- `(code
- ,@(mapcar (lambda (key)
- `(code "if (tmp === undefined) return " ,(ls-compile nil) ";"
- "tmp = tmp[xstring(" ,(ls-compile key) ")];" ))
- keys))
- "return tmp === undefined? " (ls-compile nil) " : tmp;" ))
+ (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))))
(define-raw-builtin oset* (value object key &rest keys)
(let ((keys (cons key keys)))
- (js!selfcall
- "var obj = " (ls-compile object) ";"
- `(code ,@(mapcar (lambda (key)
- `(code "obj = obj[xstring(" ,(ls-compile key) ")];"
- "if (obj === undefined) throw 'Impossible to set Javascript property.';" ))
- (butlast keys)))
- "var tmp = obj[xstring(" (ls-compile (car (last keys))) ")] = " (ls-compile value) ";"
- "return tmp === undefined? " (ls-compile nil) " : tmp;" )))
+ (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))))))
(define-raw-builtin oget (object key &rest keys)
`(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys))))
(js!bool `(in (call |xstring| ,key) ,object)))
(define-builtin map-for-in (function object)
- (js!selfcall
- "var f = " function ";"
- "var g = (typeof f === 'function' ? f : f.fvalue);"
- "var o = " object ";"
- "for (var key in o){"
- `(code "g(" ,(if *multiple-value-p* "values" "pv") ", 1, o[key]);" )
- "}"
- " return " (ls-compile nil) ";" ))
+ (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))))
(define-compilation %js-vref (var)
- `(code "js_to_lisp(" ,var ")"))
+ `(call |js_to_lisp| ,(make-symbol var)))
(define-compilation %js-vset (var val)
- `(code "(" ,var " = lisp_to_js(" ,(ls-compile val) "))"))
+ `(= ,(make-symbol var) (call |lisp_to_js| ,(ls-compile val))))
(define-setf-expander %js-vref (var)
(let ((new-value (gensym)))
projects / jscl.git / blobdiff