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