src/compiler.lisp

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