X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=af7acb6dad6f38bcf6b4d02200e13a9f1a060ac5;hb=e8e89355662f04c69f67f93cc2aef4542b077892;hp=57a7e79c5dd759f2698cb1ca866e9b2b0d71e427;hpb=6221b6afc66203e2e68be6fa142558e69a7d31b2;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 57a7e79..af7acb6 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -117,7 +117,8 @@ (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) @@ -250,10 +251,10 @@ (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) @@ -495,7 +496,8 @@ (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 @@ -571,11 +573,7 @@ ((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))) @@ -607,11 +605,9 @@ (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)) @@ -619,13 +615,13 @@ (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)))) @@ -817,15 +813,15 @@ `(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) @@ -1172,9 +1168,11 @@ (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)) @@ -1184,20 +1182,21 @@ (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) @@ -1222,22 +1221,22 @@ (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 @@ -1245,81 +1244,90 @@ (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)))) @@ -1338,20 +1346,19 @@ (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)))