X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=6e269471ca8836a761960e2e454a00bef315c177;hb=5f9371f19ae17198175d48540f3b06f168e10760;hp=79bf25037e1f8fed27625288798483d63bf2b48f;hpb=18ada11fb234e336a3d2ac4370d384d80d36f9f0;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 79bf250..6e26947 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 @@ -24,8 +24,10 @@ `(call (function () ,@body))) (define-js-macro bool (expr) - `(if ,expr ,(ls-compile t) ,(ls-compile nil))) + `(if ,expr ,(convert t) ,(convert nil))) +(define-js-macro method-call (x method &rest args) + `(call (get ,x ,method) ,@args)) ;;; Translate the Lisp code to Javascript. It will compile the special ;;; forms. Some primitive functions are compiled as special forms @@ -42,27 +44,6 @@ (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. @@ -111,13 +92,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) @@ -139,7 +119,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) @@ -194,9 +174,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)) @@ -280,11 +260,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))))))) @@ -293,9 +273,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)) @@ -317,11 +297,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) @@ -333,16 +313,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) @@ -359,7 +338,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| @@ -418,7 +397,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 @@ -430,8 +409,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) @@ -441,19 +420,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) @@ -481,6 +458,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) @@ -492,7 +470,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 @@ -504,29 +482,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 @@ -538,16 +515,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,12 +533,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 @@ -576,8 +550,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))) @@ -600,8 +573,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) @@ -612,11 +585,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) @@ -624,19 +597,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*))) @@ -648,7 +621,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) @@ -666,7 +639,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))))) @@ -674,23 +647,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))) @@ -701,10 +674,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 @@ -715,31 +688,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) @@ -754,23 +723,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)) @@ -787,25 +753,21 @@ (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|)) ,(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) @@ -813,8 +775,8 @@ (var (|values| |mv|)) (throw (object |type| "catch" - |id| ,(ls-compile id) - |values| ,(ls-compile value t) + |id| ,(convert id) + |values| ,(convert value t) |message| "Throw uncatched.")))) (defun go-tag-p (x) @@ -834,7 +796,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)) @@ -847,30 +809,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))))) - (progn - (collect (ls-compile form)) - ;; TEMPORAL! - (collect '(code ";")))))) + (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)) @@ -883,22 +842,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)) + ,(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 @@ -907,21 +866,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 ,@(interleave (mapcar #'ls-compile forms) - '(code ";") - t)) + (var (args ,(convert first-form *multiple-value-p*))) + (progn ,@(mapcar #'convert forms)) (return args))) (define-transformation backquote (form) @@ -941,7 +897,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 @@ -960,7 +916,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!")) @@ -1029,13 +985,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)) @@ -1049,15 +1005,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) @@ -1104,10 +1060,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))) @@ -1142,42 +1098,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) @@ -1187,10 +1143,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 @@ -1230,23 +1186,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 @@ -1256,37 +1212,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"))) @@ -1305,13 +1261,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))) @@ -1369,48 +1325,43 @@ (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 ,(convert function) ,@arglist)) (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 @@ -1421,9 +1372,9 @@ (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) @@ -1444,9 +1395,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) @@ -1469,12 +1417,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 - ,@(interleave (get-toplevel-compilations) '(code "; -") t) - (code ,code ";"))))))) + ,@(get-toplevel-compilations) + ,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))))