src/compiler.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 ;;; reserved symbols/literals
   4
   5 (defvar *ps-reserved-symbol-names*
   6   (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
   7         "finally" "for" "function" "if" "in" "instanceof" "new" "return"
   8         "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
   9         "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
  10         "enum" "export" "extends" "final" "float" "goto" "implements" "import"
  11         "int" "interface" "long" "native" "package" "private" "protected"
  12         "public" "short" "static" "super" "synchronized" "throws" "transient"
  13         "volatile"))
  14
  15 (defun add-ps-reserved-symbol (name)
  16   (pushnew (symbol-name-to-js-string name) *ps-reserved-symbol-names* :test #'equalp))
  17
  18 (defun ps-reserved-symbol-p (symbol)
  19   (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp))
  20
  21 ;;; special forms
  22
  23 (defvar *ps-special-forms* (make-hash-table :test 'eq))
  24
  25 (defun get-ps-special-form (name)
  26   (gethash name *ps-special-forms*))
  27
  28 (defmacro define-ps-special-form (name lambda-list &rest body)
  29   "Define a special form NAME. The first argument (an anaphor called
  30 'expecting' automatically added to the arglist) to the special form is
  31 a keyword indicating whether the form is expected to produce
  32 an :expression or a :statement."
  33   (let ((args (gensym "ps-arglist-")))
  34     `(setf (gethash ',name *ps-special-forms*)
  35            (lambda (&rest ,args)
  36              (destructuring-bind ,(cons 'expecting lambda-list)
  37                  ,args
  38                (declare (ignorable expecting))
  39                ,@body)))))
  40
  41 (defun undefine-ps-special-form (name)
  42   (remhash name *ps-special-forms*))
  43
  44 (defun ps-special-form-p (form)
  45   (and (consp form)
  46        (symbolp (car form))
  47        (gethash (car form) *ps-special-forms*)))
  48
  49 ;;; scoping
  50
  51 (defvar *enclosing-lexical-block-declarations* ()
  52   "This special variable is expected to be bound to a fresh list by
  53 special forms that introduce a new JavaScript lexical block (currently
  54 function definitions and lambdas). Enclosed special forms are expected
  55 to push variable declarations onto the list when the variables
  56 declaration cannot be made by the enclosed form \(for example, a
  57 \(x,y,z\) expression progn\). It is then the responsibility of the
  58 enclosing special form to introduce the variable bindings in its
  59 lexical block.")
  60
  61 (defvar *ps-special-variables* ())
  62
  63 (defun ps-special-variable-p (sym)
  64   (member sym *ps-special-variables*))
  65
  66 ;;; form predicates
  67
  68 (defun op-form-p (form)
  69   (and (listp form)
  70        (not (ps-special-form-p form))
  71        (not (null (op-precedence (first form))))))
  72
  73 (defun funcall-form-p (form)
  74   (and form
  75        (listp form)
  76        (not (op-form-p form))
  77        (not (ps-special-form-p form))))
  78
  79 ;;; macro expansion
  80 (eval-when (:compile-toplevel :load-toplevel :execute)
  81   (defun make-macro-dictionary ()
  82     (make-hash-table :test 'eq))
  83
  84   (defvar *ps-macro-toplevel* (make-macro-dictionary)
  85     "Toplevel macro environment dictionary.")
  86
  87   (defvar *ps-macro-env* (list *ps-macro-toplevel*)
  88     "Current macro environment.")
  89
  90   (defvar *ps-symbol-macro-toplevel* (make-macro-dictionary))
  91
  92   (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*))
  93
  94   (defvar *ps-local-function-names* ())
  95
  96   (defvar *ps-setf-expanders* (make-macro-dictionary)
  97     "Setf expander dictionary. Key is the symbol of the access
  98 function of the place, value is an expansion function that takes the
  99 arguments of the access functions as a first value and the form to be
 100 stored as the second value.")
 101
 102   (defparameter *ps-compilation-level* :toplevel
 103     "This value takes on the following values:
 104 :toplevel indicates that we are traversing toplevel forms.
 105 :inside-toplevel-form indicates that we are inside a call to compile-parenscript-form
 106 nil indicates we are no longer toplevel-related."))
 107
 108 (defun lookup-macro-def (name env)
 109   (loop for e in env thereis (gethash name e)))
 110
 111 (defun make-ps-macro-function (args body)
 112   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 113          (effective-lambda-list (if whole-var (cddr args) args))
 114          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
 115     `(lambda (,whole-arg)
 116        (destructuring-bind ,effective-lambda-list
 117            (cdr ,whole-arg)
 118          ,@body))))
 119
 120 (defmacro defpsmacro (name args &body body)
 121   `(progn (undefine-ps-special-form ',name)
 122           (setf (gethash ',name *ps-macro-toplevel*) ,(make-ps-macro-function args body))
 123           ',name))
 124
 125 (defmacro define-ps-symbol-macro (symbol expansion)
 126   (let ((x (gensym)))
 127     `(progn (undefine-ps-special-form ',symbol)
 128             (setf (gethash ',symbol *ps-symbol-macro-toplevel*) (lambda (,x) (declare (ignore ,x)) ',expansion))
 129             ',symbol)))
 130
 131 (defun import-macros-from-lisp (&rest names)
 132   "Import the named Lisp macros into the ParenScript macro
 133 environment. When the imported macro is macroexpanded by ParenScript,
 134 it is first fully macroexpanded in the Lisp macro environment, and
 135 then that expansion is further expanded by ParenScript."
 136   (dolist (name names)
 137     (eval `(defpsmacro ,name (&rest args)
 138              (macroexpand `(,',name ,@args))))))
 139
 140 (defmacro defmacro/ps (name args &body body)
 141   "Define a Lisp macro and import it into the ParenScript macro environment."
 142   `(progn (defmacro ,name ,args ,@body)
 143           (import-macros-from-lisp ',name)))
 144
 145 (defmacro defmacro+ps (name args &body body)
 146   "Define a Lisp macro and a ParenScript macro with the same macro
 147 function (ie - the same result from macroexpand-1), for cases when the
 148 two have different full macroexpansions (for example if the CL macro
 149 contains implementation-specific code when macroexpanded fully in the
 150 CL environment)."
 151   `(progn (defmacro ,name ,args ,@body)
 152           (defpsmacro ,name ,args ,@body)))
 153
 154 (defun ps-macroexpand (form)
 155   (aif (or (lookup-macro-def form *ps-symbol-macro-env*)
 156            (and (consp form) (lookup-macro-def (car form) *ps-macro-env*)))
 157        (values (ps-macroexpand (funcall it form)) t)
 158        form))
 159
 160 (defun maybe-rename-local-function (fun-name)
 161   (aif (lookup-macro-def fun-name *ps-local-function-names*)
 162        it
 163        fun-name))
 164
 165 ;;;; compiler interface
 166 (defgeneric compile-parenscript-form (form &key expecting)
 167   (:documentation "Compiles a ParenScript form to the intermediate
 168 ParenScript representation. :expecting determines whether the form is
 169 compiled to an :expression (the default), a :statement, or a
 170 :symbol."))
 171
 172 (defun adjust-ps-compilation-level (form level)
 173   (cond ((or (and (consp form) (eq 'progn (car form)))
 174              (and (symbolp form) (eq :toplevel level)))
 175          level)
 176         ((eq :toplevel level) :inside-toplevel-form)))
 177
 178 (defmethod compile-parenscript-form :around (form &key expecting)
 179   (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
 180   (if (eq expecting :symbol)
 181       (compile-to-symbol form)
 182       (let ((*ps-compilation-level* (adjust-ps-compilation-level form *ps-compilation-level*)))
 183         (call-next-method))))
 184
 185 (defun compile-to-symbol (form)
 186   "Compiles the given Parenscript form and guarantees that the
 187 resultant symbol has an associated script-package. Raises an error if
 188 the form cannot be compiled to a symbol."
 189   (let ((exp (compile-parenscript-form form :expecting :expression)))
 190     (when (eq (first exp) 'js:variable)
 191       (setf exp (second exp)))
 192     (assert (symbolp exp) ()
 193             "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form (ps* form) form)
 194     exp))
 195
 196 (defmethod compile-parenscript-form (form &key expecting)
 197   (declare (ignore expecting))
 198   (error "The object ~S cannot be compiled by ParenScript." form))
 199
 200 (defmethod compile-parenscript-form ((form number) &key expecting)
 201   (declare (ignore expecting))
 202   form)
 203
 204 (defmethod compile-parenscript-form ((form string) &key expecting)
 205   (declare (ignore expecting))
 206   form)
 207
 208 (defmethod compile-parenscript-form ((form character) &key expecting)
 209   (declare (ignore expecting))
 210   (compile-parenscript-form (string form)))
 211
 212 (defmethod compile-parenscript-form ((symbol symbol) &key expecting)
 213   (when (eq *ps-compilation-level* :toplevel)
 214     (multiple-value-bind (expansion expanded-p)
 215         (ps-macroexpand symbol)
 216       (when expanded-p
 217         (return-from compile-parenscript-form (compile-parenscript-form expansion :expecting expecting)))))
 218   (cond ((keywordp symbol) symbol)
 219         ((ps-special-form-p (list symbol))
 220          (if (ps-reserved-symbol-p symbol)
 221              (funcall (get-ps-special-form symbol) :symbol)
 222              (error "Attempting to use Parenscript special form ~a as variable" symbol)))
 223         (t `(js:variable ,symbol))))
 224
 225 (defun ps-convert-op-name (op)
 226   (case op
 227     (and '\&\&)
 228     (or '\|\|)
 229     (not '!)
 230     (eql '\=\=)
 231     (=   '\=\=)
 232     (t op)))
 233
 234 (defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
 235   (multiple-value-bind (form expanded-p)
 236       (ps-macroexpand form)
 237     (cond (expanded-p (compile-parenscript-form form :expecting expecting))
 238           ((ps-special-form-p form) (apply (get-ps-special-form (car form)) (cons expecting (cdr form))))
 239           ((op-form-p form)
 240            `(js:operator ,(ps-convert-op-name (compile-parenscript-form (car form) :expecting :symbol))
 241                          ,@(mapcar (lambda (form)
 242                                      (compile-parenscript-form (ps-macroexpand form) :expecting :expression))
 243                                    (cdr form))))
 244           ((funcall-form-p form)
 245            `(js:funcall ,(compile-parenscript-form (if (symbolp (car form))
 246                                                        (maybe-rename-local-function (car form))
 247                                                        (ps-macroexpand (car form)))
 248                                                    :expecting :expression)
 249                         ,@(mapcar (lambda (arg)
 250                                     (compile-parenscript-form (ps-macroexpand arg) :expecting :expression))
 251                                   (cdr form))))
 252           (t (error "Cannot compile ~S to a ParenScript form." form)))))
 253
 254 (defvar *ps-gensym-counter* 0)
 255
 256 (defun ps-gensym (&optional (prefix "_js"))
 257   (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil))))
 258     (make-symbol (format nil "~A~:[~;_~]~A" prefix
 259                          (digit-char-p (char prefix (1- (length prefix))))
 260                          (incf *ps-gensym-counter*)))))
 261
 262 (defmacro with-ps-gensyms (symbols &body body)
 263   "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
 264
 265 Each element of SYMBOLS is either a symbol or a list of (symbol
 266 gensym-prefix-string)."
 267   `(let* ,(mapcar (lambda (symbol)
 268                     (destructuring-bind (symbol &optional prefix)
 269                         (if (consp symbol)
 270                             symbol
 271                             (list symbol))
 272                       (if prefix
 273                           `(,symbol (ps-gensym ,prefix))
 274                           `(,symbol (ps-gensym ,(symbol-to-js-string symbol))))))
 275                   symbols)
 276      ,@body))
 277
 278 (defun %check-once-only-vars (vars)
 279   (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars)))
 280     (when bad-var
 281       (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var))))
 282
 283 (defmacro ps-once-only ((&rest vars) &body body)
 284   (%check-once-only-vars vars)
 285   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 286     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 287        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 288           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 289              ,@body)))))