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)
26 (if (typep expr
`(cons (member lambda named-lambda lambda-with-lexenv
)))
29 ;; why PROGN? So that attempts to eval free declarations
30 ;; signal errors rather than return NIL. -- CSR, 2007-05-01
34 ;;; general case of EVAL (except in that it can't handle toplevel
35 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
36 (defun %simple-eval
(expr lexenv
)
37 (multiple-value-bind (lambda call
) (make-eval-lambda expr
)
39 ;; This tells the compiler where the lambda comes from, in case it
40 ;; wants to report any problems.
41 (let ((sb!c
::*source-form-context-alist
*
42 (acons lambda
*eval-source-context
*
43 sb
!c
::*source-form-context-alist
*)))
44 (handler-bind (;; Compiler notes just clutter up the REPL:
45 ;; anyone caring about performance should not
47 (compiler-note #'muffle-warning
))
48 (sb!c
:compile-in-lexenv
49 nil lambda lexenv
*eval-source-info
* *eval-tlf-index
* (not call
))))))
50 (declare (function fun
))
55 ;;; Handle PROGN and implicit PROGN.
56 (defun simple-eval-progn-body (progn-body lexenv
)
57 (unless (list-with-length-p progn-body
)
58 (let ((*print-circle
* t
))
59 (error 'simple-program-error
61 "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
62 :format-arguments
(list progn-body
))))
64 ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
65 ;; need to take care to return all the values of the final EVAL.
66 ;; * It's left as an exercise to the reader to verify that this
67 ;; gives the right result when PROGN-BODY is NIL, because
68 ;; (FIRST NIL) = (REST NIL) = NIL.
69 (do* ((i progn-body rest-i
)
70 (rest-i (rest i
) (rest i
)))
72 (if rest-i
; if not last element of list
73 (simple-eval-in-lexenv (first i
) lexenv
)
74 (return (simple-eval-in-lexenv (first i
) lexenv
)))))
76 (defun simple-eval-locally (exp lexenv
&key vars
)
77 (multiple-value-bind (body decls
) (parse-body (rest exp
) nil
)
79 ;; KLUDGE: Uh, yeah. I'm not anticipating
80 ;; winning any prizes for this code, which was
81 ;; written on a "let's get it to work" basis.
82 ;; These seem to be the variables that need
83 ;; bindings for PROCESS-DECLS to work
84 ;; (*FREE-FUNS* and *FREE-VARS* so that
85 ;; references to free functions and variables
86 ;; in the declarations can be noted;
87 ;; *UNDEFINED-WARNINGS* so that warnings about
88 ;; undefined things can be accumulated [and
89 ;; then thrown away, as it happens]). -- CSR,
91 (let* ((sb!c
:*lexenv
* lexenv
)
92 (sb!c
::*free-funs
* (make-hash-table :test
'equal
))
93 (sb!c
::*free-vars
* (make-hash-table :test
'eq
))
94 (sb!c
::*undefined-warnings
* nil
))
95 ;; FIXME: VALUES declaration
96 (sb!c
::process-decls decls
101 (simple-eval-progn-body body lexenv
))))
105 ;;;; Analogous to COMPILER-ERROR, but simpler.
107 (define-condition eval-error
(encapsulated-condition)
109 (:report
(lambda (condition stream
)
110 (print-object (encapsulated-condition condition
) stream
))))
112 (defun eval-error (condition)
113 (signal 'eval-error
:condition condition
)
114 (bug "Unhandled EVAL-ERROR"))
116 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
117 ;;; magical cases, and call %SIMPLE-EVAL for the rest.
118 (defun simple-eval-in-lexenv (original-exp lexenv
)
119 (declare (optimize (safety 1)))
120 ;; (aver (lexenv-simple-p lexenv))
122 (sb!c
:with-compiler-error-resignalling
123 (let ((exp (macroexpand original-exp lexenv
)))
124 (handler-bind ((eval-error
126 (error 'interpreted-program-error
127 :condition
(encapsulated-condition condition
)
131 (ecase (info :variable
:kind exp
)
132 ((:special
:global
:constant
:unknown
)
134 ;; FIXME: This special case here is a symptom of non-ANSI
135 ;; weirdness in SBCL's ALIEN implementation, which could
136 ;; cause problems for e.g. code walkers. It'd probably be
137 ;; good to ANSIfy it by making alien variable accessors
138 ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
139 ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
140 ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
141 ;; be retained for compatibility, it can be implemented
142 ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
145 (sb!alien-internals
:alien-value exp
))))
147 (let ((name (first exp
))
148 (n-args (1- (length exp
))))
152 (error "wrong number of args to FUNCTION:~% ~S" exp
))
153 (let ((name (second exp
)))
154 (if (and (legal-fun-name-p name
)
155 (not (consp (let ((sb!c
:*lexenv
* lexenv
))
156 (sb!c
:lexenv-find name funs
)))))
157 (%coerce-name-to-fun name
)
158 ;; FIXME: This is a bit wasteful: it would be nice to call
159 ;; COMPILE-IN-LEXENV with the lambda-form directly, but
160 ;; getting consistent source context and muffling compiler notes
161 ;; is easier this way.
162 (%simple-eval original-exp lexenv
))))
165 (error "wrong number of args to QUOTE:~% ~S" exp
))
168 (unless (evenp n-args
)
169 (error "odd number of args to SETQ:~% ~S" exp
))
170 (unless (zerop n-args
)
171 (do ((name (cdr exp
) (cddr name
)))
173 (do ((args (cdr exp
) (cddr args
)))
175 ;; We duplicate the call to SET so that the
176 ;; correct value gets returned.
178 (simple-eval-in-lexenv (second args
) lexenv
)))
180 (simple-eval-in-lexenv (second args
) lexenv
))))
181 (let ((symbol (first name
)))
182 (case (info :variable
:kind symbol
)
184 (t (return (%simple-eval original-exp lexenv
))))
185 (unless (type= (info :variable
:type symbol
)
187 ;; let the compiler deal with type checking
188 (return (%simple-eval original-exp lexenv
)))))))
190 (simple-eval-progn-body (rest exp
) lexenv
))
192 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
193 ;; instead of PROGRAM-ERROR when there's something wrong
194 ;; with the syntax here (e.g. missing SITUATIONS). This
195 ;; could be fixed by hand-crafting clauses to catch and
196 ;; report each possibility, but it would probably be
197 ;; cleaner to write a new macro
198 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
199 ;; DESTRUCTURING-BIND and promotes any mismatch to
200 ;; PROGRAM-ERROR, then to use it here and in (probably
201 ;; dozens of) other places where the same problem
203 (destructuring-bind (eval-when situations
&rest body
) exp
204 (declare (ignore eval-when
))
205 (multiple-value-bind (ct lt e
)
206 (sb!c
:parse-eval-when-situations situations
)
207 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
208 ;; the situation :EXECUTE (or EVAL) controls whether
209 ;; evaluation occurs for other EVAL-WHEN forms; that
210 ;; is, those that are not top level forms, or those
211 ;; in code processed by EVAL or COMPILE. If the
212 ;; :EXECUTE situation is specified in such a form,
213 ;; then the body forms are processed as an implicit
214 ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
215 (declare (ignore ct lt
))
217 (simple-eval-progn-body body lexenv
)))))
219 (simple-eval-locally exp lexenv
))
221 (destructuring-bind (definitions &rest body
)
224 (let ((sb!c
:*lexenv
* lexenv
))
225 (sb!c
::funcall-in-macrolet-lexenv
228 (declare (ignore funs
))
231 (simple-eval-locally `(locally ,@body
) lexenv
))))
233 (destructuring-bind (definitions &rest body
) (rest exp
)
234 (multiple-value-bind (lexenv vars
)
235 (let ((sb!c
:*lexenv
* lexenv
))
236 (sb!c
::funcall-in-symbol-macrolet-lexenv
239 (values sb
!c
:*lexenv
* vars
))
241 (simple-eval-locally `(locally ,@body
) lexenv
:vars vars
))))
243 (destructuring-bind (test then
&optional else
) (rest exp
)
244 (eval-in-lexenv (if (eval-in-lexenv test lexenv
)
249 (%simple-eval exp lexenv
))
251 (if (and (symbolp name
)
252 (eq (info :function
:kind name
) :function
))
254 (dolist (arg (rest exp
))
255 (args (eval-in-lexenv arg lexenv
)))
256 (apply (symbol-function name
) (args)))
257 (%simple-eval exp lexenv
))))))
261 (defun eval-in-lexenv (exp lexenv
)
263 (let ((lexenv (or lexenv
(make-null-lexenv))))
264 (if (eq *evaluator-mode
* :compile
)
265 (simple-eval-in-lexenv exp lexenv
)
266 (sb!eval
:eval-in-native-environment exp lexenv
)))
268 (if (eq *evaluator-mode
* :compile
)
269 (simple-eval-in-lexenv exp
(or lexenv
(make-null-lexenv)))
270 (sb!interpreter
:eval-in-environment exp lexenv
))
271 #!-
(or sb-eval sb-fasteval
)
272 (simple-eval-in-lexenv exp
(or lexenv
(make-null-lexenv))))
274 (defun eval (original-exp)
276 "Evaluate the argument in a null lexical environment, returning the
278 (let ((*eval-source-context
* original-exp
)
279 (*eval-tlf-index
* nil
)
280 (*eval-source-info
* nil
))
281 (eval-in-lexenv original-exp nil
)))
283 (defun eval-tlf (original-exp tlf-index
&optional lexenv
)
284 (let ((*eval-source-context
* original-exp
)
285 (*eval-tlf-index
* tlf-index
)
286 (*eval-source-info
* sb
!c
::*source-info
*))
287 (eval-in-lexenv original-exp lexenv
)))
289 ;;; miscellaneous full function definitions of things which are
290 ;;; ordinarily handled magically by the compiler
292 (defun apply (function arg
&rest arguments
)
294 "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
295 the manner of LIST*. That is, a list is made of the values of all but the
296 last argument, appended to the value of the last argument, which must be a
298 (cond ((atom arguments
)
299 (apply function arg
))
300 ((atom (cdr arguments
))
301 (apply function
(cons arg
(car arguments
))))
302 (t (do* ((a1 arguments a2
)
303 (a2 (cdr arguments
) (cdr a2
)))
306 (apply function
(cons arg arguments
)))))))
308 (defun funcall (function &rest arguments
)
310 "Call FUNCTION with the given ARGUMENTS."
311 (apply function arguments
))
313 (defun values (&rest values
)
315 "Return all arguments, in order, as values."
316 (declare (truly-dynamic-extent values
))
317 (values-list values
))
319 (defun values-list (list)
321 "Return all of the elements of LIST, in order, as values."