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