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 (defun !eval-cold-init ()
18 *evaluator-mode* :compile)
20 (setf sb!eval::*eval-level* -1
21 sb!eval::*eval-verbose* nil))
23 (defvar *eval-source-context* nil)
25 (defun make-eval-lambda (expr)
27 ;; This name is used to communicate the original context
28 ;; for the compiler, and identifies the lambda for use of
29 ;; EVAL-LAMBDA-SOURCE-LAMBDA below.
30 (eval ,(sb!c::source-form-context *eval-source-context*)) ()
31 (declare (muffle-conditions compiler-note))
32 ;; why PROGN? So that attempts to eval free declarations
33 ;; signal errors rather than return NIL. -- CSR, 2007-05-01
36 (defun eval-lambda-p (form)
37 (when (and (consp form) (eq 'named-lambda (first form)))
38 (let ((name (second form)))
39 (when (and (consp name) (eq 'eval (first name)))
42 (defun eval-lambda-source-lambda (eval-lambda)
43 (if (eval-lambda-p eval-lambda)
44 (destructuring-bind (named-lambda name lambda-list decl (progn expr))
46 (declare (ignore named-lambda name lambda-list decl progn))
47 (when (and (consp expr) (member (car expr) '(lambda named-lambda)))
51 ;;; general case of EVAL (except in that it can't handle toplevel
52 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
53 (defun %simple-eval (expr lexenv)
54 ;; FIXME: It might be nice to quieten the toplevel by muffling
55 ;; warnings generated by this compilation (since we're about to
56 ;; execute the results irrespective of the warnings). We might want
57 ;; to be careful about not muffling warnings arising from inner
58 ;; evaluations/compilations, though [e.g. the ignored variable in
59 ;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13
61 ;; As of 1.0.21.6 we muffle compiler notes lexically here, which seems
63 (let* ((lambda (make-eval-lambda expr))
64 (fun (sb!c:compile-in-lexenv nil lambda lexenv)))
67 ;;; Handle PROGN and implicit PROGN.
68 (defun simple-eval-progn-body (progn-body lexenv)
69 (unless (list-with-length-p progn-body)
70 (let ((*print-circle* t))
71 (error 'simple-program-error
73 "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
74 :format-arguments (list progn-body))))
76 ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
77 ;; need to take care to return all the values of the final EVAL.
78 ;; * It's left as an exercise to the reader to verify that this
79 ;; gives the right result when PROGN-BODY is NIL, because
80 ;; (FIRST NIL) = (REST NIL) = NIL.
81 (do* ((i progn-body rest-i)
82 (rest-i (rest i) (rest i)))
84 (if rest-i ; if not last element of list
85 (simple-eval-in-lexenv (first i) lexenv)
86 (return (simple-eval-in-lexenv (first i) lexenv)))))
88 (defun simple-eval-locally (exp lexenv &key vars)
89 (multiple-value-bind (body decls)
90 (parse-body (rest exp) :doc-string-allowed nil)
92 ;; KLUDGE: Uh, yeah. I'm not anticipating
93 ;; winning any prizes for this code, which was
94 ;; written on a "let's get it to work" basis.
95 ;; These seem to be the variables that need
96 ;; bindings for PROCESS-DECLS to work
97 ;; (*FREE-FUNS* and *FREE-VARS* so that
98 ;; references to free functions and variables
99 ;; in the declarations can be noted;
100 ;; *UNDEFINED-WARNINGS* so that warnings about
101 ;; undefined things can be accumulated [and
102 ;; then thrown away, as it happens]). -- CSR,
104 (let* ((sb!c:*lexenv* lexenv)
105 (sb!c::*free-funs* (make-hash-table :test 'equal))
106 (sb!c::*free-vars* (make-hash-table :test 'eq))
107 (sb!c::*undefined-warnings* nil))
108 ;; FIXME: VALUES declaration
109 (sb!c::process-decls decls
114 (simple-eval-progn-body body lexenv))))
118 ;;;; Analogous to COMPILER-ERROR, but simpler.
120 (define-condition eval-error (encapsulated-condition)
122 (:report (lambda (condition stream)
123 (print-object (encapsulated-condition condition) stream))))
125 (defun eval-error (condition)
126 (signal 'eval-error :condition condition)
127 (bug "Unhandled EVAL-ERROR"))
129 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
130 ;;; 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))
136 ((sb!c:compiler-error
138 (if (boundp 'sb!c::*compiler-error-bailout*)
139 ;; if we're in the compiler, delegate either to a higher
140 ;; authority or, if that's us, back down to the
141 ;; outermost compiler handler...
145 ;; ... if we're not in the compiler, better signal the
146 ;; error straight away.
147 (invoke-restart 'sb!c::signal-error)))))
148 (let ((exp (macroexpand original-exp lexenv)))
149 (handler-bind ((eval-error
151 (error 'interpreted-program-error
152 :condition (encapsulated-condition condition)
156 (ecase (info :variable :kind exp)
157 ((:special :global :constant :unknown)
159 ;; FIXME: This special case here is a symptom of non-ANSI
160 ;; weirdness in SBCL's ALIEN implementation, which could
161 ;; cause problems for e.g. code walkers. It'd probably be
162 ;; good to ANSIfy it by making alien variable accessors
163 ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
164 ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
165 ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
166 ;; be retained for compatibility, it can be implemented
167 ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
170 (%simple-eval original-exp lexenv))))
172 (let ((name (first exp))
173 (n-args (1- (length exp))))
177 (error "wrong number of args to FUNCTION:~% ~S" exp))
178 (let ((name (second exp)))
179 (if (and (legal-fun-name-p name)
180 (not (consp (let ((sb!c:*lexenv* lexenv))
181 (sb!c:lexenv-find name funs)))))
182 (%coerce-name-to-fun name)
183 ;; FIXME: This is a bit wasteful: it would be nice to call
184 ;; COMPILE-IN-LEXENV with the lambda-form directly, but
185 ;; getting consistent source context and muffling compiler notes
186 ;; is easier this way.
187 (%simple-eval original-exp lexenv))))
190 (error "wrong number of args to QUOTE:~% ~S" exp))
193 (unless (evenp n-args)
194 (error "odd number of args to SETQ:~% ~S" exp))
195 (unless (zerop n-args)
196 (do ((name (cdr exp) (cddr name)))
198 (do ((args (cdr exp) (cddr args)))
200 ;; We duplicate the call to SET so that the
201 ;; correct value gets returned.
203 (simple-eval-in-lexenv (second args) lexenv)))
205 (simple-eval-in-lexenv (second args) lexenv))))
206 (let ((symbol (first name)))
207 (case (info :variable :kind symbol)
209 (t (return (%simple-eval original-exp lexenv))))
210 (unless (type= (info :variable :type symbol)
212 ;; let the compiler deal with type checking
213 (return (%simple-eval original-exp lexenv)))))))
215 (simple-eval-progn-body (rest exp) lexenv))
217 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
218 ;; instead of PROGRAM-ERROR when there's something wrong
219 ;; with the syntax here (e.g. missing SITUATIONS). This
220 ;; could be fixed by hand-crafting clauses to catch and
221 ;; report each possibility, but it would probably be
222 ;; cleaner to write a new macro
223 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
224 ;; DESTRUCTURING-BIND and promotes any mismatch to
225 ;; PROGRAM-ERROR, then to use it here and in (probably
226 ;; dozens of) other places where the same problem
228 (destructuring-bind (eval-when situations &rest body) exp
229 (declare (ignore eval-when))
230 (multiple-value-bind (ct lt e)
231 (sb!c:parse-eval-when-situations situations)
232 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
233 ;; the situation :EXECUTE (or EVAL) controls whether
234 ;; evaluation occurs for other EVAL-WHEN forms; that
235 ;; is, those that are not top level forms, or those
236 ;; in code processed by EVAL or COMPILE. If the
237 ;; :EXECUTE situation is specified in such a form,
238 ;; then the body forms are processed as an implicit
239 ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
240 (declare (ignore ct lt))
242 (simple-eval-progn-body body lexenv)))))
244 (simple-eval-locally exp lexenv))
246 (destructuring-bind (definitions &rest body)
249 (let ((sb!c:*lexenv* lexenv))
250 (sb!c::funcall-in-macrolet-lexenv
253 (declare (ignore funs))
256 (simple-eval-locally `(locally ,@body) lexenv))))
258 (destructuring-bind (definitions &rest body) (rest exp)
259 (multiple-value-bind (lexenv vars)
260 (let ((sb!c:*lexenv* lexenv))
261 (sb!c::funcall-in-symbol-macrolet-lexenv
264 (values sb!c:*lexenv* vars))
266 (simple-eval-locally `(locally ,@body) lexenv :vars vars))))
268 (destructuring-bind (test then &optional else) (rest exp)
269 (eval-in-lexenv (if (eval-in-lexenv test lexenv)
274 (destructuring-bind (definitions &rest body) (rest exp)
275 (if (null definitions)
276 (simple-eval-locally `(locally ,@body) lexenv)
277 (%simple-eval exp lexenv))))
279 (if (and (symbolp name)
280 (eq (info :function :kind name) :function))
282 (dolist (arg (rest exp))
283 (args (eval-in-lexenv arg lexenv)))
284 (apply (symbol-function name) (args)))
285 (%simple-eval exp lexenv))))))
289 (defun eval-in-lexenv (exp lexenv)
291 (if (eq *evaluator-mode* :compile)
292 (simple-eval-in-lexenv exp lexenv)
293 (sb!eval:eval-in-native-environment exp lexenv))
295 (simple-eval-in-lexenv exp lexenv))
297 (defun eval (original-exp)
299 "Evaluate the argument in a null lexical environment, returning the
301 (let ((*eval-source-context* original-exp))
302 (eval-in-lexenv original-exp (make-null-lexenv))))
305 ;;; miscellaneous full function definitions of things which are
306 ;;; ordinarily handled magically by the compiler
308 (defun apply (function arg &rest arguments)
310 "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
311 the manner of LIST*. That is, a list is made of the values of all but the
312 last argument, appended to the value of the last argument, which must be a
314 (cond ((atom arguments)
315 (apply function arg))
316 ((atom (cdr arguments))
317 (apply function (cons arg (car arguments))))
318 (t (do* ((a1 arguments a2)
319 (a2 (cdr arguments) (cdr a2)))
322 (apply function (cons arg arguments)))))))
324 (defun funcall (function &rest arguments)
326 "Call FUNCTION with the given ARGUMENTS."
327 (apply function arguments))
329 (defun values (&rest values)
331 "Return all arguments, in order, as values."
332 (declare (truly-dynamic-extent values))
333 (values-list values))
335 (defun values-list (list)
337 "Return all of the elements of LIST, in order, as values."