1.0.41.42: ppc: Documentation and NEWS updates for threading.
[sbcl.git] / src / code / full-eval.lisp
1 ;;;; An interpreting EVAL
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!EVAL")
13
14 ;; (declaim (optimize (speed 3) (debug 1) (safety 1)))
15
16 ;;; Values used for marking specials/macros/etc in environments.
17 (defvar *special* (gensym "SPECIAL"))
18 (defvar *macro* (gensym "MACRO"))
19 (defvar *symbol-macro* (gensym "SYMBOL-MACRO"))
20 (defvar *not-present* (gensym "NOT-PRESENT"))
21
22 (define-condition interpreted-program-error (program-error simple-condition sb!impl::encapsulated-condition)
23   ()
24   (:report (lambda (condition stream)
25              (if (slot-boundp condition 'condition)
26                  (progn
27                    (format stream "Error evaluating a form:~% ~A"
28                            (sb!impl::encapsulated-condition condition)))
29                  (format stream "Error evaluating a form:~% ~?"
30                          (simple-condition-format-control condition)
31                          (simple-condition-format-arguments condition))))))
32
33 ;;; ANSI defines that program syntax errors should be of type
34 ;;; PROGRAM-ERROR.  Therefore...
35 (define-condition arg-count-program-error (sb!kernel::arg-count-error
36                                            program-error)
37   ())
38
39 (defun arg-count-program-error (datum &rest arguments)
40   (declare (ignore datum))
41   (apply #'error 'arg-count-program-error arguments))
42
43 ;; OAOOM? (see destructuring-bind.lisp)
44 (defmacro program-destructuring-bind (lambda-list arg-list &body body)
45   (let ((arg-list-name (gensym "ARG-LIST-")))
46     (multiple-value-bind (body local-decls)
47         (sb!kernel:parse-defmacro lambda-list arg-list-name body nil
48                                   'program-destructuring-bind
49                                   :anonymousp t
50                                   :doc-string-allowed nil
51                                   :wrap-block nil
52                                   :error-fun 'arg-count-program-error)
53       `(let ((,arg-list-name ,arg-list))
54          ,@local-decls
55          ,body))))
56
57 (defun ip-error (format-control &rest format-arguments)
58   (error 'interpreted-program-error
59          :format-control format-control
60          :format-arguments format-arguments))
61
62 (defmacro nconc-2 (a b)
63   (let ((tmp (gensym))
64         (tmp2 (gensym)))
65     `(let ((,tmp ,a)
66            (,tmp2 ,b))
67        (if ,tmp
68            (progn (setf (cdr (last ,tmp)) ,tmp2) ,tmp)
69            ,tmp2))))
70
71 ;;; Construct a compiler LEXENV from the same data that's used for
72 ;;; creating an interpreter ENV. This is needed for example when
73 ;;; passing the environment to macroexpanders or when compiling an
74 ;;; interpreted function.
75 (defun fabricate-new-native-environment (old-lexenv new-funs new-expanders
76                                          new-vars new-symbol-expansions
77                                          declarations)
78   (labels ((to-native-funs (binding)
79              ;; Non-macroexpander function entries are irrelevant for
80              ;; the LEXENV. If we're using the LEXENV for
81              ;; macro-expansion any references to local non-macro
82              ;; function bindings are undefined behaviour. If we're
83              ;; compiling an interpreted function, a lexical environment
84              ;; with non-macro functions will be too hairy to compile.
85              (if (eq (cdr binding) *macro*)
86                  (cons (car binding)
87                        (cons 'sb!sys:macro
88                              (cdr (assoc (car binding) new-expanders))))
89                  (cons (car binding)
90                        :bogus)))
91            (to-native-vars (binding)
92              ;; And likewise for symbol macros.
93              (if (eq (cdr binding) *symbol-macro*)
94                  (cons (car binding)
95                        (cons 'sb!sys:macro
96                              (cdr (assoc (car binding) new-symbol-expansions))))
97                  (cons (car binding)
98                        :bogus))))
99     (let ((lexenv (sb!c::internal-make-lexenv
100                    (nconc-2 (mapcar #'to-native-funs new-funs)
101                             (sb!c::lexenv-funs old-lexenv))
102                    (nconc-2 (mapcar #'to-native-vars new-vars)
103                             (sb!c::lexenv-vars old-lexenv))
104                    nil nil nil nil nil
105                    (sb!c::lexenv-handled-conditions old-lexenv)
106                    (sb!c::lexenv-disabled-package-locks old-lexenv)
107                    (sb!c::lexenv-policy old-lexenv)
108                    (sb!c::lexenv-user-data old-lexenv))))
109       (dolist (declaration declarations)
110         (unless (consp declaration)
111           (ip-error "malformed declaration specifier ~S in ~S"
112                     declaration (cons 'declare declarations)))
113         (case (car declaration)
114           ((optimize)
115            (dolist (element (cdr declaration))
116              (multiple-value-bind (quality value)
117                  (if (not (consp element))
118                      (values element 3)
119                      (program-destructuring-bind (quality value)
120                          element
121                        (values quality value)))
122                (if (sb!c::policy-quality-name-p quality)
123                    (push (cons quality value)
124                          (sb!c::lexenv-%policy lexenv))
125                    (warn "ignoring unknown optimization quality ~
126                                       ~S in ~S" quality
127                                       (cons 'declare declarations))))))
128           (sb!ext:muffle-conditions
129            (setf (sb!c::lexenv-handled-conditions lexenv)
130                  (sb!c::process-muffle-conditions-decl
131                   declaration
132                   (sb!c::lexenv-handled-conditions lexenv))))
133           (sb!ext:unmuffle-conditions
134            (setf (sb!c::lexenv-handled-conditions lexenv)
135                  (sb!c::process-unmuffle-conditions-decl
136                   declaration
137                   (sb!c::lexenv-handled-conditions lexenv))))
138           ((sb!ext:disable-package-locks sb!ext:enable-package-locks)
139            (setf (sb!c::lexenv-disabled-package-locks lexenv)
140                  (sb!c::process-package-lock-decl
141                   declaration
142                   (sb!c::lexenv-disabled-package-locks lexenv))))))
143       lexenv)))
144
145 (defstruct (env
146              (:constructor %make-env
147                            (parent vars funs expanders symbol-expansions
148                             tags blocks declarations native-lexenv)))
149   parent
150   vars
151   funs
152   expanders
153   symbol-expansions
154   tags
155   blocks
156   declarations
157   native-lexenv)
158
159 (defun make-env (&key parent vars funs expanders
160                  symbol-expansions tags blocks declarations)
161   (%make-env parent
162              (append vars (env-vars parent))
163              (append funs (env-funs parent))
164              (append expanders (env-expanders parent))
165              (append symbol-expansions (env-symbol-expansions parent))
166              (nconc-2 tags (env-tags parent))
167              (nconc-2 blocks (env-blocks parent))
168              declarations
169              (fabricate-new-native-environment (env-native-lexenv parent)
170                                                funs expanders
171                                                vars symbol-expansions
172                                                declarations)))
173
174 (defun make-null-environment ()
175   (%make-env nil nil nil nil nil nil nil nil
176              (sb!c::internal-make-lexenv
177               nil nil
178               nil nil nil nil nil nil nil
179               sb!c::*policy*
180               nil)))
181
182 ;;; Augment ENV with a special or lexical variable binding
183 (declaim (inline push-var))
184 (defun push-var (name value env)
185   (push (cons name value) (env-vars env))
186   (push (cons name :bogus) (sb!c::lexenv-vars (env-native-lexenv env))))
187
188 ;;; Augment ENV with a local function binding
189 (declaim (inline push-fun))
190 (defun push-fun (name value calling-env body-env)
191   (when (fboundp name)
192     (let ((sb!c:*lexenv* (env-native-lexenv calling-env)))
193       (program-assert-symbol-home-package-unlocked
194        :eval name "binding ~A as a local function")))
195   (push (cons name value) (env-funs body-env))
196   (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv body-env))))
197
198 (sb!int:def!method print-object ((env env) stream)
199   (print-unreadable-object (env stream :type t :identity t)))
200
201 (macrolet ((define-get-binding (name accessor &key (test '#'eq))
202              ;; A macro, sadly, because an inline function here is
203              ;; "too hairy"
204              `(defmacro ,name (symbol env)
205                 `(assoc ,symbol (,',accessor ,env) :test ,',test))))
206   (define-get-binding get-binding env-vars)
207   (define-get-binding get-fbinding env-funs :test #'equal)
208   (define-get-binding get-expander-binding env-expanders)
209   (define-get-binding get-symbol-expansion-binding env-symbol-expansions)
210   (define-get-binding get-tag-binding env-tags :test #'eql)
211   (define-get-binding get-block-binding env-blocks))
212
213 ;;; Return a list of all symbols that are declared special in the
214 ;;; declarations listen in DECLS.
215 (defun declared-specials (decls)
216   (let ((specials nil))
217     (dolist (decl decls)
218       (when (eql (car decl) 'special)
219         (dolist (var (cdr decl))
220           (push var specials))))
221     specials))
222
223 ;;; Given a list of variables that should be marked as special in an
224 ;;; environment, return the appropriate binding forms to be given
225 ;;; to MAKE-ENV.
226 (defun special-bindings (specials env)
227   (mapcar #'(lambda (var)
228               (let ((sb!c:*lexenv* (env-native-lexenv env)))
229                 (program-assert-symbol-home-package-unlocked
230                  :eval var "declaring ~A special"))
231               (cons var *special*))
232           specials))
233
234 ;;; Return true if SYMBOL has been declared special either globally
235 ;;; or is in the DECLARED-SPECIALS list.
236 (defun specialp (symbol declared-specials)
237   (let ((type (sb!int:info :variable :kind symbol)))
238     (cond
239       ((eq type :constant)
240        ;; Horrible place for this, but it works.
241        (ip-error "Can't bind constant symbol: ~S" symbol))
242       ((eq type :global)
243        ;; Ditto...
244        (ip-error "Can't bind a global variable: ~S" symbol))
245       ((eq type :special) t)
246       ((member symbol declared-specials :test #'eq)
247        t)
248       (t nil))))
249
250 (defun binding-name (binding)
251   (if (consp binding) (first binding) binding))
252 (defun binding-value (binding)
253   (if (consp binding) (second binding) nil))
254 (defun supplied-p-parameter (spec)
255   (if (consp spec) (third spec) nil))
256 (defun keyword-name (spec)
257   (if (consp spec)
258       (if (consp (first spec))
259           (second (first spec))
260           (first spec))
261       spec))
262 (defun keyword-key (spec)
263   (if (consp spec)
264       (if (consp (first spec))
265           (first (first spec))
266           (intern (symbol-name (first spec)) "KEYWORD"))
267       (intern (symbol-name spec) "KEYWORD")))
268 (defun keyword-default-value (spec)
269   (if (consp spec) (second spec) nil))
270
271 ;;; Given a list of ARGUMENTS and a LAMBDA-LIST, return two values:
272 ;;;   * An alist[*] mapping the required parameters of the function to
273 ;;;     the corresponding argument values
274 ;;;   * An alist mapping the keyword, optional and rest parameters of
275 ;;;     the function to the corresponding argument values (if supplied)
276 ;;;     or to the parameter's default expression (if not). Supplied-p
277 ;;;     parameters and aux variables are handled in a similar manner.
278 ;;;
279 ;;; For example given the argument list of (1 2) and the lambda-list of
280 ;;; (A &OPTIONAL (B A) (C (1+ A))), we'd return the values
281 ;;; (A . '1) and ((B . '2) (C . (1+ A))).
282 ;;;
283 ;;; Used only for implementing calls to interpreted functions.
284 (defun parse-arguments (arguments lambda-list)
285   (multiple-value-bind (required optional rest-p rest keyword-p
286                         keyword allow-other-keys-p aux-p aux)
287       (handler-bind ((style-warning #'muffle-warning))
288         (sb!int:parse-lambda-list lambda-list))
289     (let* ((original-arguments arguments)
290            (arguments-present (length arguments))
291            (required-length (length required))
292            (optional-length (length optional))
293            (non-keyword-arguments (+ required-length optional-length))
294            (optionals-present (- (min non-keyword-arguments arguments-present)
295                                  required-length))
296            (keywords-present-p (> arguments-present non-keyword-arguments))
297            (let-like-bindings nil)
298            (let*-like-bindings nil))
299       (cond
300         ((< arguments-present required-length)
301          (ip-error "~@<Too few arguments in ~S to satisfy lambda list ~S.~:@>"
302                    arguments lambda-list))
303         ((and (not (or rest-p keyword-p)) keywords-present-p)
304          (ip-error "~@<Too many arguments in ~S to satisfy lambda list ~S.~:@>"
305                    arguments lambda-list))
306         ((and keyword-p keywords-present-p
307               (oddp (- arguments-present non-keyword-arguments)))
308          (ip-error "~@<Odd number of &KEY arguments in ~S for ~S.~:@>"
309                    arguments lambda-list)))
310       (dotimes (i required-length)
311         (push (cons (pop required) (pop arguments)) let-like-bindings))
312       (do ((optionals-parsed 0 (1+ optionals-parsed)))
313           ((null optional))
314         (let ((this-optional (pop optional))
315               (supplied-p (< optionals-parsed optionals-present)))
316           (push (cons (binding-name this-optional)
317                       (if supplied-p
318                           (list 'quote (pop arguments))
319                           (binding-value this-optional)))
320                 let*-like-bindings)
321           (when (supplied-p-parameter this-optional)
322             (push (cons (supplied-p-parameter this-optional)
323                         (list 'quote supplied-p))
324                   let*-like-bindings))))
325       (let ((keyword-plist arguments))
326         (when rest-p
327           (push (cons rest (list 'quote keyword-plist)) let*-like-bindings))
328         (when keyword-p
329           (unless (or allow-other-keys-p
330                       (getf keyword-plist :allow-other-keys))
331             (loop for (key value) on keyword-plist by #'cddr doing
332                   (when (and (not (eq key :allow-other-keys))
333                              (not (member key keyword :key #'keyword-key)))
334                     (ip-error "~@<Unknown &KEY argument ~S in ~S for ~S.~:@>"
335                               key original-arguments lambda-list))))
336           (dolist (keyword-spec keyword)
337             (let ((supplied (getf keyword-plist (keyword-key keyword-spec)
338                                   *not-present*)))
339               (push (cons (keyword-name keyword-spec)
340                           (if (eq supplied *not-present*)
341                               (keyword-default-value keyword-spec)
342                               (list 'quote supplied)))
343                     let*-like-bindings)
344               (when (supplied-p-parameter keyword-spec)
345                 (push (cons (supplied-p-parameter keyword-spec)
346                             (list 'quote (not (eq supplied *not-present*))))
347                       let*-like-bindings))))))
348       (when aux-p
349         (do ()
350             ((null aux))
351           (let ((this-aux (pop aux)))
352             (push (cons (binding-name this-aux)
353                         (binding-value this-aux))
354                   let*-like-bindings))))
355       (values (nreverse let-like-bindings) (nreverse let*-like-bindings)))))
356
357 ;;; Evaluate LET*-like (sequential) bindings.
358 ;;;
359 ;;; Given an alist of BINDINGS, evaluate the value form of the first
360 ;;; binding in ENV, bind the variable to the value in ENV, and then
361 ;;; evaluate the next binding form. Once all binding forms have been
362 ;;; handled, END-ACTION is funcalled.
363 ;;;
364 ;;; SPECIALS is a list of variables that have a bound special declaration.
365 ;;; These variables (and those that have been declaimed as special) are
366 ;;; bound as special variables.
367 (defun eval-next-let*-binding (bindings specials env end-action)
368   (flet ((maybe-eval (exp)
369            ;; Pick off the easy (QUOTE x) case which is very common
370            ;; due to function calls.  (see PARSE-ARGUMENTS)
371            (if (and (consp exp) (eq (car exp) 'quote))
372                (second exp)
373                (%eval exp env))))
374     (if bindings
375         (let* ((binding-name (car (car bindings)))
376                (binding-value (cdr (car bindings))))
377           (if (specialp binding-name specials)
378               (progv
379                   (list binding-name)
380                   (list (maybe-eval binding-value))
381                 ;; Mark the variable as special in this environment
382                 (push-var binding-name *special* env)
383                 (eval-next-let*-binding (cdr bindings)
384                                         specials env end-action))
385               (progn
386                 (push-var binding-name (maybe-eval binding-value) env)
387                 (eval-next-let*-binding (cdr bindings)
388                                         specials env end-action))))
389         (funcall end-action))))
390
391 ;;; Create a new environment based on OLD-ENV by adding the variable
392 ;;; bindings in BINDINGS to it, and call FUNCTION with the new environment
393 ;;; as the only parameter. DECLARATIONS are the declarations that were
394 ;;; in a source position where bound declarations for the bindings could
395 ;;; be introduced.
396 ;;;
397 ;;; FREE-SPECIALS-P controls whether all special declarations should
398 ;;; end cause the variables to be marked as special in the environment
399 ;;; (when true), or only bound declarations (when false). Basically
400 ;;; it'll be T when handling a LET, and NIL when handling a call to an
401 ;;; interpreted function.
402 (defun call-with-new-env (old-env bindings declarations
403                           free-specials-p function)
404   (let* ((specials (declared-specials declarations))
405          (dynamic-vars nil)
406          (dynamic-values nil))
407     ;; To check for package-lock violations
408     (special-bindings specials old-env)
409     (flet ((generate-binding (binding)
410              (if (specialp (car binding) specials)
411                  ;; If the variable being bound is globally special or
412                  ;; there's a bound special declaration for it, record it
413                  ;; in DYNAMIC-VARS / -VALUES separately:
414                  ;;   * To handle the case of FREE-SPECIALS-P == T more
415                  ;;     cleanly.
416                  ;;   * The dynamic variables will be bound with PROGV just
417                  ;;     before funcalling
418                  (progn
419                    (push (car binding) dynamic-vars)
420                    (push (cdr binding) dynamic-values)
421                    nil)
422                  ;; Otherwise it's a lexical binding, and the value
423                  ;; will be recorded in the environment.
424                  (list binding))))
425       (let ((new-env (make-env
426                       :parent old-env
427                       :vars (mapcan #'generate-binding bindings)
428                       :declarations declarations)))
429         (dolist (special (if free-specials-p specials dynamic-vars))
430           (push-var special *special* new-env))
431         (if dynamic-vars
432             (progv dynamic-vars dynamic-values
433               (funcall function new-env))
434             ;; When there are no specials, the PROGV would be a no-op,
435             ;; but it's better to elide it completely, since the
436             ;; funcall is then in tail position.
437             (funcall function new-env))))))
438
439 ;;; Create a new environment based on OLD-ENV by binding the argument
440 ;;; list ARGUMENTS to LAMBDA-LIST, and call FUNCTION with the new
441 ;;; environment as argument. DECLARATIONS are the declarations that
442 ;;; were in a source position where bound declarations for the
443 ;;; bindings could be introduced.
444 (defun call-with-new-env-full-parsing
445     (old-env lambda-list arguments declarations function)
446   (multiple-value-bind (let-like-bindings let*-like-binding)
447       (parse-arguments arguments lambda-list)
448     (let ((specials (declared-specials declarations))
449           var-specials free-specials)
450       ;; Separate the bound and free special declarations
451       (dolist (special specials)
452         (if (or (member special let-like-bindings :key #'car)
453                 (member special let*-like-binding :key #'car))
454             (push special var-specials)
455             (push special free-specials)))
456       ;; First introduce the required parameters into the environment
457       ;; with CALL-WITH-NEW-ENV
458       (call-with-new-env
459        old-env let-like-bindings declarations nil
460        #'(lambda (env)
461            ;; Then deal with optionals / keywords / etc.
462            (eval-next-let*-binding
463             let*-like-binding var-specials env
464             #'(lambda ()
465                 ;; And now that we have evaluated all the
466                 ;; initialization forms for the bindings, add the free
467                 ;; special declarations to the environment. To see why
468                 ;; this is the right thing to do (instead of passing
469                 ;; FREE-SPECIALS-P == T to CALL-WITH-NEW-ENV),
470                 ;; consider:
471                 ;;
472                 ;;   (eval '(let ((*a* 1))
473                 ;;     (declare (special *a*))
474                 ;;     (let ((*a* 2))
475                 ;;       (funcall (lambda (&optional (b *a*))
476                 ;;                  (declare (special *a*))
477                 ;;                  (values b *a*))))))
478                 ;;
479                 ;; *A* should be special in the body of the lambda, but
480                 ;; not when evaluating the default value of B.
481                 (dolist (special free-specials)
482                   (push-var special *special* env))
483                 (funcall function env))))))))
484
485 ;;; Set the VALUE of the binding (either lexical or special) of the
486 ;;; variable named by SYMBOL in the environment ENV.
487 (defun set-variable (symbol value env)
488   (let ((binding (get-binding symbol env)))
489     (if binding
490         (cond
491           ((eq (cdr binding) *special*)
492            (setf (symbol-value symbol) value))
493           ((eq (cdr binding) *symbol-macro*)
494            (error "Tried to set a symbol-macrolet!"))
495           (t (setf (cdr binding) value)))
496         (case (sb!int:info :variable :kind symbol)
497           (:macro (error "Tried to set a symbol-macrolet!"))
498           (:alien (let ((type (sb!int:info :variable :alien-info symbol)))
499                     (setf (sb!alien::%heap-alien type) value)))
500           (t
501            (let ((type (sb!c::info :variable :type symbol)))
502              (when type
503                (let ((type-specifier (sb!kernel:type-specifier type)))
504                  (unless (typep value type-specifier)
505                    (error 'type-error
506                           :datum value
507                           :expected-type type-specifier))))
508              (setf (symbol-value symbol) value)))))))
509
510 ;;; Retrieve the value of the binding (either lexical or special) of
511 ;;; the variable named by SYMBOL in the environment ENV. For symbol
512 ;;; macros the expansion is returned instead.
513 (defun get-variable (symbol env)
514   (let ((binding (get-binding symbol env)))
515     (if binding
516         (cond
517           ((eq (cdr binding) *special*)
518            (values (symbol-value symbol) :variable))
519           ((eq (cdr binding) *symbol-macro*)
520            (values (cdr (get-symbol-expansion-binding symbol env))
521                    :expansion))
522           (t (values (cdr binding) :variable)))
523         (case (sb!int:info :variable :kind symbol)
524           (:macro (values (macroexpand-1 symbol) :expansion))
525           (:alien (let ((type (sb!int:info :variable :alien-info symbol)))
526                     (values (sb!alien::%heap-alien type)
527                             :variable)))
528           (t (values (symbol-value symbol) :variable))))))
529
530 ;;; Retrieve the function/macro binding of the symbol NAME in
531 ;;; environment ENV. The second return value will be :MACRO for macro
532 ;;; bindings, :FUNCTION for function bindings.
533 (defun get-function (name env)
534   (let ((binding (get-fbinding name env)))
535     (if binding
536         (cond
537           ((eq (cdr binding) *macro*)
538            (values (cdr (get-expander-binding name env)) :macro))
539           (t (values (cdr binding) :function)))
540         (cond
541           ((and (symbolp name) (macro-function name))
542            (values (macro-function name) :macro))
543           (t (values (%coerce-name-to-fun name) :function))))))
544
545 ;;; Return true if EXP is a lambda form.
546 (defun lambdap (exp)
547   (case (car exp) ((lambda
548                     sb!int:named-lambda
549                     sb!kernel:instance-lambda)
550                    t)))
551
552 ;;; Split off the declarations (and the docstring, if
553 ;;; DOC-STRING-ALLOWED is true) from the actual forms of BODY.
554 ;;; Returns three values: the cons in BODY containing the first
555 ;;; non-header subform, the docstring, and a list of the declarations.
556 ;;;
557 ;;; FIXME: The name of this function is somewhat misleading. It's not
558 ;;; used just for parsing the headers from lambda bodies, but for all
559 ;;; special forms that have attached declarations.
560 (defun parse-lambda-headers (body &key doc-string-allowed)
561   (loop with documentation = nil
562         with declarations = nil
563         for form on body do
564         (cond
565           ((and doc-string-allowed (stringp (car form)))
566            (if (cdr form)               ; CLHS 3.4.11
567                (if documentation
568                    (ip-error "~@<Duplicate doc string ~S.~:@>" (car form))
569                    (setf documentation (car form)))
570                (return (values form documentation declarations))))
571           ((and (consp (car form)) (eql (caar form) 'declare))
572            (setf declarations (append declarations (cdar form))))
573           (t (return (values form documentation declarations))))
574         finally (return (values nil documentation declarations))))
575
576 ;;; Create an interpreted function from the lambda-form EXP evaluated
577 ;;; in the environment ENV.
578 (defun eval-lambda (exp env)
579   (case (car exp)
580     ((lambda sb!kernel:instance-lambda)
581      (multiple-value-bind (body documentation declarations)
582          (parse-lambda-headers (cddr exp) :doc-string-allowed t)
583        (make-interpreted-function :lambda-list (second exp)
584                                   :env env :body body
585                                   :documentation documentation
586                                   :source-location (sb!c::make-definition-source-location)
587                                   :declarations declarations)))
588     ((sb!int:named-lambda)
589      (multiple-value-bind (body documentation declarations)
590          (parse-lambda-headers (cdddr exp) :doc-string-allowed t)
591        (make-interpreted-function :name (second exp)
592                                   :lambda-list (third exp)
593                                   :env env :body body
594                                   :documentation documentation
595                                   :source-location (sb!c::make-definition-source-location)
596                                   :declarations declarations)))))
597
598 (defun eval-progn (body env)
599   (let ((previous-exp nil))
600     (dolist (exp body)
601       (if previous-exp
602           (%eval previous-exp env))
603       (setf previous-exp exp))
604     ;; Preserve tail call
605     (%eval previous-exp env)))
606
607 (defun eval-if (body env)
608   (program-destructuring-bind (test if-true &optional if-false) body
609     (if (%eval test env)
610         (%eval if-true env)
611         (%eval if-false env))))
612
613 (defun eval-let (body env)
614   (program-destructuring-bind (bindings &body body) body
615     ;; First evaluate the bindings in parallel
616     (let ((bindings (mapcar
617                      #'(lambda (binding)
618                          (cons (binding-name binding)
619                                (%eval (binding-value binding) env)))
620                      bindings)))
621       (multiple-value-bind (body documentation declarations)
622           (parse-lambda-headers body :doc-string-allowed nil)
623         (declare (ignore documentation))
624         ;; Then establish them into the environment, and evaluate the
625         ;; body.
626         (call-with-new-env env bindings declarations t
627                            #'(lambda (env)
628                                (eval-progn body env)))))))
629
630 (defun eval-let* (body old-env)
631   (program-destructuring-bind (bindings &body body) body
632     (multiple-value-bind (body documentation declarations)
633         (parse-lambda-headers body :doc-string-allowed nil)
634       (declare (ignore documentation))
635       ;; First we separate the special declarations into bound and
636       ;; free declarations.
637       (let ((specials (declared-specials declarations))
638             var-specials free-specials)
639         (dolist (special specials)
640           (if (member special bindings :key #'binding-name)
641               (push special var-specials)
642               (push special free-specials)))
643         (let ((env (make-env :parent old-env
644                              :declarations declarations)))
645           ;; Then we establish the bindings into the environment
646           ;; sequentially.
647           (eval-next-let*-binding
648            (mapcar #'(lambda (binding)
649                        (cons (binding-name binding)
650                              (binding-value binding)))
651                    bindings)
652            var-specials env
653            #'(lambda ()
654                ;; Now that we're done evaluating the bindings, add the
655                ;; free special declarations. See also
656                ;; CALL-WITH-NEW-ENV-FULL-PARSING.
657                (dolist (special free-specials)
658                  (push-var special *special* env))
659                (eval-progn body env))))))))
660
661 ;; Return a named local function in the environment ENV, made from the
662 ;; definition form FUNCTION-DEF.
663 (defun eval-local-function-def (function-def env)
664   (program-destructuring-bind (name lambda-list &body local-body) function-def
665     (multiple-value-bind (local-body documentation declarations)
666         (parse-lambda-headers local-body :doc-string-allowed t)
667       (%eval `#'(sb!int:named-lambda ,name ,lambda-list
668                   ,@(if documentation
669                         (list documentation)
670                         nil)
671                   (declare ,@declarations)
672                   (block ,(cond ((consp name) (second name))
673                                 (t name))
674                     ,@local-body))
675              env))))
676
677 (defun eval-flet (body env)
678   (program-destructuring-bind ((&rest local-functions) &body body) body
679     (multiple-value-bind (body documentation declarations)
680         (parse-lambda-headers body :doc-string-allowed nil)
681       (declare (ignore documentation))
682       (let* ((specials (declared-specials declarations))
683              (new-env (make-env :parent env
684                                 :vars (special-bindings specials env)
685                                 :declarations declarations)))
686         (dolist (function-def local-functions)
687           (push-fun (car function-def)
688                     ;; Evaluate the function definitions in ENV.
689                     (eval-local-function-def function-def env)
690                     ;; Do package-lock checks in ENV.
691                     env
692                     ;; But add the bindings to the child environment.
693                     new-env))
694         (eval-progn body new-env)))))
695
696 (defun eval-labels (body old-env)
697   (program-destructuring-bind ((&rest local-functions) &body body) body
698     (multiple-value-bind (body documentation declarations)
699         (parse-lambda-headers body :doc-string-allowed nil)
700       (declare (ignore documentation))
701       ;; Create a child environment, evaluate the function definitions
702       ;; in it, and add them into the same environment.
703       (let ((env (make-env :parent old-env
704                            :declarations declarations)))
705         (dolist (function-def local-functions)
706           (push-fun (car function-def)
707                     (eval-local-function-def function-def env)
708                     old-env
709                     env))
710         ;; And then add an environment for the body of the LABELS.  A
711         ;; separate environment from the one where we added the
712         ;; functions to is needed, since any special variable
713         ;; declarations need to be in effect in the body, but not in
714         ;; the bodies of the local functions.
715         (let* ((specials (declared-specials declarations))
716                (new-env (make-env :parent env
717                                   :vars (special-bindings specials env))))
718           (eval-progn body new-env))))))
719
720 ;; Return a local macro-expander in the environment ENV, made from the
721 ;; definition form FUNCTION-DEF.
722 (defun eval-local-macro-def (function-def env)
723   (program-destructuring-bind (name lambda-list &body local-body) function-def
724     (multiple-value-bind (local-body documentation declarations)
725         (parse-lambda-headers local-body :doc-string-allowed t)
726       ;; HAS-ENVIRONMENT and HAS-WHOLE will be either NIL or the name
727       ;; of the variable. (Better names?)
728       (let (has-environment has-whole)
729         ;; Filter out &WHOLE and &ENVIRONMENT from the lambda-list, and
730         ;; do some syntax checking.
731         (when (eq (car lambda-list) '&whole)
732           (setf has-whole (second lambda-list))
733           (setf lambda-list (cddr lambda-list)))
734         (setf lambda-list
735               (loop with skip = 0
736                     for element in lambda-list
737                     if (cond
738                          ((/= skip 0)
739                           (decf skip)
740                           (setf has-environment element)
741                           nil)
742                          ((eq element '&environment)
743                           (if has-environment
744                               (ip-error "Repeated &ENVIRONMENT.")
745                               (setf skip 1))
746                           nil)
747                          ((eq element '&whole)
748                           (ip-error "&WHOLE may only appear first ~
749                                      in MACROLET lambda-list."))
750                          (t t))
751                     collect element))
752         (let ((outer-whole (gensym "WHOLE"))
753               (environment (or has-environment (gensym "ENVIRONMENT")))
754               (macro-name (gensym "NAME")))
755           (%eval `#'(lambda (,outer-whole ,environment)
756                       ,@(if documentation
757                             (list documentation)
758                             nil)
759                       (declare ,@(unless has-environment
760                                          `((ignore ,environment))))
761                       (program-destructuring-bind
762                           (,@(if has-whole
763                                  (list '&whole has-whole)
764                                  nil)
765                              ,macro-name ,@lambda-list)
766                           ,outer-whole
767                         (declare (ignore ,macro-name)
768                                  ,@declarations)
769                         (block ,name ,@local-body)))
770                  env))))))
771
772 (defun eval-macrolet (body env)
773   (program-destructuring-bind ((&rest local-functions) &body body) body
774     (flet ((generate-fbinding (macro-def)
775              (cons (car macro-def) *macro*))
776            (generate-mbinding (macro-def)
777              (let ((name (car macro-def))
778                    (sb!c:*lexenv* (env-native-lexenv env)))
779                (when (fboundp name)
780                  (program-assert-symbol-home-package-unlocked
781                   :eval name "binding ~A as a local macro"))
782                (cons name (eval-local-macro-def macro-def env)))))
783       (multiple-value-bind (body documentation declarations)
784           (parse-lambda-headers body :doc-string-allowed nil)
785         (declare (ignore documentation))
786         (let* ((specials (declared-specials declarations))
787                (new-env (make-env :parent env
788                                   :vars (special-bindings specials env)
789                                   :funs (mapcar #'generate-fbinding
790                                                 local-functions)
791                                   :expanders (mapcar #'generate-mbinding
792                                                      local-functions)
793                                   :declarations declarations)))
794           (eval-progn body new-env))))))
795
796 (defun eval-symbol-macrolet (body env)
797   (program-destructuring-bind ((&rest bindings) &body body) body
798     (flet ((generate-binding (binding)
799              (cons (car binding) *symbol-macro*))
800            (generate-sm-binding (binding)
801              (let ((name (car binding))
802                    (sb!c:*lexenv* (env-native-lexenv env)))
803                (when (or (boundp name)
804                          (eq (sb!int:info :variable :kind name) :macro))
805                  (program-assert-symbol-home-package-unlocked
806                   :eval name "binding ~A as a local symbol-macro"))
807                (cons name (second binding)))))
808       (multiple-value-bind (body documentation declarations)
809           (parse-lambda-headers body :doc-string-allowed nil)
810         (declare (ignore documentation))
811         (let ((specials (declared-specials declarations)))
812           (dolist (binding bindings)
813             (when (specialp (binding-name binding) specials)
814               (ip-error "~@<Can't bind SYMBOL-MACROLET of special ~
815                          variable ~S.~:@>"
816                         (binding-name binding)))))
817         (let* ((specials (declared-specials declarations))
818                (new-env (make-env :parent env
819                                   :vars (nconc-2 (mapcar #'generate-binding
820                                                          bindings)
821                                                  (special-bindings specials env))
822                                   :symbol-expansions (mapcar
823                                                       #'generate-sm-binding
824                                                       bindings)
825                                   :declarations declarations)))
826           (eval-progn body new-env))))))
827
828 (defun eval-progv (body env)
829   (program-destructuring-bind (vars vals &body body) body
830     (progv (%eval vars env) (%eval vals env)
831       (eval-progn body env))))
832
833 (defun eval-function (body env)
834   (program-destructuring-bind (name) body
835     (cond
836       ;; LAMBDAP assumes that the argument is a cons, so we need the
837       ;; initial symbol case, instead of relying on the fall-through
838       ;; case that has the same function body.
839       ((symbolp name) (nth-value 0 (get-function name env)))
840       ((lambdap name) (eval-lambda name env))
841       (t (nth-value 0 (get-function name env))))))
842
843 (defun eval-eval-when (body env)
844   (program-destructuring-bind ((&rest situation) &body body) body
845     ;; FIXME: check that SITUATION only contains valid situations
846     (if (or (member :execute situation)
847             (member 'eval situation))
848         (eval-progn body env))))
849
850 (defun eval-quote (body env)
851   (declare (ignore env))
852   (program-destructuring-bind (object) body
853     object))
854
855 (defun eval-setq (pairs env)
856   (when (oddp (length pairs))
857     (ip-error "~@<Odd number of args to SETQ: ~S~:@>" (cons 'setq pairs)))
858   (let ((last nil))
859     (loop for (var new-val) on pairs by #'cddr do
860           (handler-case
861               (multiple-value-bind (expansion type) (get-variable var env)
862                 (ecase type
863                   (:expansion
864                    (setf last
865                          (%eval (list 'setf expansion new-val) env)))
866                   (:variable
867                    (setf last (set-variable var (%eval new-val env)
868                                             env)))))
869             (unbound-variable (c)
870               (declare (ignore c))
871               (setf last (setf (symbol-value var)
872                                (%eval new-val env))))))
873     last))
874
875 (defun eval-multiple-value-call (body env)
876   (program-destructuring-bind (function-form &body forms) body
877     (%apply (%eval function-form env)
878             (loop for form in forms
879                   nconc (multiple-value-list (%eval form env))))))
880
881 (defun eval-multiple-value-prog1 (body env)
882   (program-destructuring-bind (first-form &body forms) body
883     (multiple-value-prog1 (%eval first-form env)
884       (eval-progn forms env))))
885
886 (defun eval-catch (body env)
887   (program-destructuring-bind (tag &body forms) body
888     (catch (%eval tag env)
889       (eval-progn forms env))))
890
891 (defun eval-tagbody (body old-env)
892   (let ((env (make-env :parent old-env))
893         (tags nil)
894         (start body)
895         (target-tag nil))
896     (tagbody
897        (flet ((go-to-tag (tag)
898                 (setf target-tag tag)
899                 (go go-to-tag)))
900          ;; For each tag, store a trampoline function into the environment
901          ;; and the location in the body into the TAGS alist.
902          (do ((form body (cdr form)))
903              ((null form) nil)
904            (when (atom (car form))
905              (when (assoc (car form) tags)
906                (ip-error "The tag :A appears more than once in a tagbody."))
907              (push (cons (car form) (cdr form)) tags)
908              (push (cons (car form) #'go-to-tag) (env-tags env)))))
909        ;; And then evaluate the forms in the body, starting from the
910        ;; first one.
911        (go execute)
912      go-to-tag
913        ;; The trampoline has set the TARGET-TAG. Restart evaluation of
914        ;; the body from the location in body that matches the tag.
915        (setf start (cdr (assoc target-tag tags)))
916      execute
917        (dolist (form start)
918          (when (not (atom form))
919            (%eval form env))))))
920
921 (defun eval-go (body env)
922   (program-destructuring-bind (tag) body
923     (let ((target (get-tag-binding tag env)))
924       (if target
925           ;; Call the GO-TO-TAG trampoline
926           (funcall (cdr target) tag)
927           (ip-error "~@<Attempt to GO to nonexistent tag: ~S~:@>" tag)))))
928
929 (defun eval-block (body old-env)
930   (flet ((return-from-eval-block (&rest values)
931            (return-from eval-block (values-list values))))
932     (program-destructuring-bind (name &body body) body
933       (unless (symbolp name)
934         (ip-error "~@<The block name ~S is not a symbol.~:@>" name))
935       (let ((env (make-env
936                   :blocks (list (cons name #'return-from-eval-block))
937                   :parent old-env)))
938         (eval-progn body env)))))
939
940 (defun eval-return-from (body env)
941   (program-destructuring-bind (name &optional result) body
942     (let ((target (get-block-binding name env)))
943       (if target
944           (multiple-value-call (cdr target) (%eval result env))
945           (ip-error "~@<Return for unknown block: ~S~:@>" name)))))
946
947 (defun eval-the (body env)
948   (program-destructuring-bind (value-type form) body
949     (declare (ignore value-type))
950     ;; FIXME: We should probably check the types here, even though
951     ;; the consequences of the values not being of the asserted types
952     ;; are formally undefined.
953     (%eval form env)))
954
955 (defun eval-unwind-protect (body env)
956   (program-destructuring-bind (protected-form &body cleanup-forms) body
957     (unwind-protect (%eval protected-form env)
958       (eval-progn cleanup-forms env))))
959
960 (defun eval-throw (body env)
961   (program-destructuring-bind (tag result-form) body
962     (throw (%eval tag env)
963       (%eval result-form env))))
964
965 (defun eval-load-time-value (body env)
966   (program-destructuring-bind (form &optional read-only-p) body
967     (declare (ignore read-only-p))
968     (%eval form env)))
969
970 (defun eval-locally (body env)
971   (multiple-value-bind (body documentation declarations)
972       (parse-lambda-headers body :doc-string-allowed nil)
973     (declare (ignore documentation))
974     (let* ((specials (declared-specials declarations))
975            (new-env (if (or specials declarations)
976                         (make-env :parent env
977                                   :vars (special-bindings specials env)
978                                   :declarations declarations)
979                         env)))
980       (eval-progn body new-env))))
981
982 (defun eval-args (args env)
983   (mapcar #'(lambda (arg) (%eval arg env)) args))
984
985 ;;; The expansion of SB-SYS:WITH-PINNED-OBJECTS on GENCGC uses some
986 ;;; VOPs which can't be reasonably implemented in the interpreter. So
987 ;;; we special-case the macro.
988 (defun eval-with-pinned-objects (args env)
989   (program-destructuring-bind (values &body body) args
990     (if (null values)
991         (eval-progn body env)
992         (sb!sys:with-pinned-objects ((car values))
993           (eval-with-pinned-objects (cons (cdr values) body) env)))))
994
995 (define-condition macroexpand-hook-type-error (type-error)
996   ()
997   (:report (lambda (condition stream)
998              (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~A"
999                      (type-error-datum condition)))))
1000
1001 (defvar *eval-dispatch-functions* nil)
1002
1003 ;;; Dispatch to the appropriate EVAL-FOO function based on the contents of EXP.
1004 (declaim (inline %%eval))
1005 (defun %%eval (exp env)
1006   (cond
1007     ((symbolp exp)
1008      ;; CLHS 3.1.2.1.1 Symbols as Forms
1009      (multiple-value-bind (value kind) (get-variable exp env)
1010        (ecase kind
1011          (:variable value)
1012          (:expansion (%eval value env)))))
1013     ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
1014     ((atom exp) exp)
1015     ;; CLHS 3.1.2.1.2 Conses as Forms
1016     ((consp exp)
1017      (case (car exp)
1018        ;; CLHS 3.1.2.1.2.1 Special Forms
1019        ((block)                (eval-block (cdr exp) env))
1020        ((catch)                (eval-catch (cdr exp) env))
1021        ((eval-when)            (eval-eval-when (cdr exp) env))
1022        ((flet)                 (eval-flet (cdr exp) env))
1023        ((function)             (eval-function (cdr exp) env))
1024        ((go)                   (eval-go (cdr exp) env))
1025        ((if)                   (eval-if (cdr exp) env))
1026        ((labels)               (eval-labels (cdr exp) env))
1027        ((let)                  (eval-let (cdr exp) env))
1028        ((let*)                 (eval-let* (cdr exp) env))
1029        ((load-time-value)      (eval-load-time-value (cdr exp) env))
1030        ((locally)              (eval-locally (cdr exp) env))
1031        ((macrolet)             (eval-macrolet (cdr exp) env))
1032        ((multiple-value-call)  (eval-multiple-value-call (cdr exp) env))
1033        ((multiple-value-prog1) (eval-multiple-value-prog1 (cdr exp) env))
1034        ((progn)                (eval-progn (cdr exp) env))
1035        ((progv)                (eval-progv (cdr exp) env))
1036        ((quote)                (eval-quote (cdr exp) env))
1037        ((return-from)          (eval-return-from (cdr exp) env))
1038        ((setq)                 (eval-setq (cdr exp) env))
1039        ((symbol-macrolet)      (eval-symbol-macrolet (cdr exp) env))
1040        ((tagbody)              (eval-tagbody (cdr exp) env))
1041        ((the)                  (eval-the (cdr exp) env))
1042        ((throw)                (eval-throw (cdr exp) env))
1043        ((unwind-protect)       (eval-unwind-protect (cdr exp) env))
1044        ;; SBCL-specific:
1045        ((sb!ext:truly-the)     (eval-the (cdr exp) env))
1046        ;; Not a special form, but a macro whose expansion wouldn't be
1047        ;; handled correctly by the evaluator.
1048        ((sb!sys:with-pinned-objects) (eval-with-pinned-objects (cdr exp) env))
1049        (t
1050         (let ((dispatcher (getf *eval-dispatch-functions* (car exp))))
1051           (cond
1052             (dispatcher
1053              (funcall dispatcher exp env))
1054             ;; CLHS 3.1.2.1.2.4 Lambda Forms
1055             ((and (consp (car exp)) (eq (caar exp) 'lambda))
1056              (interpreted-apply (eval-function (list (car exp)) env)
1057                                 (eval-args (cdr exp) env)))
1058             (t
1059              (multiple-value-bind (function kind) (get-function (car exp) env)
1060                (ecase kind
1061                  ;; CLHS 3.1.2.1.2.3 Function Forms
1062                  (:function (%apply function (eval-args (cdr exp) env)))
1063                  ;; CLHS 3.1.2.1.2.2 Macro Forms
1064                  (:macro
1065                   (let ((hook *macroexpand-hook*))
1066                     ;; Having an interpreted function as the
1067                     ;; macroexpander hook could cause an infinite
1068                     ;; loop.
1069                     (unless (compiled-function-p
1070                              (etypecase hook
1071                                (function hook)
1072                                (symbol (symbol-function hook))))
1073                       (error 'macroexpand-hook-type-error
1074                              :datum hook
1075                              :expected-type 'compiled-function))
1076                     (%eval (funcall hook
1077                                     function
1078                                     exp
1079                                     (env-native-lexenv env))
1080                            env)))))))))))))
1081
1082 (defun %eval (exp env)
1083   (incf *eval-calls*)
1084   (if *eval-verbose*
1085       ;; Dynamically binding *EVAL-LEVEL* will prevent tail call
1086       ;; optimization. So only do it when its value will be used for
1087       ;; printing debug output.
1088       (let ((*eval-level* (1+ *eval-level*)))
1089         (let ((*print-circle* t))
1090           (format t "~&~vA~S~%" *eval-level* "" `(%eval ,exp)))
1091         (%%eval exp env))
1092       (%%eval exp env)))
1093
1094 (defun %apply (fun args)
1095   (etypecase fun
1096     (interpreted-function (interpreted-apply fun args))
1097     (function (apply fun args))
1098     (symbol (apply fun args))))
1099
1100 (defun interpreted-apply (fun args)
1101   (let ((lambda-list (interpreted-function-lambda-list fun))
1102         (env (interpreted-function-env fun))
1103         (body (interpreted-function-body fun))
1104         (declarations (interpreted-function-declarations fun)))
1105     (call-with-new-env-full-parsing
1106      env lambda-list args declarations
1107      #'(lambda (env)
1108          (eval-progn body env)))))
1109
1110 ;;; We need separate conditions for the different *-TOO-COMPLEX-ERRORs to
1111 ;;; avoid spuriously triggering the handler in EVAL-IN-NATIVE-ENVIRONMENT
1112 ;;; on code like:
1113 ;;;
1114 ;;;   (let ((sb-ext:*evaluator-mode* :interpret))
1115 ;;;     (let ((fun (eval '(let ((a 1)) (lambda () a)))))
1116 ;;;         (eval `(compile nil ,fun))))
1117 ;;;
1118 ;;; FIXME: should these be exported?
1119 (define-condition interpreter-environment-too-complex-error (simple-error)
1120   ())
1121 (define-condition compiler-environment-too-complex-error (simple-error)
1122   ())
1123
1124 ;;; Try to compile an interpreted function. If the environment
1125 ;;; contains local functions or lexical variables we'll punt on
1126 ;;; compiling it.
1127 (defun prepare-for-compile (function)
1128   (let ((env (interpreted-function-env function)))
1129     (when (or (env-tags env)
1130               (env-blocks env)
1131               (find-if-not #'(lambda (x) (eq x *macro*))
1132                            (env-funs env) :key #'cdr)
1133               (find-if-not #'(lambda (x) (eq x *symbol-macro*))
1134                            (env-vars env)
1135                            :key #'cdr))
1136       (error 'interpreter-environment-too-complex-error
1137              :format-control
1138              "~@<Lexical environment of ~S is too complex to compile.~:@>"
1139              :format-arguments
1140              (list function)))
1141     (values
1142      `(sb!int:named-lambda ,(interpreted-function-name function)
1143           ,(interpreted-function-lambda-list function)
1144         (declare ,@(interpreted-function-declarations function))
1145         ,@(interpreted-function-body function))
1146      (env-native-lexenv env))))
1147
1148 ;;; Convert a compiler LEXENV to an interpreter ENV. This is needed
1149 ;;; for EVAL-IN-LEXENV.
1150 (defun make-env-from-native-environment (lexenv)
1151   (let ((native-funs (sb!c::lexenv-funs lexenv))
1152         (native-vars (sb!c::lexenv-vars lexenv)))
1153     (flet ((is-macro (thing)
1154              (and (consp thing) (eq (car thing) 'sb!sys:macro))))
1155       (when (or (sb!c::lexenv-blocks lexenv)
1156                 (sb!c::lexenv-cleanup lexenv)
1157                 (sb!c::lexenv-lambda lexenv)
1158                 (sb!c::lexenv-tags lexenv)
1159                 (sb!c::lexenv-type-restrictions lexenv)
1160                 (find-if-not #'is-macro native-funs :key #'cdr)
1161                 (find-if-not #'is-macro native-vars :key #'cdr))
1162         (error 'compiler-environment-too-complex-error
1163                :format-control
1164                "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
1165                :format-arguments
1166                (list lexenv))))
1167     (flet ((make-binding (native)
1168              (cons (car native) *symbol-macro*))
1169            (make-sm-binding (native)
1170              (cons (car native) (cddr native)))
1171            (make-fbinding (native)
1172              (cons (car native) *macro*))
1173            (make-mbinding (native)
1174              (cons (car native) (cddr native))))
1175       (%make-env nil
1176                  (mapcar #'make-binding native-vars)
1177                  (mapcar #'make-fbinding native-funs)
1178                  (mapcar #'make-mbinding native-funs)
1179                  (mapcar #'make-sm-binding native-vars)
1180                  nil
1181                  nil
1182                  nil
1183                  lexenv))))
1184
1185 (defun eval-in-environment (form env)
1186   (%eval form env))
1187
1188 (defun eval-in-native-environment (form lexenv)
1189   (handler-bind
1190       ((sb!impl::eval-error
1191         (lambda (condition)
1192           (error 'interpreted-program-error
1193                  :condition (sb!int:encapsulated-condition condition)
1194                  :form form)))
1195        (sb!c:compiler-error
1196         (lambda (c)
1197           (if (boundp 'sb!c::*compiler-error-bailout*)
1198               ;; if we're in the compiler, delegate either to a higher
1199               ;; authority or, if that's us, back down to the
1200               ;; outermost compiler handler...
1201               (progn
1202                 (signal c)
1203                 nil)
1204               ;; ... if we're not in the compiler, better signal the
1205               ;; error straight away.
1206               (invoke-restart 'sb!c::signal-error)))))
1207     (handler-case
1208         (let ((env (make-env-from-native-environment lexenv)))
1209           (%eval form env))
1210       (compiler-environment-too-complex-error (condition)
1211         (declare (ignore condition))
1212         (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex
1213                            :form form :lexenv lexenv)
1214         (sb!int:simple-eval-in-lexenv form lexenv)))))