X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=1c0bad185aa31a748fb30af99995529d16cccd5b;hb=852666e17ad12f114ab5bb05a9d5ff065f8d72ff;hp=57248f746d565aa058cc84c6917d79566bf7b76e;hpb=495b4eb54403d32d69d575550f8718da044ca1f1;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 57248f7..1c0bad1 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -1,6 +1,6 @@ ;;; 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 @@ -25,48 +25,14 @@ ;;; 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)) - -;;; 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. -;;; 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)))) - -(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 -;;; 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 @@ -112,13 +78,12 @@ (defvar *environment* (make-lexenv)) - (defvar *variable-counter* 0) (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) @@ -140,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) @@ -195,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)) @@ -249,11 +214,11 @@ (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 @@ -281,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))))))) @@ -294,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)) @@ -318,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) @@ -334,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) @@ -360,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| @@ -419,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 @@ -431,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) @@ -442,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) @@ -482,6 +444,7 @@ ;;; evaluated. For this reason we define a valid macro-function for ;;; this symbol. (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE")) + #-jscl (setf (macro-function *magic-unquote-marker*) (lambda (form &optional environment) @@ -493,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 @@ -505,29 +468,28 @@ (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)) (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) (string sexp)) (t (or (cdr (assoc sexp *literal-table* :test #'eql)) (let ((dumped (typecase sexp @@ -539,16 +501,16 @@ ;; `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 jsvar) *literal-table*) - (toplevel-compilation `(code "var " ,jsvar " = " ,dumped)) + (toplevel-compilation `(var (,jsvar ,dumped))) (when (keywordp sexp) - (toplevel-compilation `(code ,jsvar ".value = " ,jsvar))) + (toplevel-compilation `(= ,(get jsvar "value") ,jsvar))) jsvar))))))) @@ -556,13 +518,10 @@ (literal sexp)) (define-compilation %while (pred &rest body) - (js!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)))) + `(selfcall + (while (!== ,(convert pred) ,(convert nil)) + ,(convert-block body)) + (return ,(convert nil)))) (define-compilation function (x) (cond @@ -577,8 +536,7 @@ (let ((b (lookup-in-lexenv x *environment* 'function))) (if b (binding-value b) - (ls-compile `(symbol-function ',x))))))) - + (convert `(symbol-function ',x))))))) (defun make-function-binding (fname) (make-binding :name fname :type 'function :value (gvarname fname))) @@ -601,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,14 +569,13 @@ (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 (,(translate-function (car func)) + ,(compile-lambda (cadr func) + `((block ,(car func) ,@(cddr func))))))) + definitions) + ,(convert-block body t)))) (defvar *compiling-file* nil) @@ -626,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*))) @@ -650,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) @@ -668,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))))) @@ -676,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))) @@ -703,10 +660,10 @@ (let ((var (first binding)) (value (second binding))) (if (special-variable-p var) - `(code ,(ls-compile `(setq ,var ,value)) ";" ) + (convert `(setq ,var ,value)) (let* ((v (gvarname var)) (b (make-binding :name var :type 'variable :value v))) - (prog1 `(code "var " ,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,31 +674,27 @@ (return-from let*-binding-wrapper body)) (let ((store (mapcar (lambda (s) (cons s (gvarname s))) (remove-if-not #'special-variable-p symbols)))) - `(code - "try {" - (code - ,@(mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(code "var " ,(cdr b) " = " ,s ".value;" ))) - store) - ,body) - "}" - "finally {" - (code - ,@(mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - `(code ,s ".value" " = " ,(cdr b) ";" ))) - store)) - "}" ))) + `(progn + (try + ,@(mapcar (lambda (b) + (let ((s (convert `(quote ,(car b))))) + `(var (,(cdr b) (get ,s "value"))))) + store) + ,body) + (finally + ,@(mapcar (lambda (b) + (let ((s (convert `(quote ,(car b))))) + `(= (get ,s "value") ,(cdr b)))) + store))))) (define-compilation let* (bindings &rest body) (let ((bindings (mapcar #'ensure-list bindings)) (*environment* (copy-lexenv *environment*))) - (js!selfcall - (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) - (body `(code ,@(mapcar #'let*-initialize-value bindings) - ,(ls-compile-block body t t)))) - (let*-binding-wrapper specials body))))) + (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) + (body `(progn + ,@(mapcar #'let*-initialize-value bindings) + ,(convert-block body t t)))) + `(selfcall ,(let*-binding-wrapper specials body))))) (define-compilation block (name &rest body) @@ -756,23 +709,20 @@ (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)) - (js!selfcall - "try {" - "var " idvar " = [];" - `(code ,cbody) - "}" - "catch (cf){" - " if (cf.type == 'block' && cf.id == " idvar ")" - (if *multiple-value-p* - " return values.apply(this, forcemv(cf.values));" - " return cf.values;") - - " else" - " throw cf;" - "}" ) - (js!selfcall cbody))))) + `(selfcall + (try + (var (,idvar #())) + ,cbody) + (catch (cf) + (if (and (== (get cf "type") "block") + (== (get cf "id") ,idvar)) + ,(if *multiple-value-p* + `(return (method-call |values| "apply" this (call |forcemv| (get cf "values")))) + `(return (get cf "values"))) + (throw cf)))) + `(selfcall ,cbody))))) (define-compilation return-from (name &optional value) (let* ((b (lookup-in-lexenv name *environment* 'block)) @@ -784,41 +734,36 @@ ;; 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" ,(binding-value b) + "values" ,(convert 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 ,(convert id))) + (try + ,(convert-block body t)) + (catch (|cf|) + (if (and (== (get |cf| "type") "catch") + (== (get |cf| "id") id)) + ,(if *multiple-value-p* + `(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) - (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" ,(convert id) + "values" ,(convert value t) + "message" "Throw uncatched.")))) (defun go-tag-p (x) (or (integerp x) (symbolp x))) @@ -837,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)) @@ -848,32 +793,29 @@ 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 (,branch ,initag)) + (var (,tbidx #())) + (label tbloop + (while true + (try + (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 (convert form))))) + default + (break tbloop))) + (catch (jump) + (if (and (== (get jump "type") "tagbody") + (== (get jump "id") ,tbidx)) + (= ,branch (get jump "label")) + (throw jump))))) + (return ,(convert nil)))))) (define-compilation go (label) (let ((b (lookup-in-lexenv label *environment* 'gotag)) @@ -882,47 +824,47 @@ ((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" ,(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 ,(convert nil))) + (try + (= ret ,(convert form))) + (finally + ,(convert-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 ,(convert 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 ,(convert form t))) + (collect `(if (and (=== (typeof vs) "object") + (in "multiple-value" vs)) + (= args (method-call args "concat" vs)) + (method-call args "push" vs)))))) + (= (property args 1) (- (property args "length") 2)) + (return (method-call 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 ,(convert first-form *multiple-value-p*))) + (progn ,@(mapcar #'convert forms)) + (return args))) (define-transformation backquote (form) (bq-completely-process form)) @@ -941,36 +883,14 @@ (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))) -;;; 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")) @@ -978,28 +898,24 @@ (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 ,(convert 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) @@ -1024,7 +940,8 @@ (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) @@ -1041,7 +958,7 @@ `(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 < <) @@ -1051,55 +968,48 @@ (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)")) + `(method-call |Math| "floor" ,x)) (define-builtin expt (x y) - (type-check (("x" "number" x) - ("y" "number" y)) - "Math.pow(x, y)")) + `(method-call |Math| "pow" ,x ,y)) (define-builtin float-to-string (x) - (type-check (("x" "number" x)) - "make_lisp_string(x.toString())")) + `(call |make_lisp_string| (method-call ,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 ,(convert nil)) + ,(convert 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 ,(convert nil)) + ,(convert 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))) @@ -1114,51 +1024,49 @@ `(= (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))) + `(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) - (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)) @@ -1167,80 +1075,79 @@ `(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 ,(convert func))) + (return (call (if (=== (typeof f) "function") + f + (get f "fvalue")) + ,@(list* (if *multiple-value-p* '|values| '|pv|) + (length 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)))) - (js!selfcall* - `(var (f ,(ls-compile func))) - `(var (args ,(list-to-vector + `(selfcall + (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* - (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 (method-call |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)) + `(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 ;;; 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")) @@ -1249,39 +1156,39 @@ `(= (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 (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 @@ -1289,64 +1196,64 @@ '(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 ,(convert object) (call |xstring| ,(convert key))))) + ,@(mapcar (lambda (key) + `(progn + (if (=== tmp undefined) (return ,(convert nil))) + (= tmp (property tmp (call |xstring| ,(convert key)))))) + keys)) + (return (if (=== tmp undefined) ,(convert 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 ,(convert object))) + ,@(mapcar (lambda (key) + `(progn + (= obj (property obj (call |xstring| ,(convert key)))) + (if (=== object undefined) + (throw "Impossible to set object property.")))) + (butlast keys)) + (var (tmp + (= (property obj (call |xstring| ,(convert (car (last keys))))) + ,(convert value)))) + (return (if (=== tmp undefined) + ,(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) - (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 ,(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))) @@ -1404,48 +1311,49 @@ (values form nil)))) (defun compile-funcall (function args) - (let* ((values-funcs (if *multiple-value-p* "values" "pv")) - (arglist `(code "(" ,@(interleave (list* values-funcs - (integer-to-string (length args)) - (mapcar #'ls-compile args)) - ", ") - ")"))) + (let* ((arglist (list* (if *multiple-value-p* '|values| '|pv|) + (length 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) - `(code ,(translate-function function) ,arglist)) + `(call ,(translate-function function) ,@arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) #-jscl t) - `(code ,(ls-compile `',function) ".fvalue" ,arglist)) + `(method-call ,(convert `',function) "fvalue" ,@arglist)) #+jscl((symbolp function) - `(code ,(ls-compile `#',function) ,arglist)) + `(call ,(convert `#',function) ,@arglist)) ((and (consp function) (eq (car function) 'lambda)) - `(code ,(ls-compile `#',function) ,arglist)) + `(call ,(convert `#',function) ,@arglist)) ((and (consp function) (eq (car function) 'oget)) - `(code ,(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 - `(code ,(ls-compile-block (butlast sexps) nil decls-allowed-p) - "return " ,(ls-compile (car (last sexps)) *multiple-value-p*) ";") - `(code - ,@(interleave (mapcar #'ls-compile sexps) "; -" *newline*) - ";" ,*newline*)))) - -(defun ls-compile* (sexp &optional multiple-value-p) + `(progn + ,@(mapcar #'convert (butlast sexps)) + (return ,(convert (car (last sexps)) *multiple-value-p*))) + `(progn ,@(mapcar #'convert sexps))))) + +(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 @@ -1456,9 +1364,9 @@ (binding-value b)) ((or (keywordp sexp) (and b (member 'constant (binding-declarations b)))) - `(code ,(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) @@ -1479,9 +1387,6 @@ (t (error "How should I compile `~S'?" sexp)))))) -(defun ls-compile (sexp &optional multiple-value-p) - `(code "(" ,(ls-compile* sexp multiple-value-p) ")")) - (defvar *compile-print-toplevels* nil) @@ -1504,13 +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))) - `(code - ,@(interleave (get-toplevel-compilations) "; -" t) - ,(when code - `(code ,code ";")))))))) - -(defun ls-compile-toplevel (sexp &optional multiple-value-p) + (let ((code (convert sexp multiple-value-p))) + `(progn + ,@(get-toplevel-compilations) + ,code)))))) + +(defun compile-toplevel (sexp &optional multiple-value-p) (with-output-to-string (*standard-output*) (js (convert-toplevel sexp multiple-value-p))))