X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=c02d326160121561dccf2867cb1683bbdf5fc623;hb=fbb8a269e0af1f0ea29cee2b0bc910c91595ddc0;hp=b1065ee8f50a8ae8b6f5910949ff6b08c66eff8d;hpb=dead14d8e0ceddb307fb535b0fe6be719cda3ee2;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index b1065ee..c02d326 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -251,8 +251,8 @@ (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)) @@ -265,13 +265,11 @@ (block nil ;; Special case: a positive exact number of arguments. (when (and (< 0 min) (eql min max)) - (return `(code "checkArgs(nargs, " ,min ");"))) + (return `(call |checkArgs| |nargs| ,min))) ;; General case: - `(code - ,(when (< 0 min) - `(code "checkArgsAtLeast(nargs, " ,min ");")) - ,(when (numberp max) - `(code "checkArgsAtMost(nargs, " ,max ");")))))) + `(progn + ,(when (< 0 min) `(call |checkArgsAtLeast| |nargs| ,min)) + ,(when (numberp max) `(call |checkArgsAtMost| |nargs| ,max)))))) (defun compile-lambda-optional (ll) (let* ((optional-arguments (ll-optional-arguments-canonical ll)) @@ -304,11 +302,15 @@ (n-optional-arguments (length (ll-optional-arguments ll))) (rest-argument (ll-rest-argument ll))) (when rest-argument - (let ((js!rest (translate-variable rest-argument))) - `(code "var " ,js!rest "= " ,(ls-compile nil) ";" - "for (var i = nargs-1; i>=" ,(+ n-required-arguments n-optional-arguments) - "; i--)" - (code ,js!rest " = {car: arguments[i+2], cdr: " ,js!rest "};")))))) + (let ((js!rest (make-symbol (translate-variable rest-argument)))) + `(progn + (var (,js!rest ,(ls-compile nil))) + (var i) + (for ((= i (- |nargs| 1)) + (>= i ,(+ n-required-arguments n-optional-arguments)) + (post-- i)) + (= ,js!rest (object "car" (property |arguments| (+ i 2)) + "cdr" ,js!rest)))))))) (defun compile-lambda-parse-keywords (ll) (let ((n-required-arguments @@ -417,26 +419,23 @@ keyword-arguments (ll-svars ll))))) (lambda-name/docstring-wrapper name documentation - `(code - "(function (" - ,(join (list* "values" - "nargs" - (mapcar #'translate-variable - (append required-arguments optional-arguments))) - ",") - "){" - ;; Check number of arguments - ,(lambda-check-argument-count n-required-arguments - n-optional-arguments - (or rest-argument keyword-arguments)) - ,(compile-lambda-optional ll) - ,(compile-lambda-rest ll) - ,(compile-lambda-parse-keywords ll) - ,(let ((*multiple-value-p* t)) - (if block - (ls-compile-block `((block ,block ,@body)) t) - (ls-compile-block body t))) - "})")))))) + `(function (|values| |nargs| ,@(mapcar (lambda (x) + (make-symbol (translate-variable x))) + (append required-arguments optional-arguments))) + ;; Check number of arguments + ,(lambda-check-argument-count n-required-arguments + n-optional-arguments + (or rest-argument keyword-arguments)) + (code + ,(compile-lambda-optional ll)) + ,(compile-lambda-rest ll) + (code + ,(compile-lambda-parse-keywords ll)) + + ,(let ((*multiple-value-p* t)) + (if block + (ls-compile-block `((block ,block ,@body)) t) + (ls-compile-block body t))))))))) (defun setq-pair (var val) @@ -573,11 +572,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))) @@ -609,11 +604,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)) @@ -621,13 +614,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)))) @@ -674,26 +667,20 @@ (defun let-binding-wrapper (bindings body) (when (null bindings) (return-from let-binding-wrapper body)) - `(code - "try {" - (code "var tmp;" - ,@(mapcar - (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(code "tmp = " ,s ".value;" - ,s ".value = " ,(cdr b) ";" - ,(cdr b) " = tmp;" ))) - bindings) - ,body - ) - "}" - "finally {" - (code - ,@(mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(code ,s ".value" " = " ,(cdr b) ";" ))) - bindings)) - "}" )) + `(progn + (try (var tmp) + ,@(with-collect + (dolist (b bindings) + (let ((s (ls-compile `',(car b)))) + (collect `(= tmp (get ,s "value"))) + (collect `(= (get ,s "value") ,(cdr b))) + (collect `(= ,(cdr b) tmp))))) + ,body) + (finally + ,@(with-collect + (dolist (b bindings) + (let ((s (ls-compile `(quote ,(car b))))) + (collect `(= (get ,s "value") ,(cdr b))))))))) (define-compilation let (bindings &rest body) (let* ((bindings (mapcar #'ensure-list bindings)) @@ -701,20 +688,16 @@ (cvalues (mapcar #'ls-compile (mapcar #'second bindings))) (*environment* (extend-local-env (remove-if #'special-variable-p variables))) (dynamic-bindings)) - `(code "(function(" - ,@(interleave - (mapcar (lambda (x) - (if (special-variable-p x) - (let ((v (gvarname x))) - (push (cons x v) dynamic-bindings) - v) - (translate-variable x))) - variables) - ",") - "){" - ,(let ((body (ls-compile-block body t t))) - `(code ,(let-binding-wrapper dynamic-bindings body))) - "})(" ,@(interleave cvalues ",") ")"))) + `(call (function ,(mapcar (lambda (x) + (if (special-variable-p x) + (let ((v (gvarname x))) + (push (cons x (make-symbol v)) dynamic-bindings) + (make-symbol v)) + (make-symbol (translate-variable x)))) + variables) + ,(let ((body (ls-compile-block body t t))) + `,(let-binding-wrapper dynamic-bindings body))) + ,@cvalues))) ;;; Return the code to initialize BINDING, and push it extending the @@ -819,15 +802,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) @@ -1174,9 +1157,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)) @@ -1193,15 +1178,14 @@ (== (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) @@ -1267,7 +1251,7 @@ (define-builtin storage-vector-ref (vector n) (js!selfcall* - `(var (x (get ,vector ,n))) + `(var (x (property ,vector ,n))) `(if (=== x undefined) (throw "Out of range.")) `(return x))) @@ -1288,18 +1272,17 @@ `(return r))) (define-builtin get-internal-real-time () - `(call (get (new (call 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 @@ -1309,11 +1292,11 @@ (define-raw-builtin oget* (object key &rest keys) (js!selfcall* `(progn - (var (tmp (get ,(ls-compile object) (call |xstring| ,(ls-compile key))))) + (var (tmp (property ,(ls-compile object) (call |xstring| ,(ls-compile key))))) ,@(mapcar (lambda (key) `(progn (if (=== tmp undefined) (return ,(ls-compile nil))) - (= tmp (get tmp (call |xstring| ,(ls-compile key)))))) + (= tmp (property tmp (call |xstring| ,(ls-compile key)))))) keys)) `(return (if (=== tmp undefined) ,(ls-compile nil) tmp)))) @@ -1324,12 +1307,12 @@ (var (obj ,(ls-compile object))) ,@(mapcar (lambda (key) `(progn - (= obj (get obj (call |xstring| ,(ls-compile key)))) + (= obj (property obj (call |xstring| ,(ls-compile key)))) (if (=== object undefined) (throw "Impossible to set object property.")))) (butlast keys)) (var (tmp - (= (get obj (call |xstring| ,(ls-compile (car (last keys))))) + (= (property obj (call |xstring| ,(ls-compile (car (last keys))))) ,(ls-compile value)))) (return (if (=== tmp undefined) ,(ls-compile nil) @@ -1361,10 +1344,10 @@ `(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)))