0.7.5.15:
[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 ;;; general case of EVAL (except in that it can't handle toplevel
15 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
16 (defun %eval (expr)
17   (funcall (compile (gensym "EVAL-TMPFUN-")
18                     `(lambda ()
19
20                        ;; The user can reasonably expect that the
21                        ;; interpreter will be safe.
22                        (declare (optimize (safety 3)))
23
24                        ;; It's also good if the interpreter doesn't
25                        ;; spend too long thinking about each input
26                        ;; form, since if the user'd wanted the
27                        ;; tradeoff to favor quality of compiled code
28                        ;; over compilation speed, he'd've explicitly
29                        ;; asked for compilation.
30                        (declare (optimize (compilation-speed 2)))
31
32                        ;; Other properties are relatively unimportant.
33                        (declare (optimize (speed 1) (debug 1) (space 1)))
34
35                        ,expr))))
36
37 ;;; Handle PROGN and implicit PROGN.
38 (defun eval-progn-body (progn-body)
39   (unless (list-with-length-p progn-body)
40     (let ((*print-circle* t))
41       (error 'simple-program-error
42              :format-control
43              "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
44              :format-arguments (list progn-body))))
45   ;; Note:
46   ;;   * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
47   ;;     need to take care to return all the values of the final EVAL.
48   ;;   * It's left as an exercise to the reader to verify that this
49   ;;     gives the right result when PROGN-BODY is NIL, because
50   ;;     (FIRST NIL) = (REST NIL) = NIL.
51   (do* ((i progn-body rest-i)
52         (rest-i (rest i) (rest i)))
53       (nil)
54     (if rest-i ; if not last element of list
55         (eval (first i))
56         (return (eval (first i))))))
57
58 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
59 ;;; magical cases, and call %EVAL for the rest. 
60 (defun eval (original-exp)
61   #!+sb-doc
62   "Evaluate the argument in a null lexical environment, returning the
63   result or results."
64   (declare (optimize (safety 1)))
65   (let ((exp (macroexpand original-exp)))
66     (typecase exp
67       (symbol
68        (ecase (info :variable :kind exp)
69          (:constant
70           (values (info :variable :constant-value exp)))
71          ((:special :global)
72           (symbol-value exp))
73          ;; FIXME: This special case here is a symptom of non-ANSI
74          ;; weirdness in SBCL's ALIEN implementation, which could
75          ;; cause problems for e.g. code walkers. It'd probably be
76          ;; good to ANSIfy it by making alien variable accessors into
77          ;; ordinary forms, e.g. (SB-UNIX:ENV) and (SETF SB-UNIX:ENV),
78          ;; instead of magical symbols, e.g. plain SB-UNIX:ENV. Then
79          ;; if the old magical-symbol syntax is to be retained for
80          ;; compatibility, it can be implemented with
81          ;; DEFINE-SYMBOL-MACRO, keeping the code walkers happy.
82          (:alien
83           (%eval original-exp))))
84       (list
85        (let ((name (first exp))
86              (n-args (1- (length exp))))
87          (case name
88            (function
89             (unless (= n-args 1)
90               (error "wrong number of args to FUNCTION:~% ~S" exp))
91             (let ((name (second exp)))
92               (if (or (atom name)
93                       (and (consp name)
94                            (eq (car name) 'setf)))
95                   (fdefinition name)
96                   (%eval original-exp))))
97            (quote
98             (unless (= n-args 1)
99               (error "wrong number of args to QUOTE:~% ~S" exp))
100             (second exp))
101            (setq
102             (unless (evenp n-args)
103               (error "odd number of args to SETQ:~% ~S" exp))
104             (unless (zerop n-args)
105               (do ((name (cdr exp) (cddr name)))
106                   ((null name)
107                    (do ((args (cdr exp) (cddr args)))
108                        ((null (cddr args))
109                         ;; We duplicate the call to SET so that the
110                         ;; correct value gets returned.
111                         (set (first args) (eval (second args))))
112                      (set (first args) (eval (second args)))))
113                 (let ((symbol (first name)))
114                   (case (info :variable :kind symbol)
115                     ;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE*
116                     ;; test here, and removed the *TOPLEVEL-AUTO-DECLARE*
117                     ;; variable; the code should now act as though that
118                     ;; variable is NIL. This should be tested..
119                     (:special)
120                     (t (return (%eval original-exp))))))))
121            ((progn)
122             (eval-progn-body (rest exp)))
123            ((eval-when)
124             ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
125             ;; instead of PROGRAM-ERROR when there's something wrong
126             ;; with the syntax here (e.g. missing SITUATIONS). This
127             ;; could be fixed by hand-crafting clauses to catch and
128             ;; report each possibility, but it would probably be
129             ;; cleaner to write a new macro
130             ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
131             ;; DESTRUCTURING-BIND and promotes any mismatch to
132             ;; PROGRAM-ERROR, then to use it here and in (probably
133             ;; dozens of) other places where the same problem arises.
134             (destructuring-bind (eval-when situations &rest body) exp
135               (declare (ignore eval-when))
136               (multiple-value-bind (ct lt e)
137                   (sb!c:parse-eval-when-situations situations)
138                 ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
139                 ;; the situation :EXECUTE (or EVAL) controls whether
140                 ;; evaluation occurs for other EVAL-WHEN forms; that
141                 ;; is, those that are not top level forms, or those in
142                 ;; code processed by EVAL or COMPILE. If the :EXECUTE
143                 ;; situation is specified in such a form, then the
144                 ;; body forms are processed as an implicit PROGN;
145                 ;; otherwise, the EVAL-WHEN form returns NIL.
146                 (declare (ignore ct lt))
147                 (when e
148                   (eval-progn-body body)))))
149            (t
150             (if (and (symbolp name)
151                      (eq (info :function :kind name) :function))
152                 (collect ((args))
153                   (dolist (arg (rest exp))
154                     (args (eval arg)))
155                   (apply (symbol-function name) (args)))
156                 (%eval original-exp))))))
157       (t
158        exp))))
159 \f
160 ;;; miscellaneous full function definitions of things which are
161 ;;; ordinarily handled magically by the compiler
162
163 (defun apply (function arg &rest arguments)
164   #!+sb-doc
165   "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
166   the manner of LIST*. That is, a list is made of the values of all but the
167   last argument, appended to the value of the last argument, which must be a
168   list."
169   (cond ((atom arguments)
170          (apply function arg))
171         ((atom (cdr arguments))
172          (apply function (cons arg (car arguments))))
173         (t (do* ((a1 arguments a2)
174                  (a2 (cdr arguments) (cdr a2)))
175                 ((atom (cdr a2))
176                  (rplacd a1 (car a2))
177                  (apply function (cons arg arguments)))))))
178
179 (defun funcall (function &rest arguments)
180   #!+sb-doc
181   "Call FUNCTION with the given ARGUMENTS."
182   (apply function arguments))
183
184 (defun values (&rest values)
185   #!+sb-doc
186   "Return all arguments, in order, as values."
187   (values-list values))
188
189 (defun values-list (list)
190   #!+sb-doc
191   "Return all of the elements of LIST, in order, as values."
192   (values-list list))