src/compiler.lisp

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