src/compiler.lisp

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