From 81acf0d435f13d0850a0fa48b7502e8b3ea8f2d0 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Fri, 21 Jun 2013 06:07:59 +0200 Subject: [PATCH] WIP: compiler.lisp uses a explicit back-end representation --- src/compiler.lisp | 869 +++++++++++++++++++++++++++-------------------------- 1 file changed, 448 insertions(+), 421 deletions(-) diff --git a/src/compiler.lisp b/src/compiler.lisp index 64f87be..a81de2f 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -23,6 +23,16 @@ ;;; 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 @@ -30,13 +40,15 @@ ((integerp arg) (integer-to-string arg)) ((floatp arg) (float-to-string arg)) ((stringp arg) arg) - (t (error "Unknown argument `~S'." 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) - (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")")) + `(code "(" ,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 @@ -44,7 +56,7 @@ ;;; It could be defined as function, but we could do some ;;; preprocessing in the future. (defmacro js!selfcall (&body body) - `(code "(function(){" *newline* (code ,@body) "})()")) + ``(code "(function(){" (code ,,@body) "})()")) ;;; Like CODE, but prefix each line with four spaces. Two versions ;;; of this function are available, because the Ecmalisp version is @@ -99,7 +111,7 @@ (defun gvarname (symbol) (declare (ignore symbol)) - (code "v" (incf *variable-counter*))) + `(code "v" ,(incf *variable-counter*))) (defun translate-variable (symbol) (awhen (lookup-in-lexenv symbol *environment* 'variable) @@ -176,10 +188,10 @@ *compilations*)) (define-compilation if (condition true &optional false) - (code "(" (ls-compile condition) " !== " (ls-compile nil) - " ? " (ls-compile true *multiple-value-p*) - " : " (ls-compile false *multiple-value-p*) - ")")) + `(code "(" ,(ls-compile condition) " !== " ,(ls-compile nil) + " ? " ,(ls-compile true *multiple-value-p*) + " : " ,(ls-compile false *multiple-value-p*) + ")")) (defvar *ll-keywords* '(&optional &rest &key)) @@ -229,16 +241,16 @@ (ll-optional-arguments-canonical lambda-list)))) (remove nil (mapcar #'third args)))) -(defun lambda-name/docstring-wrapper (name docstring &rest strs) +(defun lambda-name/docstring-wrapper (name docstring &rest code) (if (or name docstring) (js!selfcall - "var func = " (join strs) ";" *newline* + "var func = " `(code ,code) ";" (when name - (code "func.fname = " (js-escape-string name) ";" *newline*)) + `(code "func.fname = " ,(js-escape-string name) ";")) (when docstring - (code "func.docstring = " (js-escape-string docstring) ";" *newline*)) - "return func;" *newline*) - (apply #'code strs))) + `(code "func.docstring = " ,(js-escape-string docstring) ";")) + "return func;") + `(code ,@code))) (defun lambda-check-argument-count (n-required-arguments n-optional-arguments rest-p) @@ -249,39 +261,39 @@ (block nil ;; Special case: a positive exact number of arguments. (when (and (< 0 min) (eql min max)) - (return (code "checkArgs(nargs, " min ");" *newline*))) + (return `(code "checkArgs(nargs, " ,min ");"))) ;; General case: - (code - (when (< 0 min) - (code "checkArgsAtLeast(nargs, " min ");" *newline*)) - (when (numberp max) - (code "checkArgsAtMost(nargs, " max ");" *newline*)))))) + `(code + ,(when (< 0 min) + `(code "checkArgsAtLeast(nargs, " ,min ");")) + ,(when (numberp max) + `(code "checkArgsAtMost(nargs, " ,max ");")))))) (defun compile-lambda-optional (ll) (let* ((optional-arguments (ll-optional-arguments-canonical ll)) (n-required-arguments (length (ll-required-arguments ll))) (n-optional-arguments (length optional-arguments))) (when optional-arguments - (code "switch(nargs){" *newline* - (let ((cases nil) - (idx 0)) - (progn - (while (< idx n-optional-arguments) - (let ((arg (nth idx optional-arguments))) - (push (code "case " (+ idx n-required-arguments) ":" *newline* - (code (translate-variable (car arg)) - "=" - (ls-compile (cadr arg)) ";" *newline*) - (when (third arg) - (code (translate-variable (third arg)) - "=" - (ls-compile nil) - ";" *newline*))) - cases) - (incf idx))) - (push (code "default: break;" *newline*) cases) - (join (reverse cases)))) - "}" *newline*)))) + `(code "switch(nargs){" + ,(let ((cases nil) + (idx 0)) + (progn + (while (< idx n-optional-arguments) + (let ((arg (nth idx optional-arguments))) + (push `(code "case " ,(+ idx n-required-arguments) ":" + (code ,(translate-variable (car arg)) + "=" + ,(ls-compile (cadr arg)) ";") + ,(when (third arg) + `(code ,(translate-variable (third arg)) + "=" + ,(ls-compile nil) + ";"))) + cases) + (incf idx))) + (push `(code "default: break;") cases) + `(code ,@(reverse cases)))) + "}")))) (defun compile-lambda-rest (ll) (let ((n-required-arguments (length (ll-required-arguments ll))) @@ -289,10 +301,10 @@ (rest-argument (ll-rest-argument ll))) (when rest-argument (let ((js!rest (translate-variable rest-argument))) - (code "var " js!rest "= " (ls-compile nil) ";" *newline* - "for (var i = nargs-1; i>=" (+ n-required-arguments n-optional-arguments) - "; i--)" *newline* - (code js!rest " = {car: arguments[i+2], cdr: " js!rest "};" *newline*)))))) + `(code "var " ,js!rest "= " ,(ls-compile nil) ";" + "for (var i = nargs-1; i>=" ,(+ n-required-arguments n-optional-arguments) + "; i--)" + (code ,js!rest " = {car: arguments[i+2], cdr: " ,js!rest "};")))))) (defun compile-lambda-parse-keywords (ll) (let ((n-required-arguments @@ -301,55 +313,58 @@ (length (ll-optional-arguments ll))) (keyword-arguments (ll-keyword-arguments-canonical ll))) - (code - ;; Declare variables - (mapconcat (lambda (arg) - (let ((var (second (car arg)))) - (code "var " (translate-variable var) "; " *newline* - (when (third arg) - (code "var " (translate-variable (third arg)) - " = " (ls-compile nil) - ";" *newline*))))) - keyword-arguments) - ;; Parse keywords - (flet ((parse-keyword (keyarg) - ;; ((keyword-name var) init-form) - (code "for (i=" (+ n-required-arguments n-optional-arguments) - "; i= x.length) throw 'Out of range';" *newline* - "return x[i] = " value ";" *newline*)) + "var x = " vector ";" + "var i = " n ";" + "if (i < 0 || i >= x.length) throw 'Out of range';" + "return x[i] = " value ";" )) (define-builtin concatenate-storage-vector (sv1 sv2) (js!selfcall - "var sv1 = " sv1 ";" *newline* - "var r = sv1.concat(" sv2 ");" *newline* - "r.type = sv1.type;" *newline* - "r.stringp = sv1.stringp;" *newline* - "return r;" *newline*)) + "var sv1 = " sv1 ";" + "var r = sv1.concat(" sv2 ");" + "r.type = sv1.type;" + "r.stringp = sv1.stringp;" + "return r;" )) (define-builtin get-internal-real-time () "(new Date()).getTime()") (define-builtin values-array (array) (if *multiple-value-p* - (code "values.apply(this, " array ")") - (code "pv.apply(this, " array ")"))) + `(code "values.apply(this, " ,array ")") + `(code "pv.apply(this, " ,array ")"))) (define-raw-builtin values (&rest args) (if *multiple-value-p* - (code "values(" (join (mapcar #'ls-compile args) ", ") ")") - (code "pv(" (join (mapcar #'ls-compile args) ", ") ")"))) + `(code "values(" ,@(interleave (mapcar #'ls-compile args) ",") ")") + `(code "pv(" ,@(interleave (mapcar #'ls-compile args) ", ") ")"))) ;;; Javascript FFI @@ -1282,55 +1306,56 @@ (define-raw-builtin oget* (object key &rest keys) (js!selfcall - "var tmp = (" (ls-compile object) ")[xstring(" (ls-compile key) ")];" *newline* - (mapconcat (lambda (key) - (code "if (tmp === undefined) return " (ls-compile nil) ";" *newline* - "tmp = tmp[xstring(" (ls-compile key) ")];" *newline*)) - keys) - "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*)) + "var tmp = (" (ls-compile object) ")[xstring(" (ls-compile key) ")];" + `(code + ,@(mapcar (lambda (key) + `(code "if (tmp === undefined) return " ,(ls-compile nil) ";" + "tmp = tmp[xstring(" ,(ls-compile key) ")];" )) + keys)) + "return tmp === undefined? " (ls-compile nil) " : tmp;" )) (define-raw-builtin oset* (value object key &rest keys) (let ((keys (cons key keys))) (js!selfcall - "var obj = " (ls-compile object) ";" *newline* - (mapconcat (lambda (key) - (code "obj = obj[xstring(" (ls-compile key) ")];" - "if (obj === undefined) throw 'Impossible to set Javascript property.';" *newline*)) - (butlast keys)) - "var tmp = obj[xstring(" (ls-compile (car (last keys))) ")] = " (ls-compile value) ";" *newline* - "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*))) + "var obj = " (ls-compile object) ";" + `(code ,@(mapcar (lambda (key) + `(code "obj = obj[xstring(" ,(ls-compile key) ")];" + "if (obj === undefined) throw 'Impossible to set Javascript property.';" )) + (butlast keys))) + "var tmp = obj[xstring(" (ls-compile (car (last keys))) ")] = " (ls-compile value) ";" + "return tmp === undefined? " (ls-compile nil) " : tmp;" ))) (define-raw-builtin oget (object key &rest keys) - (code "js_to_lisp(" (ls-compile `(oget* ,object ,key ,@keys)) ")")) + `(code "js_to_lisp(" ,(ls-compile `(oget* ,object ,key ,@keys)) ")")) (define-raw-builtin oset (value object key &rest keys) (ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) (define-builtin objectp (x) - (js!bool (code "(typeof (" x ") === 'object')"))) + (js!bool `(code "(typeof (" ,x ") === 'object')"))) -(define-builtin lisp-to-js (x) (code "lisp_to_js(" x ")")) -(define-builtin js-to-lisp (x) (code "js_to_lisp(" x ")")) +(define-builtin lisp-to-js (x) `(code "lisp_to_js(" ,x ")")) +(define-builtin js-to-lisp (x) `(code "js_to_lisp(" ,x ")")) (define-builtin in (key object) - (js!bool (code "(xstring(" key ") in (" object "))"))) + (js!bool `(code "(xstring(" ,key ") in (" ,object "))"))) (define-builtin map-for-in (function object) (js!selfcall - "var f = " function ";" *newline* - "var g = (typeof f === 'function' ? f : f.fvalue);" *newline* - "var o = " object ";" *newline* - "for (var key in o){" *newline* - (code "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*) + "var f = " function ";" + "var g = (typeof f === 'function' ? f : f.fvalue);" + "var o = " object ";" + "for (var key in o){" + `(code "g(" ,(if *multiple-value-p* "values" "pv") ", 1, o[key]);" ) "}" - " return " (ls-compile nil) ";" *newline*)) + " return " (ls-compile nil) ";" )) (define-compilation %js-vref (var) - (code "js_to_lisp(" var ")")) + `(code "js_to_lisp(" ,var ")")) (define-compilation %js-vset (var val) - (code "(" var " = lisp_to_js(" (ls-compile val) "))")) + `(code "(" ,var " = lisp_to_js(" ,(ls-compile val) "))")) (define-setf-expander %js-vref (var) (let ((new-value (gensym))) @@ -1389,26 +1414,28 @@ (defun compile-funcall (function args) (let* ((values-funcs (if *multiple-value-p* "values" "pv")) - (arglist (concat "(" (join (list* values-funcs - (integer-to-string (length args)) - (mapcar #'ls-compile args)) ", ") ")"))) + (arglist `(code "(" ,@(interleave (list* values-funcs + (integer-to-string (length args)) + (mapcar #'ls-compile args)) + ", ") + ")"))) (unless (or (symbolp function) (and (consp function) (member (car function) '(lambda oget)))) (error "Bad function designator `~S'" function)) (cond ((translate-function function) - (concat (translate-function function) arglist)) + `(code ,(translate-function function) ,arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) #-jscl t) - (code (ls-compile `',function) ".fvalue" arglist)) + `(code ,(ls-compile `',function) ".fvalue" ,arglist)) #+jscl((symbolp function) - (code (ls-compile `#',function) arglist)) + `(code ,(ls-compile `#',function) ,arglist)) ((and (consp function) (eq (car function) 'lambda)) - (code (ls-compile `#',function) arglist)) + `(code ,(ls-compile `#',function) ,arglist)) ((and (consp function) (eq (car function) 'oget)) - (code (ls-compile function) arglist)) + `(code ,(ls-compile function) ,arglist)) (t (error "Bad function descriptor"))))) @@ -1417,11 +1444,11 @@ (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*) ";") - (join-trailing - (mapcar #'ls-compile sexps) - (concat ";" *newline*))))) + `(code ,(ls-compile-block (butlast sexps) nil decls-allowed-p) + "return " ,(ls-compile (car (last sexps)) *multiple-value-p*) ";") + `(code + ,@(mapcar #'ls-compile sexps) + ";")))) (defun ls-compile (sexp &optional multiple-value-p) (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp) @@ -1437,7 +1464,7 @@ (binding-value b)) ((or (keywordp sexp) (and b (member 'constant (binding-declarations b)))) - (code (ls-compile `',sexp) ".value")) + `(code ,(ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp)) @@ -1481,7 +1508,7 @@ (let ((form-string (prin1-to-string sexp))) (format t "Compiling ~a..." (truncate-string form-string)))) (let ((code (ls-compile sexp multiple-value-p))) - (code (join-trailing (get-toplevel-compilations) - (code ";" *newline*)) - (when code - (code code ";" *newline*)))))))) + `(code + ,@(interleave (get-toplevel-compilations) ";" t) + ,(when code + `(code ,code ";")))))))) -- 1.7.10.4