src/compiler.lisp

   1 (in-package #:parenscript)
   2
   3 (defvar *reserved-symbol-names*
   4   (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
   5         "finally" "for" "function" "if" "in" "instanceof" "new" "return"
   6         "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
   7         "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
   8         "enum" "export" "extends" "final" "float" "goto" "implements" "import"
   9         "int" "interface" "long" "native" "package" "private" "protected"
  10         "public" "short" "static" "super" "synchronized" "throws" "transient"
  11         "volatile" "{}" "true" "false" "null" "undefined"))
  12
  13 (defun reserved-symbol? (symbol)
  14   (find (string-downcase (symbol-name symbol)) *reserved-symbol-names* :test #'string=))
  15
  16 ;;; special forms
  17
  18 (defvar *special-expression-operators* (make-hash-table :test 'eq))
  19 (defvar *special-statement-operators* (make-hash-table :test 'eq))
  20
  21 ;; need to split special op definition into two parts - statement and expression
  22 (defmacro %define-special-operator (type name lambda-list &body body)
  23   `(setf (gethash ',name ,type)
  24          (lambda (&rest whole)
  25            (destructuring-bind ,lambda-list whole
  26              ,@body))))
  27
  28 (defmacro define-expression-operator (name lambda-list &body body)
  29   `(%define-special-operator *special-expression-operators* ,name ,lambda-list ,@body))
  30
  31 (defmacro define-statement-operator (name lambda-list &body body)
  32   `(%define-special-operator *special-statement-operators* ,name ,lambda-list ,@body))
  33
  34 (defun special-form? (form)
  35   (and (consp form)
  36        (symbolp (car form))
  37        (or (gethash (car form) *special-expression-operators*) (gethash (car form) *special-statement-operators*))))
  38
  39 ;;; scoping and lexical environment
  40
  41 (defvar *enclosing-lexical-block-declarations* ()
  42   "This special variable is expected to be bound to a fresh list by
  43 special forms that introduce a new JavaScript lexical block (currently
  44 function definitions and lambdas). Enclosed special forms are expected
  45 to push variable declarations onto the list when the variables
  46 declaration cannot be made by the enclosed form for example, a
  47 x,y,z expression progn. It is then the responsibility of the
  48 enclosing special form to introduce the variable bindings in its
  49 lexical block.")
  50
  51 (defvar in-loop-scope? nil
  52   "Used for seeing when we're in loops, so that we can introduce
  53   proper scoping for lambdas closing over loop-bound
  54   variables (otherwise they all share the same binding).")
  55
  56 (defvar *loop-scope-lexicals* ())
  57 (defvar *loop-scope-lexicals-captured* ())
  58
  59 (defvar *function-block-name* nil)
  60
  61 (defvar *special-variables* ())
  62
  63 (defun special-variable? (sym)
  64   (member sym *special-variables*))
  65
  66 ;;; macros
  67 (defun make-macro-dictionary ()
  68   (make-hash-table :test 'eq))
  69
  70 (defvar *macro-toplevel* (make-macro-dictionary)
  71   "Toplevel macro environment dictionary.")
  72
  73 (defvar *macro-env* (list *macro-toplevel*)
  74   "Current macro environment.")
  75
  76 (defvar *symbol-macro-toplevel* (make-macro-dictionary))
  77
  78 (defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
  79
  80 (defvar *local-function-names* ())
  81 ;; is a subset of
  82 (defvar *enclosing-lexicals* ())
  83
  84 (defvar *setf-expanders* (make-macro-dictionary)
  85   "Setf expander dictionary. Key is the symbol of the access
  86 function of the place, value is an expansion function that takes the
  87 arguments of the access functions as a first value and the form to be
  88 stored as the second value.")
  89
  90 (defun lookup-macro-def (name env)
  91   (loop for e in env thereis (gethash name e)))
  92
  93 (defun make-ps-macro-function (args body)
  94   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
  95          (effective-lambda-list (if whole-var (cddr args) args))
  96          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
  97     `(lambda (,whole-arg)
  98        (destructuring-bind ,effective-lambda-list
  99            (cdr ,whole-arg)
 100          ,@body))))
 101
 102 (defmacro defpsmacro (name args &body body)
 103   `(setf (gethash ',name *macro-toplevel*) ,(make-ps-macro-function args body)))
 104
 105 (defmacro define-ps-symbol-macro (symbol expansion)
 106   `(setf (gethash ',symbol *symbol-macro-toplevel*) (lambda (form) (declare (ignore form)) ',expansion)))
 107
 108 (defun import-macros-from-lisp (&rest names)
 109   "Import the named Lisp macros into the Parenscript macro
 110 environment. When the imported macro is macroexpanded by Parenscript,
 111 it is first fully macroexpanded in the Lisp macro environment, and
 112 then that expansion is further expanded by Parenscript."
 113   (dolist (name names)
 114     (eval `(defpsmacro ,name (&rest args)
 115              (macroexpand `(,',name ,@args))))))
 116
 117 (defmacro defmacro+ps (name args &body body)
 118   "Define a Lisp macro and a Parenscript macro with the same macro
 119 function (ie - the same result from macroexpand-1), for cases when the
 120 two have different full macroexpansions (for example if the CL macro
 121 contains implementation-specific code when macroexpanded fully in the
 122 CL environment)."
 123   `(progn (defmacro ,name ,args ,@body)
 124           (defpsmacro ,name ,args ,@body)))
 125
 126 (defun ps-macroexpand-1 (form)
 127   (aif (or (and (symbolp form) (lookup-macro-def form *symbol-macro-env*))
 128            (and (consp form) (lookup-macro-def (car form) *macro-env*)))
 129        (values (ps-macroexpand (funcall it form)) t)
 130        form))
 131
 132 (defun ps-macroexpand (form)
 133   (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
 134     (if expanded?
 135         (values (ps-macroexpand form1) t)
 136         form1)))
 137
 138 ;;;; compiler interface
 139
 140 (defparameter *compilation-level* :toplevel
 141   "This value takes on the following values:
 142 :toplevel indicates that we are traversing toplevel forms.
 143 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
 144 nil indicates we are no longer toplevel-related.")
 145
 146 (defun adjust-compilation-level (form level)
 147   "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
 148 form, FORM, returns the new value for *compilation-level*."
 149   (cond ((or (and (consp form) (member (car form) '(progn locally macrolet symbol-macrolet)))
 150              (and (symbolp form) (eq :toplevel level)))
 151          level)
 152         ((eq :toplevel level)
 153          :inside-toplevel-form)))
 154
 155 (defvar compile-expression?)
 156
 157 (define-condition compile-expression-error (error)
 158   ((form :initarg :form :reader error-form))
 159   (:report (lambda (condition stream)
 160              (format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))
 161
 162 (defun compile-special-form (form)
 163   (apply (if compile-expression?
 164              (or (gethash (car form) *special-expression-operators*)
 165                  (error 'compile-expression-error :form form))
 166              (or (gethash (car form) *special-statement-operators*)
 167                  (gethash (car form) *special-expression-operators*)))
 168          (cdr form)))
 169
 170 (defun ps-compile (form)
 171   (typecase form
 172     ((or null number string character) form)
 173     ((or symbol list)
 174      (multiple-value-bind (expansion expanded?) (ps-macroexpand form)
 175        (if expanded?
 176            (ps-compile expansion)
 177            (if (symbolp form)
 178                form
 179                (let ((*compilation-level* (adjust-compilation-level form *compilation-level*)))
 180                  (if (special-form? form)
 181                      (compile-special-form form)
 182                      `(js:funcall ,(if (symbolp (car form))
 183                                        (maybe-rename-local-function (car form))
 184                                        (compile-expression (car form)))
 185                                   ,@(mapcar #'compile-expression (cdr form)))))))))
 186     (vector (ps-compile `(quote ,(coerce form 'list))))))
 187
 188 (defun compile-statement (form)
 189   (let ((compile-expression? nil))
 190     (ps-compile form)))
 191
 192 (defun compile-expression (form)
 193   (let ((compile-expression? t))
 194     (ps-compile form)))
 195
 196 (defvar *ps-gensym-counter* 0)
 197
 198 (defun ps-gensym (&optional (prefix "_js"))
 199   (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil))))
 200     (make-symbol (format nil "~A~:[~;_~]~A" prefix
 201                          (digit-char-p (char prefix (1- (length prefix))))
 202                          (incf *ps-gensym-counter*)))))
 203
 204 (defmacro with-ps-gensyms (symbols &body body)
 205   "Each element of SYMBOLS is either a symbol or a list of (symbol
 206 gensym-prefix-string)."
 207   `(let* ,(mapcar (lambda (symbol)
 208                     (destructuring-bind (symbol &optional prefix)
 209                         (if (consp symbol)
 210                             symbol
 211                             (list symbol))
 212                       (if prefix
 213                           `(,symbol (ps-gensym ,prefix))
 214                           `(,symbol (ps-gensym ,(symbol-to-js-string symbol))))))
 215                   symbols)
 216      ,@body))
 217
 218 (defmacro ps-once-only ((&rest vars) &body body)
 219   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 220     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 221        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 222           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 223              ,@body)))))