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
)
78 (parse-body (rest exp
) :doc-string-allowed nil
)
80 ;; KLUDGE: Uh, yeah. I'm not anticipating
81 ;; winning any prizes for this code, which was
82 ;; written on a "let's get it to work" basis.
83 ;; These seem to be the variables that need
84 ;; bindings for PROCESS-DECLS to work
85 ;; (*FREE-FUNS* and *FREE-VARS* so that
86 ;; references to free functions and variables
87 ;; in the declarations can be noted;
88 ;; *UNDEFINED-WARNINGS* so that warnings about
89 ;; undefined things can be accumulated [and
90 ;; then thrown away, as it happens]). -- CSR,
92 (let* ((sb!c
:*lexenv
* lexenv
)
93 (sb!c
::*free-funs
* (make-hash-table :test
'equal
))
94 (sb!c
::*free-vars
* (make-hash-table :test
'eq
))
95 (sb!c
::*undefined-warnings
* nil
))
96 ;; FIXME: VALUES declaration
97 (sb!c
::process-decls decls
102 (simple-eval-progn-body body lexenv
))))
106 ;;;; Analogous to COMPILER-ERROR, but simpler.
108 (define-condition eval-error
(encapsulated-condition)
110 (:report
(lambda (condition stream
)
111 (print-object (encapsulated-condition condition
) stream
))))
113 (defun eval-error (condition)
114 (signal 'eval-error
:condition condition
)
115 (bug "Unhandled EVAL-ERROR"))
117 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
118 ;;; magical cases, and call %SIMPLE-EVAL for the rest.
119 (defun simple-eval-in-lexenv (original-exp lexenv
)
120 (declare (optimize (safety 1)))
121 ;; (aver (lexenv-simple-p lexenv))
123 (sb!c
:with-compiler-error-resignalling
124 (let ((exp (macroexpand original-exp lexenv
)))
125 (handler-bind ((eval-error
127 (error 'interpreted-program-error
128 :condition
(encapsulated-condition condition
)
132 (ecase (info :variable
:kind exp
)
133 ((:special
:global
:constant
:unknown
)
135 ;; FIXME: This special case here is a symptom of non-ANSI
136 ;; weirdness in SBCL's ALIEN implementation, which could
137 ;; cause problems for e.g. code walkers. It'd probably be
138 ;; good to ANSIfy it by making alien variable accessors
139 ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
140 ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
141 ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
142 ;; be retained for compatibility, it can be implemented
143 ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
146 (sb!alien-internals
:alien-value exp
))))
148 (let ((name (first exp
))
149 (n-args (1- (length exp
))))
153 (error "wrong number of args to FUNCTION:~% ~S" exp
))
154 (let ((name (second exp
)))
155 (if (and (legal-fun-name-p name
)
156 (not (consp (let ((sb!c
:*lexenv
* lexenv
))
157 (sb!c
:lexenv-find name funs
)))))
158 (%coerce-name-to-fun name
)
159 ;; FIXME: This is a bit wasteful: it would be nice to call
160 ;; COMPILE-IN-LEXENV with the lambda-form directly, but
161 ;; getting consistent source context and muffling compiler notes
162 ;; is easier this way.
163 (%simple-eval original-exp lexenv
))))
166 (error "wrong number of args to QUOTE:~% ~S" exp
))
169 (unless (evenp n-args
)
170 (error "odd number of args to SETQ:~% ~S" exp
))
171 (unless (zerop n-args
)
172 (do ((name (cdr exp
) (cddr name
)))
174 (do ((args (cdr exp
) (cddr args
)))
176 ;; We duplicate the call to SET so that the
177 ;; correct value gets returned.
179 (simple-eval-in-lexenv (second args
) lexenv
)))
181 (simple-eval-in-lexenv (second args
) lexenv
))))
182 (let ((symbol (first name
)))
183 (case (info :variable
:kind symbol
)
185 (t (return (%simple-eval original-exp lexenv
))))
186 (unless (type= (info :variable
:type symbol
)
188 ;; let the compiler deal with type checking
189 (return (%simple-eval original-exp lexenv
)))))))
191 (simple-eval-progn-body (rest exp
) lexenv
))
193 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
194 ;; instead of PROGRAM-ERROR when there's something wrong
195 ;; with the syntax here (e.g. missing SITUATIONS). This
196 ;; could be fixed by hand-crafting clauses to catch and
197 ;; report each possibility, but it would probably be
198 ;; cleaner to write a new macro
199 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
200 ;; DESTRUCTURING-BIND and promotes any mismatch to
201 ;; PROGRAM-ERROR, then to use it here and in (probably
202 ;; dozens of) other places where the same problem
204 (destructuring-bind (eval-when situations
&rest body
) exp
205 (declare (ignore eval-when
))
206 (multiple-value-bind (ct lt e
)
207 (sb!c
:parse-eval-when-situations situations
)
208 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
209 ;; the situation :EXECUTE (or EVAL) controls whether
210 ;; evaluation occurs for other EVAL-WHEN forms; that
211 ;; is, those that are not top level forms, or those
212 ;; in code processed by EVAL or COMPILE. If the
213 ;; :EXECUTE situation is specified in such a form,
214 ;; then the body forms are processed as an implicit
215 ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
216 (declare (ignore ct lt
))
218 (simple-eval-progn-body body lexenv
)))))
220 (simple-eval-locally exp lexenv
))
222 (destructuring-bind (definitions &rest body
)
225 (let ((sb!c
:*lexenv
* lexenv
))
226 (sb!c
::funcall-in-macrolet-lexenv
229 (declare (ignore funs
))
232 (simple-eval-locally `(locally ,@body
) lexenv
))))
234 (destructuring-bind (definitions &rest body
) (rest exp
)
235 (multiple-value-bind (lexenv vars
)
236 (let ((sb!c
:*lexenv
* lexenv
))
237 (sb!c
::funcall-in-symbol-macrolet-lexenv
240 (values sb
!c
:*lexenv
* vars
))
242 (simple-eval-locally `(locally ,@body
) lexenv
:vars vars
))))
244 (destructuring-bind (test then
&optional else
) (rest exp
)
245 (eval-in-lexenv (if (eval-in-lexenv test lexenv
)
250 (%simple-eval exp lexenv
))
252 (if (and (symbolp name
)
253 (eq (info :function
:kind name
) :function
))
255 (dolist (arg (rest exp
))
256 (args (eval-in-lexenv arg lexenv
)))
257 (apply (symbol-function name
) (args)))
258 (%simple-eval exp lexenv
))))))
262 (defun eval-in-lexenv (exp lexenv
)
264 (if (eq *evaluator-mode
* :compile
)
265 (simple-eval-in-lexenv exp lexenv
)
266 (sb!eval
:eval-in-native-environment exp lexenv
))
268 (simple-eval-in-lexenv exp lexenv
))
270 (defun eval (original-exp)
272 "Evaluate the argument in a null lexical environment, returning the
274 (let ((*eval-source-context
* original-exp
)
275 (*eval-tlf-index
* nil
)
276 (*eval-source-info
* nil
))
277 (eval-in-lexenv original-exp
(make-null-lexenv))))
279 (defun eval-tlf (original-exp tlf-index
&optional
(lexenv (make-null-lexenv)))
280 (let ((*eval-source-context
* original-exp
)
281 (*eval-tlf-index
* tlf-index
)
282 (*eval-source-info
* sb
!c
::*source-info
*))
283 (eval-in-lexenv original-exp lexenv
)))
285 ;;; miscellaneous full function definitions of things which are
286 ;;; ordinarily handled magically by the compiler
288 (defun apply (function arg
&rest arguments
)
290 "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
291 the manner of LIST*. That is, a list is made of the values of all but the
292 last argument, appended to the value of the last argument, which must be a
294 (cond ((atom arguments
)
295 (apply function arg
))
296 ((atom (cdr arguments
))
297 (apply function
(cons arg
(car arguments
))))
298 (t (do* ((a1 arguments a2
)
299 (a2 (cdr arguments
) (cdr a2
)))
302 (apply function
(cons arg arguments
)))))))
304 (defun funcall (function &rest arguments
)
306 "Call FUNCTION with the given ARGUMENTS."
307 (apply function arguments
))
309 (defun values (&rest values
)
311 "Return all arguments, in order, as values."
312 (declare (truly-dynamic-extent values
))
313 (values-list values
))
315 (defun values-list (list)
317 "Return all of the elements of LIST, in order, as values."