From 212339794f45942973ca539691e37e87059e5832 Mon Sep 17 00:00:00 2001 From: Owen Rodley Date: Tue, 9 Jul 2013 16:52:00 +1200 Subject: [PATCH] Modify the way source files are listed in *SOURCE* Allow subdirectories by having a list rather than a keyword in the entry for a file. For example, the entry: ("foo" ("bar" :HOST) ("baz" :BOTH)) includes the files `foo/bar.lisp' and `foo/baz.lisp'. Subdirectories are processed recursively, so arbitrarily deeply nested directories should work. A simple DOLIST over *SOURCE* doesn't work any more, as the file list has to be processed by GET-FILES first. The macro DO-SOURCE should be used instead. All previous occurances of DOLIST were changed in the previous commit with the introduction of DO-SOURCE. Also removed trailing whitespace from compiler.lisp and codegen.lisp to make my git pre-commit hook happy --- jscl.lisp | 84 ++- src/compiler-codegen.lisp | 505 ---------------- src/compiler.lisp | 1425 -------------------------------------------- src/compiler/codegen.lisp | 505 ++++++++++++++++ src/compiler/compiler.lisp | 1425 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 1987 insertions(+), 1957 deletions(-) delete mode 100644 src/compiler-codegen.lisp delete mode 100644 src/compiler.lisp create mode 100644 src/compiler/codegen.lisp create mode 100644 src/compiler/compiler.lisp diff --git a/jscl.lisp b/jscl.lisp index 04b9450..9dd2b5a 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -22,37 +22,67 @@ (in-package :jscl) +;;; List of all the source files that need to be compiled, and whether they +;;; are to be compiled just by the host, by the target JSCL, or by both. +;;; All files have a `.lisp' extension, and +;;; are relative to src/ +;;; Subdirectories are indicated by the presence of a list rather than a +;;; keyword in the second element of the list. For example, this list: +;;; (("foo" :target) +;;; ("bar" +;;; ("baz" :host) +;;; ("quux" :both))) +;;; Means that src/foo.lisp and src/bar/quux.lisp need to be compiled in the +;;; target, and that src/bar/baz.lisp and src/bar/quux.lisp need to be +;;; compiled in the host (defvar *source* - '(("boot" :target) - ("compat" :host) - ("utils" :both) - ("numbers" :target) - ("char" :target) - ("list" :target) - ("array" :target) - ("string" :target) - ("sequence" :target) - ("stream" :target) - ("print" :target) - ("package" :target) - ("misc" :target) - ("ffi" :both) - ("read" :both) - ("defstruct" :both) - ("lambda-list" :both) - ("backquote" :both) - ("compiler-codegen" :both) - ("compiler" :both) - ("toplevel" :target))) + '(("boot" :target) + ("compat" :host) + ("utils" :both) + ("numbers" :target) + ("char" :target) + ("list" :target) + ("array" :target) + ("string" :target) + ("sequence" :target) + ("stream" :target) + ("print" :target) + ("package" :target) + ("misc" :target) + ("ffi" :both) + ("read" :both) + ("defstruct" :both) + ("lambda-list" :both) + ("backquote" :both) + ("compiler" + ("codegen" :both) + ("compiler" :both)) + ("toplevel" :target))) + +(defun get-files (file-list type dir) + "Traverse FILE-LIST and retrieve a list of the files within which match + either TYPE or :BOTH, processing subdirectories." + (let ((file (car file-list))) + (cond + ((null file-list) + ()) + ((listp (cadr file)) + (append + (get-files (cdr file) type (append dir (list (car file)))) + (get-files (cdr file-list) type dir))) + ((member (cadr file) (list type :both)) + (cons (source-pathname (car file) :directory dir :type "lisp") + (get-files (cdr file-list) type dir))) + (t + (get-files (cdr file-list) type dir))))) (defmacro do-source (name type &body body) + "Iterate over all the source files that need to be compiled in the host or + the target, depending on the TYPE argument." (unless (member type '(:host :target)) - (error "TYPE should be one of :HOST or :TARGET")) - (let ((file (gensym))) - `(dolist (,file *source*) - (when (member (cadr ,file) (list :both ,type)) - (let ((,name (source-pathname (car ,file) :type "lisp"))) - ,@body))))) + (error "TYPE must be one of :HOST or :TARGET, not ~S" type)) + `(dolist (,name (get-files *source* ,type '(:relative "src"))) + ,@body)) (defun source-pathname (filename &key (directory '(:relative "src")) (type nil) (defaults filename)) diff --git a/src/compiler-codegen.lisp b/src/compiler-codegen.lisp deleted file mode 100644 index 9bb915d..0000000 --- a/src/compiler-codegen.lisp +++ /dev/null @@ -1,505 +0,0 @@ -;;; compiler-codege.lisp --- Naive Javascript unparser - -;; copyright (C) 2013 David Vazquez - -;; JSCL is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; JSCL is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with JSCL. If not, see . - -;;; This code generator takes as input a S-expression representation -;;; of the Javascript AST and generates Javascript code without -;;; redundant syntax constructions like extra parenthesis. -;;; -;;; It is intended to be used with the new compiler. However, it is -;;; quite independent so it has been integrated early in JSCL. - -(/debug "loading compiler-codegen.lisp!") - -(defvar *js-macros* nil) -(defmacro define-js-macro (name lambda-list &body body) - (let ((form (gensym))) - `(push (cons ',name - (lambda (,form) - (block ,name - (destructuring-bind ,lambda-list ,form - ,@body)))) - *js-macros*))) - -(defun js-macroexpand (js) - (if (and (consp js) (assoc (car js) *js-macros*)) - (let ((expander (cdr (assoc (car js) *js-macros*)))) - (multiple-value-bind (expansion stop-expand-p) - (funcall expander (cdr js)) - (if stop-expand-p - expansion - (js-macroexpand expansion)))) - js)) - - -(defconstant no-comma 12) - -(defvar *js-output* t) - -;;; Two seperate functions are needed for escaping strings: -;;; One for producing JavaScript string literals (which are singly or -;;; doubly quoted) -;;; And one for producing Lisp strings (which are only doubly quoted) -;;; -;;; The same function would suffice for both, but for javascript string -;;; literals it is neater to use either depending on the context, e.g: -;;; foo's => "foo's" -;;; "foo" => '"foo"' -;;; which avoids having to escape quotes where possible -(defun js-escape-string (string) - (let ((index 0) - (size (length string)) - (seen-single-quote nil) - (seen-double-quote nil)) - (flet ((%js-escape-string (string escape-single-quote-p) - (let ((output "") - (index 0)) - (while (< index size) - (let ((ch (char string index))) - (when (char= ch #\\) - (setq output (concat output "\\"))) - (when (and escape-single-quote-p (char= ch #\')) - (setq output (concat output "\\"))) - (when (char= ch #\newline) - (setq output (concat output "\\")) - (setq ch #\n)) - (setq output (concat output (string ch)))) - (incf index)) - output))) - ;; First, scan the string for single/double quotes - (while (< index size) - (let ((ch (char string index))) - (when (char= ch #\') - (setq seen-single-quote t)) - (when (char= ch #\") - (setq seen-double-quote t))) - (incf index)) - ;; Then pick the appropriate way to escape the quotes - (cond - ((not seen-single-quote) - (concat "'" (%js-escape-string string nil) "'")) - ((not seen-double-quote) - (concat "\"" (%js-escape-string string nil) "\"")) - (t (concat "'" (%js-escape-string string t) "'")))))) - - -(defun js-format (fmt &rest args) - (apply #'format *js-output* fmt args)) - -(defun valid-js-identifier (string-designator) - (let ((string (typecase string-designator - (symbol (symbol-name string-designator)) - (string string-designator) - (t - (return-from valid-js-identifier (values nil nil)))))) - (flet ((constitutentp (ch) - (or (alphanumericp ch) (member ch '(#\$ #\_))))) - (if (and (every #'constitutentp string) - (if (plusp (length string)) - (not (digit-char-p (char string 0))) - t)) - (values (format nil "~a" string) t) - (values nil nil))))) - -(defun js-identifier (string-designator) - (multiple-value-bind (string valid) - (valid-js-identifier string-designator) - (unless valid - (error "~S is not a valid Javascript identifier." string)) - (js-format "~a" string))) - -(defun js-primary-expr (form) - (cond - ((numberp form) - (if (<= 0 form) - (js-format "~a" form) - (js-expr `(- ,(abs form))))) - ((stringp form) - (js-format "~a" (js-escape-string form))) - ((symbolp form) - (case form - (true (js-format "true")) - (false (js-format "false")) - (null (js-format "null")) - (this (js-format "this")) - (undefined (js-format "undefined")) - (otherwise - (js-identifier form)))) - (t - (error "Unknown Javascript syntax ~S." form)))) - -(defun js-vector-initializer (vector) - (let ((size (length vector))) - (js-format "[") - (dotimes (i (1- size)) - (let ((elt (aref vector i))) - (unless (eq elt 'null) - (js-expr elt no-comma)) - (js-format ","))) - (when (plusp size) - (js-expr (aref vector (1- size)) no-comma)) - (js-format "]"))) - -(defun js-object-initializer (plist) - (js-format "{") - (do* ((tail plist (cddr tail))) - ((null tail)) - (let ((key (car tail)) - (value (cadr tail))) - (multiple-value-bind (identifier identifier-p) (valid-js-identifier key) - (declare (ignore identifier)) - (if identifier-p - (js-identifier key) - (js-expr (string key) no-comma))) - (js-format ": ") - (js-expr value no-comma) - (unless (null (cddr tail)) - (js-format ",")))) - (js-format "}")) - -(defun js-function (arguments &rest body) - (js-format "function(") - (when arguments - (js-identifier (car arguments)) - (dolist (arg (cdr arguments)) - (js-format ",") - (js-identifier arg))) - (js-format ")") - (js-stmt `(group ,@body) t)) - -(defun check-lvalue (x) - (unless (or (symbolp x) - (nth-value 1 (valid-js-identifier x)) - (and (consp x) - (member (car x) '(get = property)))) - (error "Bad Javascript lvalue ~S" x))) - -;;; Process the Javascript AST to reduce some syntax sugar. -(defun js-expand-expr (form) - (if (consp form) - (case (car form) - (+ - (case (length (cdr form)) - (1 `(unary+ ,(cadr form))) - (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form))))) - (- - (case (length (cdr form)) - (1 `(unary- ,(cadr form))) - (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form))))) - ((and or) - (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form))) - ((progn comma) - (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t)) - (t - (js-macroexpand form))) - form)) - -(defun js-operator-expression (op args precedence associativity operand-order) - (let ((op1 (car args)) - (op2 (cadr args))) - (case op - ;; Accessors - (property - (js-expr (car args) 0) - (js-format "[") - (js-expr (cadr args) no-comma) - (js-format "]")) - (get - (multiple-value-bind (accessor accessorp) - (valid-js-identifier (cadr args)) - (unless accessorp - (error "Invalid accessor ~S" (cadr args))) - (js-expr (car args) 0) - (js-format ".") - (js-identifier accessor))) - ;; Function call - (call - (js-expr (car args) 1) - (js-format "(") - (when (cdr args) - (js-expr (cadr args) no-comma) - (dolist (operand (cddr args)) - (js-format ",") - (js-expr operand no-comma))) - (js-format ")")) - ;; Object syntax - (object - (js-object-initializer args)) - ;; Function expressions - (function - (js-format "(") - (apply #'js-function args) - (js-format ")")) - (t - (labels ((low-precedence-p (op-precedence) - (cond - ((> op-precedence precedence)) - ((< op-precedence precedence) nil) - (t (not (eq operand-order associativity))))) - - (%unary-op (operator string operator-precedence operator-associativity post lvalue) - (when (eq op operator) - (when lvalue (check-lvalue op1)) - (when (low-precedence-p operator-precedence) (js-format "(")) - (cond - (post - (js-expr op1 operator-precedence operator-associativity 'left) - (js-format "~a" string)) - (t - (js-format "~a" string) - (js-expr op1 operator-precedence operator-associativity 'right))) - (when (low-precedence-p operator-precedence) (js-format ")")) - (return-from js-operator-expression))) - - (%binary-op (operator string operator-precedence operator-associativity lvalue) - (when (eq op operator) - (when lvalue (check-lvalue op1)) - (when (low-precedence-p operator-precedence) (js-format "(")) - (js-expr op1 operator-precedence operator-associativity 'left) - (js-format "~a" string) - (js-expr op2 operator-precedence operator-associativity 'right) - (when (low-precedence-p operator-precedence) (js-format ")")) - (return-from js-operator-expression)))) - - (macrolet ((unary-op (operator string precedence associativity &key post lvalue) - `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue)) - (binary-op (operator string precedence associativity &key lvalue) - `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue))) - - (unary-op pre++ "++" 2 right :lvalue t) - (unary-op pre-- "--" 2 right :lvalue t) - (unary-op post++ "++" 2 right :lvalue t :post t) - (unary-op post-- "--" 2 right :lvalue t :post t) - (unary-op not "!" 2 right) - (unary-op bit-not "~" 2 right) - ;; Note that the leading space is necessary because it - ;; could break with post++, for example. TODO: Avoid - ;; leading space when it's possible. - (unary-op unary+ " +" 2 right) - (unary-op unary- " -" 2 right) - (unary-op delete "delete " 2 right) - (unary-op void "void " 2 right) - (unary-op typeof "typeof " 2 right) - (unary-op new "new " 2 right) - - (binary-op * "*" 3 left) - (binary-op / "/" 3 left) - (binary-op mod "%" 3 left) - (binary-op % "%" 3 left) - (binary-op + "+" 4 left) - (binary-op - "-" 5 left) - (binary-op << "<<" 5 left) - (binary-op >> "<<" 5 left) - (binary-op >>> ">>>" 5 left) - (binary-op <= "<=" 6 left) - (binary-op < "<" 6 left) - (binary-op > ">" 6 left) - (binary-op >= ">=" 6 left) - (binary-op instanceof " instanceof " 6 left) - (binary-op in " in " 6 left) - (binary-op == "==" 7 left) - (binary-op != "!=" 7 left) - (binary-op === "===" 7 left) - (binary-op !== "!==" 7 left) - (binary-op bit-and "&" 8 left) - (binary-op bit-xor "^" 9 left) - (binary-op bit-or "|" 10 left) - (binary-op and "&&" 11 left) - (binary-op or "||" 12 left) - (binary-op = "=" 13 right :lvalue t) - (binary-op += "+=" 13 right :lvalue t) - (binary-op incf "+=" 13 right :lvalue t) - (binary-op -= "-=" 13 right :lvalue t) - (binary-op decf "-=" 13 right :lvalue t) - (binary-op *= "*=" 13 right :lvalue t) - (binary-op /= "*=" 13 right :lvalue t) - (binary-op bit-xor= "^=" 13 right :lvalue t) - (binary-op bit-and= "&=" 13 right :lvalue t) - (binary-op bit-or= "|=" 13 right :lvalue t) - (binary-op <<= "<<=" 13 right :lvalue t) - (binary-op >>= ">>=" 13 right :lvalue t) - (binary-op >>>= ">>>=" 13 right :lvalue t) - - (binary-op comma "," 13 right) - (binary-op progn "," 13 right) - - (when (member op '(? if)) - (when (low-precedence-p 12) (js-format "(")) - (js-expr (first args) 12 'right 'left) - (js-format "?") - (js-expr (second args) 12 'right 'right) - (js-format ":") - (js-expr (third args) 12 'right 'right) - (when (low-precedence-p 12) (js-format ")")) - (return-from js-operator-expression)) - - (error "Unknown operator `~S'" op))))))) - -(defun js-expr (form &optional (precedence 1000) associativity operand-order) - (let ((form (js-expand-expr form))) - (cond - ((or (symbolp form) (numberp form) (stringp form)) - (js-primary-expr form)) - ((vectorp form) - (js-vector-initializer form)) - (t - (js-operator-expression (car form) (cdr form) precedence associativity operand-order))))) - -(defun js-expand-stmt (form) - (cond - ((and (consp form) (eq (car form) 'progn)) - (destructuring-bind (&body body) (cdr form) - (cond - ((null body) - nil) - ((null (cdr body)) - (js-expand-stmt (car body))) - (t - `(group ,@(cdr form)))))) - (t - (js-macroexpand form)))) - -(defun js-stmt (form &optional parent) - (let ((form (js-expand-stmt form))) - (flet ((js-stmt (x) (js-stmt x form))) - (cond - ((null form) - (unless (or (and (consp parent) (eq (car parent) 'group)) - (null parent)) - (js-format ";"))) - ((atom form) - (progn - (js-expr form) - (js-format ";"))) - (t - (case (car form) - (label - (destructuring-bind (label &body body) (cdr form) - (js-identifier label) - (js-format ":") - (js-stmt `(progn ,@body)))) - (break - (destructuring-bind (&optional label) (cdr form) - (js-format "break") - (when label - (js-format " ") - (js-identifier label)) - (js-format ";"))) - (return - (destructuring-bind (value) (cdr form) - (js-format "return ") - (js-expr value) - (js-format ";"))) - (var - (flet ((js-var (spec) - (destructuring-bind (variable &optional initial) - (ensure-list spec) - (js-identifier variable) - (when initial - (js-format "=") - (js-expr initial no-comma))))) - (destructuring-bind (var &rest vars) (cdr form) - (js-format "var ") - (js-var var) - (dolist (var vars) - (js-format ",") - (js-var var)) - (js-format ";")))) - (if - (destructuring-bind (condition true &optional false) (cdr form) - (js-format "if (") - (js-expr condition) - (js-format ") ") - (js-stmt true) - (when false - (js-format " else ") - (js-stmt false)))) - (group - (let ((in-group-p - (or (null parent) - (and (consp parent) (eq (car parent) 'group))))) - (unless in-group-p (js-format "{")) - (mapc #'js-stmt (cdr form)) - (unless in-group-p (js-format "}")))) - (while - (destructuring-bind (condition &body body) (cdr form) - (js-format "while (") - (js-expr condition) - (js-format ")") - (js-stmt `(progn ,@body)))) - (switch - (destructuring-bind (value &rest cases) (cdr form) - (js-format "switch(") - (js-expr value) - (js-format "){") - (dolist (case cases) - (cond - ((and (consp case) (eq (car case) 'case)) - (js-format "case ") - (let ((value (cadr case))) - (unless (or (stringp value) (integerp value)) - (error "Non-constant switch case `~S'." value)) - (js-expr value)) - (js-format ":")) - ((eq case 'default) - (js-format "default:")) - (t - (js-stmt case)))) - (js-format "}"))) - (for - (destructuring-bind ((start condition step) &body body) (cdr form) - (js-format "for (") - (js-expr start) - (js-format ";") - (js-expr condition) - (js-format ";") - (js-expr step) - (js-format ")") - (js-stmt `(progn ,@body)))) - (for-in - (destructuring-bind ((x object) &body body) (cdr form) - (js-format "for (") - (js-identifier x) - (js-format " in ") - (js-expr object) - (js-format ")") - (js-stmt `(progn ,@body)))) - (try - (destructuring-bind (&rest body) (cdr form) - (js-format "try") - (js-stmt `(group ,@body)))) - (catch - (destructuring-bind ((var) &rest body) (cdr form) - (js-format "catch (") - (js-identifier var) - (js-format ")") - (js-stmt `(group ,@body)))) - (finally - (destructuring-bind (&rest body) (cdr form) - (js-format "finally") - (js-stmt `(group ,@body)))) - (throw - (destructuring-bind (object) (cdr form) - (js-format "throw ") - (js-expr object) - (js-format ";"))) - (t - (js-expr form) - (js-format ";")))))))) - -(defun js (&rest stmts) - (mapc #'js-stmt stmts) - nil) diff --git a/src/compiler.lisp b/src/compiler.lisp deleted file mode 100644 index 51fb547..0000000 --- a/src/compiler.lisp +++ /dev/null @@ -1,1425 +0,0 @@ -;;; compiler.lisp --- - -;; Copyright (C) 2012, 2013 David Vazquez -;; Copyright (C) 2012 Raimon Grau - -;; JSCL is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; JSCL is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with JSCL. If not, see . - -;;;; Compiler - -(/debug "loading compiler.lisp!") - -;;; 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. - -(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 -;;; returning an individual object. However, if the special variable -;;; `*multiple-value-p*' is NIL, is granted that only the primary -;;; value will be used, so we can optimize to avoid the VALUES -;;; function call. -(defvar *multiple-value-p* nil) - -;;; Environment - -(def!struct binding - name - type - value - declarations) - -(def!struct lexenv - variable - function - block - gotag) - -(defun lookup-in-lexenv (name lexenv namespace) - (find name (ecase namespace - (variable (lexenv-variable lexenv)) - (function (lexenv-function lexenv)) - (block (lexenv-block lexenv)) - (gotag (lexenv-gotag lexenv))) - :key #'binding-name)) - -(defun push-to-lexenv (binding lexenv namespace) - (ecase namespace - (variable (push binding (lexenv-variable lexenv))) - (function (push binding (lexenv-function lexenv))) - (block (push binding (lexenv-block lexenv))) - (gotag (push binding (lexenv-gotag lexenv))))) - -(defun extend-lexenv (bindings lexenv namespace) - (let ((env (copy-lexenv lexenv))) - (dolist (binding (reverse bindings) env) - (push-to-lexenv binding env namespace)))) - - -(defvar *environment* (make-lexenv)) -(defvar *variable-counter* 0) - -(defun gvarname (symbol) - (declare (ignore symbol)) - (incf *variable-counter*) - (make-symbol (concat "v" (integer-to-string *variable-counter*)))) - -(defun translate-variable (symbol) - (awhen (lookup-in-lexenv symbol *environment* 'variable) - (binding-value it))) - -(defun extend-local-env (args) - (let ((new (copy-lexenv *environment*))) - (dolist (symbol args new) - (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol)))) - (push-to-lexenv b new 'variable))))) - -;;; Toplevel compilations -(defvar *toplevel-compilations* nil) - -(defun toplevel-compilation (string) - (push string *toplevel-compilations*)) - -(defun get-toplevel-compilations () - (reverse *toplevel-compilations*)) - -(defun %compile-defmacro (name lambda) - (toplevel-compilation (convert `',name)) - (let ((binding (make-binding :name name :type 'macro :value lambda))) - (push-to-lexenv binding *environment* 'function)) - name) - -(defun global-binding (name type namespace) - (or (lookup-in-lexenv name *environment* namespace) - (let ((b (make-binding :name name :type type :value nil))) - (push-to-lexenv b *environment* namespace) - b))) - -(defun claimp (symbol namespace claim) - (let ((b (lookup-in-lexenv symbol *environment* namespace))) - (and b (member claim (binding-declarations b))))) - -(defun !proclaim (decl) - (case (car decl) - (special - (dolist (name (cdr decl)) - (let ((b (global-binding name 'variable 'variable))) - (push 'special (binding-declarations b))))) - (notinline - (dolist (name (cdr decl)) - (let ((b (global-binding name 'function 'function))) - (push 'notinline (binding-declarations b))))) - (constant - (dolist (name (cdr decl)) - (let ((b (global-binding name 'variable 'variable))) - (push 'constant (binding-declarations b))))))) - -#+jscl -(fset 'proclaim #'!proclaim) - -(defun %define-symbol-macro (name expansion) - (let ((b (make-binding :name name :type 'macro :value expansion))) - (push-to-lexenv b *environment* 'variable) - name)) - -#+jscl -(defmacro define-symbol-macro (name expansion) - `(%define-symbol-macro ',name ',expansion)) - - -;;; Special forms - -(defvar *compilations* nil) - -(defmacro define-compilation (name args &body body) - ;; Creates a new primitive `name' with parameters args and - ;; @body. The body can access to the local environment through the - ;; variable *ENVIRONMENT*. - `(push (list ',name (lambda ,args (block ,name ,@body))) - *compilations*)) - -(define-compilation if (condition true &optional false) - `(if (!== ,(convert condition) ,(convert nil)) - ,(convert true *multiple-value-p*) - ,(convert false *multiple-value-p*))) - -(defvar *ll-keywords* '(&optional &rest &key)) - -(defun list-until-keyword (list) - (if (or (null list) (member (car list) *ll-keywords*)) - nil - (cons (car list) (list-until-keyword (cdr list))))) - -(defun ll-section (keyword ll) - (list-until-keyword (cdr (member keyword ll)))) - -(defun ll-required-arguments (ll) - (list-until-keyword ll)) - -(defun ll-optional-arguments-canonical (ll) - (mapcar #'ensure-list (ll-section '&optional ll))) - -(defun ll-optional-arguments (ll) - (mapcar #'car (ll-optional-arguments-canonical ll))) - -(defun ll-rest-argument (ll) - (let ((rest (ll-section '&rest ll))) - (when (cdr rest) - (error "Bad lambda-list `~S'." ll)) - (car rest))) - -(defun ll-keyword-arguments-canonical (ll) - (flet ((canonicalize (keyarg) - ;; Build a canonical keyword argument descriptor, filling - ;; the optional fields. The result is a list of the form - ;; ((keyword-name var) init-form svar). - (let ((arg (ensure-list keyarg))) - (cons (if (listp (car arg)) - (car arg) - (list (intern (symbol-name (car arg)) "KEYWORD") (car arg))) - (cdr arg))))) - (mapcar #'canonicalize (ll-section '&key ll)))) - -(defun ll-keyword-arguments (ll) - (mapcar (lambda (keyarg) (second (first keyarg))) - (ll-keyword-arguments-canonical ll))) - -(defun ll-svars (lambda-list) - (let ((args - (append - (ll-keyword-arguments-canonical lambda-list) - (ll-optional-arguments-canonical lambda-list)))) - (remove nil (mapcar #'third args)))) - -(defun lambda-name/docstring-wrapper (name docstring code) - (if (or name docstring) - `(selfcall - (var (func ,code)) - ,(when name `(= (get func "fname") ,name)) - ,(when docstring `(= (get func "docstring") ,docstring)) - (return func)) - code)) - -(defun lambda-check-argument-count - (n-required-arguments n-optional-arguments rest-p) - ;; Note: Remember that we assume that the number of arguments of a - ;; call is at least 1 (the values argument). - (let ((min n-required-arguments) - (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments)))) - (block nil - ;; Special case: a positive exact number of arguments. - (when (and (< 0 min) (eql min max)) - (return `(call |checkArgs| |nargs| ,min))) - ;; General case: - `(progn - ,(when (< 0 min) `(call |checkArgsAtLeast| |nargs| ,min)) - ,(when (numberp max) `(call |checkArgsAtMost| |nargs| ,max)))))) - -(defun compile-lambda-optional (ll) - (let* ((optional-arguments (ll-optional-arguments-canonical ll)) - (n-required-arguments (length (ll-required-arguments ll))) - (n-optional-arguments (length optional-arguments))) - (when optional-arguments - `(switch |nargs| - ,@(with-collect - (dotimes (idx n-optional-arguments) - (let ((arg (nth idx optional-arguments))) - (collect `(case ,(+ idx n-required-arguments))) - (collect `(= ,(translate-variable (car arg)) - ,(convert (cadr arg)))) - (collect (when (third arg) - `(= ,(translate-variable (third arg)) - ,(convert nil)))))) - (collect 'default) - (collect '(break))))))) - -(defun compile-lambda-rest (ll) - (let ((n-required-arguments (length (ll-required-arguments ll))) - (n-optional-arguments (length (ll-optional-arguments ll))) - (rest-argument (ll-rest-argument ll))) - (when rest-argument - (let ((js!rest (translate-variable rest-argument))) - `(progn - (var (,js!rest ,(convert nil))) - (var i) - (for ((= i (- |nargs| 1)) - (>= i ,(+ n-required-arguments n-optional-arguments)) - (post-- i)) - (= ,js!rest (object "car" (property |arguments| (+ i 2)) - "cdr" ,js!rest)))))))) - -(defun compile-lambda-parse-keywords (ll) - (let ((n-required-arguments - (length (ll-required-arguments ll))) - (n-optional-arguments - (length (ll-optional-arguments ll))) - (keyword-arguments - (ll-keyword-arguments-canonical ll))) - `(progn - ;; Declare variables - ,@(with-collect - (dolist (keyword-argument keyword-arguments) - (destructuring-bind ((keyword-name var) &optional initform svar) - keyword-argument - (declare (ignore keyword-name initform)) - (collect `(var ,(translate-variable var))) - (when svar - (collect - `(var (,(translate-variable svar) - ,(convert nil)))))))) - - ;; Parse keywords - ,(flet ((parse-keyword (keyarg) - (destructuring-bind ((keyword-name var) &optional initform svar) keyarg - ;; ((keyword-name var) init-form svar) - `(progn - (for ((= i ,(+ n-required-arguments n-optional-arguments)) - (< i |nargs|) - (+= i 2)) - ;; .... - (if (=== (property |arguments| (+ i 2)) - ,(convert keyword-name)) - (progn - (= ,(translate-variable var) - (property |arguments| (+ i 3))) - ,(when svar `(= ,(translate-variable svar) - ,(convert t))) - (break)))) - (if (== i |nargs|) - (= ,(translate-variable var) ,(convert initform))))))) - (when keyword-arguments - `(progn - (var i) - ,@(mapcar #'parse-keyword keyword-arguments)))) - - ;; Check for unknown keywords - ,(when keyword-arguments - `(progn - (var (start ,(+ n-required-arguments n-optional-arguments))) - (if (== (% (- |nargs| start) 2) 1) - (throw "Odd number of keyword arguments.")) - (for ((= i start) (< i |nargs|) (+= i 2)) - (if (and ,@(mapcar (lambda (keyword-argument) - (destructuring-bind ((keyword-name var) &optional initform svar) - keyword-argument - (declare (ignore var initform svar)) - `(!== (property |arguments| (+ i 2)) ,(convert keyword-name)))) - keyword-arguments)) - (throw (+ "Unknown keyword argument " - (call |xstring| - (property - (property |arguments| (+ i 2)) - "name"))))))))))) - -(defun parse-lambda-list (ll) - (values (ll-required-arguments ll) - (ll-optional-arguments ll) - (ll-keyword-arguments ll) - (ll-rest-argument ll))) - -;;; Process BODY for declarations and/or docstrings. Return as -;;; multiple values the BODY without docstrings or declarations, the -;;; list of declaration forms and the docstring. -(defun parse-body (body &key declarations docstring) - (let ((value-declarations) - (value-docstring)) - ;; Parse declarations - (when declarations - (do* ((rest body (cdr rest)) - (form (car rest) (car rest))) - ((or (atom form) (not (eq (car form) 'declare))) - (setf body rest)) - (push form value-declarations))) - ;; Parse docstring - (when (and docstring - (stringp (car body)) - (not (null (cdr body)))) - (setq value-docstring (car body)) - (setq body (cdr body))) - (values body value-declarations value-docstring))) - -;;; Compile a lambda function with lambda list LL and body BODY. If -;;; NAME is given, it should be a constant string and it will become -;;; the name of the function. If BLOCK is non-NIL, a named block is -;;; created around the body. NOTE: No block (even anonymous) is -;;; created if BLOCk is NIL. -(defun compile-lambda (ll body &key name block) - (multiple-value-bind (required-arguments - optional-arguments - keyword-arguments - rest-argument) - (parse-lambda-list ll) - (multiple-value-bind (body decls documentation) - (parse-body body :declarations t :docstring t) - (declare (ignore decls)) - (let ((n-required-arguments (length required-arguments)) - (n-optional-arguments (length optional-arguments)) - (*environment* (extend-local-env - (append (ensure-list rest-argument) - required-arguments - optional-arguments - keyword-arguments - (ll-svars ll))))) - (lambda-name/docstring-wrapper name documentation - `(function (|values| |nargs| ,@(mapcar (lambda (x) - (translate-variable x)) - (append required-arguments optional-arguments))) - ;; Check number of arguments - ,(lambda-check-argument-count n-required-arguments - n-optional-arguments - (or rest-argument keyword-arguments)) - ,(compile-lambda-optional ll) - ,(compile-lambda-rest ll) - ,(compile-lambda-parse-keywords ll) - - ,(let ((*multiple-value-p* t)) - (if block - (convert-block `((block ,block ,@body)) t) - (convert-block body t))))))))) - - -(defun setq-pair (var val) - (let ((b (lookup-in-lexenv var *environment* 'variable))) - (cond - ((and b - (eq (binding-type b) 'variable) - (not (member 'special (binding-declarations b))) - (not (member 'constant (binding-declarations b)))) - `(= ,(binding-value b) ,(convert val))) - ((and b (eq (binding-type b) 'macro)) - (convert `(setf ,var ,val))) - (t - (convert `(set ',var ,val)))))) - - -(define-compilation setq (&rest pairs) - (let ((result nil)) - (when (null pairs) - (return-from setq (convert nil))) - (while t - (cond - ((null pairs) - (return)) - ((null (cdr pairs)) - (error "Odd pairs in SETQ")) - (t - (push `,(setq-pair (car pairs) (cadr pairs)) result) - (setq pairs (cddr pairs))))) - `(progn ,@(reverse result)))) - - -;;; Compilation of literals an object dumping - -;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during -;;; the bootstrap. Once everything is compiled, we want to dump the -;;; whole global environment to the output file to reproduce it in the -;;; run-time. However, the environment must contain expander functions -;;; rather than lists. We do not know how to dump function objects -;;; itself, so we mark the list definitions with this object and the -;;; compiler will be called when this object has to be dumped. -;;; Backquote/unquote does a similar magic, but this use is exclusive. -;;; -;;; Indeed, perhaps to compile the object other macros need to be -;;; 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) - (declare (ignore environment)) - (second form))) - -(defvar *literal-table* nil) -(defvar *literal-counter* 0) - -(defun genlit () - (incf *literal-counter*) - (make-symbol (concat "l" (integer-to-string *literal-counter*)))) - -(defun dump-symbol (symbol) - #-jscl - (let ((package (symbol-package symbol))) - (if (eq package (find-package "KEYWORD")) - `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package)))) - `(new (call |Symbol| ,(dump-string (symbol-name symbol)))))) - #+jscl - (let ((package (symbol-package symbol))) - (if (null package) - `(new (call |Symbol| ,(dump-string (symbol-name symbol)))) - (convert `(intern ,(symbol-name symbol) ,(package-name package)))))) - -(defun dump-cons (cons) - (let ((head (butlast cons)) - (tail (last cons))) - `(call |QIList| - ,@(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 #'literal elements)))) - -(defun dump-string (string) - `(call |make_lisp_string| ,string)) - -(defun literal (sexp &optional recursive) - (cond - ((integerp sexp) sexp) - ((floatp sexp) sexp) - ((characterp sexp) (string sexp)) - (t - (or (cdr (assoc sexp *literal-table* :test #'eql)) - (let ((dumped (typecase sexp - (symbol (dump-symbol sexp)) - (string (dump-string sexp)) - (cons - ;; BOOTSTRAP MAGIC: See the root file - ;; jscl.lisp and the function - ;; `dump-global-environment' for futher - ;; information. - (if (eq (car sexp) *magic-unquote-marker*) - (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 `(var (,jsvar ,dumped))) - (when (keywordp sexp) - (toplevel-compilation `(= ,(get jsvar "value") ,jsvar))) - jsvar))))))) - - -(define-compilation quote (sexp) - (literal sexp)) - -(define-compilation %while (pred &rest body) - `(selfcall - (while (!== ,(convert pred) ,(convert nil)) - ,(convert-block body)) - (return ,(convert nil)))) - -(define-compilation function (x) - (cond - ((and (listp x) (eq (car x) 'lambda)) - (compile-lambda (cadr x) (cddr x))) - ((and (listp x) (eq (car x) 'named-lambda)) - (destructuring-bind (name ll &rest body) (cdr x) - (compile-lambda ll body - :name (symbol-name name) - :block name))) - ((symbolp x) - (let ((b (lookup-in-lexenv x *environment* 'function))) - (if b - (binding-value b) - (convert `(symbol-function ',x))))))) - -(defun make-function-binding (fname) - (make-binding :name fname :type 'function :value (gvarname fname))) - -(defun compile-function-definition (list) - (compile-lambda (car list) (cdr list))) - -(defun translate-function (name) - (let ((b (lookup-in-lexenv name *environment* 'function))) - (and b (binding-value b)))) - -(define-compilation flet (definitions &rest body) - (let* ((fnames (mapcar #'car definitions)) - (cfuncs (mapcar (lambda (def) - (compile-lambda (cadr def) - `((block ,(car def) - ,@(cddr def))))) - definitions)) - (*environment* - (extend-lexenv (mapcar #'make-function-binding fnames) - *environment* - 'function))) - `(call (function ,(mapcar #'translate-function fnames) - ,(convert-block body t)) - ,@cfuncs))) - -(define-compilation labels (definitions &rest body) - (let* ((fnames (mapcar #'car definitions)) - (*environment* - (extend-lexenv (mapcar #'make-function-binding fnames) - *environment* - 'function))) - `(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) -(define-compilation eval-when-compile (&rest body) - (if *compiling-file* - (progn - (eval (cons 'progn body)) - (convert 0)) - (convert `(progn ,@body)))) - -(defmacro define-transformation (name args form) - `(define-compilation ,name ,args - (convert ,form))) - -(define-compilation progn (&rest body) - (if (null (cdr body)) - (convert (car body) *multiple-value-p*) - `(progn - ,@(append (mapcar #'convert (butlast body)) - (list (convert (car (last body)) t)))))) - -(define-compilation macrolet (definitions &rest body) - (let ((*environment* (copy-lexenv *environment*))) - (dolist (def definitions) - (destructuring-bind (name lambda-list &body body) def - (let ((binding (make-binding :name name :type 'macro :value - (let ((g!form (gensym))) - `(lambda (,g!form) - (destructuring-bind ,lambda-list ,g!form - ,@body)))))) - (push-to-lexenv binding *environment* 'function)))) - (convert `(progn ,@body) *multiple-value-p*))) - - -(defun special-variable-p (x) - (and (claimp x 'variable 'special) t)) - -;;; Wrap CODE to restore the symbol values of the dynamic -;;; bindings. BINDINGS is a list of pairs of the form -;;; (SYMBOL . PLACE), where PLACE is a Javascript variable -;;; name to initialize the symbol value and where to stored -;;; the old value. -(defun let-binding-wrapper (bindings body) - (when (null bindings) - (return-from let-binding-wrapper body)) - `(progn - (try (var tmp) - ,@(with-collect - (dolist (b bindings) - (let ((s (convert `',(car b)))) - (collect `(= tmp (get ,s "value"))) - (collect `(= (get ,s "value") ,(cdr b))) - (collect `(= ,(cdr b) tmp))))) - ,body) - (finally - ,@(with-collect - (dolist (b bindings) - (let ((s (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 #'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 v) dynamic-bindings) - v) - (translate-variable x))) - variables) - ,(let ((body (convert-block body t t))) - `,(let-binding-wrapper dynamic-bindings body))) - ,@cvalues))) - - -;;; Return the code to initialize BINDING, and push it extending the -;;; current lexical environment if the variable is not special. -(defun let*-initialize-value (binding) - (let ((var (first binding)) - (value (second binding))) - (if (special-variable-p var) - (convert `(setq ,var ,value)) - (let* ((v (gvarname var)) - (b (make-binding :name var :type 'variable :value v))) - (prog1 `(var (,v ,(convert value))) - (push-to-lexenv b *environment* 'variable)))))) - -;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It -;;; DOES NOT generate code to initialize the value of the symbols, -;;; unlike let-binding-wrapper. -(defun let*-binding-wrapper (symbols body) - (when (null symbols) - (return-from let*-binding-wrapper body)) - (let ((store (mapcar (lambda (s) (cons s (gvarname s))) - (remove-if-not #'special-variable-p symbols)))) - `(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*))) - (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) - ;; We use Javascript exceptions to implement non local control - ;; transfer. Exceptions has dynamic scoping, so we use a uniquely - ;; generated object to identify the block. The instance of a empty - ;; array is used to distinguish between nested dynamic Javascript - ;; exceptions. See https://github.com/davazp/jscl/issues/64 for - ;; futher details. - (let* ((idvar (gvarname name)) - (b (make-binding :name name :type 'block :value idvar))) - (when *multiple-value-p* - (push 'multiple-value (binding-declarations b))) - (let* ((*environment* (extend-lexenv (list b) *environment* 'block)) - (cbody (convert-block body t))) - (if (member 'used (binding-declarations b)) - `(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)) - (multiple-value-p (member 'multiple-value (binding-declarations b)))) - (when (null b) - (error "Return from unknown block `~S'." (symbol-name name))) - (push 'used (binding-declarations b)) - ;; The binding value is the name of a variable, whose value is the - ;; 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. - `(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) - `(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) - `(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))) - -(defun declare-tagbody-tags (tbidx body) - (let* ((go-tag-counter 0) - (bindings - (mapcar (lambda (label) - (let ((tagidx (incf go-tag-counter))) - (make-binding :name label :type 'gotag :value (list tbidx tagidx)))) - (remove-if-not #'go-tag-p body)))) - (extend-lexenv bindings *environment* 'gotag))) - -(define-compilation tagbody (&rest body) - ;; Ignore the tagbody if it does not contain any go-tag. We do this - ;; 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 (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)) - ;; Tagbody compilation - (let ((branch (gvarname 'branch)) - (tbidx (gvarname 'tbidx))) - (let ((*environment* (declare-tagbody-tags tbidx body)) - initag) - (let ((b (lookup-in-lexenv (first body) *environment* 'gotag))) - (setq initag (second (binding-value b)))) - `(selfcall - ;; TAGBODY branch to take - (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)) - (n (cond - ((symbolp label) (symbol-name label)) - ((integerp label) (integer-to-string label))))) - (when (null b) - (error "Unknown tag `~S'" label)) - `(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) - `(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) - `(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) - `(selfcall - (var (args ,(convert first-form *multiple-value-p*))) - (progn ,@(mapcar #'convert forms)) - (return args))) - -(define-transformation backquote (form) - (bq-completely-process form)) - - -;;; Primitives - -(defvar *builtins* nil) - -(defmacro define-raw-builtin (name args &body body) - ;; Creates a new primitive function `name' with parameters args and - ;; @body. The body can access to the local environment through the - ;; variable *ENVIRONMENT*. - `(push (list ',name (lambda ,args (block ,name ,@body))) - *builtins*)) - -(defmacro define-builtin (name args &body body) - `(define-raw-builtin ,name ,args - (let ,(mapcar (lambda (arg) `(,arg (convert ,arg))) args) - ,@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")) - (let ((counter 0) - (fargs '()) - (prelude '())) - (dolist (x args) - (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) `(return ,,@body)))) - -(define-raw-builtin + (&rest numbers) - (if (null numbers) - 0 - (variable-arity numbers - `(+ ,@numbers)))) - -(define-raw-builtin - (x &rest others) - (let ((args (cons x others))) - (variable-arity args `(- ,@args)))) - -(define-raw-builtin * (&rest numbers) - (if (null numbers) - 1 - (variable-arity numbers `(* ,@numbers)))) - -(define-raw-builtin / (x &rest others) - (let ((args (cons x others))) - (variable-arity args - (if (null others) - `(/ 1 ,(car args)) - (reduce (lambda (x y) `(/ ,x ,y)) - args))))) - -(define-builtin mod (x y) - `(% ,x ,y)) - - -(defun comparison-conjuntion (vars op) - (cond - ((null (cdr vars)) - 'true) - ((null (cddr vars)) - `(,op ,(car vars) ,(cadr vars))) - (t - `(and (,op ,(car vars) ,(cadr vars)) - ,(comparison-conjuntion (cdr vars) op))))) - -(defmacro define-builtin-comparison (op sym) - `(define-raw-builtin ,op (x &rest args) - (let ((args (cons x args))) - (variable-arity args - `(bool ,(comparison-conjuntion args ',sym)))))) - -(define-builtin-comparison > >) -(define-builtin-comparison < <) -(define-builtin-comparison >= >=) -(define-builtin-comparison <= <=) -(define-builtin-comparison = ==) -(define-builtin-comparison /= !=) - -(define-builtin numberp (x) - `(bool (== (typeof ,x) "number"))) - -(define-builtin floor (x) - `(method-call |Math| "floor" ,x)) - -(define-builtin expt (x y) - `(method-call |Math| "pow" ,x ,y)) - -(define-builtin float-to-string (x) - `(call |make_lisp_string| (method-call ,x |toString|))) - -(define-builtin cons (x y) - `(object "car" ,x "cdr" ,y)) - -(define-builtin consp (x) - `(selfcall - (var (tmp ,x)) - (return (bool (and (== (typeof tmp) "object") - (in "car" tmp)))))) - -(define-builtin car (x) - `(selfcall - (var (tmp ,x)) - (return (if (=== tmp ,(convert nil)) - ,(convert nil) - (get tmp "car"))))) - -(define-builtin cdr (x) - `(selfcall - (var (tmp ,x)) - (return (if (=== tmp ,(convert nil)) - ,(convert nil) - (get tmp "cdr"))))) - -(define-builtin rplaca (x new) - `(selfcall - (var (tmp ,x)) - (= (get tmp "car") ,new) - (return tmp))) - -(define-builtin rplacd (x new) - `(selfcall - (var (tmp ,x)) - (= (get tmp "cdr") ,new) - (return tmp))) - -(define-builtin symbolp (x) - `(bool (instanceof ,x |Symbol|))) - -(define-builtin make-symbol (name) - `(new (call |Symbol| ,name))) - -(define-builtin symbol-name (x) - `(get ,x "name")) - -(define-builtin set (symbol value) - `(= (get ,symbol "value") ,value)) - -(define-builtin fset (symbol value) - `(= (get ,symbol "fvalue") ,value)) - -(define-builtin boundp (x) - `(bool (!== (get ,x "value") undefined))) - -(define-builtin fboundp (x) - `(bool (!== (get ,x "fvalue") undefined))) - -(define-builtin symbol-value (x) - `(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) - `(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") ,(convert nil))) - -(define-builtin lambda-code (x) - `(call |make_lisp_string| (method-call ,x "toString"))) - -(define-builtin eq (x y) - `(bool (=== ,x ,y))) - -(define-builtin char-code (x) - `(call |char_to_codepoint| ,x)) - -(define-builtin code-char (x) - `(call |char_from_codepoint| ,x)) - -(define-builtin characterp (x) - `(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)) - -(define-builtin char-downcase (x) - `(call |safe_char_downcase| ,x)) - -(define-builtin stringp (x) - `(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) - `(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) - (convert func) - (let ((args (butlast args)) - (last (car (last args)))) - `(selfcall - (var (f ,(convert func))) - (var (args ,(list-to-vector - (list* (if *multiple-value-p* '|values| '|pv|) - (length args) - (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 (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 (method-call |values| "apply" this (call |forcemv| v)))) - `(call |globalEval| (call |xstring| ,string)))) - -(define-builtin %throw (string) - `(selfcall (throw ,string))) - -(define-builtin functionp (x) - `(bool (=== (typeof ,x) "function"))) - -(define-builtin %write-string (x) - `(method-call |lisp| "write" ,x)) - -(define-builtin /debug (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) - `(selfcall - (var (x ,x)) - (return (bool (and (=== (typeof x) "object") (in "length" x)))))) - -(define-builtin make-storage-vector (n) - `(selfcall - (var (r #())) - (= (get r "length") ,n) - (return r))) - -(define-builtin storage-vector-size (x) - `(get ,x "length")) - -(define-builtin resize-storage-vector (vector new-size) - `(= (get ,vector "length") ,new-size)) - -(define-builtin storage-vector-ref (vector n) - `(selfcall - (var (x (property ,vector ,n))) - (if (=== x undefined) (throw "Out of range.")) - (return x))) - -(define-builtin storage-vector-set (vector n 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) - `(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 () - `(method-call (new (call |Date|)) "getTime")) - -(define-builtin values-array (array) - (if *multiple-value-p* - `(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 #'convert args)) - `(call |pv| ,@(mapcar #'convert args)))) - -;;; Javascript FFI - -(define-builtin new () - '(object)) - -(define-raw-builtin oget* (object key &rest keys) - `(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))) - `(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| ,(convert `(oget* ,object ,key ,@keys)))) - -(define-raw-builtin oset (value object key &rest keys) - (convert `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) - -(define-builtin objectp (x) - `(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) - `(bool (in (call |xstring| ,key) ,object))) - -(define-builtin map-for-in (function object) - `(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| ,(convert val)))) - -(define-setf-expander %js-vref (var) - (let ((new-value (gensym))) - (unless (stringp var) - (error "`~S' is not a string." var)) - (values nil - (list var) - (list new-value) - `(%js-vset ,var ,new-value) - `(%js-vref ,var)))) - - -#-jscl -(defvar *macroexpander-cache* - (make-hash-table :test #'eq)) - -(defun !macro-function (symbol) - (unless (symbolp symbol) - (error "`~S' is not a symbol." symbol)) - (let ((b (lookup-in-lexenv symbol *environment* 'function))) - (if (and b (eq (binding-type b) 'macro)) - (let ((expander (binding-value b))) - (cond - #-jscl - ((gethash b *macroexpander-cache*) - (setq expander (gethash b *macroexpander-cache*))) - ((listp expander) - (let ((compiled (eval expander))) - ;; The list representation are useful while - ;; bootstrapping, as we can dump the definition of the - ;; macros easily, but they are slow because we have to - ;; evaluate them and compile them now and again. So, let - ;; us replace the list representation version of the - ;; function with the compiled one. - ;; - #+jscl (setf (binding-value b) compiled) - #-jscl (setf (gethash b *macroexpander-cache*) compiled) - (setq expander compiled)))) - expander) - nil))) - -(defun !macroexpand-1 (form) - (cond - ((symbolp form) - (let ((b (lookup-in-lexenv form *environment* 'variable))) - (if (and b (eq (binding-type b) 'macro)) - (values (binding-value b) t) - (values form nil)))) - ((and (consp form) (symbolp (car form))) - (let ((macrofun (!macro-function (car form)))) - (if macrofun - (values (funcall macrofun (cdr form)) t) - (values form nil)))) - (t - (values form nil)))) - -(defun compile-funcall (function 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) - `(call ,(translate-function function) ,@arglist)) - ((and (symbolp function) - #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) - #-jscl t) - `(method-call ,(convert `',function) "fvalue" ,@arglist)) - #+jscl((symbolp function) - `(call ,(convert `#',function) ,@arglist)) - ((and (consp function) (eq (car function) 'lambda)) - `(call ,(convert `#',function) ,@arglist)) - ((and (consp function) (eq (car function) 'oget)) - `(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 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 #'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 convert (convert sexp multiple-value-p))) - ;; The expression has been macroexpanded. Now compile it! - (let ((*multiple-value-p* multiple-value-p)) - (cond - ((symbolp sexp) - (let ((b (lookup-in-lexenv sexp *environment* 'variable))) - (cond - ((and b (not (member 'special (binding-declarations b)))) - (binding-value b)) - ((or (keywordp sexp) - (and b (member 'constant (binding-declarations b)))) - `(get ,(convert `',sexp) "value")) - (t - (convert `(symbol-value ',sexp)))))) - ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp)) - (literal sexp)) - ((listp sexp) - (let ((name (car sexp)) - (args (cdr sexp))) - (cond - ;; Special forms - ((assoc name *compilations*) - (let ((comp (second (assoc name *compilations*)))) - (apply comp args))) - ;; Built-in functions - ((and (assoc name *builtins*) - (not (claimp name 'function 'notinline))) - (let ((comp (second (assoc name *builtins*)))) - (apply comp args))) - (t - (compile-funcall name args))))) - (t - (error "How should I compile `~S'?" sexp)))))) - - -(defvar *compile-print-toplevels* nil) - -(defun truncate-string (string &optional (width 60)) - (let ((n (or (position #\newline string) - (min width (length string))))) - (subseq string 0 n))) - -(defun convert-toplevel (sexp &optional multiple-value-p) - (let ((*toplevel-compilations* nil)) - (cond - ;; Non-empty toplevel progn - ((and (consp sexp) - (eq (car sexp) 'progn) - (cdr sexp)) - `(progn - ,@(mapcar (lambda (s) (convert-toplevel s t)) - (cdr sexp)))) - (t - (when *compile-print-toplevels* - (let ((form-string (prin1-to-string sexp))) - (format t "Compiling ~a..." (truncate-string form-string)))) - (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)))) diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp new file mode 100644 index 0000000..51e5c65 --- /dev/null +++ b/src/compiler/codegen.lisp @@ -0,0 +1,505 @@ +;;; compiler-codege.lisp --- Naive Javascript unparser + +;; copyright (C) 2013 David Vazquez + +;; JSCL is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; JSCL is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with JSCL. If not, see . + +;;; This code generator takes as input a S-expression representation +;;; of the Javascript AST and generates Javascript code without +;;; redundant syntax constructions like extra parenthesis. +;;; +;;; It is intended to be used with the new compiler. However, it is +;;; quite independent so it has been integrated early in JSCL. + +(/debug "loading compiler-codegen.lisp!") + +(defvar *js-macros* nil) +(defmacro define-js-macro (name lambda-list &body body) + (let ((form (gensym))) + `(push (cons ',name + (lambda (,form) + (block ,name + (destructuring-bind ,lambda-list ,form + ,@body)))) + *js-macros*))) + +(defun js-macroexpand (js) + (if (and (consp js) (assoc (car js) *js-macros*)) + (let ((expander (cdr (assoc (car js) *js-macros*)))) + (multiple-value-bind (expansion stop-expand-p) + (funcall expander (cdr js)) + (if stop-expand-p + expansion + (js-macroexpand expansion)))) + js)) + + +(defconstant no-comma 12) + +(defvar *js-output* t) + +;;; Two seperate functions are needed for escaping strings: +;;; One for producing JavaScript string literals (which are singly or +;;; doubly quoted) +;;; And one for producing Lisp strings (which are only doubly quoted) +;;; +;;; The same function would suffice for both, but for javascript string +;;; literals it is neater to use either depending on the context, e.g: +;;; foo's => "foo's" +;;; "foo" => '"foo"' +;;; which avoids having to escape quotes where possible +(defun js-escape-string (string) + (let ((index 0) + (size (length string)) + (seen-single-quote nil) + (seen-double-quote nil)) + (flet ((%js-escape-string (string escape-single-quote-p) + (let ((output "") + (index 0)) + (while (< index size) + (let ((ch (char string index))) + (when (char= ch #\\) + (setq output (concat output "\\"))) + (when (and escape-single-quote-p (char= ch #\')) + (setq output (concat output "\\"))) + (when (char= ch #\newline) + (setq output (concat output "\\")) + (setq ch #\n)) + (setq output (concat output (string ch)))) + (incf index)) + output))) + ;; First, scan the string for single/double quotes + (while (< index size) + (let ((ch (char string index))) + (when (char= ch #\') + (setq seen-single-quote t)) + (when (char= ch #\") + (setq seen-double-quote t))) + (incf index)) + ;; Then pick the appropriate way to escape the quotes + (cond + ((not seen-single-quote) + (concat "'" (%js-escape-string string nil) "'")) + ((not seen-double-quote) + (concat "\"" (%js-escape-string string nil) "\"")) + (t (concat "'" (%js-escape-string string t) "'")))))) + + +(defun js-format (fmt &rest args) + (apply #'format *js-output* fmt args)) + +(defun valid-js-identifier (string-designator) + (let ((string (typecase string-designator + (symbol (symbol-name string-designator)) + (string string-designator) + (t + (return-from valid-js-identifier (values nil nil)))))) + (flet ((constitutentp (ch) + (or (alphanumericp ch) (member ch '(#\$ #\_))))) + (if (and (every #'constitutentp string) + (if (plusp (length string)) + (not (digit-char-p (char string 0))) + t)) + (values (format nil "~a" string) t) + (values nil nil))))) + +(defun js-identifier (string-designator) + (multiple-value-bind (string valid) + (valid-js-identifier string-designator) + (unless valid + (error "~S is not a valid Javascript identifier." string)) + (js-format "~a" string))) + +(defun js-primary-expr (form) + (cond + ((numberp form) + (if (<= 0 form) + (js-format "~a" form) + (js-expr `(- ,(abs form))))) + ((stringp form) + (js-format "~a" (js-escape-string form))) + ((symbolp form) + (case form + (true (js-format "true")) + (false (js-format "false")) + (null (js-format "null")) + (this (js-format "this")) + (undefined (js-format "undefined")) + (otherwise + (js-identifier form)))) + (t + (error "Unknown Javascript syntax ~S." form)))) + +(defun js-vector-initializer (vector) + (let ((size (length vector))) + (js-format "[") + (dotimes (i (1- size)) + (let ((elt (aref vector i))) + (unless (eq elt 'null) + (js-expr elt no-comma)) + (js-format ","))) + (when (plusp size) + (js-expr (aref vector (1- size)) no-comma)) + (js-format "]"))) + +(defun js-object-initializer (plist) + (js-format "{") + (do* ((tail plist (cddr tail))) + ((null tail)) + (let ((key (car tail)) + (value (cadr tail))) + (multiple-value-bind (identifier identifier-p) (valid-js-identifier key) + (declare (ignore identifier)) + (if identifier-p + (js-identifier key) + (js-expr (string key) no-comma))) + (js-format ": ") + (js-expr value no-comma) + (unless (null (cddr tail)) + (js-format ",")))) + (js-format "}")) + +(defun js-function (arguments &rest body) + (js-format "function(") + (when arguments + (js-identifier (car arguments)) + (dolist (arg (cdr arguments)) + (js-format ",") + (js-identifier arg))) + (js-format ")") + (js-stmt `(group ,@body) t)) + +(defun check-lvalue (x) + (unless (or (symbolp x) + (nth-value 1 (valid-js-identifier x)) + (and (consp x) + (member (car x) '(get = property)))) + (error "Bad Javascript lvalue ~S" x))) + +;;; Process the Javascript AST to reduce some syntax sugar. +(defun js-expand-expr (form) + (if (consp form) + (case (car form) + (+ + (case (length (cdr form)) + (1 `(unary+ ,(cadr form))) + (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form))))) + (- + (case (length (cdr form)) + (1 `(unary- ,(cadr form))) + (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form))))) + ((and or) + (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form))) + ((progn comma) + (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t)) + (t + (js-macroexpand form))) + form)) + +(defun js-operator-expression (op args precedence associativity operand-order) + (let ((op1 (car args)) + (op2 (cadr args))) + (case op + ;; Accessors + (property + (js-expr (car args) 0) + (js-format "[") + (js-expr (cadr args) no-comma) + (js-format "]")) + (get + (multiple-value-bind (accessor accessorp) + (valid-js-identifier (cadr args)) + (unless accessorp + (error "Invalid accessor ~S" (cadr args))) + (js-expr (car args) 0) + (js-format ".") + (js-identifier accessor))) + ;; Function call + (call + (js-expr (car args) 1) + (js-format "(") + (when (cdr args) + (js-expr (cadr args) no-comma) + (dolist (operand (cddr args)) + (js-format ",") + (js-expr operand no-comma))) + (js-format ")")) + ;; Object syntax + (object + (js-object-initializer args)) + ;; Function expressions + (function + (js-format "(") + (apply #'js-function args) + (js-format ")")) + (t + (labels ((low-precedence-p (op-precedence) + (cond + ((> op-precedence precedence)) + ((< op-precedence precedence) nil) + (t (not (eq operand-order associativity))))) + + (%unary-op (operator string operator-precedence operator-associativity post lvalue) + (when (eq op operator) + (when lvalue (check-lvalue op1)) + (when (low-precedence-p operator-precedence) (js-format "(")) + (cond + (post + (js-expr op1 operator-precedence operator-associativity 'left) + (js-format "~a" string)) + (t + (js-format "~a" string) + (js-expr op1 operator-precedence operator-associativity 'right))) + (when (low-precedence-p operator-precedence) (js-format ")")) + (return-from js-operator-expression))) + + (%binary-op (operator string operator-precedence operator-associativity lvalue) + (when (eq op operator) + (when lvalue (check-lvalue op1)) + (when (low-precedence-p operator-precedence) (js-format "(")) + (js-expr op1 operator-precedence operator-associativity 'left) + (js-format "~a" string) + (js-expr op2 operator-precedence operator-associativity 'right) + (when (low-precedence-p operator-precedence) (js-format ")")) + (return-from js-operator-expression)))) + + (macrolet ((unary-op (operator string precedence associativity &key post lvalue) + `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue)) + (binary-op (operator string precedence associativity &key lvalue) + `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue))) + + (unary-op pre++ "++" 2 right :lvalue t) + (unary-op pre-- "--" 2 right :lvalue t) + (unary-op post++ "++" 2 right :lvalue t :post t) + (unary-op post-- "--" 2 right :lvalue t :post t) + (unary-op not "!" 2 right) + (unary-op bit-not "~" 2 right) + ;; Note that the leading space is necessary because it + ;; could break with post++, for example. TODO: Avoid + ;; leading space when it's possible. + (unary-op unary+ " +" 2 right) + (unary-op unary- " -" 2 right) + (unary-op delete "delete " 2 right) + (unary-op void "void " 2 right) + (unary-op typeof "typeof " 2 right) + (unary-op new "new " 2 right) + + (binary-op * "*" 3 left) + (binary-op / "/" 3 left) + (binary-op mod "%" 3 left) + (binary-op % "%" 3 left) + (binary-op + "+" 4 left) + (binary-op - "-" 5 left) + (binary-op << "<<" 5 left) + (binary-op >> "<<" 5 left) + (binary-op >>> ">>>" 5 left) + (binary-op <= "<=" 6 left) + (binary-op < "<" 6 left) + (binary-op > ">" 6 left) + (binary-op >= ">=" 6 left) + (binary-op instanceof " instanceof " 6 left) + (binary-op in " in " 6 left) + (binary-op == "==" 7 left) + (binary-op != "!=" 7 left) + (binary-op === "===" 7 left) + (binary-op !== "!==" 7 left) + (binary-op bit-and "&" 8 left) + (binary-op bit-xor "^" 9 left) + (binary-op bit-or "|" 10 left) + (binary-op and "&&" 11 left) + (binary-op or "||" 12 left) + (binary-op = "=" 13 right :lvalue t) + (binary-op += "+=" 13 right :lvalue t) + (binary-op incf "+=" 13 right :lvalue t) + (binary-op -= "-=" 13 right :lvalue t) + (binary-op decf "-=" 13 right :lvalue t) + (binary-op *= "*=" 13 right :lvalue t) + (binary-op /= "*=" 13 right :lvalue t) + (binary-op bit-xor= "^=" 13 right :lvalue t) + (binary-op bit-and= "&=" 13 right :lvalue t) + (binary-op bit-or= "|=" 13 right :lvalue t) + (binary-op <<= "<<=" 13 right :lvalue t) + (binary-op >>= ">>=" 13 right :lvalue t) + (binary-op >>>= ">>>=" 13 right :lvalue t) + + (binary-op comma "," 13 right) + (binary-op progn "," 13 right) + + (when (member op '(? if)) + (when (low-precedence-p 12) (js-format "(")) + (js-expr (first args) 12 'right 'left) + (js-format "?") + (js-expr (second args) 12 'right 'right) + (js-format ":") + (js-expr (third args) 12 'right 'right) + (when (low-precedence-p 12) (js-format ")")) + (return-from js-operator-expression)) + + (error "Unknown operator `~S'" op))))))) + +(defun js-expr (form &optional (precedence 1000) associativity operand-order) + (let ((form (js-expand-expr form))) + (cond + ((or (symbolp form) (numberp form) (stringp form)) + (js-primary-expr form)) + ((vectorp form) + (js-vector-initializer form)) + (t + (js-operator-expression (car form) (cdr form) precedence associativity operand-order))))) + +(defun js-expand-stmt (form) + (cond + ((and (consp form) (eq (car form) 'progn)) + (destructuring-bind (&body body) (cdr form) + (cond + ((null body) + nil) + ((null (cdr body)) + (js-expand-stmt (car body))) + (t + `(group ,@(cdr form)))))) + (t + (js-macroexpand form)))) + +(defun js-stmt (form &optional parent) + (let ((form (js-expand-stmt form))) + (flet ((js-stmt (x) (js-stmt x form))) + (cond + ((null form) + (unless (or (and (consp parent) (eq (car parent) 'group)) + (null parent)) + (js-format ";"))) + ((atom form) + (progn + (js-expr form) + (js-format ";"))) + (t + (case (car form) + (label + (destructuring-bind (label &body body) (cdr form) + (js-identifier label) + (js-format ":") + (js-stmt `(progn ,@body)))) + (break + (destructuring-bind (&optional label) (cdr form) + (js-format "break") + (when label + (js-format " ") + (js-identifier label)) + (js-format ";"))) + (return + (destructuring-bind (value) (cdr form) + (js-format "return ") + (js-expr value) + (js-format ";"))) + (var + (flet ((js-var (spec) + (destructuring-bind (variable &optional initial) + (ensure-list spec) + (js-identifier variable) + (when initial + (js-format "=") + (js-expr initial no-comma))))) + (destructuring-bind (var &rest vars) (cdr form) + (js-format "var ") + (js-var var) + (dolist (var vars) + (js-format ",") + (js-var var)) + (js-format ";")))) + (if + (destructuring-bind (condition true &optional false) (cdr form) + (js-format "if (") + (js-expr condition) + (js-format ") ") + (js-stmt true) + (when false + (js-format " else ") + (js-stmt false)))) + (group + (let ((in-group-p + (or (null parent) + (and (consp parent) (eq (car parent) 'group))))) + (unless in-group-p (js-format "{")) + (mapc #'js-stmt (cdr form)) + (unless in-group-p (js-format "}")))) + (while + (destructuring-bind (condition &body body) (cdr form) + (js-format "while (") + (js-expr condition) + (js-format ")") + (js-stmt `(progn ,@body)))) + (switch + (destructuring-bind (value &rest cases) (cdr form) + (js-format "switch(") + (js-expr value) + (js-format "){") + (dolist (case cases) + (cond + ((and (consp case) (eq (car case) 'case)) + (js-format "case ") + (let ((value (cadr case))) + (unless (or (stringp value) (integerp value)) + (error "Non-constant switch case `~S'." value)) + (js-expr value)) + (js-format ":")) + ((eq case 'default) + (js-format "default:")) + (t + (js-stmt case)))) + (js-format "}"))) + (for + (destructuring-bind ((start condition step) &body body) (cdr form) + (js-format "for (") + (js-expr start) + (js-format ";") + (js-expr condition) + (js-format ";") + (js-expr step) + (js-format ")") + (js-stmt `(progn ,@body)))) + (for-in + (destructuring-bind ((x object) &body body) (cdr form) + (js-format "for (") + (js-identifier x) + (js-format " in ") + (js-expr object) + (js-format ")") + (js-stmt `(progn ,@body)))) + (try + (destructuring-bind (&rest body) (cdr form) + (js-format "try") + (js-stmt `(group ,@body)))) + (catch + (destructuring-bind ((var) &rest body) (cdr form) + (js-format "catch (") + (js-identifier var) + (js-format ")") + (js-stmt `(group ,@body)))) + (finally + (destructuring-bind (&rest body) (cdr form) + (js-format "finally") + (js-stmt `(group ,@body)))) + (throw + (destructuring-bind (object) (cdr form) + (js-format "throw ") + (js-expr object) + (js-format ";"))) + (t + (js-expr form) + (js-format ";")))))))) + +(defun js (&rest stmts) + (mapc #'js-stmt stmts) + nil) diff --git a/src/compiler/compiler.lisp b/src/compiler/compiler.lisp new file mode 100644 index 0000000..a2e5dee --- /dev/null +++ b/src/compiler/compiler.lisp @@ -0,0 +1,1425 @@ +;;; compiler.lisp --- + +;; Copyright (C) 2012, 2013 David Vazquez +;; Copyright (C) 2012 Raimon Grau + +;; JSCL is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; JSCL is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with JSCL. If not, see . + +;;;; Compiler + +(/debug "loading compiler.lisp!") + +;;; 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. + +(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 +;;; returning an individual object. However, if the special variable +;;; `*multiple-value-p*' is NIL, is granted that only the primary +;;; value will be used, so we can optimize to avoid the VALUES +;;; function call. +(defvar *multiple-value-p* nil) + +;;; Environment + +(def!struct binding + name + type + value + declarations) + +(def!struct lexenv + variable + function + block + gotag) + +(defun lookup-in-lexenv (name lexenv namespace) + (find name (ecase namespace + (variable (lexenv-variable lexenv)) + (function (lexenv-function lexenv)) + (block (lexenv-block lexenv)) + (gotag (lexenv-gotag lexenv))) + :key #'binding-name)) + +(defun push-to-lexenv (binding lexenv namespace) + (ecase namespace + (variable (push binding (lexenv-variable lexenv))) + (function (push binding (lexenv-function lexenv))) + (block (push binding (lexenv-block lexenv))) + (gotag (push binding (lexenv-gotag lexenv))))) + +(defun extend-lexenv (bindings lexenv namespace) + (let ((env (copy-lexenv lexenv))) + (dolist (binding (reverse bindings) env) + (push-to-lexenv binding env namespace)))) + + +(defvar *environment* (make-lexenv)) +(defvar *variable-counter* 0) + +(defun gvarname (symbol) + (declare (ignore symbol)) + (incf *variable-counter*) + (make-symbol (concat "v" (integer-to-string *variable-counter*)))) + +(defun translate-variable (symbol) + (awhen (lookup-in-lexenv symbol *environment* 'variable) + (binding-value it))) + +(defun extend-local-env (args) + (let ((new (copy-lexenv *environment*))) + (dolist (symbol args new) + (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol)))) + (push-to-lexenv b new 'variable))))) + +;;; Toplevel compilations +(defvar *toplevel-compilations* nil) + +(defun toplevel-compilation (string) + (push string *toplevel-compilations*)) + +(defun get-toplevel-compilations () + (reverse *toplevel-compilations*)) + +(defun %compile-defmacro (name lambda) + (toplevel-compilation (convert `',name)) + (let ((binding (make-binding :name name :type 'macro :value lambda))) + (push-to-lexenv binding *environment* 'function)) + name) + +(defun global-binding (name type namespace) + (or (lookup-in-lexenv name *environment* namespace) + (let ((b (make-binding :name name :type type :value nil))) + (push-to-lexenv b *environment* namespace) + b))) + +(defun claimp (symbol namespace claim) + (let ((b (lookup-in-lexenv symbol *environment* namespace))) + (and b (member claim (binding-declarations b))))) + +(defun !proclaim (decl) + (case (car decl) + (special + (dolist (name (cdr decl)) + (let ((b (global-binding name 'variable 'variable))) + (push 'special (binding-declarations b))))) + (notinline + (dolist (name (cdr decl)) + (let ((b (global-binding name 'function 'function))) + (push 'notinline (binding-declarations b))))) + (constant + (dolist (name (cdr decl)) + (let ((b (global-binding name 'variable 'variable))) + (push 'constant (binding-declarations b))))))) + +#+jscl +(fset 'proclaim #'!proclaim) + +(defun %define-symbol-macro (name expansion) + (let ((b (make-binding :name name :type 'macro :value expansion))) + (push-to-lexenv b *environment* 'variable) + name)) + +#+jscl +(defmacro define-symbol-macro (name expansion) + `(%define-symbol-macro ',name ',expansion)) + + +;;; Special forms + +(defvar *compilations* nil) + +(defmacro define-compilation (name args &body body) + ;; Creates a new primitive `name' with parameters args and + ;; @body. The body can access to the local environment through the + ;; variable *ENVIRONMENT*. + `(push (list ',name (lambda ,args (block ,name ,@body))) + *compilations*)) + +(define-compilation if (condition true &optional false) + `(if (!== ,(convert condition) ,(convert nil)) + ,(convert true *multiple-value-p*) + ,(convert false *multiple-value-p*))) + +(defvar *ll-keywords* '(&optional &rest &key)) + +(defun list-until-keyword (list) + (if (or (null list) (member (car list) *ll-keywords*)) + nil + (cons (car list) (list-until-keyword (cdr list))))) + +(defun ll-section (keyword ll) + (list-until-keyword (cdr (member keyword ll)))) + +(defun ll-required-arguments (ll) + (list-until-keyword ll)) + +(defun ll-optional-arguments-canonical (ll) + (mapcar #'ensure-list (ll-section '&optional ll))) + +(defun ll-optional-arguments (ll) + (mapcar #'car (ll-optional-arguments-canonical ll))) + +(defun ll-rest-argument (ll) + (let ((rest (ll-section '&rest ll))) + (when (cdr rest) + (error "Bad lambda-list `~S'." ll)) + (car rest))) + +(defun ll-keyword-arguments-canonical (ll) + (flet ((canonicalize (keyarg) + ;; Build a canonical keyword argument descriptor, filling + ;; the optional fields. The result is a list of the form + ;; ((keyword-name var) init-form svar). + (let ((arg (ensure-list keyarg))) + (cons (if (listp (car arg)) + (car arg) + (list (intern (symbol-name (car arg)) "KEYWORD") (car arg))) + (cdr arg))))) + (mapcar #'canonicalize (ll-section '&key ll)))) + +(defun ll-keyword-arguments (ll) + (mapcar (lambda (keyarg) (second (first keyarg))) + (ll-keyword-arguments-canonical ll))) + +(defun ll-svars (lambda-list) + (let ((args + (append + (ll-keyword-arguments-canonical lambda-list) + (ll-optional-arguments-canonical lambda-list)))) + (remove nil (mapcar #'third args)))) + +(defun lambda-name/docstring-wrapper (name docstring code) + (if (or name docstring) + `(selfcall + (var (func ,code)) + ,(when name `(= (get func "fname") ,name)) + ,(when docstring `(= (get func "docstring") ,docstring)) + (return func)) + code)) + +(defun lambda-check-argument-count + (n-required-arguments n-optional-arguments rest-p) + ;; Note: Remember that we assume that the number of arguments of a + ;; call is at least 1 (the values argument). + (let ((min n-required-arguments) + (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments)))) + (block nil + ;; Special case: a positive exact number of arguments. + (when (and (< 0 min) (eql min max)) + (return `(call |checkArgs| |nargs| ,min))) + ;; General case: + `(progn + ,(when (< 0 min) `(call |checkArgsAtLeast| |nargs| ,min)) + ,(when (numberp max) `(call |checkArgsAtMost| |nargs| ,max)))))) + +(defun compile-lambda-optional (ll) + (let* ((optional-arguments (ll-optional-arguments-canonical ll)) + (n-required-arguments (length (ll-required-arguments ll))) + (n-optional-arguments (length optional-arguments))) + (when optional-arguments + `(switch |nargs| + ,@(with-collect + (dotimes (idx n-optional-arguments) + (let ((arg (nth idx optional-arguments))) + (collect `(case ,(+ idx n-required-arguments))) + (collect `(= ,(translate-variable (car arg)) + ,(convert (cadr arg)))) + (collect (when (third arg) + `(= ,(translate-variable (third arg)) + ,(convert nil)))))) + (collect 'default) + (collect '(break))))))) + +(defun compile-lambda-rest (ll) + (let ((n-required-arguments (length (ll-required-arguments ll))) + (n-optional-arguments (length (ll-optional-arguments ll))) + (rest-argument (ll-rest-argument ll))) + (when rest-argument + (let ((js!rest (translate-variable rest-argument))) + `(progn + (var (,js!rest ,(convert nil))) + (var i) + (for ((= i (- |nargs| 1)) + (>= i ,(+ n-required-arguments n-optional-arguments)) + (post-- i)) + (= ,js!rest (object "car" (property |arguments| (+ i 2)) + "cdr" ,js!rest)))))))) + +(defun compile-lambda-parse-keywords (ll) + (let ((n-required-arguments + (length (ll-required-arguments ll))) + (n-optional-arguments + (length (ll-optional-arguments ll))) + (keyword-arguments + (ll-keyword-arguments-canonical ll))) + `(progn + ;; Declare variables + ,@(with-collect + (dolist (keyword-argument keyword-arguments) + (destructuring-bind ((keyword-name var) &optional initform svar) + keyword-argument + (declare (ignore keyword-name initform)) + (collect `(var ,(translate-variable var))) + (when svar + (collect + `(var (,(translate-variable svar) + ,(convert nil)))))))) + + ;; Parse keywords + ,(flet ((parse-keyword (keyarg) + (destructuring-bind ((keyword-name var) &optional initform svar) keyarg + ;; ((keyword-name var) init-form svar) + `(progn + (for ((= i ,(+ n-required-arguments n-optional-arguments)) + (< i |nargs|) + (+= i 2)) + ;; .... + (if (=== (property |arguments| (+ i 2)) + ,(convert keyword-name)) + (progn + (= ,(translate-variable var) + (property |arguments| (+ i 3))) + ,(when svar `(= ,(translate-variable svar) + ,(convert t))) + (break)))) + (if (== i |nargs|) + (= ,(translate-variable var) ,(convert initform))))))) + (when keyword-arguments + `(progn + (var i) + ,@(mapcar #'parse-keyword keyword-arguments)))) + + ;; Check for unknown keywords + ,(when keyword-arguments + `(progn + (var (start ,(+ n-required-arguments n-optional-arguments))) + (if (== (% (- |nargs| start) 2) 1) + (throw "Odd number of keyword arguments.")) + (for ((= i start) (< i |nargs|) (+= i 2)) + (if (and ,@(mapcar (lambda (keyword-argument) + (destructuring-bind ((keyword-name var) &optional initform svar) + keyword-argument + (declare (ignore var initform svar)) + `(!== (property |arguments| (+ i 2)) ,(convert keyword-name)))) + keyword-arguments)) + (throw (+ "Unknown keyword argument " + (call |xstring| + (property + (property |arguments| (+ i 2)) + "name"))))))))))) + +(defun parse-lambda-list (ll) + (values (ll-required-arguments ll) + (ll-optional-arguments ll) + (ll-keyword-arguments ll) + (ll-rest-argument ll))) + +;;; Process BODY for declarations and/or docstrings. Return as +;;; multiple values the BODY without docstrings or declarations, the +;;; list of declaration forms and the docstring. +(defun parse-body (body &key declarations docstring) + (let ((value-declarations) + (value-docstring)) + ;; Parse declarations + (when declarations + (do* ((rest body (cdr rest)) + (form (car rest) (car rest))) + ((or (atom form) (not (eq (car form) 'declare))) + (setf body rest)) + (push form value-declarations))) + ;; Parse docstring + (when (and docstring + (stringp (car body)) + (not (null (cdr body)))) + (setq value-docstring (car body)) + (setq body (cdr body))) + (values body value-declarations value-docstring))) + +;;; Compile a lambda function with lambda list LL and body BODY. If +;;; NAME is given, it should be a constant string and it will become +;;; the name of the function. If BLOCK is non-NIL, a named block is +;;; created around the body. NOTE: No block (even anonymous) is +;;; created if BLOCk is NIL. +(defun compile-lambda (ll body &key name block) + (multiple-value-bind (required-arguments + optional-arguments + keyword-arguments + rest-argument) + (parse-lambda-list ll) + (multiple-value-bind (body decls documentation) + (parse-body body :declarations t :docstring t) + (declare (ignore decls)) + (let ((n-required-arguments (length required-arguments)) + (n-optional-arguments (length optional-arguments)) + (*environment* (extend-local-env + (append (ensure-list rest-argument) + required-arguments + optional-arguments + keyword-arguments + (ll-svars ll))))) + (lambda-name/docstring-wrapper name documentation + `(function (|values| |nargs| ,@(mapcar (lambda (x) + (translate-variable x)) + (append required-arguments optional-arguments))) + ;; Check number of arguments + ,(lambda-check-argument-count n-required-arguments + n-optional-arguments + (or rest-argument keyword-arguments)) + ,(compile-lambda-optional ll) + ,(compile-lambda-rest ll) + ,(compile-lambda-parse-keywords ll) + + ,(let ((*multiple-value-p* t)) + (if block + (convert-block `((block ,block ,@body)) t) + (convert-block body t))))))))) + + +(defun setq-pair (var val) + (let ((b (lookup-in-lexenv var *environment* 'variable))) + (cond + ((and b + (eq (binding-type b) 'variable) + (not (member 'special (binding-declarations b))) + (not (member 'constant (binding-declarations b)))) + `(= ,(binding-value b) ,(convert val))) + ((and b (eq (binding-type b) 'macro)) + (convert `(setf ,var ,val))) + (t + (convert `(set ',var ,val)))))) + + +(define-compilation setq (&rest pairs) + (let ((result nil)) + (when (null pairs) + (return-from setq (convert nil))) + (while t + (cond + ((null pairs) + (return)) + ((null (cdr pairs)) + (error "Odd pairs in SETQ")) + (t + (push `,(setq-pair (car pairs) (cadr pairs)) result) + (setq pairs (cddr pairs))))) + `(progn ,@(reverse result)))) + + +;;; Compilation of literals an object dumping + +;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during +;;; the bootstrap. Once everything is compiled, we want to dump the +;;; whole global environment to the output file to reproduce it in the +;;; run-time. However, the environment must contain expander functions +;;; rather than lists. We do not know how to dump function objects +;;; itself, so we mark the list definitions with this object and the +;;; compiler will be called when this object has to be dumped. +;;; Backquote/unquote does a similar magic, but this use is exclusive. +;;; +;;; Indeed, perhaps to compile the object other macros need to be +;;; 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) + (declare (ignore environment)) + (second form))) + +(defvar *literal-table* nil) +(defvar *literal-counter* 0) + +(defun genlit () + (incf *literal-counter*) + (make-symbol (concat "l" (integer-to-string *literal-counter*)))) + +(defun dump-symbol (symbol) + #-jscl + (let ((package (symbol-package symbol))) + (if (eq package (find-package "KEYWORD")) + `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package)))) + `(new (call |Symbol| ,(dump-string (symbol-name symbol)))))) + #+jscl + (let ((package (symbol-package symbol))) + (if (null package) + `(new (call |Symbol| ,(dump-string (symbol-name symbol)))) + (convert `(intern ,(symbol-name symbol) ,(package-name package)))))) + +(defun dump-cons (cons) + (let ((head (butlast cons)) + (tail (last cons))) + `(call |QIList| + ,@(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 #'literal elements)))) + +(defun dump-string (string) + `(call |make_lisp_string| ,string)) + +(defun literal (sexp &optional recursive) + (cond + ((integerp sexp) sexp) + ((floatp sexp) sexp) + ((characterp sexp) (string sexp)) + (t + (or (cdr (assoc sexp *literal-table* :test #'eql)) + (let ((dumped (typecase sexp + (symbol (dump-symbol sexp)) + (string (dump-string sexp)) + (cons + ;; BOOTSTRAP MAGIC: See the root file + ;; jscl.lisp and the function + ;; `dump-global-environment' for futher + ;; information. + (if (eq (car sexp) *magic-unquote-marker*) + (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 `(var (,jsvar ,dumped))) + (when (keywordp sexp) + (toplevel-compilation `(= ,(get jsvar "value") ,jsvar))) + jsvar))))))) + + +(define-compilation quote (sexp) + (literal sexp)) + +(define-compilation %while (pred &rest body) + `(selfcall + (while (!== ,(convert pred) ,(convert nil)) + ,(convert-block body)) + (return ,(convert nil)))) + +(define-compilation function (x) + (cond + ((and (listp x) (eq (car x) 'lambda)) + (compile-lambda (cadr x) (cddr x))) + ((and (listp x) (eq (car x) 'named-lambda)) + (destructuring-bind (name ll &rest body) (cdr x) + (compile-lambda ll body + :name (symbol-name name) + :block name))) + ((symbolp x) + (let ((b (lookup-in-lexenv x *environment* 'function))) + (if b + (binding-value b) + (convert `(symbol-function ',x))))))) + +(defun make-function-binding (fname) + (make-binding :name fname :type 'function :value (gvarname fname))) + +(defun compile-function-definition (list) + (compile-lambda (car list) (cdr list))) + +(defun translate-function (name) + (let ((b (lookup-in-lexenv name *environment* 'function))) + (and b (binding-value b)))) + +(define-compilation flet (definitions &rest body) + (let* ((fnames (mapcar #'car definitions)) + (cfuncs (mapcar (lambda (def) + (compile-lambda (cadr def) + `((block ,(car def) + ,@(cddr def))))) + definitions)) + (*environment* + (extend-lexenv (mapcar #'make-function-binding fnames) + *environment* + 'function))) + `(call (function ,(mapcar #'translate-function fnames) + ,(convert-block body t)) + ,@cfuncs))) + +(define-compilation labels (definitions &rest body) + (let* ((fnames (mapcar #'car definitions)) + (*environment* + (extend-lexenv (mapcar #'make-function-binding fnames) + *environment* + 'function))) + `(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) +(define-compilation eval-when-compile (&rest body) + (if *compiling-file* + (progn + (eval (cons 'progn body)) + (convert 0)) + (convert `(progn ,@body)))) + +(defmacro define-transformation (name args form) + `(define-compilation ,name ,args + (convert ,form))) + +(define-compilation progn (&rest body) + (if (null (cdr body)) + (convert (car body) *multiple-value-p*) + `(progn + ,@(append (mapcar #'convert (butlast body)) + (list (convert (car (last body)) t)))))) + +(define-compilation macrolet (definitions &rest body) + (let ((*environment* (copy-lexenv *environment*))) + (dolist (def definitions) + (destructuring-bind (name lambda-list &body body) def + (let ((binding (make-binding :name name :type 'macro :value + (let ((g!form (gensym))) + `(lambda (,g!form) + (destructuring-bind ,lambda-list ,g!form + ,@body)))))) + (push-to-lexenv binding *environment* 'function)))) + (convert `(progn ,@body) *multiple-value-p*))) + + +(defun special-variable-p (x) + (and (claimp x 'variable 'special) t)) + +;;; Wrap CODE to restore the symbol values of the dynamic +;;; bindings. BINDINGS is a list of pairs of the form +;;; (SYMBOL . PLACE), where PLACE is a Javascript variable +;;; name to initialize the symbol value and where to stored +;;; the old value. +(defun let-binding-wrapper (bindings body) + (when (null bindings) + (return-from let-binding-wrapper body)) + `(progn + (try (var tmp) + ,@(with-collect + (dolist (b bindings) + (let ((s (convert `',(car b)))) + (collect `(= tmp (get ,s "value"))) + (collect `(= (get ,s "value") ,(cdr b))) + (collect `(= ,(cdr b) tmp))))) + ,body) + (finally + ,@(with-collect + (dolist (b bindings) + (let ((s (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 #'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 v) dynamic-bindings) + v) + (translate-variable x))) + variables) + ,(let ((body (convert-block body t t))) + `,(let-binding-wrapper dynamic-bindings body))) + ,@cvalues))) + + +;;; Return the code to initialize BINDING, and push it extending the +;;; current lexical environment if the variable is not special. +(defun let*-initialize-value (binding) + (let ((var (first binding)) + (value (second binding))) + (if (special-variable-p var) + (convert `(setq ,var ,value)) + (let* ((v (gvarname var)) + (b (make-binding :name var :type 'variable :value v))) + (prog1 `(var (,v ,(convert value))) + (push-to-lexenv b *environment* 'variable)))))) + +;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It +;;; DOES NOT generate code to initialize the value of the symbols, +;;; unlike let-binding-wrapper. +(defun let*-binding-wrapper (symbols body) + (when (null symbols) + (return-from let*-binding-wrapper body)) + (let ((store (mapcar (lambda (s) (cons s (gvarname s))) + (remove-if-not #'special-variable-p symbols)))) + `(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*))) + (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) + ;; We use Javascript exceptions to implement non local control + ;; transfer. Exceptions has dynamic scoping, so we use a uniquely + ;; generated object to identify the block. The instance of a empty + ;; array is used to distinguish between nested dynamic Javascript + ;; exceptions. See https://github.com/davazp/jscl/issues/64 for + ;; futher details. + (let* ((idvar (gvarname name)) + (b (make-binding :name name :type 'block :value idvar))) + (when *multiple-value-p* + (push 'multiple-value (binding-declarations b))) + (let* ((*environment* (extend-lexenv (list b) *environment* 'block)) + (cbody (convert-block body t))) + (if (member 'used (binding-declarations b)) + `(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)) + (multiple-value-p (member 'multiple-value (binding-declarations b)))) + (when (null b) + (error "Return from unknown block `~S'." (symbol-name name))) + (push 'used (binding-declarations b)) + ;; The binding value is the name of a variable, whose value is the + ;; 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. + `(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) + `(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) + `(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))) + +(defun declare-tagbody-tags (tbidx body) + (let* ((go-tag-counter 0) + (bindings + (mapcar (lambda (label) + (let ((tagidx (incf go-tag-counter))) + (make-binding :name label :type 'gotag :value (list tbidx tagidx)))) + (remove-if-not #'go-tag-p body)))) + (extend-lexenv bindings *environment* 'gotag))) + +(define-compilation tagbody (&rest body) + ;; Ignore the tagbody if it does not contain any go-tag. We do this + ;; 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 (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)) + ;; Tagbody compilation + (let ((branch (gvarname 'branch)) + (tbidx (gvarname 'tbidx))) + (let ((*environment* (declare-tagbody-tags tbidx body)) + initag) + (let ((b (lookup-in-lexenv (first body) *environment* 'gotag))) + (setq initag (second (binding-value b)))) + `(selfcall + ;; TAGBODY branch to take + (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)) + (n (cond + ((symbolp label) (symbol-name label)) + ((integerp label) (integer-to-string label))))) + (when (null b) + (error "Unknown tag `~S'" label)) + `(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) + `(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) + `(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) + `(selfcall + (var (args ,(convert first-form *multiple-value-p*))) + (progn ,@(mapcar #'convert forms)) + (return args))) + +(define-transformation backquote (form) + (bq-completely-process form)) + + +;;; Primitives + +(defvar *builtins* nil) + +(defmacro define-raw-builtin (name args &body body) + ;; Creates a new primitive function `name' with parameters args and + ;; @body. The body can access to the local environment through the + ;; variable *ENVIRONMENT*. + `(push (list ',name (lambda ,args (block ,name ,@body))) + *builtins*)) + +(defmacro define-builtin (name args &body body) + `(define-raw-builtin ,name ,args + (let ,(mapcar (lambda (arg) `(,arg (convert ,arg))) args) + ,@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")) + (let ((counter 0) + (fargs '()) + (prelude '())) + (dolist (x args) + (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) `(return ,,@body)))) + +(define-raw-builtin + (&rest numbers) + (if (null numbers) + 0 + (variable-arity numbers + `(+ ,@numbers)))) + +(define-raw-builtin - (x &rest others) + (let ((args (cons x others))) + (variable-arity args `(- ,@args)))) + +(define-raw-builtin * (&rest numbers) + (if (null numbers) + 1 + (variable-arity numbers `(* ,@numbers)))) + +(define-raw-builtin / (x &rest others) + (let ((args (cons x others))) + (variable-arity args + (if (null others) + `(/ 1 ,(car args)) + (reduce (lambda (x y) `(/ ,x ,y)) + args))))) + +(define-builtin mod (x y) + `(% ,x ,y)) + + +(defun comparison-conjuntion (vars op) + (cond + ((null (cdr vars)) + 'true) + ((null (cddr vars)) + `(,op ,(car vars) ,(cadr vars))) + (t + `(and (,op ,(car vars) ,(cadr vars)) + ,(comparison-conjuntion (cdr vars) op))))) + +(defmacro define-builtin-comparison (op sym) + `(define-raw-builtin ,op (x &rest args) + (let ((args (cons x args))) + (variable-arity args + `(bool ,(comparison-conjuntion args ',sym)))))) + +(define-builtin-comparison > >) +(define-builtin-comparison < <) +(define-builtin-comparison >= >=) +(define-builtin-comparison <= <=) +(define-builtin-comparison = ==) +(define-builtin-comparison /= !=) + +(define-builtin numberp (x) + `(bool (== (typeof ,x) "number"))) + +(define-builtin floor (x) + `(method-call |Math| "floor" ,x)) + +(define-builtin expt (x y) + `(method-call |Math| "pow" ,x ,y)) + +(define-builtin float-to-string (x) + `(call |make_lisp_string| (method-call ,x |toString|))) + +(define-builtin cons (x y) + `(object "car" ,x "cdr" ,y)) + +(define-builtin consp (x) + `(selfcall + (var (tmp ,x)) + (return (bool (and (== (typeof tmp) "object") + (in "car" tmp)))))) + +(define-builtin car (x) + `(selfcall + (var (tmp ,x)) + (return (if (=== tmp ,(convert nil)) + ,(convert nil) + (get tmp "car"))))) + +(define-builtin cdr (x) + `(selfcall + (var (tmp ,x)) + (return (if (=== tmp ,(convert nil)) + ,(convert nil) + (get tmp "cdr"))))) + +(define-builtin rplaca (x new) + `(selfcall + (var (tmp ,x)) + (= (get tmp "car") ,new) + (return tmp))) + +(define-builtin rplacd (x new) + `(selfcall + (var (tmp ,x)) + (= (get tmp "cdr") ,new) + (return tmp))) + +(define-builtin symbolp (x) + `(bool (instanceof ,x |Symbol|))) + +(define-builtin make-symbol (name) + `(new (call |Symbol| ,name))) + +(define-builtin symbol-name (x) + `(get ,x "name")) + +(define-builtin set (symbol value) + `(= (get ,symbol "value") ,value)) + +(define-builtin fset (symbol value) + `(= (get ,symbol "fvalue") ,value)) + +(define-builtin boundp (x) + `(bool (!== (get ,x "value") undefined))) + +(define-builtin fboundp (x) + `(bool (!== (get ,x "fvalue") undefined))) + +(define-builtin symbol-value (x) + `(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) + `(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") ,(convert nil))) + +(define-builtin lambda-code (x) + `(call |make_lisp_string| (method-call ,x "toString"))) + +(define-builtin eq (x y) + `(bool (=== ,x ,y))) + +(define-builtin char-code (x) + `(call |char_to_codepoint| ,x)) + +(define-builtin code-char (x) + `(call |char_from_codepoint| ,x)) + +(define-builtin characterp (x) + `(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)) + +(define-builtin char-downcase (x) + `(call |safe_char_downcase| ,x)) + +(define-builtin stringp (x) + `(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) + `(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) + (convert func) + (let ((args (butlast args)) + (last (car (last args)))) + `(selfcall + (var (f ,(convert func))) + (var (args ,(list-to-vector + (list* (if *multiple-value-p* '|values| '|pv|) + (length args) + (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 (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 (method-call |values| "apply" this (call |forcemv| v)))) + `(call |globalEval| (call |xstring| ,string)))) + +(define-builtin %throw (string) + `(selfcall (throw ,string))) + +(define-builtin functionp (x) + `(bool (=== (typeof ,x) "function"))) + +(define-builtin %write-string (x) + `(method-call |lisp| "write" ,x)) + +(define-builtin /debug (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) + `(selfcall + (var (x ,x)) + (return (bool (and (=== (typeof x) "object") (in "length" x)))))) + +(define-builtin make-storage-vector (n) + `(selfcall + (var (r #())) + (= (get r "length") ,n) + (return r))) + +(define-builtin storage-vector-size (x) + `(get ,x "length")) + +(define-builtin resize-storage-vector (vector new-size) + `(= (get ,vector "length") ,new-size)) + +(define-builtin storage-vector-ref (vector n) + `(selfcall + (var (x (property ,vector ,n))) + (if (=== x undefined) (throw "Out of range.")) + (return x))) + +(define-builtin storage-vector-set (vector n 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) + `(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 () + `(method-call (new (call |Date|)) "getTime")) + +(define-builtin values-array (array) + (if *multiple-value-p* + `(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 #'convert args)) + `(call |pv| ,@(mapcar #'convert args)))) + +;;; Javascript FFI + +(define-builtin new () + '(object)) + +(define-raw-builtin oget* (object key &rest keys) + `(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))) + `(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| ,(convert `(oget* ,object ,key ,@keys)))) + +(define-raw-builtin oset (value object key &rest keys) + (convert `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) + +(define-builtin objectp (x) + `(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) + `(bool (in (call |xstring| ,key) ,object))) + +(define-builtin map-for-in (function object) + `(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| ,(convert val)))) + +(define-setf-expander %js-vref (var) + (let ((new-value (gensym))) + (unless (stringp var) + (error "`~S' is not a string." var)) + (values nil + (list var) + (list new-value) + `(%js-vset ,var ,new-value) + `(%js-vref ,var)))) + + +#-jscl +(defvar *macroexpander-cache* + (make-hash-table :test #'eq)) + +(defun !macro-function (symbol) + (unless (symbolp symbol) + (error "`~S' is not a symbol." symbol)) + (let ((b (lookup-in-lexenv symbol *environment* 'function))) + (if (and b (eq (binding-type b) 'macro)) + (let ((expander (binding-value b))) + (cond + #-jscl + ((gethash b *macroexpander-cache*) + (setq expander (gethash b *macroexpander-cache*))) + ((listp expander) + (let ((compiled (eval expander))) + ;; The list representation are useful while + ;; bootstrapping, as we can dump the definition of the + ;; macros easily, but they are slow because we have to + ;; evaluate them and compile them now and again. So, let + ;; us replace the list representation version of the + ;; function with the compiled one. + ;; + #+jscl (setf (binding-value b) compiled) + #-jscl (setf (gethash b *macroexpander-cache*) compiled) + (setq expander compiled)))) + expander) + nil))) + +(defun !macroexpand-1 (form) + (cond + ((symbolp form) + (let ((b (lookup-in-lexenv form *environment* 'variable))) + (if (and b (eq (binding-type b) 'macro)) + (values (binding-value b) t) + (values form nil)))) + ((and (consp form) (symbolp (car form))) + (let ((macrofun (!macro-function (car form)))) + (if macrofun + (values (funcall macrofun (cdr form)) t) + (values form nil)))) + (t + (values form nil)))) + +(defun compile-funcall (function 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) + `(call ,(translate-function function) ,@arglist)) + ((and (symbolp function) + #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) + #-jscl t) + `(method-call ,(convert `',function) "fvalue" ,@arglist)) + #+jscl((symbolp function) + `(call ,(convert `#',function) ,@arglist)) + ((and (consp function) (eq (car function) 'lambda)) + `(call ,(convert `#',function) ,@arglist)) + ((and (consp function) (eq (car function) 'oget)) + `(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 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 #'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 convert (convert sexp multiple-value-p))) + ;; The expression has been macroexpanded. Now compile it! + (let ((*multiple-value-p* multiple-value-p)) + (cond + ((symbolp sexp) + (let ((b (lookup-in-lexenv sexp *environment* 'variable))) + (cond + ((and b (not (member 'special (binding-declarations b)))) + (binding-value b)) + ((or (keywordp sexp) + (and b (member 'constant (binding-declarations b)))) + `(get ,(convert `',sexp) "value")) + (t + (convert `(symbol-value ',sexp)))))) + ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp)) + (literal sexp)) + ((listp sexp) + (let ((name (car sexp)) + (args (cdr sexp))) + (cond + ;; Special forms + ((assoc name *compilations*) + (let ((comp (second (assoc name *compilations*)))) + (apply comp args))) + ;; Built-in functions + ((and (assoc name *builtins*) + (not (claimp name 'function 'notinline))) + (let ((comp (second (assoc name *builtins*)))) + (apply comp args))) + (t + (compile-funcall name args))))) + (t + (error "How should I compile `~S'?" sexp)))))) + + +(defvar *compile-print-toplevels* nil) + +(defun truncate-string (string &optional (width 60)) + (let ((n (or (position #\newline string) + (min width (length string))))) + (subseq string 0 n))) + +(defun convert-toplevel (sexp &optional multiple-value-p) + (let ((*toplevel-compilations* nil)) + (cond + ;; Non-empty toplevel progn + ((and (consp sexp) + (eq (car sexp) 'progn) + (cdr sexp)) + `(progn + ,@(mapcar (lambda (s) (convert-toplevel s t)) + (cdr sexp)))) + (t + (when *compile-print-toplevels* + (let ((form-string (prin1-to-string sexp))) + (format t "Compiling ~a..." (truncate-string form-string)))) + (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)))) -- 1.7.10.4