(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))
+++ /dev/null
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;;; 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)
+++ /dev/null
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;;;; 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))))
--- /dev/null
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
--- /dev/null
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;;; 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))))
projects / jscl.git / commitdiff