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 *vars-needing-to-be-declared* ()
  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 x,y,z
  71 expression progn). It is then the responsibility of the enclosing
  72 special form to introduce the variable declarations in its lexical
  73 block.")
  74
  75 (defvar *used-up-names*)
  76 (setf (documentation '*used-up-names* 'variable)
  77       "Names that have been already used for lexical bindings in the current function scope.")
  78
  79 (defvar in-case? nil
  80   "Bind to T when compiling CASE branches.")
  81
  82 (defvar in-loop-scope? nil
  83   "Used for seeing when we're in loops, so that we can introduce
  84   proper scoping for lambdas closing over loop-bound
  85   variables (otherwise they all share the same binding).")
  86 (defvar *loop-return-var* nil
  87   "Variable which is used to return values from inside loop bodies.")
  88 (defvar loop-returns? nil
  89   "Set to T by RETURN-FROM when it returns a value from inside a loop.")
  90
  91 (defvar *loop-scope-lexicals*)
  92 (setf (documentation '*loop-scope-lexicals* 'variable)
  93       "Lexical variables introduced by a loop.")
  94 (defvar *loop-scope-lexicals-captured*)
  95 (setf (documentation '*loop-scope-lexicals-captured* 'variable)
  96       "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
  97
  98 (defvar in-function-scope? nil
  99   "Lets the compiler know when lambda wrapping is necessary.")
 100
 101 (defvar *local-function-names* ()
 102   "Functions named by flet and label.")
 103 ;; is a subset of
 104 (defvar *enclosing-lexicals* ()
 105   "All enclosing lexical variables (includes function names).")
 106 (defvar *enclosing-function-arguments* ()
 107   "Lexical variables bound in all lexically enclosing function argument lists.")
 108
 109 (defvar *function-block-names* ()
 110   "All block names that this function is responsible for catching.")
 111 (defvar *dynamic-return-tags* ()
 112   "Tags that need to be thrown to to reach.")
 113 (defvar *current-block-tag* nil
 114   "Name of the lexically enclosing block, if any.")
 115
 116 (defvar *special-variables* ()
 117   "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
 118
 119 (defun special-variable? (sym)
 120   (member sym *special-variables*))
 121
 122 ;;; meta info
 123
 124 (defvar *macro-toplevel-lambda-list* (make-hash-table)
 125   "Table of lambda lists for toplevel macros.")
 126
 127 (defvar *function-lambda-list* (make-hash-table)
 128   "Table of lambda lists for defined functions.")
 129
 130 ;;; macros
 131 (defun make-macro-dictionary ()
 132   (make-hash-table :test 'eq))
 133
 134 (defvar *macro-toplevel* (make-macro-dictionary)
 135   "Toplevel macro environment dictionary.")
 136
 137 (defvar *macro-env* (list *macro-toplevel*)
 138   "Current macro environment.")
 139
 140 (defvar *symbol-macro-toplevel* (make-macro-dictionary))
 141
 142 (defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
 143
 144 (defvar *setf-expanders* (make-macro-dictionary)
 145   "Setf expander dictionary. Key is the symbol of the access
 146 function of the place, value is an expansion function that takes the
 147 arguments of the access functions as a first value and the form to be
 148 stored as the second value.")
 149
 150 (defun lookup-macro-def (name env)
 151   (loop for e in env thereis (gethash name e)))
 152
 153 (defun make-ps-macro-function (args body)
 154   "Given the arguments and body to a parenscript macro, returns a
 155 function that may be called on the entire parenscript form and outputs
 156 some parenscript code.  Returns a second value that is the effective
 157 lambda list from a Parenscript perspective."
 158   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 159          (effective-lambda-list (if whole-var (cddr args) args))
 160          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
 161     (values
 162      `(lambda (,whole-arg)
 163         (destructuring-bind ,effective-lambda-list
 164             (cdr ,whole-arg)
 165           ,@body))
 166      effective-lambda-list)))
 167
 168 (defmacro defpsmacro (name args &body body)
 169   (defined-operator-override-check name
 170       (multiple-value-bind (macro-fn-form effective-lambda-list)
 171           (make-ps-macro-function args body)
 172         `(progn
 173            (setf (gethash ',name *macro-toplevel*) ,macro-fn-form)
 174            (setf (gethash ',name *macro-toplevel-lambda-list*) ',effective-lambda-list)
 175            ',name))))
 176
 177 (defmacro define-ps-symbol-macro (symbol expansion)
 178   (defined-operator-override-check symbol
 179       `(setf (gethash ',symbol *symbol-macro-toplevel*) (lambda (form) (declare (ignore form)) ',expansion))))
 180
 181 (defun import-macros-from-lisp (&rest names)
 182   "Import the named Lisp macros into the Parenscript macro
 183 environment. When the imported macro is macroexpanded by Parenscript,
 184 it is first fully macroexpanded in the Lisp macro environment, and
 185 then that expansion is further expanded by Parenscript."
 186   (dolist (name names)
 187     (eval `(defpsmacro ,name (&rest args)
 188              (macroexpand `(,',name ,@args))))))
 189
 190 (defmacro defmacro+ps (name args &body body)
 191   "Define a Lisp macro and a Parenscript macro with the same macro
 192 function (ie - the same result from macroexpand-1), for cases when the
 193 two have different full macroexpansions (for example if the CL macro
 194 contains implementation-specific code when macroexpanded fully in the
 195 CL environment)."
 196   `(progn (defmacro ,name ,args ,@body)
 197           (defpsmacro ,name ,args ,@body)))
 198
 199 (defun ps-macroexpand-1 (form)
 200   (aif (or (and (symbolp form)
 201                 (or (and (member form *enclosing-lexicals*)
 202                          (lookup-macro-def form *symbol-macro-env*))
 203                     (gethash form *symbol-macro-toplevel*))) ;; hack
 204            (and (consp form) (lookup-macro-def (car form) *macro-env*)))
 205        (values (ps-macroexpand (funcall it form)) t)
 206        form))
 207
 208 (defun ps-macroexpand (form)
 209   (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
 210     (if expanded?
 211         (values (ps-macroexpand form1) t)
 212         form1)))
 213
 214 ;;;; compiler interface
 215
 216 (defparameter *compilation-level* :toplevel
 217   "This value takes on the following values:
 218 :toplevel indicates that we are traversing toplevel forms.
 219 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
 220 nil indicates we are no longer toplevel-related.")
 221
 222 (defun adjust-compilation-level (form level)
 223   "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
 224 form, FORM, returns the new value for *compilation-level*."
 225   (cond ((or (and (consp form)
 226                   (member (car form) '(progn locally macrolet symbol-macrolet)))
 227              (and (symbolp form) (eq :toplevel level)))
 228          level)
 229         ((eq :toplevel level) :inside-toplevel-form)))
 230
 231 (defvar compile-expression?)
 232
 233 (define-condition compile-expression-error (error)
 234   ((form :initarg :form :reader error-form))
 235   (:report (lambda (condition stream)
 236              (format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))
 237
 238 (defun compile-special-form (form)
 239   (let* ((op (car form))
 240          (statement-impl (gethash op *special-statement-operators*))
 241          (expression-impl (gethash op *special-expression-operators*)))
 242     (cond ((not compile-expression?)
 243            (apply (or statement-impl expression-impl) (cdr form)))
 244           (expression-impl
 245            (apply expression-impl (cdr form)))
 246           ((member op *lambda-wrappable-statements*)
 247            (compile-expression `((lambda () ,form))))
 248           (t (error 'compile-expression-error :form form)))))
 249
 250 (defun ps-compile (form)
 251   (typecase form
 252     ((or null number string character) form)
 253     (vector (ps-compile `(quote ,(coerce form 'list))))
 254     ((or symbol list)
 255      (multiple-value-bind (expansion expanded?) (ps-macroexpand form)
 256        (if expanded?
 257            (ps-compile expansion)
 258            (if (symbolp form)
 259                form
 260                (let ((*compilation-level*
 261                       (adjust-compilation-level form *compilation-level*)))
 262                  (if (special-form? form)
 263                      (compile-special-form form)
 264                      `(ps-js:funcall
 265                        ,(if (symbolp (car form))
 266                             (maybe-rename-local-function (car form))
 267                             (compile-expression (car form)))
 268                        ,@(mapcar #'compile-expression (cdr form)))))))))))
 269
 270 (defun compile-statement (form)
 271   (let ((compile-expression? nil))
 272     (ps-compile form)))
 273
 274 (defun compile-expression (form)
 275   (let ((compile-expression? t))
 276     (ps-compile form)))
 277
 278 (defvar *ps-gensym-counter* 0)
 279
 280 (defun ps-gensym (&optional (prefix-or-counter "_JS"))
 281   (assert (or (stringp prefix-or-counter) (integerp prefix-or-counter)))
 282   (let ((prefix (if (stringp prefix-or-counter) prefix-or-counter "_JS"))
 283         (counter (if (integerp prefix-or-counter) prefix-or-counter (incf *ps-gensym-counter*))))
 284    (make-symbol (format nil "~A~:[~;_~]~A" prefix
 285                         (digit-char-p (char prefix (1- (length prefix))))
 286                         counter))))
 287
 288 (defmacro with-ps-gensyms (symbols &body body)
 289   "Each element of SYMBOLS is either a symbol or a list of (symbol
 290 gensym-prefix-string)."
 291   `(let* ,(mapcar (lambda (symbol)
 292                     (destructuring-bind (symbol &optional prefix)
 293                         (if (consp symbol)
 294                             symbol
 295                             (list symbol))
 296                       (if prefix
 297                           `(,symbol (ps-gensym ,(string prefix)))
 298                           `(,symbol (ps-gensym ,(string symbol))))))
 299                   symbols)
 300      ,@body))
 301
 302 (defmacro ps-once-only ((&rest vars) &body body)
 303   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 304     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 305        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 306           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 307              ,@body)))))