Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / src / code / eval.lisp
1 ;;;; EVAL and friends
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!IMPL")
13
14 (defparameter *eval-calls* 0)
15
16 (defun !eval-cold-init ()
17   (setf *eval-calls* 0
18         *evaluator-mode* :compile)
19   #!+sb-eval
20   (setf sb!eval::*eval-level* -1
21         sb!eval::*eval-verbose* nil))
22
23 (defvar *eval-source-context* nil)
24
25 (defvar *eval-tlf-index* nil)
26 (defvar *eval-source-info* nil)
27
28 ;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns
29 ;;;; a secondary value of T if we must call the resulting function
30 ;;;; to evaluate EXPR -- if EXPR is already a lambda form, there's
31 ;;;; no need.
32 (defun make-eval-lambda (expr)
33   (if (typep expr `(cons (member lambda named-lambda lambda-with-lexenv)))
34       (values expr nil)
35       (values `(lambda ()
36                  ;; why PROGN? So that attempts to eval free declarations
37                  ;; signal errors rather than return NIL. -- CSR, 2007-05-01
38                  (progn ,expr))
39               t)))
40
41 ;;; general case of EVAL (except in that it can't handle toplevel
42 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
43 (defun %simple-eval (expr lexenv)
44   (multiple-value-bind (lambda call) (make-eval-lambda expr)
45     (let ((fun
46             ;; This tells the compiler where the lambda comes from, in case it
47             ;; wants to report any problems.
48             (let ((sb!c::*source-form-context-alist*
49                     (acons lambda *eval-source-context*
50                            sb!c::*source-form-context-alist*)))
51               (handler-bind (;; Compiler notes just clutter up the REPL:
52                              ;; anyone caring about performance should not
53                              ;; be using EVAL.
54                              (compiler-note #'muffle-warning))
55                 (sb!c:compile-in-lexenv
56                  nil lambda lexenv *eval-source-info* *eval-tlf-index* (not call))))))
57       (declare (function fun))
58       (if call
59           (funcall fun)
60           fun))))
61
62 ;;; Handle PROGN and implicit PROGN.
63 (defun simple-eval-progn-body (progn-body lexenv)
64   (unless (list-with-length-p progn-body)
65     (let ((*print-circle* t))
66       (error 'simple-program-error
67              :format-control
68              "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
69              :format-arguments (list progn-body))))
70   ;; Note:
71   ;;   * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
72   ;;     need to take care to return all the values of the final EVAL.
73   ;;   * It's left as an exercise to the reader to verify that this
74   ;;     gives the right result when PROGN-BODY is NIL, because
75   ;;     (FIRST NIL) = (REST NIL) = NIL.
76   (do* ((i progn-body rest-i)
77         (rest-i (rest i) (rest i)))
78       (nil)
79     (if rest-i ; if not last element of list
80         (simple-eval-in-lexenv (first i) lexenv)
81         (return (simple-eval-in-lexenv (first i) lexenv)))))
82
83 (defun simple-eval-locally (exp lexenv &key vars)
84   (multiple-value-bind (body decls)
85       (parse-body (rest exp) :doc-string-allowed nil)
86     (let ((lexenv
87            ;; KLUDGE: Uh, yeah.  I'm not anticipating
88            ;; winning any prizes for this code, which was
89            ;; written on a "let's get it to work" basis.
90            ;; These seem to be the variables that need
91            ;; bindings for PROCESS-DECLS to work
92            ;; (*FREE-FUNS* and *FREE-VARS* so that
93            ;; references to free functions and variables
94            ;; in the declarations can be noted;
95            ;; *UNDEFINED-WARNINGS* so that warnings about
96            ;; undefined things can be accumulated [and
97            ;; then thrown away, as it happens]). -- CSR,
98            ;; 2002-10-24
99            (let* ((sb!c:*lexenv* lexenv)
100                   (sb!c::*free-funs* (make-hash-table :test 'equal))
101                   (sb!c::*free-vars* (make-hash-table :test 'eq))
102                   (sb!c::*undefined-warnings* nil))
103              ;; FIXME: VALUES declaration
104              (sb!c::process-decls decls
105                                   vars
106                                   nil
107                                   :lexenv lexenv
108                                   :context :eval))))
109       (simple-eval-progn-body body lexenv))))
110
111 ;;;; EVAL-ERROR
112 ;;;;
113 ;;;; Analogous to COMPILER-ERROR, but simpler.
114
115 (define-condition eval-error (encapsulated-condition)
116   ()
117   (:report (lambda (condition stream)
118              (print-object (encapsulated-condition condition) stream))))
119
120 (defun eval-error (condition)
121   (signal 'eval-error :condition condition)
122   (bug "Unhandled EVAL-ERROR"))
123
124 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
125 ;;; magical cases, and call %SIMPLE-EVAL for the rest.
126 (defun simple-eval-in-lexenv (original-exp lexenv)
127   (declare (optimize (safety 1)))
128   ;; (aver (lexenv-simple-p lexenv))
129   (incf *eval-calls*)
130   (handler-bind
131       ((sb!c:compiler-error
132         (lambda (c)
133           (if (boundp 'sb!c::*compiler-error-bailout*)
134               ;; if we're in the compiler, delegate either to a higher
135               ;; authority or, if that's us, back down to the
136               ;; outermost compiler handler...
137               (progn
138                 (signal c)
139                 nil)
140               ;; ... if we're not in the compiler, better signal the
141               ;; error straight away.
142               (invoke-restart 'sb!c::signal-error)))))
143     (let ((exp (macroexpand original-exp lexenv)))
144       (handler-bind ((eval-error
145                       (lambda (condition)
146                         (error 'interpreted-program-error
147                                :condition (encapsulated-condition condition)
148                                :form exp))))
149         (typecase exp
150           (symbol
151            (ecase (info :variable :kind exp)
152              ((:special :global :constant :unknown)
153               (symbol-value exp))
154              ;; FIXME: This special case here is a symptom of non-ANSI
155              ;; weirdness in SBCL's ALIEN implementation, which could
156              ;; cause problems for e.g. code walkers. It'd probably be
157              ;; good to ANSIfy it by making alien variable accessors
158              ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
159              ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
160              ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
161              ;; be retained for compatibility, it can be implemented
162              ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
163              ;; happy.
164              (:alien
165               (sb!alien-internals:alien-value exp))))
166           (list
167            (let ((name (first exp))
168                  (n-args (1- (length exp))))
169              (case name
170                ((function)
171                 (unless (= n-args 1)
172                   (error "wrong number of args to FUNCTION:~% ~S" exp))
173                 (let ((name (second exp)))
174                   (if (and (legal-fun-name-p name)
175                            (not (consp (let ((sb!c:*lexenv* lexenv))
176                                          (sb!c:lexenv-find name funs)))))
177                       (%coerce-name-to-fun name)
178                       ;; FIXME: This is a bit wasteful: it would be nice to call
179                       ;; COMPILE-IN-LEXENV with the lambda-form directly, but
180                       ;; getting consistent source context and muffling compiler notes
181                       ;; is easier this way.
182                       (%simple-eval original-exp lexenv))))
183                ((quote)
184                 (unless (= n-args 1)
185                   (error "wrong number of args to QUOTE:~% ~S" exp))
186                 (second exp))
187                (setq
188                 (unless (evenp n-args)
189                   (error "odd number of args to SETQ:~% ~S" exp))
190                 (unless (zerop n-args)
191                   (do ((name (cdr exp) (cddr name)))
192                       ((null name)
193                        (do ((args (cdr exp) (cddr args)))
194                            ((null (cddr args))
195                             ;; We duplicate the call to SET so that the
196                             ;; correct value gets returned.
197                             (set (first args)
198                                  (simple-eval-in-lexenv (second args) lexenv)))
199                          (set (first args)
200                               (simple-eval-in-lexenv (second args) lexenv))))
201                     (let ((symbol (first name)))
202                       (case (info :variable :kind symbol)
203                         (:special)
204                         (t (return (%simple-eval original-exp lexenv))))
205                       (unless (type= (info :variable :type symbol)
206                                      *universal-type*)
207                         ;; let the compiler deal with type checking
208                         (return (%simple-eval original-exp lexenv)))))))
209                ((progn)
210                 (simple-eval-progn-body (rest exp) lexenv))
211                ((eval-when)
212                 ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
213                 ;; instead of PROGRAM-ERROR when there's something wrong
214                 ;; with the syntax here (e.g. missing SITUATIONS). This
215                 ;; could be fixed by hand-crafting clauses to catch and
216                 ;; report each possibility, but it would probably be
217                 ;; cleaner to write a new macro
218                 ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
219                 ;; DESTRUCTURING-BIND and promotes any mismatch to
220                 ;; PROGRAM-ERROR, then to use it here and in (probably
221                 ;; dozens of) other places where the same problem
222                 ;; arises.
223                 (destructuring-bind (eval-when situations &rest body) exp
224                   (declare (ignore eval-when))
225                   (multiple-value-bind (ct lt e)
226                       (sb!c:parse-eval-when-situations situations)
227                     ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
228                     ;; the situation :EXECUTE (or EVAL) controls whether
229                     ;; evaluation occurs for other EVAL-WHEN forms; that
230                     ;; is, those that are not top level forms, or those
231                     ;; in code processed by EVAL or COMPILE. If the
232                     ;; :EXECUTE situation is specified in such a form,
233                     ;; then the body forms are processed as an implicit
234                     ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
235                     (declare (ignore ct lt))
236                     (when e
237                       (simple-eval-progn-body body lexenv)))))
238                ((locally)
239                 (simple-eval-locally exp lexenv))
240                ((macrolet)
241                 (destructuring-bind (definitions &rest body)
242                     (rest exp)
243                   (let ((lexenv
244                          (let ((sb!c:*lexenv* lexenv))
245                            (sb!c::funcall-in-macrolet-lexenv
246                             definitions
247                             (lambda (&key funs)
248                               (declare (ignore funs))
249                               sb!c:*lexenv*)
250                             :eval))))
251                     (simple-eval-locally `(locally ,@body) lexenv))))
252                ((symbol-macrolet)
253                 (destructuring-bind (definitions &rest body) (rest exp)
254                   (multiple-value-bind (lexenv vars)
255                       (let ((sb!c:*lexenv* lexenv))
256                         (sb!c::funcall-in-symbol-macrolet-lexenv
257                          definitions
258                          (lambda (&key vars)
259                            (values sb!c:*lexenv* vars))
260                          :eval))
261                     (simple-eval-locally `(locally ,@body) lexenv :vars vars))))
262                ((if)
263                 (destructuring-bind (test then &optional else) (rest exp)
264                   (eval-in-lexenv (if (eval-in-lexenv test lexenv)
265                                       then
266                                       else)
267                                   lexenv)))
268                ((let let*)
269                 (%simple-eval exp lexenv))
270                (t
271                 (if (and (symbolp name)
272                          (eq (info :function :kind name) :function))
273                     (collect ((args))
274                       (dolist (arg (rest exp))
275                         (args (eval-in-lexenv arg lexenv)))
276                       (apply (symbol-function name) (args)))
277                     (%simple-eval exp lexenv))))))
278           (t
279            exp))))))
280
281 (defun eval-in-lexenv (exp lexenv)
282   #!+sb-eval
283   (if (eq *evaluator-mode* :compile)
284       (simple-eval-in-lexenv exp lexenv)
285       (sb!eval:eval-in-native-environment exp lexenv))
286   #!-sb-eval
287   (simple-eval-in-lexenv exp lexenv))
288
289 (defun eval (original-exp)
290   #!+sb-doc
291   "Evaluate the argument in a null lexical environment, returning the
292    result or results."
293   (let ((*eval-source-context* original-exp)
294         (*eval-tlf-index* nil)
295         (*eval-source-info* nil))
296     (eval-in-lexenv original-exp (make-null-lexenv))))
297
298 (defun eval-tlf (original-exp tlf-index &optional (lexenv (make-null-lexenv)))
299   (let ((*eval-source-context* original-exp)
300         (*eval-tlf-index* tlf-index)
301         (*eval-source-info* sb!c::*source-info*))
302     (eval-in-lexenv original-exp lexenv)))
303 \f
304 ;;; miscellaneous full function definitions of things which are
305 ;;; ordinarily handled magically by the compiler
306
307 (defun apply (function arg &rest arguments)
308   #!+sb-doc
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
312   list."
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)))
319                 ((atom (cdr a2))
320                  (rplacd a1 (car a2))
321                  (apply function (cons arg arguments)))))))
322
323 (defun funcall (function &rest arguments)
324   #!+sb-doc
325   "Call FUNCTION with the given ARGUMENTS."
326   (apply function arguments))
327
328 (defun values (&rest values)
329   #!+sb-doc
330   "Return all arguments, in order, as values."
331   (declare (truly-dynamic-extent values))
332   (values-list values))
333
334 (defun values-list (list)
335   #!+sb-doc
336   "Return all of the elements of LIST, in order, as values."
337   (values-list list))