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