src/compiler.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005-2006 Edward Marco Baringer
   3 ;;; Copyright 2006 Attila Lendvai
   4 ;;; Copyright 2006 Luca Capello
   5 ;;; Copyright 2007-2012 Vladimir Sedach
   6 ;;; Copyright 2008 Travis Cross
   7 ;;; Copyright 2009-2010 Red Daly
   8 ;;; Copyright 2009-2010 Daniel Gackle
   9
  10 ;;; SPDX-License-Identifier: BSD-3-Clause
  11
  12 ;;; Redistribution and use in source and binary forms, with or
  13 ;;; without modification, are permitted provided that the following
  14 ;;; conditions are met:
  15
  16 ;;; 1. Redistributions of source code must retain the above copyright
  17 ;;; notice, this list of conditions and the following disclaimer.
  18
  19 ;;; 2. Redistributions in binary form must reproduce the above
  20 ;;; copyright notice, this list of conditions and the following
  21 ;;; disclaimer in the documentation and/or other materials provided
  22 ;;; with the distribution.
  23
  24 ;;; 3. Neither the name of the copyright holder nor the names of its
  25 ;;; contributors may be used to endorse or promote products derived
  26 ;;; from this software without specific prior written permission.
  27
  28 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  29 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  30 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  31 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  32 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  33 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  34 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  35 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  36 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  37 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  38 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  39 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  40 ;;; POSSIBILITY OF SUCH DAMAGE.
  41
  42 (in-package #:parenscript)
  43 (in-readtable :parenscript)
  44
  45 (defvar *version* 2.3 "Parenscript compiler version.")
  46
  47 (defparameter %compiling-reserved-forms-p% t
  48   "Used to issue warnings when replacing PS special operators or macros.")
  49
  50 (defvar *defined-operators* ()
  51   "Special operators and macros defined by Parenscript. Replace at your own risk!")
  52
  53 (defun defined-operator-override-check (name &rest body)
  54   (when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*))
  55     (warn 'simple-style-warning
  56           :format-control "Redefining Parenscript operator/macro ~A"
  57           :format-arguments (list name)))
  58   `(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*))
  59           ,@body))
  60
  61 (defvar *reserved-symbol-names*
  62   (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
  63         "finally" "for" "function" "if" "in" "instanceof" "new" "return"
  64         "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
  65         "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
  66         "enum" "export" "extends" "final" "float" "goto" "implements" "import"
  67         "int" "interface" "long" "native" "package" "private" "protected"
  68         "public" "short" "static" "super" "synchronized" "throws" "transient"
  69         "volatile" "{}" "true" "false" "null" "undefined"))
  70
  71 (defvar *lambda-wrappable-statements* ;; break, return, continue not included
  72   '(throw switch for for-in while try block))
  73
  74 (defun reserved-symbol-p (symbol)
  75   (find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
  76
  77 ;;; special forms
  78
  79 (defvar *special-expression-operators* (make-hash-table :test 'eq))
  80 (defvar *special-statement-operators* (make-hash-table :test 'eq))
  81
  82 ;; need to split special op definition into two parts - statement and expression
  83 (defmacro %define-special-operator (type name lambda-list &body body)
  84   (defined-operator-override-check name
  85       `(setf (gethash ',name ,type)
  86              (lambda (&rest whole)
  87                (destructuring-bind ,lambda-list whole
  88                  ,@body)))))
  89
  90 (defmacro define-expression-operator (name lambda-list &body body)
  91   `(%define-special-operator *special-expression-operators*
  92        ,name ,lambda-list ,@body))
  93
  94 (defmacro define-statement-operator (name lambda-list &body body)
  95   `(%define-special-operator *special-statement-operators*
  96        ,name ,lambda-list ,@body))
  97
  98 (defun special-form? (form)
  99   (and (consp form)
 100        (symbolp (car form))
 101        (or (gethash (car form) *special-expression-operators*)
 102            (gethash (car form) *special-statement-operators*))))
 103
 104 ;;; scoping and lexical environment
 105
 106 (defvar *vars-needing-to-be-declared* ()
 107   "This special variable is expected to be bound to a fresh list by
 108 special forms that introduce a new JavaScript lexical block (currently
 109 function definitions and lambdas). Enclosed special forms are expected
 110 to push variable declarations onto the list when the variables
 111 declaration cannot be made by the enclosed form (for example, a x,y,z
 112 expression progn). It is then the responsibility of the enclosing
 113 special form to introduce the variable declarations in its lexical
 114 block.")
 115
 116 (defvar *used-up-names*)
 117 (setf (documentation '*used-up-names* 'variable)
 118       "Names that have been already used for lexical bindings in the current function scope.")
 119
 120 (defvar in-case? nil
 121   "Bind to T when compiling CASE branches.")
 122
 123 (defvar in-loop-scope? nil
 124   "Used for seeing when we're in loops, so that we can introduce
 125   proper scoping for lambdas closing over loop-bound
 126   variables (otherwise they all share the same binding).")
 127 (defvar *loop-return-var* nil
 128   "Variable which is used to return values from inside loop bodies.")
 129 (defvar *loop-return-set-var* nil
 130   "Variable which is set by RETURN-FROM when it returns a value from inside
 131   a loop.  The value is the name of a PS variable which dynamically
 132   indicates if the return statement indeed has been invoked.")
 133
 134 (defvar *loop-scope-lexicals*)
 135 (setf (documentation '*loop-scope-lexicals* 'variable)
 136       "Lexical variables introduced by a loop.")
 137 (defvar *loop-scope-lexicals-captured*)
 138 (setf (documentation '*loop-scope-lexicals-captured* 'variable)
 139       "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
 140
 141 (defvar in-function-scope? nil
 142   "Lets the compiler know when lambda wrapping is necessary.")
 143
 144 (defvar *local-function-names* ()
 145   "Functions named by flet and label.")
 146 ;; is a subset of
 147 (defvar *enclosing-lexicals* ()
 148   "All enclosing lexical variables (includes function names).")
 149 (defvar *enclosing-function-arguments* ()
 150   "Lexical variables bound in all lexically enclosing function argument lists.")
 151
 152 (defvar *function-block-names* ()
 153   "All block names that this function is responsible for catching.")
 154 (defvar *dynamic-return-tags* ()
 155   "Tags that need to be thrown to to reach.")
 156 (defvar *current-block-tag* nil
 157   "Name of the lexically enclosing block, if any.")
 158
 159 (defvar *special-variables* ()
 160   "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
 161
 162 (defun special-variable? (sym)
 163   (member sym *special-variables*))
 164
 165 ;;; meta info
 166
 167 (defvar *macro-toplevel-lambda-list* (make-hash-table)
 168   "Table of lambda lists for toplevel macros.")
 169
 170 (defvar *function-lambda-list* (make-hash-table)
 171   "Table of lambda lists for defined functions.")
 172
 173 ;;; macros
 174 (defun make-macro-dictionary ()
 175   (make-hash-table :test 'eq))
 176
 177 (defvar *macro-toplevel* (make-macro-dictionary)
 178   "Toplevel macro environment dictionary.")
 179
 180 (defvar *macro-env* (list *macro-toplevel*)
 181   "Current macro environment.")
 182
 183 (defvar *symbol-macro-toplevel* (make-macro-dictionary))
 184
 185 (defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
 186
 187 (defvar *setf-expanders* (make-macro-dictionary)
 188   "Setf expander dictionary. Key is the symbol of the access
 189 function of the place, value is an expansion function that takes the
 190 arguments of the access functions as a first value and the form to be
 191 stored as the second value.")
 192
 193 (defun lookup-macro-def (name env)
 194   (loop for e in env thereis (gethash name e)))
 195
 196 (defun make-ps-macro-function (args body)
 197   "Given the arguments and body to a parenscript macro, returns a
 198 function that may be called on the entire parenscript form and outputs
 199 some parenscript code.  Returns a second value that is the effective
 200 lambda list from a Parenscript perspective."
 201   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 202          (effective-lambda-list (if whole-var (cddr args) args))
 203          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
 204     (values
 205      `(lambda (,whole-arg)
 206         (destructuring-bind ,effective-lambda-list
 207             (cdr ,whole-arg)
 208           ,@body))
 209      effective-lambda-list)))
 210
 211 (defmacro defpsmacro (name args &body body)
 212   (defined-operator-override-check name
 213       (multiple-value-bind (macro-fn-form effective-lambda-list)
 214           (make-ps-macro-function args body)
 215         `(eval-when (:compile-toplevel :load-toplevel :execute)
 216            (setf (gethash ',name *macro-toplevel*) ,macro-fn-form)
 217            (setf (gethash ',name *macro-toplevel-lambda-list*) ',effective-lambda-list)
 218            ',name))))
 219
 220 (defmacro define-ps-symbol-macro (symbol expansion)
 221   (defined-operator-override-check symbol
 222       `(eval-when (:compile-toplevel :load-toplevel :execute)
 223          (setf (gethash ',symbol *symbol-macro-toplevel*) (lambda (form) (declare (ignore form)) ',expansion)))))
 224
 225 (defun import-macros-from-lisp (&rest names)
 226   "Import the named Lisp macros into the Parenscript macro
 227 environment. When the imported macro is macroexpanded by Parenscript,
 228 it is first fully macroexpanded in the Lisp macro environment, and
 229 then that expansion is further expanded by Parenscript."
 230   (dolist (name names)
 231     (eval `(defpsmacro ,name (&rest args)
 232              (macroexpand `(,',name ,@args))))))
 233
 234 (defmacro defmacro+ps (name args &body body)
 235   "Define a Lisp macro and a Parenscript macro with the same macro
 236 function (ie - the same result from macroexpand-1), for cases when the
 237 two have different full macroexpansions (for example if the CL macro
 238 contains implementation-specific code when macroexpanded fully in the
 239 CL environment)."
 240   `(progn (defmacro ,name ,args ,@body)
 241           (defpsmacro ,name ,args ,@body)))
 242
 243 (defun ps-macroexpand-1 (form)
 244   (aif (or (and (symbolp form)
 245                 (or (and (member form *enclosing-lexicals*)
 246                          (lookup-macro-def form *symbol-macro-env*))
 247                     (gethash form *symbol-macro-toplevel*))) ;; hack
 248            (and (consp form) (lookup-macro-def (car form) *macro-env*)))
 249        (values (ps-macroexpand (funcall it form)) t)
 250        form))
 251
 252 (defun ps-macroexpand (form)
 253   (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
 254     (if expanded?
 255         (values (ps-macroexpand form1) t)
 256         form1)))
 257
 258 ;;; lambda wrapping
 259
 260 (defvar *ps-gensym-counter* 0)
 261
 262 (defvar this-in-lambda-wrapped-form? nil)
 263
 264 (defun lambda-wrap (form)
 265   (let ((this-in-lambda-wrapped-form? :query)
 266         (*ps-gensym-counter* *ps-gensym-counter*))
 267     (ps-compile form)
 268     (if (eq this-in-lambda-wrapped-form? :yes)
 269         `(chain (lambda () ,form) (call this))
 270         `((lambda () ,form)))))
 271
 272 ;;;; compiler interface
 273
 274 (defparameter *compilation-level* :toplevel
 275   "This value takes on the following values:
 276 :toplevel indicates that we are traversing toplevel forms.
 277 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
 278 nil indicates we are no longer toplevel-related.")
 279
 280 (defun adjust-compilation-level (form level)
 281   "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
 282 form, FORM, returns the new value for *compilation-level*."
 283   (cond ((or (and (consp form)
 284                   (member (car form) '(progn locally macrolet symbol-macrolet)))
 285              (and (symbolp form) (eq :toplevel level)))
 286          level)
 287         ((eq :toplevel level) :inside-toplevel-form)))
 288
 289 (defvar compile-expression?)
 290
 291 (define-condition compile-expression-error (error)
 292   ((form :initarg :form :reader error-form))
 293   (:report (lambda (condition stream)
 294              (format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))
 295
 296 (defun compile-special-form (form)
 297   (let* ((op (car form))
 298          (statement-impl (gethash op *special-statement-operators*))
 299          (expression-impl (gethash op *special-expression-operators*)))
 300     (cond ((or (not compile-expression?) this-in-lambda-wrapped-form?)
 301            (apply (or statement-impl expression-impl) (cdr form)))
 302           (expression-impl
 303            (apply expression-impl (cdr form)))
 304           ((member op *lambda-wrappable-statements*)
 305            (compile-expression (lambda-wrap form)))
 306           (t (error 'compile-expression-error :form form)))))
 307
 308 (defun ps-compile (form)
 309   (macrolet ((try-expanding (form &body body)
 310                `(multiple-value-bind (expansion expanded?) (ps-macroexpand ,form)
 311                   (if expanded?
 312                       (ps-compile expansion)
 313                       (progn ,@body)))))
 314     (typecase form
 315       ((or null number string character)
 316        form)
 317       (vector
 318        (ps-compile `(quote ,(coerce form 'list))))
 319       (symbol
 320        (try-expanding form
 321          (when (and (eq form 'this) (eq this-in-lambda-wrapped-form? :query))
 322            (setq this-in-lambda-wrapped-form? :yes))
 323          form))
 324       (cons
 325        (try-expanding form
 326          (let ((*compilation-level*
 327                 (adjust-compilation-level form *compilation-level*)))
 328            (if (special-form? form)
 329                (compile-special-form form)
 330                `(ps-js:funcall
 331                  ,(if (symbolp (car form))
 332                       (maybe-rename-local-function (car form))
 333                       (compile-expression (car form)))
 334                  ,@(mapcar #'compile-expression (cdr form))))))))))
 335
 336 (defun compile-statement (form)
 337   (let ((compile-expression? nil))
 338     (ps-compile form)))
 339
 340 (defun compile-expression (form)
 341   (let ((compile-expression? t))
 342     (ps-compile form)))
 343
 344 (defun ps-gensym (&optional (x '_js))
 345   (make-symbol
 346    (if (integerp x)
 347        (format nil "~A~A" '_js x)
 348        (let ((prefix (string x)))
 349          (format nil "~A~:[~;_~]~A"
 350                  prefix
 351                  (digit-char-p (char prefix (1- (length prefix))))
 352                  (incf *ps-gensym-counter*))))))
 353
 354 (defmacro with-ps-gensyms (symbols &body body)
 355   "Each element of SYMBOLS is either a symbol or a list of (symbol
 356 gensym-prefix-string)."
 357   `(let* ,(mapcar (lambda (symbol)
 358                     (destructuring-bind (symbol &optional prefix)
 359                         (if (consp symbol)
 360                             symbol
 361                             (list symbol))
 362                       (if prefix
 363                           `(,symbol (ps-gensym ,(string prefix)))
 364                           `(,symbol (ps-gensym ,(string symbol))))))
 365                   symbols)
 366      ,@body))
 367
 368 (defmacro ps-once-only ((&rest vars) &body body)
 369   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 370     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 371        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 372           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 373              ,@body)))))
 374
 375 (defmacro maybe-once-only (vars &body body)
 376   "Introduces a binding for a form if the form is not a variable or
 377   constant. If it is, uses that form in the body directly."
 378   (let ((vars-bound (gensym)))
 379     `(let* ((,vars-bound ())
 380             ,@(loop for var in vars collect
 381                    `(,var (if (or (constantp ,var) (symbolp ,var))
 382                               ,var
 383                               (let ((gensym (ps-gensym ,(symbol-name var))))
 384                                 (push `(,gensym ,,var) ,vars-bound)
 385                                 gensym)))))
 386        `(let ,,vars-bound
 387          ,,@body))))