src/interpreter/macros.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB-INTERPRETER")
  11
  12 ;;; Special form handlers are stored in the NAME slot of the #<FDEFN>
  13 ;;; of the symbol naming the operator. This is extremely fast to look up.
  14 ;;; It's about 9x faster than a hashtable, and 2x faster than the plist
  15 ;;; even with no other properties on the plist. Moreover, plists can be
  16 ;;; clobbered by users. Since nobody has reason to look at fdefns of
  17 ;;; special forms, it doesn't matter what the name is.
  18 ;;; You'll never see one in a disassembly.
  19 (defmacro !special-form-handler (fdefn)
  20   (let ((thing (make-symbol "DEFN")))
  21     `(let ((,thing (fdefn-name ,fdefn)))
  22        (when (typep ,thing '(cons function))
  23          ,thing))))
  24
  25 ;;; DEFSPECIAL name (destructuring-lambda-list)
  26 ;;;    [FORMS]*
  27 ;;;    :IMMEDIATE (ENV) FORMS+
  28 ;;;    :DEFERRED (&optional ENV) FORMS+
  29 ;;;
  30 ;;; Two versions of a special-form processor for NAME are defined:
  31 ;;; an immediate-mode processor which performs recursive-descent EVAL,
  32 ;;; and a deferred-mode processor which digests the form to produce
  33 ;;; a callable object that when called evaluates the form.
  34 ;;; KLUDGE: Any code preceding :IMMEDIATE or :DEFERRED is common to both,
  35 ;;; and stuffed in front of the mode-specific handler.
  36 ;;; Processors may be specified for ordinary macros; this permits
  37 ;;; treating things like AND/OR/COND as specials forms.
  38 ;;;
  39 ;;; If :IMMEDIATE code is unspecified, immediate mode generates a deferred
  40 ;;; handler, then call that. If specified as :NONE, the form is not treated
  41 ;;; as a special form in immediate mode - it must be a macro.
  42 ;;;
  43 (defmacro defspecial (name macro-lambda-list &body body)
  44   (let* ((specialized-code
  45           (member-if (lambda (form) (member form '(:immediate :deferred)))
  46                      body))
  47          (common-code (ldiff body specialized-code))
  48          (immediate-code)
  49          (deferred-code))
  50     ;; allow either-order
  51     (ecase (car specialized-code)
  52       (:immediate
  53         (setq deferred-code (member :deferred specialized-code)
  54               immediate-code (ldiff specialized-code deferred-code)))
  55       (:deferred
  56        (setq immediate-code (member :immediate specialized-code)
  57              deferred-code (ldiff specialized-code immediate-code))))
  58     (pop immediate-code)
  59     (pop deferred-code)
  60     (unless deferred-code
  61       (error "Deferred-mode handler is mandatory"))
  62     (let ((form-var (gensym "FORM")))
  63       (flet ((gen-code (mode body)
  64                (when (equal body '(:none))
  65                  (return-from gen-code nil))
  66                (destructuring-bind (&optional (env (gensym "ENV")
  67                                                    env-supplied-p))
  68                    (pop body)
  69                  (setq body (append common-code body))
  70                  `(named-lambda (,mode ,name) (,form-var ,env)
  71                     ,@(unless env-supplied-p
  72                         `((declare (ignorable ,env))))
  73                     (block ,name
  74                       (macrolet ((when-lexical-var ((frame-ptr sym) &body body)
  75                                    `(let ((,frame-ptr
  76                                            (maybe-lexical-var env ,sym)))
  77                                       (unless ,frame-ptr (return-from ,',name))
  78                                       ,@body)))
  79                         (with-subforms ,macro-lambda-list ,form-var
  80                                        ,@body)))))))
  81         ;; KLUDGE: obfuscated so that this isn't FOPCOMPILEd.
  82         ;; I don't want SB-VM::%SET-FDEFN-NAME to be funcallable.
  83         `((lambda (name def) (sb-vm::%set-fdefn-name name def))
  84           (find-fdefn ',name)
  85           ;; If there is no immediate handler, just punt by
  86           ;; dispatching an ad-hoc SEXPR. It is somewhat wasteful
  87           ;; to cons a handler that is called once and discarded,
  88           ;; but probably not too objectionable.
  89           (cons ,(if immediate-code
  90                      (gen-code :imm immediate-code)
  91                      `#'(named-lambda (:imm ,name) (form env)
  92                           (dispatch (%sexpr (cons ',name form)) env)))
  93                 ,(gen-code :def deferred-code)))))))
  94
  95 ;;; Create parallel bindings for LET or a LAMBDA's required args.
  96 ;;; Use of this macro is highly confined, so no bothering with ONCE-ONLY.
  97 ;;; FRAME-INDEX is purposely exposed and SPECIAL-B is freely referenced.
  98 ;;; It would be a MACROLET in the LET special form handler,
  99 ;;; except that LAMBDA needs it too.
 100 ;;;
 101 (defmacro with-let-bindings ; also used by LAMBDA binder
 102     ((value-cells count
 103       &key (specialp '(locally (declare (muffle-conditions compiler-note))
 104                        (logbitp frame-index special-b)))
 105            value specials)
 106      &rest finally)
 107   (if specialp ; if some bound variables are special - free specials don't count
 108       (let ((special-vals (make-symbol "SPECIAL-VALS")))
 109         (assert specials)
 110         `(let (,special-vals)
 111            ;; It is important not to access 'specials' unless some binding is
 112            ;; actually special, because the access in APPLY-LAMBDA is with POP
 113            ;; which would destroy the list for the LET*-like bindings.
 114            (dotimes (frame-index ,count
 115                      (if ,special-vals
 116                          (progv ,specials ,special-vals ,@finally)
 117                          (progn ,@finally)))
 118              (let ((value ,value))
 119                (if ,specialp
 120                    (push value ,special-vals)
 121                    (setf (svref ,value-cells frame-index) value))))))
 122       ;; else no variables are special
 123       `(dotimes (frame-index ,count (progn ,@finally))
 124          (setf (svref ,value-cells frame-index) ,value))))
 125
 126 ;;; Serial binding macro strives to have roughly the syntax as WITH-LET-BINDINGS
 127 ;;; but the name is different because this only binds the binder (LET*-BIND)
 128 ;;; which must be called to start recursion over bindings.
 129 ;;; As above, the uses of this macro are sufficiently confined that the
 130 ;;; usual precautions of WITH-UNIQUE-NAMES,ONCE-ONLY are dispensed with.
 131 ;;;
 132 (defmacro with-let*-binder ; also used by LAMBDA binder
 133     ((value-cells count-place
 134       &key (specialp '(locally (declare (muffle-conditions compiler-note))
 135                        (logbitp frame-index special-b)))
 136            value specials)
 137      initially &rest finally)
 138   `(labels
 139        ((let*-bind (frame-index end)
 140           (declare (index frame-index end))
 141           (if (< frame-index end)
 142               (let ((value ,value))
 143                 ;; if specialp is statically nil we avoid a code deletion
 144                 ;; note by "manually" eliding half the logic :-(
 145                 ,@(if specialp
 146                       `((if ,specialp
 147                             (progv ,specials (list value)
 148                               (let*-bind (setf ,count-place (1+ frame-index))
 149                                          end))
 150                             (progn
 151                               (setf (svref ,value-cells frame-index) value)
 152                               (let*-bind (setf ,count-place (1+ frame-index))
 153                                          end))))
 154                       `((setf (svref ,value-cells frame-index) value)
 155                         (let*-bind (setf ,count-place (1+ frame-index)) end))))
 156               (progn ,@finally))))
 157      ,initially))
 158
 159 ;;; Bind VAR to each declaration-specifier in INPUT, which is a list of
 160 ;;; subexpresssions whose head was DECLARE in a form accepting declarations.
 161 ;;; The list as stored is doubly-nested because each DECLARE expression
 162 ;;; is preserved separately, and within it the declarations.
 163 (defmacro do-decl-spec ((var input &optional result) &body body)
 164   (let ((outer (gensym))
 165         (inner (gensym)))
 166     `(dolist (,outer ,input ,result)
 167        (do-anonymous ((,inner (cdr ,outer) (cdr ,inner))) ((endp ,inner))
 168          (let ((,var (car ,inner)))
 169            ,@body)))))
 170
 171 ;;; Special forms that accept declarations use this macro
 172 ;;; to perform typechecks upon entry to the declaration scope.
 173 (defmacro enforce-types (scope env)
 174   `(let ((typechecks (extra-typechecks ,scope)))
 175      (unless (eql typechecks +none+)
 176        (%enforce-types typechecks ,env))))
 177
 178 ;;; When the evaluator preprocesses a form that interacts with package locking,
 179 ;;; we convert the declarations to the format that a LEXENV expects.
 180 ;;; FIXME: it would be more efficient to change the package-lock tests
 181 ;;; to understand either a compiler LEXENV or an interpreter ENV.
 182 ;;; The main difficulty is that *LEXENV* can't be bound to an interpreter env.
 183 (defmacro with-package-lock-context ((env-var) &body body)
 184   ;; PROGRAM-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED can signal EVAL-ERROR,
 185   ;; and it's the only thing that can, so this is the only place
 186   ;; that we need to handle that condition.
 187   `(handler-case
 188        (let ((sb-c:*lexenv*
 189               (sb-c::make-lexenv :disabled-package-locks
 190                                  (env-disabled-package-locks ,env-var)
 191                                  :default (sb-kernel:make-null-lexenv))))
 192          ,@body)
 193      (sb-impl::eval-error (condition)
 194        ;; Just pull the original condition out and signal that.
 195        (error (encapsulated-condition condition)))))
 196
 197 ;;; Wrap SB-C:POLICY changing its accessor to convert to a policy.
 198 ;;; The default of %COERCE-TO-POLICY is wrong for the interpreter -
 199 ;;; it needs to be ENV-POLICY. The last macro arg is unevaluated
 200 ;;; and names the function to call to get a policy from ENV-VAR.
 201 (defmacro policy (env-obj expr) `(sb-c:policy ,env-obj ,expr env-policy))
 202
 203 ;;; This is used for two different things, which happen to be identical
 204 ;;; in their operation - extracting the symbol from:
 205 ;;; 1. a binding cell in a LET environment symbol vector, like #((A) ... B)
 206 ;;;    in which A is lexically bound and B is a free special var.
 207 ;;; 2. the symbol from the original LET form, as in (LET ((A 3) ... B) ...)
 208 ;;;    in which A had a non-nil default and B did not.
 209 (declaim (inline binding-symbol))
 210 (defun binding-symbol (x) (if (listp x) (car x) x))