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 ;;; *APPLYHOOK* works more-or-less as described in CLtL2, which is
13 ;;; not at all like the *SELF-APPLYHOOK* that hooks every call
14 ;;; into a function as part of the function itself.
15 ;;; Don't bind it to an interpreted-function; probably don't bind to a
16 ;;; symbol, and definitely not a lambda expression- just a compiled function.
17 ;;; Also note: it's never rebound to NIL around each application,
18 ;;; because that would make EVAL non-tail-recursive. It is assumed that
19 ;;; anyone messing with it knows what (s)he is doing.
20 (defvar *applyhook
* nil
)
22 ;;; Retrieve the value of the binding (either lexical or special) of
23 ;;; the variable named by SYMBOL in the environment ENV. For symbol
24 ;;; macros the expansion is returned instead.
25 ;;; Second values is T if the primary value is a macroexpansion.
26 ;;; Tertiary value is the type to assert, or NIL if no type should be asserted.
27 ;;; That is, policy-related decisions need to be made here, not in the caller.
28 (defun expand-or-eval-symbol (env symbol
)
29 (declare (symbol symbol
))
30 (binding* (((binding kind nil value
) (find-lexical-var env symbol
))
31 (type (var-type-assertion env symbol binding
:read
))
35 (:normal
(values nil value
))
36 (:macro
(values t
(symexpand env symbol value
)))
37 (t (values nil
(symbol-value symbol
))))
38 (case (info :variable
:kind symbol
)
39 (:macro
(values t
(symexpand env symbol
)))
40 (:alien
(values nil
(alien-value symbol
)))
41 (t (values nil
(symbol-value symbol
)))))))
42 (values value macro-p type
)))
44 ;; Macros must go through the hook, but we can avoid it if the hook is FUNCALL.
45 (defun symexpand (env sym
46 &optional
(expansion (info :variable
:macro-expansion sym
)))
47 (let ((hook (valid-macroexpand-hook)))
48 (if (eq hook
#'funcall
)
51 (lambda (form env
) (declare (ignore form env
)) expansion
)
54 ;;; Implementation note: APPLY is the main reason the interpreter conses.
55 ;;; It would be nice if you could preallocate a DX arglist and pass that
56 ;;; on the stack. Applying directly from a DX arglist would make the
57 ;;; interpreter non-tail-recursive, so we don't want to do that.
58 ;;; There is sort of a way - assuming MAKE-LIST is made to be DXable -
59 ;;; but it is probably much worse for performance:
60 ;;; (multiple-value-call thing
61 ;;; (let ((foo (make-list n)))
62 ;;; (setf (nth 0 foo) (eval-nth-arg ...))
66 (defparameter *eval-level
* -
1)
67 (defparameter *eval-verbose
* nil
)
69 ;;; These are the forms sb-fasteval will process for itself when the evaluator
70 ;;; mode is :COMPILE. They all preserve a bidirectional mapping between
71 ;;; LEXENV and subtypes of BASIC-ENV. Things like BLOCK/RETURN could not.
72 ;;; The list also happens to match the the tiny evaluator (in 'eval'),
73 ;;; though it might be reasonable to have additional things here.
74 (defconstant-eqx !simple-special-operators
75 '(eval-when if progn quote locally macrolet symbol-macrolet setq
)
78 (defun %eval
(exp env
)
80 ((%%eval
(&aux fname special-op
)
83 ;; CLHS 3.1.2.1.1 Symbols as Forms
84 (binding* (((val expanded-p type
) (expand-or-eval-symbol env exp
))
85 (eval-val (if expanded-p
(%eval val env
) val
)))
86 (when (and type
(not (itypep eval-val type
)))
87 (typecheck-fail/ref exp eval-val type
))
89 ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
90 ;; We can save a few instructions vs. testing ATOM
91 ;; because SYMBOLP was already picked off.
92 ((not (listp exp
)) exp
)
93 ;; CLHS 3.1.2.1.2 Conses as Forms
94 ((eq (setq fname
(car exp
)) 'setq
)
95 (eval-setq (cdr exp
) env nil
)) ; SEXPR = nil
96 ;; CLHS 3.1.2.1.2.4 Lambda Forms
97 ((typep fname
'(cons (eql lambda
)))
98 (if (eq sb-ext
:*evaluator-mode
* :interpret
)
99 ;; It should be possible to avoid consing a function,
100 ;; but this syntax isn't common enough to matter.
101 (apply-it (funcall (if (must-freeze-p env
) #'enclose-freeze
#'enclose
)
102 (make-proto-fn fname
) env nil
))
104 ((not (symbolp fname
))
105 (ip-error "Invalid function name: ~S" fname
))
106 ;; CLHS 3.1.2.1.2.1 Special Forms
107 ;; Pick off special forms first for speed. Special operators
108 ;; can't be shadowed by local defs.
109 ((setq special-op
(let ((fdefn (sb-impl::symbol-fdefn fname
)))
110 (and fdefn
(!special-form-handler fdefn
))))
111 (if (or (eq sb-ext
:*evaluator-mode
* :interpret
)
112 (member fname
!simple-special-operators
))
113 (funcall (truly-the function
(car special-op
)) (cdr exp
) env
)
116 ;; Everything else: macros and functions.
117 (multiple-value-bind (fn macro-p
) (get-function (car exp
) env
)
119 (%eval
(funcall (valid-macroexpand-hook) fn exp env
) env
)
121 (compile-it () ; the escape hatch for evaluator-mode = :COMPILE.
122 (sb-impl::%simple-eval
123 exp
(if env
(lexenv-from-env env
) (make-null-lexenv))))
125 (let ((args (mapcar (lambda (arg) (%eval arg env
)) (cdr exp
)))
128 (eq h
(load-time-value #'funcall t
))
131 (funcall h f args
)))))
132 ;; Binding *EVAL-LEVEL* inhibits tail-call, so try to avoid it
134 (let ((*eval-level
* (1+ *eval-level
*)))
135 (let ((*print-circle
* t
))
136 (format t
"~&~vA~S~%" *eval-level
* "" `(%eval
,exp
)))
140 ;; DIGEST-FORM both "digests" and EVALs a form.
141 ;; It should stash an optimized handler into the SEXPR so that DIGEST-FORM
142 ;; will (ideally) not be called again on this SEXPR.
143 ;; The new handler is invoked right away.
145 ;; A few special-form-processors exist for standard macros. I test INFO on
146 ;; special-forms before considering FIND-LEXICAL-FUN. After I apply my
147 ;; globaldb speedups, it will actually be faster to use the two-part test
148 ;; than just check the lexical environment. Usually existence of a processor
149 ;; implies a special form, which is illegal to rebind lexically; whereas
150 ;; technically it's legal to rebind standard macros, though weird and
151 ;; scoring no readability points.
153 (defun digest-form (form env sexpr
)
154 (declare (sexpr sexpr
))
155 (cond ((symbolp form
) ; CLHS 3.1.2.1.1 Symbols as Forms
156 (return-from digest-form
(symeval form env sexpr
)))
157 ((not (listp form
)) ; CLHS 3.1.2.1.3 Self-Evaluating Objects
158 (setf (sexpr-handler sexpr
) (return-constant form
))
159 (return-from digest-form form
)))
160 ;; CLHS 3.1.2.1.2 Conses as Forms
161 (let ((fname (car form
)))
162 (cond ((eq fname
'setq
)
163 ;; SETQ mandates a different protocol which slightly
164 ;; simplifies the treatment of symbol macros.
165 (return-from digest-form
166 (eval-setq (cdr form
) env sexpr
)))
167 ((typep fname
'(cons (eql lambda
)))
168 ;; CLHS 3.1.2.1.2.4 "A lambda form is equivalent to using funcall of
169 ;; a lexical closure of the lambda expression on the given arguments."
170 (return-from digest-form
171 (digest-form `(funcall #',fname
,@(cdr form
)) env sexpr
)))
172 ((not (symbolp fname
))
173 (ip-error "Invalid function name: ~S" fname
)))
174 ;; CLHS 3.1.2.1.2.1 Special Forms.
175 (let ((fdefn (sb-impl::symbol-fdefn fname
)))
176 (awhen (and fdefn
(!special-form-handler fdefn
))
177 (return-from digest-form
179 (funcall (truly-the function
(cdr it
)) (cdr form
) env
)))
181 (setf (sexpr-handler sexpr
) digested-form
)
182 (%dispatch sexpr env
))
183 ((eq (info :function
:kind fname
) :special-form
)
184 ;; Special operators that reimplement macros can decline,
185 ;; falling back upon the macro. This allows faster
186 ;; implementations of things like AND,OR,COND,INCF
187 ;; without having to deal with their full generality.
188 (error "Operator ~S mustn't decline to handle ~S"
190 (let ((frame-ptr (local-fn-frame-ptr fname env
)))
191 (if (eq frame-ptr
:macro
)
192 ;; CLHS 3.1.2.1.2.2 Macro Forms
193 (multiple-value-bind (expansion keys
)
194 (tracing-macroexpand-1 form env
)
196 (setf expansion
(%sexpr expansion
)
197 (sexpr-handler sexpr
)
198 (digest-macro-form expansion fname keys
))
199 (dispatch expansion env
))
201 (digest-form expansion env sexpr
))))
203 (setf (sexpr-handler sexpr
)
204 (if frame-ptr
; a lexical function
205 (digest-local-call frame-ptr
(cdr form
))
206 (digest-global-call fname
(cdr form
) env
)))
207 (%dispatch sexpr env
))))))
209 (fmakunbound 'eval-in-environment
)
210 (defun eval-in-environment (form env
)
212 (let ((interpreter-env
214 (sb-kernel:lexenv
(if (sb-c::null-lexenv-p env
) nil
(env-from-lexenv env
)))
216 (if (eq interpreter-env
:compile
)
217 (funcall (handler-case
218 ;; Final arg of T means signal errors immediately rather
219 ;; than returning a function that signals when called.
220 (sb-c::actually-compile nil
`(lambda () ,form
) env nil nil t
)
222 ;; Whatever went wrong, just say "too complex"
223 (error 'compiler-environment-too-complex-error
225 "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
226 :format-arguments
(list env
)))))
227 ;; FIXME: should this be (OR INTERPTER-ENV (CAPTURE-TOPLEVEL-ENV)) ?
228 ;; Whether we decide to capture the policy here or not, there will always
229 ;; be some use-case that comes out wrong. Capturing it is necessary for
230 ;; the following to work in the interpreter:
232 (defmacro some-macro
(x &environment e
)
233 (if (policy e
(= safety
3)) (expand-to-safe-code) (expand-normally)))
234 (with-compilation-unit (:policy
'(optimize (safety 3)))
235 (some-macro (whatever)))
237 ;; because WITH-COMPILATION-UNIT rebinds *POLICY* and so we need
238 ;; to look at that policy regardless of whether interpreting or compiling.
239 ;; But %COERCE-TO-POLICY as used in the (POLICY) macro would return
240 ;; **BASELINE-POLICY** instead of *POLICY* when given NIL as the env,
241 ;; because the compiler wants that.
242 ;; But if we do capture the policy up front, then we _fail_ to see
243 ;; any changes that are made by PROCLAIM because those _don't_
244 ;; affect the policy in an interpreter environment.
245 (%eval form interpreter-env
))))
247 (defun unintern-init-only-stuff ()
248 (let ((this-pkg (find-package "SB-INTERPRETER")))
249 (do-symbols (s this-pkg
)
250 (when (or (and (eq (symbol-package s
) this-pkg
)
252 (not (member s
'(defspecial do-decl-spec
)))) ; for SB-CLTL2
253 (eq s
'%%eval
)) ; got inlined
254 (unintern s this-pkg
)))))