1 ;;;; This software is part of the SBCL system. See the README file for
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.
10 (in-package "SB-INTERPRETER")
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
))
25 ;;; DEFSPECIAL name (destructuring-lambda-list)
27 ;;; :IMMEDIATE (ENV) FORMS+
28 ;;; :DEFERRED (&optional ENV) FORMS+
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.
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.
43 (defmacro defspecial
(name macro-lambda-list
&body body
)
44 (let* ((specialized-code
45 (member-if (lambda (form) (member form
'(:immediate
:deferred
)))
47 (common-code (ldiff body specialized-code
))
51 (ecase (car specialized-code
)
53 (setq deferred-code
(member :deferred specialized-code
)
54 immediate-code
(ldiff specialized-code deferred-code
)))
56 (setq immediate-code
(member :immediate specialized-code
)
57 deferred-code
(ldiff specialized-code immediate-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")
69 (setq body
(append common-code body
))
70 `(named-lambda (,mode
,name
) (,form-var
,env
)
71 ,@(unless env-supplied-p
72 `((declare (ignorable ,env
))))
74 (macrolet ((when-lexical-var ((frame-ptr sym
) &body body
)
76 (maybe-lexical-var env
,sym
)))
77 (unless ,frame-ptr
(return-from ,',name
))
79 (with-subforms ,macro-lambda-list
,form-var
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
))
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
)))))))
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.
101 (defmacro with-let-bindings
; also used by LAMBDA binder
103 &key
(specialp '(locally (declare (muffle-conditions compiler-note
))
104 (logbitp frame-index special-b
)))
107 (if specialp
; if some bound variables are special - free specials don't count
108 (let ((special-vals (make-symbol "SPECIAL-VALS")))
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
116 (progv ,specials
,special-vals
,@finally
)
118 (let ((value ,value
))
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
))))
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.
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
)))
137 initially
&rest finally
)
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 :-(
147 (progv ,specials
(list value
)
148 (let*-bind
(setf ,count-place
(1+ frame-index
))
151 (setf (svref ,value-cells frame-index
) value
)
152 (let*-bind
(setf ,count-place
(1+ frame-index
))
154 `((setf (svref ,value-cells frame-index
) value
)
155 (let*-bind
(setf ,count-place
(1+ frame-index
)) end
))))
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))
166 `(dolist (,outer
,input
,result
)
167 (do-anonymous ((,inner
(cdr ,outer
) (cdr ,inner
))) ((endp ,inner
))
168 (let ((,var
(car ,inner
)))
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
))))
178 ;;; When the evaluator preprocesses a form that interacts with package locking,
179 ;;; we bind *LEXENV* to a dynamic-extent LEXENV pointing to an interpreter env.
180 (defmacro with-package-lock-context
((env-var) &body body
)
181 ;; PROGRAM-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED can signal EVAL-ERROR,
182 ;; and it's the only thing that can, so this is the only place
183 ;; that we need to handle that condition.
184 (let ((env (copy-symbol 'env
)))
186 (let ((,env
,env-var
))
187 (declare (inline sb-c
::make-package-lock-lexenv
))
188 (dx-let ((compiler-lexenv (sb-c::make-package-lock-lexenv
189 ,env
(env-policy ,env
))))
190 (let ((sb-c:*lexenv
* compiler-lexenv
))
192 (sb-impl::eval-error
(condition)
193 ;; Just pull the original condition out and signal that.
194 (error (encapsulated-condition condition
))))))
196 ;;; Wrap SB-C:POLICY changing its accessor to convert to a policy.
197 ;;; The default of %COERCE-TO-POLICY is wrong for the interpreter -
198 ;;; it needs to be ENV-POLICY. The last macro arg is unevaluated
199 ;;; and names the function to call to get a policy from ENV-VAR.
200 (defmacro policy
(env-obj expr
) `(sb-c:policy
,env-obj
,expr env-policy
))
202 ;;; This is used for two different things, which happen to be identical
203 ;;; in their operation - extracting the symbol from:
204 ;;; 1. a binding cell in a LET environment symbol vector, like #((A) ... B)
205 ;;; in which A is lexically bound and B is a free special var.
206 ;;; 2. the symbol from the original LET form, as in (LET ((A 3) ... B) ...)
207 ;;; in which A had a non-nil default and B did not.
208 (declaim (inline binding-symbol
))
209 (defun binding-symbol (x) (if (listp x
) (car x
) x
))