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 ;;; general case of EVAL (except in that it can't handle toplevel
15 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
16 (defun %simple-eval
(expr lexenv
)
17 ;; FIXME: It might be nice to quieten the toplevel by muffling
18 ;; warnings generated by this compilation (since we're about to
19 ;; execute the results irrespective of the warnings). We might want
20 ;; to be careful about not muffling warnings arising from inner
21 ;; evaluations/compilations, though [e.g. the ignored variable in
22 ;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13
23 (let ((fun (sb!c
:compile-in-lexenv nil
28 ;;; Handle PROGN and implicit PROGN.
29 (defun simple-eval-progn-body (progn-body lexenv
)
30 (unless (list-with-length-p progn-body
)
31 (let ((*print-circle
* t
))
32 (error 'simple-program-error
34 "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
35 :format-arguments
(list progn-body
))))
37 ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
38 ;; need to take care to return all the values of the final EVAL.
39 ;; * It's left as an exercise to the reader to verify that this
40 ;; gives the right result when PROGN-BODY is NIL, because
41 ;; (FIRST NIL) = (REST NIL) = NIL.
42 (do* ((i progn-body rest-i
)
43 (rest-i (rest i
) (rest i
)))
45 (if rest-i
; if not last element of list
46 (simple-eval-in-lexenv (first i
) lexenv
)
47 (return (simple-eval-in-lexenv (first i
) lexenv
)))))
49 (defun simple-eval-locally (exp lexenv
&key vars
)
50 (multiple-value-bind (body decls
)
51 (parse-body (rest exp
) :doc-string-allowed nil
)
53 ;; KLUDGE: Uh, yeah. I'm not anticipating
54 ;; winning any prizes for this code, which was
55 ;; written on a "let's get it to work" basis.
56 ;; These seem to be the variables that need
57 ;; bindings for PROCESS-DECLS to work
58 ;; (*FREE-FUNS* and *FREE-VARS* so that
59 ;; references to free functions and variables
60 ;; in the declarations can be noted;
61 ;; *UNDEFINED-WARNINGS* so that warnings about
62 ;; undefined things can be accumulated [and
63 ;; then thrown away, as it happens]). -- CSR,
65 (let* ((sb!c
:*lexenv
* lexenv
)
66 (sb!c
::*free-funs
* (make-hash-table :test
'equal
))
67 (sb!c
::*free-vars
* (make-hash-table :test
'eq
))
68 (sb!c
::*undefined-warnings
* nil
))
69 ;; FIXME: VALUES declaration
70 (sb!c
::process-decls decls
75 (simple-eval-progn-body body lexenv
))))
79 ;;;; Analogous to COMPILER-ERROR, but simpler.
81 (define-condition eval-error
(encapsulated-condition)
83 (:report
(lambda (condition stream
)
84 (print-object (encapsulated-condition condition
) stream
))))
86 (defun eval-error (condition)
87 (signal 'eval-error
:condition condition
)
88 (bug "Unhandled EVAL-ERROR"))
90 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
91 ;;; magical cases, and call %SIMPLE-EVAL for the rest.
92 (defun simple-eval-in-lexenv (original-exp lexenv
)
93 (declare (optimize (safety 1)))
94 ;; (aver (lexenv-simple-p lexenv))
98 (if (boundp 'sb
!c
::*compiler-error-bailout
*)
99 ;; if we're in the compiler, delegate either to a higher
100 ;; authority or, if that's us, back down to the
101 ;; outermost compiler handler...
105 ;; ... if we're not in the compiler, better signal the
106 ;; error straight away.
107 (invoke-restart 'sb
!c
::signal-error
)))))
108 (let ((exp (macroexpand original-exp lexenv
)))
109 (handler-bind ((eval-error
111 (error 'interpreted-program-error
112 :condition
(encapsulated-condition condition
)
116 (ecase (info :variable
:kind exp
)
118 (values (info :variable
:constant-value exp
)))
121 ;; FIXME: This special case here is a symptom of non-ANSI
122 ;; weirdness in SBCL's ALIEN implementation, which could
123 ;; cause problems for e.g. code walkers. It'd probably be
124 ;; good to ANSIfy it by making alien variable accessors
125 ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
126 ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
127 ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
128 ;; be retained for compatibility, it can be implemented
129 ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
132 (%simple-eval original-exp lexenv
))))
134 (let ((name (first exp
))
135 (n-args (1- (length exp
))))
139 (error "wrong number of args to FUNCTION:~% ~S" exp
))
140 (let ((name (second exp
)))
141 (if (and (legal-fun-name-p name
)
142 (not (consp (let ((sb!c
:*lexenv
* lexenv
))
143 (sb!c
:lexenv-find name funs
)))))
144 (%coerce-name-to-fun name
)
145 (%simple-eval original-exp lexenv
))))
148 (error "wrong number of args to QUOTE:~% ~S" exp
))
151 (unless (evenp n-args
)
152 (error "odd number of args to SETQ:~% ~S" exp
))
153 (unless (zerop n-args
)
154 (do ((name (cdr exp
) (cddr name
)))
156 (do ((args (cdr exp
) (cddr args
)))
158 ;; We duplicate the call to SET so that the
159 ;; correct value gets returned.
161 (simple-eval-in-lexenv (second args
) lexenv
)))
163 (simple-eval-in-lexenv (second args
) lexenv
))))
164 (let ((symbol (first name
)))
165 (case (info :variable
:kind symbol
)
167 (t (return (%simple-eval original-exp lexenv
))))
168 (unless (type= (info :variable
:type symbol
)
170 ;; let the compiler deal with type checking
171 (return (%simple-eval original-exp lexenv
)))))))
173 (simple-eval-progn-body (rest exp
) lexenv
))
175 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
176 ;; instead of PROGRAM-ERROR when there's something wrong
177 ;; with the syntax here (e.g. missing SITUATIONS). This
178 ;; could be fixed by hand-crafting clauses to catch and
179 ;; report each possibility, but it would probably be
180 ;; cleaner to write a new macro
181 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
182 ;; DESTRUCTURING-BIND and promotes any mismatch to
183 ;; PROGRAM-ERROR, then to use it here and in (probably
184 ;; dozens of) other places where the same problem
186 (destructuring-bind (eval-when situations
&rest body
) exp
187 (declare (ignore eval-when
))
188 (multiple-value-bind (ct lt e
)
189 (sb!c
:parse-eval-when-situations situations
)
190 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
191 ;; the situation :EXECUTE (or EVAL) controls whether
192 ;; evaluation occurs for other EVAL-WHEN forms; that
193 ;; is, those that are not top level forms, or those
194 ;; in code processed by EVAL or COMPILE. If the
195 ;; :EXECUTE situation is specified in such a form,
196 ;; then the body forms are processed as an implicit
197 ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
198 (declare (ignore ct lt
))
200 (simple-eval-progn-body body lexenv
)))))
202 (simple-eval-locally exp lexenv
))
204 (destructuring-bind (definitions &rest body
)
207 (let ((sb!c
:*lexenv
* lexenv
))
208 (sb!c
::funcall-in-macrolet-lexenv
211 (declare (ignore funs
))
214 (simple-eval-locally `(locally ,@body
) lexenv
))))
216 (destructuring-bind (definitions &rest body
) (rest exp
)
217 (multiple-value-bind (lexenv vars
)
218 (let ((sb!c
:*lexenv
* lexenv
))
219 (sb!c
::funcall-in-symbol-macrolet-lexenv
222 (values sb
!c
:*lexenv
* vars
))
224 (simple-eval-locally `(locally ,@body
) lexenv
:vars vars
))))
226 (destructuring-bind (test then
&optional else
) (rest exp
)
227 (eval-in-lexenv (if (eval-in-lexenv test lexenv
)
232 (destructuring-bind (definitions &rest body
) (rest exp
)
233 (if (null definitions
)
234 (simple-eval-locally `(locally ,@body
) lexenv
)
235 (%simple-eval exp lexenv
))))
237 (if (and (symbolp name
)
238 (eq (info :function
:kind name
) :function
))
240 (dolist (arg (rest exp
))
241 (args (eval-in-lexenv arg lexenv
)))
242 (apply (symbol-function name
) (args)))
243 (%simple-eval exp lexenv
))))))
247 (defun eval-in-lexenv (exp lexenv
)
249 (if (eq *evaluator-mode
* :compile
)
250 (simple-eval-in-lexenv exp lexenv
)
251 (sb!eval
:eval-in-native-environment exp lexenv
))
253 (simple-eval-in-lexenv exp lexenv
))
255 (defun eval (original-exp)
257 "Evaluate the argument in a null lexical environment, returning the
259 (eval-in-lexenv original-exp
(make-null-lexenv)))
262 ;;; miscellaneous full function definitions of things which are
263 ;;; ordinarily handled magically by the compiler
265 (defun apply (function arg
&rest arguments
)
267 "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
268 the manner of LIST*. That is, a list is made of the values of all but the
269 last argument, appended to the value of the last argument, which must be a
271 (cond ((atom arguments
)
272 (apply function arg
))
273 ((atom (cdr arguments
))
274 (apply function
(cons arg
(car arguments
))))
275 (t (do* ((a1 arguments a2
)
276 (a2 (cdr arguments
) (cdr a2
)))
279 (apply function
(cons arg arguments
)))))))
281 (defun funcall (function &rest arguments
)
283 "Call FUNCTION with the given ARGUMENTS."
284 (apply function arguments
))
286 (defun values (&rest values
)
288 "Return all arguments, in order, as values."
289 (declare (dynamic-extent values
))
290 (values-list values
))
292 (defun values-list (list)
294 "Return all of the elements of LIST, in order, as values."