X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=1c0bad185aa31a748fb30af99995529d16cccd5b;hb=030869df1e9829e0b284b96e585bdda7d45e0602;hp=0ce17c36a349db743d945df93731a12a42b93b5e;hpb=25d3ce6406a74dca652ff4bb27f025986626958a;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 0ce17c3..1c0bad1 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -20,51 +20,19 @@ (/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 ;;; the beginning of this file) as well as some primitive functions. -(defun interleave (list element &optional after-last-p) - (unless (null list) - (with-collect - (collect (car list)) - (dolist (x (cdr list)) - (collect element) - (collect x)) - (when after-last-p - (collect element))))) - -(defun code (&rest args) - (mapconcat (lambda (arg) - (cond - ((null arg) "") - ((integerp arg) (integer-to-string arg)) - ((floatp arg) (float-to-string arg)) - ((stringp arg) arg) - (t - (with-output-to-string (*standard-output*) - (js-expr arg))))) - args)) - -;;; 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. -;;; It could be defined as function, but we could do some -;;; preprocessing in the future. -(defmacro js!selfcall (&body body) - ``(call (function nil (code ,,@body)))) - - -;;; Like CODE, but prefix each line with four spaces. Two versions -;;; of this function are available, because the Ecmalisp version is -;;; very slow and bootstraping was annoying. +(define-js-macro selfcall (&body body) + `(call (function () ,@body))) + +(define-js-macro bool (expr) + `(if ,expr ,(convert t) ,(convert nil))) + +(define-js-macro method-call (x method &rest args) + `(call (get ,x ,method) ,@args)) ;;; A Form can return a multiple values object calling VALUES, like ;;; values(arg1, arg2, ...). It will work in any context, as well as @@ -115,7 +83,7 @@ (defun gvarname (symbol) (declare (ignore symbol)) (incf *variable-counter*) - (concat "v" (integer-to-string *variable-counter*))) + (make-symbol (concat "v" (integer-to-string *variable-counter*)))) (defun translate-variable (symbol) (awhen (lookup-in-lexenv symbol *environment* 'variable) @@ -137,7 +105,7 @@ (reverse *toplevel-compilations*)) (defun %compile-defmacro (name lambda) - (toplevel-compilation (ls-compile `',name)) + (toplevel-compilation (convert `',name)) (let ((binding (make-binding :name name :type 'macro :value lambda))) (push-to-lexenv binding *environment* 'function)) name) @@ -192,9 +160,9 @@ *compilations*)) (define-compilation if (condition true &optional false) - `(if (!== ,(ls-compile condition) ,(ls-compile nil)) - ,(ls-compile true *multiple-value-p*) - ,(ls-compile false *multiple-value-p*))) + `(if (!== ,(convert condition) ,(convert nil)) + ,(convert true *multiple-value-p*) + ,(convert false *multiple-value-p*))) (defvar *ll-keywords* '(&optional &rest &key)) @@ -278,11 +246,11 @@ (dotimes (idx n-optional-arguments) (let ((arg (nth idx optional-arguments))) (collect `(case ,(+ idx n-required-arguments))) - (collect `(= ,(make-symbol (translate-variable (car arg))) - ,(ls-compile (cadr arg)))) + (collect `(= ,(translate-variable (car arg)) + ,(convert (cadr arg)))) (collect (when (third arg) - `(= ,(make-symbol (translate-variable (third arg))) - ,(ls-compile nil)))))) + `(= ,(translate-variable (third arg)) + ,(convert nil)))))) (collect 'default) (collect '(break))))))) @@ -291,9 +259,9 @@ (n-optional-arguments (length (ll-optional-arguments ll))) (rest-argument (ll-rest-argument ll))) (when rest-argument - (let ((js!rest (make-symbol (translate-variable rest-argument)))) + (let ((js!rest (translate-variable rest-argument))) `(progn - (var (,js!rest ,(ls-compile nil))) + (var (,js!rest ,(convert nil))) (var i) (for ((= i (- |nargs| 1)) (>= i ,(+ n-required-arguments n-optional-arguments)) @@ -315,11 +283,11 @@ (destructuring-bind ((keyword-name var) &optional initform svar) keyword-argument (declare (ignore keyword-name initform)) - (collect `(var ,(make-symbol (translate-variable var)))) + (collect `(var ,(translate-variable var))) (when svar (collect - `(var (,(make-symbol (translate-variable svar)) - ,(ls-compile nil)))))))) + `(var (,(translate-variable svar) + ,(convert nil)))))))) ;; Parse keywords ,(flet ((parse-keyword (keyarg) @@ -331,16 +299,15 @@ (+= i 2)) ;; .... (if (=== (property |arguments| (+ i 2)) - ,(ls-compile keyword-name)) + ,(convert keyword-name)) (progn - (= ,(make-symbol (translate-variable var)) + (= ,(translate-variable var) (property |arguments| (+ i 3))) - ,(when svar `(= ,(make-symbol (translate-variable svar)) - ,(ls-compile t))) + ,(when svar `(= ,(translate-variable svar) + ,(convert t))) (break)))) (if (== i |nargs|) - (= ,(make-symbol (translate-variable var)) - ,(ls-compile initform))))))) + (= ,(translate-variable var) ,(convert initform))))))) (when keyword-arguments `(progn (var i) @@ -357,7 +324,7 @@ (destructuring-bind ((keyword-name var) &optional initform svar) keyword-argument (declare (ignore var initform svar)) - `(!== (property |arguments| (+ i 2)) ,(ls-compile keyword-name)))) + `(!== (property |arguments| (+ i 2)) ,(convert keyword-name)))) keyword-arguments)) (throw (+ "Unknown keyword argument " (call |xstring| @@ -416,7 +383,7 @@ (ll-svars ll))))) (lambda-name/docstring-wrapper name documentation `(function (|values| |nargs| ,@(mapcar (lambda (x) - (make-symbol (translate-variable x))) + (translate-variable x)) (append required-arguments optional-arguments))) ;; Check number of arguments ,(lambda-check-argument-count n-required-arguments @@ -428,8 +395,8 @@ ,(let ((*multiple-value-p* t)) (if block - (ls-compile-block `((block ,block ,@body)) t) - (ls-compile-block body t))))))))) + (convert-block `((block ,block ,@body)) t) + (convert-block body t))))))))) (defun setq-pair (var val) @@ -439,19 +406,17 @@ (eq (binding-type b) 'variable) (not (member 'special (binding-declarations b))) (not (member 'constant (binding-declarations b)))) - ;; TODO: Unnecesary make-symbol when codegen migration is - ;; finished. - `(= ,(make-symbol (binding-value b)) ,(ls-compile val))) + `(= ,(binding-value b) ,(convert val))) ((and b (eq (binding-type b) 'macro)) - (ls-compile `(setf ,var ,val))) + (convert `(setf ,var ,val))) (t - (ls-compile `(set ',var ,val)))))) + (convert `(set ',var ,val)))))) (define-compilation setq (&rest pairs) (let ((result nil)) (when (null pairs) - (return-from setq (ls-compile nil))) + (return-from setq (convert nil))) (while t (cond ((null pairs) @@ -491,7 +456,7 @@ (defun genlit () (incf *literal-counter*) - (concat "l" (integer-to-string *literal-counter*))) + (make-symbol (concat "l" (integer-to-string *literal-counter*)))) (defun dump-symbol (symbol) #-jscl @@ -503,7 +468,7 @@ (let ((package (symbol-package symbol))) (if (null package) `(new (call |Symbol| ,(dump-string (symbol-name symbol)))) - (ls-compile `(intern ,(symbol-name symbol) ,(package-name package)))))) + (convert `(intern ,(symbol-name symbol) ,(package-name package)))))) (defun dump-cons (cons) (let ((head (butlast cons)) @@ -524,9 +489,7 @@ (cond ((integerp sexp) sexp) ((floatp sexp) sexp) - ((characterp sexp) - ;; TODO: Remove selfcall after migration - `(selfcall (return ,(string sexp)))) + ((characterp sexp) (string sexp)) (t (or (cdr (assoc sexp *literal-table* :test #'eql)) (let ((dumped (typecase sexp @@ -538,17 +501,17 @@ ;; `dump-global-environment' for futher ;; information. (if (eq (car sexp) *magic-unquote-marker*) - (ls-compile (second sexp)) + (convert (second sexp)) (dump-cons sexp))) (array (dump-array sexp))))) (if (and recursive (not (symbolp sexp))) dumped (let ((jsvar (genlit))) - (push (cons sexp (make-symbol jsvar)) *literal-table*) - (toplevel-compilation `(var (,(make-symbol jsvar) ,dumped))) + (push (cons sexp jsvar) *literal-table*) + (toplevel-compilation `(var (,jsvar ,dumped))) (when (keywordp sexp) - (toplevel-compilation `(= ,(get (make-symbol jsvar) "value") ,(make-symbol jsvar)))) - (make-symbol jsvar)))))))) + (toplevel-compilation `(= ,(get jsvar "value") ,jsvar))) + jsvar))))))) (define-compilation quote (sexp) @@ -556,12 +519,9 @@ (define-compilation %while (pred &rest body) `(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)))) + (while (!== ,(convert pred) ,(convert nil)) + ,(convert-block body)) + (return ,(convert nil)))) (define-compilation function (x) (cond @@ -575,8 +535,8 @@ ((symbolp x) (let ((b (lookup-in-lexenv x *environment* 'function))) (if b - (make-symbol (binding-value b)) - (ls-compile `(symbol-function ',x))))))) + (binding-value b) + (convert `(symbol-function ',x))))))) (defun make-function-binding (fname) (make-binding :name fname :type 'function :value (gvarname fname))) @@ -599,8 +559,8 @@ (extend-lexenv (mapcar #'make-function-binding fnames) *environment* 'function))) - `(call (function ,(mapcar #'make-symbol (mapcar #'translate-function fnames)) - ,(ls-compile-block body t)) + `(call (function ,(mapcar #'translate-function fnames) + ,(convert-block body t)) ,@cfuncs))) (define-compilation labels (definitions &rest body) @@ -611,11 +571,11 @@ 'function))) `(selfcall ,@(mapcar (lambda (func) - `(var (,(make-symbol (translate-function (car func))) + `(var (,(translate-function (car func)) ,(compile-lambda (cadr func) `((block ,(car func) ,@(cddr func))))))) definitions) - ,(ls-compile-block body t)))) + ,(convert-block body t)))) (defvar *compiling-file* nil) @@ -623,19 +583,19 @@ (if *compiling-file* (progn (eval (cons 'progn body)) - (ls-compile 0)) - (ls-compile `(progn ,@body)))) + (convert 0)) + (convert `(progn ,@body)))) (defmacro define-transformation (name args form) `(define-compilation ,name ,args - (ls-compile ,form))) + (convert ,form))) (define-compilation progn (&rest body) (if (null (cdr body)) - (ls-compile (car body) *multiple-value-p*) + (convert (car body) *multiple-value-p*) `(progn - ,@(append (mapcar #'ls-compile (butlast body)) - (list (ls-compile (car (last body)) t)))))) + ,@(append (mapcar #'convert (butlast body)) + (list (convert (car (last body)) t)))))) (define-compilation macrolet (definitions &rest body) (let ((*environment* (copy-lexenv *environment*))) @@ -647,7 +607,7 @@ (destructuring-bind ,lambda-list ,g!form ,@body)))))) (push-to-lexenv binding *environment* 'function)))) - (ls-compile `(progn ,@body) *multiple-value-p*))) + (convert `(progn ,@body) *multiple-value-p*))) (defun special-variable-p (x) @@ -665,7 +625,7 @@ (try (var tmp) ,@(with-collect (dolist (b bindings) - (let ((s (ls-compile `',(car b)))) + (let ((s (convert `',(car b)))) (collect `(= tmp (get ,s "value"))) (collect `(= (get ,s "value") ,(cdr b))) (collect `(= ,(cdr b) tmp))))) @@ -673,23 +633,23 @@ (finally ,@(with-collect (dolist (b bindings) - (let ((s (ls-compile `(quote ,(car b))))) + (let ((s (convert `(quote ,(car b))))) (collect `(= (get ,s "value") ,(cdr b))))))))) (define-compilation let (bindings &rest body) (let* ((bindings (mapcar #'ensure-list bindings)) (variables (mapcar #'first bindings)) - (cvalues (mapcar #'ls-compile (mapcar #'second bindings))) + (cvalues (mapcar #'convert (mapcar #'second bindings))) (*environment* (extend-local-env (remove-if #'special-variable-p variables))) (dynamic-bindings)) `(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)))) + (push (cons x v) dynamic-bindings) + v) + (translate-variable x))) variables) - ,(let ((body (ls-compile-block body t t))) + ,(let ((body (convert-block body t t))) `,(let-binding-wrapper dynamic-bindings body))) ,@cvalues))) @@ -700,10 +660,10 @@ (let ((var (first binding)) (value (second binding))) (if (special-variable-p var) - (ls-compile `(setq ,var ,value)) + (convert `(setq ,var ,value)) (let* ((v (gvarname var)) (b (make-binding :name var :type 'variable :value v))) - (prog1 `(var (,(make-symbol v) ,(ls-compile value))) + (prog1 `(var (,v ,(convert value))) (push-to-lexenv b *environment* 'variable)))))) ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It @@ -717,14 +677,14 @@ `(progn (try ,@(mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(var (,(make-symbol (cdr b)) (get ,s "value"))))) + (let ((s (convert `(quote ,(car b))))) + `(var (,(cdr b) (get ,s "value"))))) store) ,body) (finally ,@(mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(= (get ,s "value") ,(make-symbol (cdr b))))) + (let ((s (convert `(quote ,(car b))))) + `(= (get ,s "value") ,(cdr b)))) store))))) (define-compilation let* (bindings &rest body) @@ -733,7 +693,7 @@ (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) (body `(progn ,@(mapcar #'let*-initialize-value bindings) - ,(ls-compile-block body t t)))) + ,(convert-block body t t)))) `(selfcall ,(let*-binding-wrapper specials body))))) @@ -749,20 +709,19 @@ (when *multiple-value-p* (push 'multiple-value (binding-declarations b))) (let* ((*environment* (extend-lexenv (list b) *environment* 'block)) - (cbody (ls-compile-block body t))) + (cbody (convert-block body t))) (if (member 'used (binding-declarations b)) `(selfcall (try - (var (,(make-symbol idvar) #())) + (var (,idvar #())) ,cbody) (catch (cf) (if (and (== (get cf "type") "block") - (== (get cf "id") ,(make-symbol idvar))) + (== (get cf "id") ,idvar)) ,(if *multiple-value-p* - `(return (call (get |values| "apply") this (call |forcemv| (get cf "values")))) + `(return (method-call |values| "apply" this (call |forcemv| (get cf "values")))) `(return (get cf "values"))) (throw cf)))) - ;; TODO: is selfcall necessary here? `(selfcall ,cbody))))) (define-compilation return-from (name &optional value) @@ -780,35 +739,31 @@ (throw (object "type" "block" - "id" ,(make-symbol (binding-value b)) - "values" ,(ls-compile value multiple-value-p) + "id" ,(binding-value b) + "values" ,(convert value multiple-value-p) "message" ,(concat "Return from unknown block '" (symbol-name name) "'.")))))) (define-compilation catch (id &rest body) `(selfcall - (var (|id| ,(ls-compile id))) + (var (id ,(convert id))) (try - ,(ls-compile-block body t)) + ,(convert-block body t)) (catch (|cf|) (if (and (== (get |cf| "type") "catch") - (== (get |cf| "id") |id|)) + (== (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"))))) + `(return (method-call |values| "apply" this (call |forcemv| (get |cf| "values")))) + `(return (method-call |pv| "apply" this (call |forcemv| (get |cf| "values"))))) (throw |cf|))))) (define-compilation throw (id value) `(selfcall (var (|values| |mv|)) (throw (object - |type| "catch" - |id| ,(ls-compile id) - |values| ,(ls-compile value t) - |message| "Throw uncatched.")))) + "type" "catch" + "id" ,(convert id) + "values" ,(convert value t) + "message" "Throw uncatched.")))) (defun go-tag-p (x) (or (integerp x) (symbolp x))) @@ -827,7 +782,7 @@ ;; because 1) it is easy and 2) many built-in forms expand to a ;; implicit tagbody, so we save some space. (unless (some #'go-tag-p body) - (return-from tagbody (ls-compile `(progn ,@body nil)))) + (return-from tagbody (convert `(progn ,@body nil)))) ;; The translation assumes the first form in BODY is a label (unless (go-tag-p (car body)) (push (gensym "START") body)) @@ -840,27 +795,27 @@ (setq initag (second (binding-value b)))) `(selfcall ;; TAGBODY branch to take - (var (,(make-symbol branch) ,initag)) - (var (,(make-symbol tbidx) #())) + (var (,branch ,initag)) + (var (,tbidx #())) (label tbloop (while true (try - (switch ,(make-symbol branch) + (switch ,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))))) - (collect (ls-compile form))))) + (collect (convert form))))) default (break tbloop))) (catch (jump) (if (and (== (get jump "type") "tagbody") - (== (get jump "id") ,(make-symbol tbidx))) - (= ,(make-symbol branch) (get jump "label")) + (== (get jump "id") ,tbidx)) + (= ,branch (get jump "label")) (throw jump))))) - (return ,(ls-compile nil)))))) + (return ,(convert nil)))))) (define-compilation go (label) (let ((b (lookup-in-lexenv label *environment* 'gotag)) @@ -873,22 +828,22 @@ (throw (object "type" "tagbody" - "id" ,(make-symbol (first (binding-value b))) + "id" ,(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) `(selfcall - (var (|ret| ,(ls-compile nil))) + (var (ret ,(convert nil))) (try - (= |ret| ,(ls-compile form))) + (= ret ,(convert form))) (finally - ,(ls-compile-block clean-up)) - (return |ret|))) + ,(convert-block clean-up)) + (return ret))) (define-compilation multiple-value-call (func-form &rest forms) `(selfcall - (var (func ,(ls-compile func-form))) + (var (func ,(convert func-form))) (var (args ,(vector (if *multiple-value-p* '|values| '|pv|) 0))) (return (selfcall @@ -897,19 +852,18 @@ (progn ,@(with-collect (dolist (form forms) - (collect `(= vs ,(ls-compile form t))) + (collect `(= vs ,(convert form t))) (collect `(if (and (=== (typeof vs) "object") (in "multiple-value" vs)) - (= args (call (get args "concat") vs)) - (call (get args "push") vs)))))) + (= args (method-call args "concat" vs)) + (method-call args "push" vs)))))) (= (property args 1) (- (property args "length") 2)) - (return (call (get func "apply") |window| args)))))) + (return (method-call func "apply" |window| args)))))) (define-compilation multiple-value-prog1 (first-form &rest forms) `(selfcall - (var (args ,(ls-compile first-form *multiple-value-p*))) - ;; TODO: Interleave is temporal - (progn ,@(mapcar #'ls-compile forms)) + (var (args ,(convert first-form *multiple-value-p*))) + (progn ,@(mapcar #'convert forms)) (return args))) (define-transformation backquote (form) @@ -929,7 +883,7 @@ (defmacro define-builtin (name args &body body) `(define-raw-builtin ,name ,args - (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args) + (let ,(mapcar (lambda (arg) `(,arg (convert ,arg))) args) ,@body))) ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for @@ -948,7 +902,7 @@ (push x fargs) (let ((v (make-symbol (concat "x" (integer-to-string (incf counter)))))) (push v fargs) - (push `(var (,v ,(ls-compile x))) + (push `(var (,v ,(convert x))) prelude) (push `(if (!= (typeof ,v) "number") (throw "Not a number!")) @@ -1017,13 +971,13 @@ `(bool (== (typeof ,x) "number"))) (define-builtin floor (x) - `(call (get |Math| |floor|) ,x)) + `(method-call |Math| "floor" ,x)) (define-builtin expt (x y) - `(call (get |Math| |pow|) ,x ,y)) + `(method-call |Math| "pow" ,x ,y)) (define-builtin float-to-string (x) - `(call |make_lisp_string| (call (get ,x |toString|)))) + `(call |make_lisp_string| (method-call ,x |toString|))) (define-builtin cons (x y) `(object "car" ,x "cdr" ,y)) @@ -1037,15 +991,15 @@ (define-builtin car (x) `(selfcall (var (tmp ,x)) - (return (if (=== tmp ,(ls-compile nil)) - ,(ls-compile nil) + (return (if (=== tmp ,(convert nil)) + ,(convert nil) (get tmp "car"))))) (define-builtin cdr (x) `(selfcall (var (tmp ,x)) - (return (if (=== tmp ,(ls-compile nil)) - ,(ls-compile nil) + (return (if (=== tmp ,(convert nil)) + ,(convert nil) (get tmp "cdr"))))) (define-builtin rplaca (x new) @@ -1092,10 +1046,10 @@ (return func))) (define-builtin symbol-plist (x) - `(or (get ,x "plist") ,(ls-compile nil))) + `(or (get ,x "plist") ,(convert nil))) (define-builtin lambda-code (x) - `(call |make_lisp_string| (call (get ,x "toString")))) + `(call |make_lisp_string| (method-call ,x "toString"))) (define-builtin eq (x y) `(bool (=== ,x ,y))) @@ -1130,42 +1084,42 @@ (define-raw-builtin funcall (func &rest args) `(selfcall - (var (f ,(ls-compile func))) + (var (f ,(convert func))) (return (call (if (=== (typeof f) "function") f (get f "fvalue")) ,@(list* (if *multiple-value-p* '|values| '|pv|) (length args) - (mapcar #'ls-compile args)))))) + (mapcar #'convert args)))))) (define-raw-builtin apply (func &rest args) (if (null args) - (ls-compile func) + (convert func) (let ((args (butlast args)) (last (car (last args)))) `(selfcall - (var (f ,(ls-compile func))) + (var (f ,(convert 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)) - (call (get args "push") (get tail "car")) + (mapcar #'convert args))))) + (var (tail ,(convert last))) + (while (!= tail ,(convert nil)) + (method-call args "push" (get tail "car")) (post++ (property args 1)) (= tail (get tail "cdr"))) - (return (call (get (if (=== (typeof f) "function") - f - (get f "fvalue")) - "apply") - this - args)))))) + (return (method-call (if (=== (typeof f) "function") + f + (get f "fvalue")) + "apply" + this + args)))))) (define-builtin js-eval (string) (if *multiple-value-p* `(selfcall (var (v (call |globalEval| (call |xstring| ,string)))) - (return (call (get |values| "apply") this (call |forcemv| v)))) + (return (method-call |values| "apply" this (call |forcemv| v)))) `(call |globalEval| (call |xstring| ,string)))) (define-builtin %throw (string) @@ -1175,10 +1129,10 @@ `(bool (=== (typeof ,x) "function"))) (define-builtin %write-string (x) - `(call (get |lisp| "write") ,x)) + `(method-call |lisp| "write" ,x)) (define-builtin /debug (x) - `(call (get |console| "log") (call |xstring| ,x))) + `(method-call |console| "log" (call |xstring| ,x))) ;;; Storage vectors. They are used to implement arrays and (in the @@ -1218,23 +1172,23 @@ (define-builtin concatenate-storage-vector (sv1 sv2) `(selfcall (var (sv1 ,sv1)) - (var (r (call (get sv1 "concat") ,sv2))) + (var (r (method-call 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"))) + `(method-call (new (call |Date|)) "getTime")) (define-builtin values-array (array) (if *multiple-value-p* - `(call (get |values| "apply") this ,array) - `(call (get |pv| "apply") this ,array))) + `(method-call |values| "apply" this ,array) + `(method-call |pv| "apply" this ,array))) (define-raw-builtin values (&rest args) (if *multiple-value-p* - `(call |values| ,@(mapcar #'ls-compile args)) - `(call |pv| ,@(mapcar #'ls-compile args)))) + `(call |values| ,@(mapcar #'convert args)) + `(call |pv| ,@(mapcar #'convert args)))) ;;; Javascript FFI @@ -1244,37 +1198,37 @@ (define-raw-builtin oget* (object key &rest keys) `(selfcall (progn - (var (tmp (property ,(ls-compile object) (call |xstring| ,(ls-compile key))))) + (var (tmp (property ,(convert object) (call |xstring| ,(convert key))))) ,@(mapcar (lambda (key) `(progn - (if (=== tmp undefined) (return ,(ls-compile nil))) - (= tmp (property tmp (call |xstring| ,(ls-compile key)))))) + (if (=== tmp undefined) (return ,(convert nil))) + (= tmp (property tmp (call |xstring| ,(convert key)))))) keys)) - (return (if (=== tmp undefined) ,(ls-compile nil) tmp)))) + (return (if (=== tmp undefined) ,(convert nil) tmp)))) (define-raw-builtin oset* (value object key &rest keys) (let ((keys (cons key keys))) `(selfcall (progn - (var (obj ,(ls-compile object))) + (var (obj ,(convert object))) ,@(mapcar (lambda (key) `(progn - (= obj (property obj (call |xstring| ,(ls-compile key)))) + (= obj (property obj (call |xstring| ,(convert 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)))) + (= (property obj (call |xstring| ,(convert (car (last keys))))) + ,(convert value)))) (return (if (=== tmp undefined) - ,(ls-compile nil) + ,(convert nil) tmp)))))) (define-raw-builtin oget (object key &rest keys) - `(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys)))) + `(call |js_to_lisp| ,(convert `(oget* ,object ,key ,@keys)))) (define-raw-builtin oset (value object key &rest keys) - (ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) + (convert `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) (define-builtin objectp (x) `(bool (=== (typeof ,x) "object"))) @@ -1293,13 +1247,13 @@ (o ,object)) (for-in (key o) (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key"))) - (return ,(ls-compile nil)))) + (return ,(convert nil)))) (define-compilation %js-vref (var) `(call |js_to_lisp| ,(make-symbol var))) (define-compilation %js-vset (var val) - `(= ,(make-symbol var) (call |lisp_to_js| ,(ls-compile val)))) + `(= ,(make-symbol var) (call |lisp_to_js| ,(convert val)))) (define-setf-expander %js-vref (var) (let ((new-value (gensym))) @@ -1359,41 +1313,47 @@ (defun compile-funcall (function args) (let* ((arglist (list* (if *multiple-value-p* '|values| '|pv|) (length args) - (mapcar #'ls-compile args)))) + (mapcar #'convert args)))) (unless (or (symbolp function) (and (consp function) (member (car function) '(lambda oget)))) (error "Bad function designator `~S'" function)) (cond ((translate-function function) - `(call ,(make-symbol (translate-function function)) ,@arglist)) + `(call ,(translate-function function) ,@arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) #-jscl t) - `(call (get ,(ls-compile `',function) "fvalue") ,@arglist)) + `(method-call ,(convert `',function) "fvalue" ,@arglist)) #+jscl((symbolp function) - `(call ,(ls-compile `#',function) ,@arglist)) + `(call ,(convert `#',function) ,@arglist)) ((and (consp function) (eq (car function) 'lambda)) - `(call ,(ls-compile `#',function) ,@arglist)) + `(call ,(convert `#',function) ,@arglist)) ((and (consp function) (eq (car function) 'oget)) - `(call ,(ls-compile function) ,@arglist)) + `(call |js_to_lisp| + (call ,(reduce (lambda (obj p) + `(property ,obj (call |xstring| ,p))) + (mapcar #'convert (cdr function))) + ,@(mapcar (lambda (s) + `(call |lisp_to_js| ,s)) + args)))) (t (error "Bad function descriptor"))))) -(defun ls-compile-block (sexps &optional return-last-p decls-allowed-p) +(defun convert-block (sexps &optional return-last-p decls-allowed-p) (multiple-value-bind (sexps decls) (parse-body sexps :declarations decls-allowed-p) (declare (ignore decls)) (if return-last-p `(progn - ,@(mapcar #'ls-compile (butlast sexps)) - (return ,(ls-compile (car (last sexps)) *multiple-value-p*))) - `(progn ,@(mapcar #'ls-compile sexps))))) + ,@(mapcar #'convert (butlast sexps)) + (return ,(convert (car (last sexps)) *multiple-value-p*))) + `(progn ,@(mapcar #'convert sexps))))) -(defun ls-compile* (sexp &optional multiple-value-p) +(defun convert (sexp &optional multiple-value-p) (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp) (when expandedp - (return-from ls-compile* (ls-compile sexp multiple-value-p))) + (return-from convert (convert sexp multiple-value-p))) ;; The expression has been macroexpanded. Now compile it! (let ((*multiple-value-p* multiple-value-p)) (cond @@ -1401,12 +1361,12 @@ (let ((b (lookup-in-lexenv sexp *environment* 'variable))) (cond ((and b (not (member 'special (binding-declarations b)))) - (make-symbol (binding-value b))) + (binding-value b)) ((or (keywordp sexp) (and b (member 'constant (binding-declarations b)))) - `(get ,(ls-compile `',sexp) "value")) + `(get ,(convert `',sexp) "value")) (t - (ls-compile `(symbol-value ',sexp)))))) + (convert `(symbol-value ',sexp)))))) ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp)) (literal sexp)) ((listp sexp) @@ -1427,9 +1387,6 @@ (t (error "How should I compile `~S'?" sexp)))))) -(defun ls-compile (sexp &optional multiple-value-p) - (ls-compile* sexp multiple-value-p)) - (defvar *compile-print-toplevels* nil) @@ -1452,12 +1409,11 @@ (when *compile-print-toplevels* (let ((form-string (prin1-to-string sexp))) (format t "Compiling ~a..." (truncate-string form-string)))) - (let ((code (ls-compile sexp multiple-value-p))) + (let ((code (convert sexp multiple-value-p))) `(progn ,@(get-toplevel-compilations) - (code ,code "; -"))))))) + ,code)))))) -(defun ls-compile-toplevel (sexp &optional multiple-value-p) +(defun compile-toplevel (sexp &optional multiple-value-p) (with-output-to-string (*standard-output*) (js (convert-toplevel sexp multiple-value-p))))