3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 (!defparameter
*eval-calls
* 0)
16 (defvar *eval-source-context
* nil
)
18 (defvar *eval-tlf-index
* nil
)
19 (defvar *eval-source-info
* nil
)
21 ;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns
22 ;;;; a secondary value of T if we must call the resulting function
23 ;;;; to evaluate EXPR -- if EXPR is already a lambda form, there's
25 (defun make-eval-lambda (expr)
27 (typep x
'(cons (member lambda named-lambda lambda-with-lexenv
)))))
31 (when (typep expr
'(cons (eql function
) (cons t null
)))
32 (let ((inner (second expr
)))
34 (return-from make-eval-lambda
(values inner nil
)))))
36 ;; why PROGN? So that attempts to eval free declarations
37 ;; signal errors rather than return NIL. -- CSR, 2007-05-01
41 ;;; FIXME: what does "except in that it can't handle toplevel ..." mean?
42 ;;; Is there anything wrong with the implementation, or is the comment obsolete?
43 ;;; general case of EVAL (except in that it can't handle toplevel
44 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
45 (defun %simple-eval
(expr lexenv
)
46 (multiple-value-bind (lambda call
) (make-eval-lambda expr
)
48 ;; This tells the compiler where the lambda comes from, in case it
49 ;; wants to report any problems.
50 (let ((sb!c
::*source-form-context-alist
*
51 (acons lambda
*eval-source-context
*
52 sb
!c
::*source-form-context-alist
*)))
53 (handler-bind (;; Compiler notes just clutter up the REPL:
54 ;; anyone caring about performance should not
56 (compiler-note #'muffle-warning
))
57 (sb!c
:compile-in-lexenv lambda lexenv nil
*eval-source-info
*
58 *eval-tlf-index
* (not call
))))))
59 (declare (function fun
))
64 ;;; Handle PROGN and implicit PROGN.
67 (defun simple-eval-progn-body (progn-body lexenv
)
68 (unless (list-with-length-p progn-body
)
69 (let ((*print-circle
* t
))
70 (error 'simple-program-error
72 "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
73 :format-arguments
(list progn-body
))))
75 ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
76 ;; need to take care to return all the values of the final EVAL.
77 ;; * It's left as an exercise to the reader to verify that this
78 ;; gives the right result when PROGN-BODY is NIL, because
79 ;; (FIRST NIL) = (REST NIL) = NIL.
80 (do* ((i progn-body rest-i
)
81 (rest-i (rest i
) (rest i
)))
83 (if rest-i
; if not last element of list
84 (simple-eval-in-lexenv (first i
) lexenv
)
85 (return (simple-eval-in-lexenv (first i
) lexenv
)))))
87 (defun simple-eval-locally (exp lexenv
&key vars funs
)
88 (multiple-value-bind (body decls
) (parse-body exp nil
)
90 ;; KLUDGE: Uh, yeah. I'm not anticipating
91 ;; winning any prizes for this code, which was
92 ;; written on a "let's get it to work" basis.
93 ;; These seem to be the variables that need
94 ;; bindings for PROCESS-DECLS to work
95 ;; (*FREE-FUNS* and *FREE-VARS* so that
96 ;; references to free functions and variables
97 ;; in the declarations can be noted;
98 ;; *UNDEFINED-WARNINGS* so that warnings about
99 ;; undefined things can be accumulated [and
100 ;; then thrown away, as it happens]). -- CSR,
102 (let* ((sb!c
:*lexenv
* lexenv
)
103 (sb!c
::*free-funs
* (make-hash-table :test
'equal
))
104 (sb!c
::*free-vars
* (make-hash-table :test
'eq
))
105 (sb!c
::*undefined-warnings
* nil
))
106 ;; FIXME: VALUES declaration
107 (sb!c
::process-decls decls
112 (simple-eval-progn-body body lexenv
))))
117 ;;;; Analogous to COMPILER-ERROR, but simpler.
119 (define-condition eval-error
(encapsulated-condition)
121 (:report
(lambda (condition stream
)
122 (print-object (encapsulated-condition condition
) stream
))))
124 (defun eval-error (condition)
125 (signal 'eval-error
:condition condition
)
126 (bug "Unhandled EVAL-ERROR"))
128 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
129 ;;; magical cases, and call %SIMPLE-EVAL for the rest.
131 (defun simple-eval-in-lexenv (original-exp lexenv
)
132 (declare (optimize (safety 1)))
133 ;; (aver (lexenv-simple-p lexenv))
135 (sb!c
:with-compiler-error-resignalling
136 (let ((exp (macroexpand original-exp lexenv
)))
137 (handler-bind ((eval-error
139 (error 'interpreted-program-error
140 :condition
(encapsulated-condition condition
)
144 (ecase (info :variable
:kind exp
)
145 ((:special
:global
:constant
:unknown
)
147 ;; FIXME: This special case here is a symptom of non-ANSI
148 ;; weirdness in SBCL's ALIEN implementation, which could
149 ;; cause problems for e.g. code walkers. It'd probably be
150 ;; good to ANSIfy it by making alien variable accessors
151 ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
152 ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
153 ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
154 ;; be retained for compatibility, it can be implemented
155 ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
158 (sb!alien-internals
:alien-value exp
))))
160 (let ((name (first exp
))
161 (n-args (1- (length exp
))))
165 (error "wrong number of args to FUNCTION:~% ~S" exp
))
166 (let ((name (second exp
)))
167 (if (and (legal-fun-name-p name
)
168 (not (consp (let ((sb!c
:*lexenv
* lexenv
))
169 (sb!c
:lexenv-find name funs
)))))
170 (%coerce-name-to-fun name
)
171 ;; FIXME: This is a bit wasteful: it would be nice to call
172 ;; COMPILE-IN-LEXENV with the lambda-form directly, but
173 ;; getting consistent source context and muffling compiler notes
174 ;; is easier this way.
175 (%simple-eval original-exp lexenv
))))
178 (error "wrong number of args to QUOTE:~% ~S" exp
))
181 (unless (evenp n-args
)
182 (error "odd number of args to SETQ:~% ~S" exp
))
183 (unless (zerop n-args
)
184 (do ((name (cdr exp
) (cddr name
)))
186 (do ((args (cdr exp
) (cddr args
)))
188 ;; We duplicate the call to SET so that the
189 ;; correct value gets returned.
191 (simple-eval-in-lexenv (second args
) lexenv
)))
193 (simple-eval-in-lexenv (second args
) lexenv
))))
194 (let ((symbol (first name
)))
195 (case (info :variable
:kind symbol
)
197 (t (return (%simple-eval original-exp lexenv
))))
198 (unless (type= (info :variable
:type symbol
)
200 ;; let the compiler deal with type checking
201 (return (%simple-eval original-exp lexenv
)))))))
203 (simple-eval-progn-body (rest exp
) lexenv
))
205 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
206 ;; instead of PROGRAM-ERROR when there's something wrong
207 ;; with the syntax here (e.g. missing SITUATIONS). This
208 ;; could be fixed by hand-crafting clauses to catch and
209 ;; report each possibility, but it would probably be
210 ;; cleaner to write a new macro
211 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
212 ;; DESTRUCTURING-BIND and promotes any mismatch to
213 ;; PROGRAM-ERROR, then to use it here and in (probably
214 ;; dozens of) other places where the same problem
216 (destructuring-bind (eval-when situations
&rest body
) exp
217 (declare (ignore eval-when
))
218 (multiple-value-bind (ct lt e
)
219 (sb!c
:parse-eval-when-situations situations
)
220 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
221 ;; the situation :EXECUTE (or EVAL) controls whether
222 ;; evaluation occurs for other EVAL-WHEN forms; that
223 ;; is, those that are not top level forms, or those
224 ;; in code processed by EVAL or COMPILE. If the
225 ;; :EXECUTE situation is specified in such a form,
226 ;; then the body forms are processed as an implicit
227 ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
228 (declare (ignore ct lt
))
230 (simple-eval-progn-body body lexenv
)))))
232 (simple-eval-locally (rest exp
) lexenv
))
234 (destructuring-bind (definitions &rest body
) (rest exp
)
235 (let ((sb!c
:*lexenv
* lexenv
))
236 (sb!c
::funcall-in-macrolet-lexenv
238 (lambda (&optional funs
)
239 (simple-eval-locally body sb
!c
:*lexenv
*
243 (destructuring-bind (definitions &rest body
) (rest exp
)
244 (let ((sb!c
:*lexenv
* lexenv
))
245 (sb!c
::funcall-in-symbol-macrolet-lexenv
247 (lambda (&optional vars
)
248 (simple-eval-locally body sb
!c
:*lexenv
*
252 (destructuring-bind (test then
&optional else
) (rest exp
)
253 (eval-in-lexenv (if (eval-in-lexenv test lexenv
)
258 (%simple-eval exp lexenv
))
260 (if (and (symbolp name
)
261 (eq (info :function
:kind name
) :function
))
263 (dolist (arg (rest exp
))
264 (args (eval-in-lexenv arg lexenv
)))
265 (apply (symbol-function name
) (args)))
266 (%simple-eval exp lexenv
))))))
270 ;;; This definition will be replaced after the interpreter is compiled.
271 ;;; Until then we just always compile.
273 (defun sb!interpreter
:eval-in-environment
(exp lexenv
)
274 (let ((exp (macroexpand exp lexenv
)))
277 (%simple-eval exp
(or lexenv
(make-null-lexenv))))))
279 (defun eval-in-lexenv (exp lexenv
)
281 (let ((lexenv (or lexenv
(make-null-lexenv))))
282 (if (eq *evaluator-mode
* :compile
)
283 (simple-eval-in-lexenv exp lexenv
)
284 (sb!eval
:eval-in-native-environment exp lexenv
)))
286 (sb!c
:with-compiler-error-resignalling
287 (sb!interpreter
:eval-in-environment exp lexenv
))
288 #!-
(or sb-eval sb-fasteval
)
289 (simple-eval-in-lexenv exp
(or lexenv
(make-null-lexenv))))
291 (defun eval (original-exp)
292 "Evaluate the argument in a null lexical environment, returning the
294 (let ((*eval-source-context
* original-exp
)
295 (*eval-tlf-index
* nil
)
296 (*eval-source-info
* nil
))
297 (eval-in-lexenv original-exp nil
)))
299 (defun eval-tlf (original-exp tlf-index
&optional lexenv
)
300 (let ((*eval-source-context
* original-exp
)
301 (*eval-tlf-index
* tlf-index
)
302 (*eval-source-info
* sb
!c
::*source-info
*))
303 (eval-in-lexenv original-exp lexenv
)))
305 ;;; miscellaneous full function definitions of things which are
306 ;;; ordinarily handled magically by the compiler
308 (defun apply (function arg
&rest arguments
)
309 "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
310 the manner of LIST*. That is, a list is made of the values of all but the
311 last argument, appended to the value of the last argument, which must be a
313 (cond ((atom arguments
)
314 (apply function arg
))
315 ((atom (cdr arguments
))
316 (apply function
(cons arg
(car arguments
))))
317 (t (do* ((a1 arguments a2
)
318 (a2 (cdr arguments
) (cdr a2
)))
321 (apply function
(cons arg arguments
)))))))
323 (defun funcall (function &rest arguments
)
324 "Call FUNCTION with the given ARGUMENTS."
325 (apply function arguments
))
327 (defun values (&rest values
)
328 "Return all arguments, in order, as values."
329 (declare (truly-dynamic-extent values
))
330 (values-list values
))
332 (defun values-list (list)
333 "Return all of the elements of LIST, in order, as values."