src/compiler.lisp

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