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, generate an augmented environment with a binding
 361 ;;; of the variable to the value in ENV, and then evaluate the next
 362 ;;; binding form. Once all binding forms have been handled, END-ACTION
 363 ;;; is funcalled with the final environment.
 364 ;;;
 365 ;;; SPECIALS is a list of variables that have a bound special declaration.
 366 ;;; These variables (and those that have been declaimed as special) are
 367 ;;; bound as special variables.
 368 (defun eval-next-let*-binding (bindings specials env end-action)
 369   (flet ((maybe-eval (exp)
 370            ;; Pick off the easy (QUOTE x) case which is very common
 371            ;; due to function calls.  (see PARSE-ARGUMENTS)
 372            (if (and (consp exp) (eq (car exp) 'quote))
 373                (second exp)
 374                (%eval exp env)))
 375          (maybe-new-env (env exp)
 376            (if (and (consp exp) (eq (car exp) 'quote))
 377                env
 378                (make-env :parent env))))
 379     (if bindings
 380         (let* ((binding-name (car (car bindings)))
 381                (binding-value (cdr (car bindings))))
 382           (if (specialp binding-name specials)
 383               (progv
 384                   (list binding-name)
 385                   (list (maybe-eval binding-value))
 386                 ;; Mark the variable as special in this environment
 387                 (push-var binding-name *special* env)
 388                 (eval-next-let*-binding
 389                  (cdr bindings) specials
 390                  (maybe-new-env env binding-value) end-action))
 391               (progn
 392                 (push-var binding-name (maybe-eval binding-value) env)
 393                 (eval-next-let*-binding
 394                  (cdr bindings) specials
 395                  (maybe-new-env env binding-value) end-action))))
 396         (funcall end-action env))))
 397
 398 ;;; Create a new environment based on OLD-ENV by adding the variable
 399 ;;; bindings in BINDINGS to it, and call FUNCTION with the new environment
 400 ;;; as the only parameter. DECLARATIONS are the declarations that were
 401 ;;; in a source position where bound declarations for the bindings could
 402 ;;; be introduced.
 403 ;;;
 404 ;;; FREE-SPECIALS-P controls whether all special declarations should
 405 ;;; end cause the variables to be marked as special in the environment
 406 ;;; (when true), or only bound declarations (when false). Basically
 407 ;;; it'll be T when handling a LET, and NIL when handling a call to an
 408 ;;; interpreted function.
 409 (defun call-with-new-env (old-env bindings declarations
 410                           free-specials-p function)
 411   (let* ((specials (declared-specials declarations))
 412          (dynamic-vars nil)
 413          (dynamic-values nil))
 414     ;; To check for package-lock violations
 415     (special-bindings specials old-env)
 416     (flet ((generate-binding (binding)
 417              (if (specialp (car binding) specials)
 418                  ;; If the variable being bound is globally special or
 419                  ;; there's a bound special declaration for it, record it
 420                  ;; in DYNAMIC-VARS / -VALUES separately:
 421                  ;;   * To handle the case of FREE-SPECIALS-P == T more
 422                  ;;     cleanly.
 423                  ;;   * The dynamic variables will be bound with PROGV just
 424                  ;;     before funcalling
 425                  (progn
 426                    (push (car binding) dynamic-vars)
 427                    (push (cdr binding) dynamic-values)
 428                    nil)
 429                  ;; Otherwise it's a lexical binding, and the value
 430                  ;; will be recorded in the environment.
 431                  (list binding))))
 432       (let ((new-env (make-env
 433                       :parent old-env
 434                       :vars (mapcan #'generate-binding bindings)
 435                       :declarations declarations)))
 436         (dolist (special (if free-specials-p specials dynamic-vars))
 437           (push-var special *special* new-env))
 438         (if dynamic-vars
 439             (progv dynamic-vars dynamic-values
 440               (funcall function new-env))
 441             ;; When there are no specials, the PROGV would be a no-op,
 442             ;; but it's better to elide it completely, since the
 443             ;; funcall is then in tail position.
 444             (funcall function new-env))))))
 445
 446 ;;; Create a new environment based on OLD-ENV by binding the argument
 447 ;;; list ARGUMENTS to LAMBDA-LIST, and call FUNCTION with the new
 448 ;;; environment as argument. DECLARATIONS are the declarations that
 449 ;;; were in a source position where bound declarations for the
 450 ;;; bindings could be introduced.
 451 (defun call-with-new-env-full-parsing
 452     (old-env lambda-list arguments declarations function)
 453   (multiple-value-bind (let-like-bindings let*-like-binding)
 454       (parse-arguments arguments lambda-list)
 455     (let ((specials (declared-specials declarations))
 456           var-specials free-specials)
 457       ;; Separate the bound and free special declarations
 458       (dolist (special specials)
 459         (if (or (member special let-like-bindings :key #'car)
 460                 (member special let*-like-binding :key #'car))
 461             (push special var-specials)
 462             (push special free-specials)))
 463       ;; First introduce the required parameters into the environment
 464       ;; with CALL-WITH-NEW-ENV
 465       (call-with-new-env
 466        old-env let-like-bindings declarations nil
 467        #'(lambda (env)
 468            ;; Then deal with optionals / keywords / etc.
 469            (eval-next-let*-binding
 470             let*-like-binding var-specials env
 471             #'(lambda (env)
 472                 ;; And now that we have evaluated all the
 473                 ;; initialization forms for the bindings, add the free
 474                 ;; special declarations to the environment. To see why
 475                 ;; this is the right thing to do (instead of passing
 476                 ;; FREE-SPECIALS-P == T to CALL-WITH-NEW-ENV),
 477                 ;; consider:
 478                 ;;
 479                 ;;   (eval '(let ((*a* 1))
 480                 ;;     (declare (special *a*))
 481                 ;;     (let ((*a* 2))
 482                 ;;       (funcall (lambda (&optional (b *a*))
 483                 ;;                  (declare (special *a*))
 484                 ;;                  (values b *a*))))))
 485                 ;;
 486                 ;; *A* should be special in the body of the lambda, but
 487                 ;; not when evaluating the default value of B.
 488                 (dolist (special free-specials)
 489                   (push-var special *special* env))
 490                 (funcall function env))))))))
 491
 492 ;;; Set the VALUE of the binding (either lexical or special) of the
 493 ;;; variable named by SYMBOL in the environment ENV.
 494 (defun set-variable (symbol value env)
 495   (let ((binding (get-binding symbol env)))
 496     (if binding
 497         (cond
 498           ((eq (cdr binding) *special*)
 499            (setf (symbol-value symbol) value))
 500           ((eq (cdr binding) *symbol-macro*)
 501            (error "Tried to set a symbol-macrolet!"))
 502           (t (setf (cdr binding) value)))
 503         (case (sb!int:info :variable :kind symbol)
 504           (:macro (error "Tried to set a symbol-macrolet!"))
 505           (:alien (let ((type (sb!int:info :variable :alien-info symbol)))
 506                     (setf (sb!alien::%heap-alien type) value)))
 507           (t
 508            (let ((type (sb!c::info :variable :type symbol)))
 509              (when type
 510                (let ((type-specifier (sb!kernel:type-specifier type)))
 511                  (unless (typep value type-specifier)
 512                    (error 'type-error
 513                           :datum value
 514                           :expected-type type-specifier))))
 515              (setf (symbol-value symbol) value)))))))
 516
 517 ;;; Retrieve the value of the binding (either lexical or special) of
 518 ;;; the variable named by SYMBOL in the environment ENV. For symbol
 519 ;;; macros the expansion is returned instead.
 520 (defun get-variable (symbol env)
 521   (let ((binding (get-binding symbol env)))
 522     (if binding
 523         (cond
 524           ((eq (cdr binding) *special*)
 525            (values (symbol-value symbol) :variable))
 526           ((eq (cdr binding) *symbol-macro*)
 527            (values (cdr (get-symbol-expansion-binding symbol env))
 528                    :expansion))
 529           (t (values (cdr binding) :variable)))
 530         (case (sb!int:info :variable :kind symbol)
 531           (:macro (values (macroexpand-1 symbol) :expansion))
 532           (:alien (values (sb!alien-internals:alien-value symbol) :variable))
 533           (t (values (symbol-value symbol) :variable))))))
 534
 535 ;;; Retrieve the function/macro binding of the symbol NAME in
 536 ;;; environment ENV. The second return value will be :MACRO for macro
 537 ;;; bindings, :FUNCTION for function bindings.
 538 (defun get-function (name env)
 539   (let ((binding (get-fbinding name env)))
 540     (if binding
 541         (cond
 542           ((eq (cdr binding) *macro*)
 543            (values (cdr (get-expander-binding name env)) :macro))
 544           (t (values (cdr binding) :function)))
 545         (cond
 546           ((and (symbolp name) (macro-function name))
 547            (values (macro-function name) :macro))
 548           (t (values (%coerce-name-to-fun name) :function))))))
 549
 550 ;;; Return true if EXP is a lambda form.
 551 (defun lambdap (exp)
 552   (case (car exp)
 553     ((lambda sb!int:named-lambda) t)))
 554
 555 ;;; Split off the declarations (and the docstring, if
 556 ;;; DOC-STRING-ALLOWED is true) from the actual forms of BODY.
 557 ;;; Returns three values: the cons in BODY containing the first
 558 ;;; non-header subform, the docstring, and a list of the declarations.
 559 ;;;
 560 ;;; FIXME: The name of this function is somewhat misleading. It's not
 561 ;;; used just for parsing the headers from lambda bodies, but for all
 562 ;;; special forms that have attached declarations.
 563 (defun parse-lambda-headers (body &key doc-string-allowed)
 564   (loop with documentation = nil
 565         with declarations = nil
 566         for form on body do
 567         (cond
 568           ((and doc-string-allowed (stringp (car form)))
 569            (if (cdr form)               ; CLHS 3.4.11
 570                (if documentation
 571                    (ip-error "~@<Duplicate doc string ~S.~:@>" (car form))
 572                    (setf documentation (car form)))
 573                (return (values form documentation declarations))))
 574           ((and (consp (car form)) (eql (caar form) 'declare))
 575            (setf declarations (append declarations (cdar form))))
 576           (t (return (values form documentation declarations))))
 577         finally (return (values nil documentation declarations))))
 578
 579 ;;; Create an interpreted function from the lambda-form EXP evaluated
 580 ;;; in the environment ENV.
 581 (defun eval-lambda (exp env)
 582   (case (car exp)
 583     ((lambda)
 584      (multiple-value-bind (body documentation declarations)
 585          (parse-lambda-headers (cddr exp) :doc-string-allowed t)
 586        (make-interpreted-function :lambda-list (second exp)
 587                                   :env env :body body
 588                                   :documentation documentation
 589                                   :source-location (sb!c::make-definition-source-location)
 590                                   :declarations declarations)))
 591     ((sb!int:named-lambda)
 592      (multiple-value-bind (body documentation declarations)
 593          (parse-lambda-headers (cdddr exp) :doc-string-allowed t)
 594        (make-interpreted-function :name (second exp)
 595                                   :lambda-list (third exp)
 596                                   :env env :body body
 597                                   :documentation documentation
 598                                   :source-location (sb!c::make-definition-source-location)
 599                                   :declarations declarations)))))
 600
 601 (defun eval-progn (body env)
 602   (let ((previous-exp nil))
 603     (dolist (exp body)
 604       (if previous-exp
 605           (%eval previous-exp env))
 606       (setf previous-exp exp))
 607     ;; Preserve tail call
 608     (%eval previous-exp env)))
 609
 610 (defun eval-if (body env)
 611   (program-destructuring-bind (test if-true &optional if-false) body
 612     (if (%eval test env)
 613         (%eval if-true env)
 614         (%eval if-false env))))
 615
 616 (defun eval-let (body env)
 617   (program-destructuring-bind (bindings &body body) body
 618     ;; First evaluate the bindings in parallel
 619     (let ((bindings (mapcar
 620                      #'(lambda (binding)
 621                          (cons (binding-name binding)
 622                                (%eval (binding-value binding) env)))
 623                      bindings)))
 624       (multiple-value-bind (body documentation declarations)
 625           (parse-lambda-headers body :doc-string-allowed nil)
 626         (declare (ignore documentation))
 627         ;; Then establish them into the environment, and evaluate the
 628         ;; body.
 629         (call-with-new-env env bindings declarations t
 630                            #'(lambda (env)
 631                                (eval-progn body env)))))))
 632
 633 (defun eval-let* (body old-env)
 634   (program-destructuring-bind (bindings &body body) body
 635     (multiple-value-bind (body documentation declarations)
 636         (parse-lambda-headers body :doc-string-allowed nil)
 637       (declare (ignore documentation))
 638       ;; First we separate the special declarations into bound and
 639       ;; free declarations.
 640       (let ((specials (declared-specials declarations))
 641             var-specials free-specials)
 642         (dolist (special specials)
 643           (if (member special bindings :key #'binding-name)
 644               (push special var-specials)
 645               (push special free-specials)))
 646         (let ((env (make-env :parent old-env
 647                              :declarations declarations)))
 648           ;; Then we establish the bindings into the environment
 649           ;; sequentially.
 650           (eval-next-let*-binding
 651            (mapcar #'(lambda (binding)
 652                        (cons (binding-name binding)
 653                              (binding-value binding)))
 654                    bindings)
 655            var-specials env
 656            #'(lambda (env)
 657                ;; Now that we're done evaluating the bindings, add the
 658                ;; free special declarations. See also
 659                ;; CALL-WITH-NEW-ENV-FULL-PARSING.
 660                (dolist (special free-specials)
 661                  (push-var special *special* env))
 662                (eval-progn body env))))))))
 663
 664 ;; Return a named local function in the environment ENV, made from the
 665 ;; definition form FUNCTION-DEF.
 666 (defun eval-local-function-def (function-def env)
 667   (program-destructuring-bind (name lambda-list &body local-body) function-def
 668     (multiple-value-bind (local-body documentation declarations)
 669         (parse-lambda-headers local-body :doc-string-allowed t)
 670       (%eval `#'(sb!int:named-lambda ,name ,lambda-list
 671                   ,@(if documentation
 672                         (list documentation)
 673                         nil)
 674                   (declare ,@declarations)
 675                   (block ,(cond ((consp name) (second name))
 676                                 (t name))
 677                     ,@local-body))
 678              env))))
 679
 680 (defun eval-flet (body env)
 681   (program-destructuring-bind ((&rest local-functions) &body body) body
 682     (multiple-value-bind (body documentation declarations)
 683         (parse-lambda-headers body :doc-string-allowed nil)
 684       (declare (ignore documentation))
 685       (let* ((specials (declared-specials declarations))
 686              (new-env (make-env :parent env
 687                                 :vars (special-bindings specials env)
 688                                 :declarations declarations)))
 689         (dolist (function-def local-functions)
 690           (push-fun (car function-def)
 691                     ;; Evaluate the function definitions in ENV.
 692                     (eval-local-function-def function-def env)
 693                     ;; Do package-lock checks in ENV.
 694                     env
 695                     ;; But add the bindings to the child environment.
 696                     new-env))
 697         (eval-progn body new-env)))))
 698
 699 (defun eval-labels (body old-env)
 700   (program-destructuring-bind ((&rest local-functions) &body body) body
 701     (multiple-value-bind (body documentation declarations)
 702         (parse-lambda-headers body :doc-string-allowed nil)
 703       (declare (ignore documentation))
 704       ;; Create a child environment, evaluate the function definitions
 705       ;; in it, and add them into the same environment.
 706       (let ((env (make-env :parent old-env
 707                            :declarations declarations)))
 708         (dolist (function-def local-functions)
 709           (push-fun (car function-def)
 710                     (eval-local-function-def function-def env)
 711                     old-env
 712                     env))
 713         ;; And then add an environment for the body of the LABELS.  A
 714         ;; separate environment from the one where we added the
 715         ;; functions to is needed, since any special variable
 716         ;; declarations need to be in effect in the body, but not in
 717         ;; the bodies of the local functions.
 718         (let* ((specials (declared-specials declarations))
 719                (new-env (make-env :parent env
 720                                   :vars (special-bindings specials env))))
 721           (eval-progn body new-env))))))
 722
 723 ;; Return a local macro-expander in the environment ENV, made from the
 724 ;; definition form FUNCTION-DEF.
 725 (defun eval-local-macro-def (function-def env)
 726   (program-destructuring-bind (name lambda-list &body local-body) function-def
 727     (multiple-value-bind (local-body documentation declarations)
 728         (parse-lambda-headers local-body :doc-string-allowed t)
 729       ;; HAS-ENVIRONMENT and HAS-WHOLE will be either NIL or the name
 730       ;; of the variable. (Better names?)
 731       (let (has-environment has-whole)
 732         ;; Filter out &WHOLE and &ENVIRONMENT from the lambda-list, and
 733         ;; do some syntax checking.
 734         (when (eq (car lambda-list) '&whole)
 735           (setf has-whole (second lambda-list))
 736           (setf lambda-list (cddr lambda-list)))
 737         (setf lambda-list
 738               (loop with skip = 0
 739                     for element in lambda-list
 740                     if (cond
 741                          ((/= skip 0)
 742                           (decf skip)
 743                           (setf has-environment element)
 744                           nil)
 745                          ((eq element '&environment)
 746                           (if has-environment
 747                               (ip-error "Repeated &ENVIRONMENT.")
 748                               (setf skip 1))
 749                           nil)
 750                          ((eq element '&whole)
 751                           (ip-error "&WHOLE may only appear first ~
 752                                      in MACROLET lambda-list."))
 753                          (t t))
 754                     collect element))
 755         (let ((outer-whole (gensym "WHOLE"))
 756               (environment (or has-environment (gensym "ENVIRONMENT")))
 757               (macro-name (gensym "NAME")))
 758           (%eval `#'(lambda (,outer-whole ,environment)
 759                       ,@(if documentation
 760                             (list documentation)
 761                             nil)
 762                       (declare ,@(unless has-environment
 763                                          `((ignore ,environment))))
 764                       (program-destructuring-bind
 765                           (,@(if has-whole
 766                                  (list '&whole has-whole)
 767                                  nil)
 768                              ,macro-name ,@lambda-list)
 769                           ,outer-whole
 770                         (declare (ignore ,macro-name)
 771                                  ,@declarations)
 772                         (block ,name ,@local-body)))
 773                  env))))))
 774
 775 (defun eval-macrolet (body env)
 776   (program-destructuring-bind ((&rest local-functions) &body body) body
 777     (flet ((generate-fbinding (macro-def)
 778              (cons (car macro-def) *macro*))
 779            (generate-mbinding (macro-def)
 780              (let ((name (car macro-def))
 781                    (sb!c:*lexenv* (env-native-lexenv env)))
 782                (when (fboundp name)
 783                  (program-assert-symbol-home-package-unlocked
 784                   :eval name "binding ~A as a local macro"))
 785                (cons name (eval-local-macro-def macro-def env)))))
 786       (multiple-value-bind (body documentation declarations)
 787           (parse-lambda-headers body :doc-string-allowed nil)
 788         (declare (ignore documentation))
 789         (let* ((specials (declared-specials declarations))
 790                (new-env (make-env :parent env
 791                                   :vars (special-bindings specials env)
 792                                   :funs (mapcar #'generate-fbinding
 793                                                 local-functions)
 794                                   :expanders (mapcar #'generate-mbinding
 795                                                      local-functions)
 796                                   :declarations declarations)))
 797           (eval-progn body new-env))))))
 798
 799 (defun eval-symbol-macrolet (body env)
 800   (program-destructuring-bind ((&rest bindings) &body body) body
 801     (flet ((generate-binding (binding)
 802              (cons (car binding) *symbol-macro*))
 803            (generate-sm-binding (binding)
 804              (let ((name (car binding))
 805                    (sb!c:*lexenv* (env-native-lexenv env)))
 806                (when (or (boundp name)
 807                          (eq (sb!int:info :variable :kind name) :macro))
 808                  (program-assert-symbol-home-package-unlocked
 809                   :eval name "binding ~A as a local symbol-macro"))
 810                (cons name (second binding)))))
 811       (multiple-value-bind (body documentation declarations)
 812           (parse-lambda-headers body :doc-string-allowed nil)
 813         (declare (ignore documentation))
 814         (let ((specials (declared-specials declarations)))
 815           (dolist (binding bindings)
 816             (when (specialp (binding-name binding) specials)
 817               (ip-error "~@<Can't bind SYMBOL-MACROLET of special ~
 818                          variable ~S.~:@>"
 819                         (binding-name binding)))))
 820         (let* ((specials (declared-specials declarations))
 821                (new-env (make-env :parent env
 822                                   :vars (nconc-2 (mapcar #'generate-binding
 823                                                          bindings)
 824                                                  (special-bindings specials env))
 825                                   :symbol-expansions (mapcar
 826                                                       #'generate-sm-binding
 827                                                       bindings)
 828                                   :declarations declarations)))
 829           (eval-progn body new-env))))))
 830
 831 (defun eval-progv (body env)
 832   (program-destructuring-bind (vars vals &body body) body
 833     (progv (%eval vars env) (%eval vals env)
 834       (eval-progn body env))))
 835
 836 (defun eval-function (body env)
 837   (program-destructuring-bind (name) body
 838     (cond
 839       ;; LAMBDAP assumes that the argument is a cons, so we need the
 840       ;; initial symbol case, instead of relying on the fall-through
 841       ;; case that has the same function body.
 842       ((symbolp name) (nth-value 0 (get-function name env)))
 843       ((lambdap name) (eval-lambda name env))
 844       (t (nth-value 0 (get-function name env))))))
 845
 846 (defun eval-eval-when (body env)
 847   (program-destructuring-bind ((&rest situation) &body body) body
 848     ;; FIXME: check that SITUATION only contains valid situations
 849     (if (or (member :execute situation)
 850             (member 'eval situation))
 851         (eval-progn body env))))
 852
 853 (defun eval-quote (body env)
 854   (declare (ignore env))
 855   (program-destructuring-bind (object) body
 856     object))
 857
 858 (defun eval-setq (pairs env)
 859   (when (oddp (length pairs))
 860     (ip-error "~@<Odd number of args to SETQ: ~S~:@>" (cons 'setq pairs)))
 861   (let ((last nil))
 862     (loop for (var new-val) on pairs by #'cddr do
 863           (handler-case
 864               (multiple-value-bind (expansion type) (get-variable var env)
 865                 (ecase type
 866                   (:expansion
 867                    (setf last
 868                          (%eval (list 'setf expansion new-val) env)))
 869                   (:variable
 870                    (setf last (set-variable var (%eval new-val env)
 871                                             env)))))
 872             (unbound-variable (c)
 873               (declare (ignore c))
 874               (setf last (setf (symbol-value var)
 875                                (%eval new-val env))))))
 876     last))
 877
 878 (defun eval-multiple-value-call (body env)
 879   (program-destructuring-bind (function-form &body forms) body
 880     (%apply (%eval function-form env)
 881             (loop for form in forms
 882                   nconc (multiple-value-list (%eval form env))))))
 883
 884 (defun eval-multiple-value-prog1 (body env)
 885   (program-destructuring-bind (first-form &body forms) body
 886     (multiple-value-prog1 (%eval first-form env)
 887       (eval-progn forms env))))
 888
 889 (defun eval-catch (body env)
 890   (program-destructuring-bind (tag &body forms) body
 891     (catch (%eval tag env)
 892       (eval-progn forms env))))
 893
 894 (defun eval-tagbody (body old-env)
 895   (let ((env (make-env :parent old-env))
 896         (tags nil)
 897         (start body)
 898         (target-tag nil))
 899     (tagbody
 900        (flet ((go-to-tag (tag)
 901                 (setf target-tag tag)
 902                 (go go-to-tag)))
 903          ;; For each tag, store a trampoline function into the environment
 904          ;; and the location in the body into the TAGS alist.
 905          (do ((form body (cdr form)))
 906              ((null form) nil)
 907            (when (atom (car form))
 908              (when (assoc (car form) tags)
 909                (ip-error "The tag :A appears more than once in a tagbody."))
 910              (push (cons (car form) (cdr form)) tags)
 911              (push (cons (car form) #'go-to-tag) (env-tags env)))))
 912        ;; And then evaluate the forms in the body, starting from the
 913        ;; first one.
 914        (go execute)
 915      go-to-tag
 916        ;; The trampoline has set the TARGET-TAG. Restart evaluation of
 917        ;; the body from the location in body that matches the tag.
 918        (setf start (cdr (assoc target-tag tags)))
 919      execute
 920        (dolist (form start)
 921          (when (not (atom form))
 922            (%eval form env))))))
 923
 924 (defun eval-go (body env)
 925   (program-destructuring-bind (tag) body
 926     (let ((target (get-tag-binding tag env)))
 927       (if target
 928           ;; Call the GO-TO-TAG trampoline
 929           (funcall (cdr target) tag)
 930           (ip-error "~@<Attempt to GO to nonexistent tag: ~S~:@>" tag)))))
 931
 932 (defun eval-block (body old-env)
 933   (flet ((return-from-eval-block (&rest values)
 934            (return-from eval-block (values-list values))))
 935     (program-destructuring-bind (name &body body) body
 936       (unless (symbolp name)
 937         (ip-error "~@<The block name ~S is not a symbol.~:@>" name))
 938       (let ((env (make-env
 939                   :blocks (list (cons name #'return-from-eval-block))
 940                   :parent old-env)))
 941         (eval-progn body env)))))
 942
 943 (defun eval-return-from (body env)
 944   (program-destructuring-bind (name &optional result) body
 945     (let ((target (get-block-binding name env)))
 946       (if target
 947           (multiple-value-call (cdr target) (%eval result env))
 948           (ip-error "~@<Return for unknown block: ~S~:@>" name)))))
 949
 950 (defun eval-the (body env)
 951   (program-destructuring-bind (value-type form) body
 952     (declare (ignore value-type))
 953     ;; FIXME: We should probably check the types here, even though
 954     ;; the consequences of the values not being of the asserted types
 955     ;; are formally undefined.
 956     (%eval form env)))
 957
 958 (defun eval-unwind-protect (body env)
 959   (program-destructuring-bind (protected-form &body cleanup-forms) body
 960     (unwind-protect (%eval protected-form env)
 961       (eval-progn cleanup-forms env))))
 962
 963 (defun eval-throw (body env)
 964   (program-destructuring-bind (tag result-form) body
 965     (throw (%eval tag env)
 966       (%eval result-form env))))
 967
 968 (defun eval-load-time-value (body env)
 969   (program-destructuring-bind (form &optional read-only-p) body
 970     (declare (ignore read-only-p))
 971     (%eval form env)))
 972
 973 (defun eval-locally (body env)
 974   (multiple-value-bind (body documentation declarations)
 975       (parse-lambda-headers body :doc-string-allowed nil)
 976     (declare (ignore documentation))
 977     (let* ((specials (declared-specials declarations))
 978            (new-env (if (or specials declarations)
 979                         (make-env :parent env
 980                                   :vars (special-bindings specials env)
 981                                   :declarations declarations)
 982                         env)))
 983       (eval-progn body new-env))))
 984
 985 (defun eval-args (args env)
 986   (mapcar #'(lambda (arg) (%eval arg env)) args))
 987
 988 ;;; The expansion of SB-SYS:WITH-PINNED-OBJECTS on GENCGC uses some
 989 ;;; VOPs which can't be reasonably implemented in the interpreter. So
 990 ;;; we special-case the macro.
 991 (defun eval-with-pinned-objects (args env)
 992   (program-destructuring-bind (values &body body) args
 993     (if (null values)
 994         (eval-progn body env)
 995         (sb!sys:with-pinned-objects ((car values))
 996           (eval-with-pinned-objects (cons (cdr values) body) env)))))
 997
 998 (define-condition macroexpand-hook-type-error (type-error)
 999   ()
1000   (:report (lambda (condition stream)
1001              (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~A"
1002                      (type-error-datum condition)))))
1003
1004 (defvar *eval-dispatch-functions* nil)
1005
1006 ;;; Dispatch to the appropriate EVAL-FOO function based on the contents of EXP.
1007 (declaim (inline %%eval))
1008 (defun %%eval (exp env)
1009   (cond
1010     ((symbolp exp)
1011      ;; CLHS 3.1.2.1.1 Symbols as Forms
1012      (multiple-value-bind (value kind) (get-variable exp env)
1013        (ecase kind
1014          (:variable value)
1015          (:expansion (%eval value env)))))
1016     ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
1017     ((atom exp) exp)
1018     ;; CLHS 3.1.2.1.2 Conses as Forms
1019     ((consp exp)
1020      (case (car exp)
1021        ;; CLHS 3.1.2.1.2.1 Special Forms
1022        ((block)                (eval-block (cdr exp) env))
1023        ((catch)                (eval-catch (cdr exp) env))
1024        ((eval-when)            (eval-eval-when (cdr exp) env))
1025        ((flet)                 (eval-flet (cdr exp) env))
1026        ((function)             (eval-function (cdr exp) env))
1027        ((go)                   (eval-go (cdr exp) env))
1028        ((if)                   (eval-if (cdr exp) env))
1029        ((labels)               (eval-labels (cdr exp) env))
1030        ((let)                  (eval-let (cdr exp) env))
1031        ((let*)                 (eval-let* (cdr exp) env))
1032        ((load-time-value)      (eval-load-time-value (cdr exp) env))
1033        ((locally)              (eval-locally (cdr exp) env))
1034        ((macrolet)             (eval-macrolet (cdr exp) env))
1035        ((multiple-value-call)  (eval-multiple-value-call (cdr exp) env))
1036        ((multiple-value-prog1) (eval-multiple-value-prog1 (cdr exp) env))
1037        ((progn)                (eval-progn (cdr exp) env))
1038        ((progv)                (eval-progv (cdr exp) env))
1039        ((quote)                (eval-quote (cdr exp) env))
1040        ((return-from)          (eval-return-from (cdr exp) env))
1041        ((setq)                 (eval-setq (cdr exp) env))
1042        ((symbol-macrolet)      (eval-symbol-macrolet (cdr exp) env))
1043        ((tagbody)              (eval-tagbody (cdr exp) env))
1044        ((the)                  (eval-the (cdr exp) env))
1045        ((throw)                (eval-throw (cdr exp) env))
1046        ((unwind-protect)       (eval-unwind-protect (cdr exp) env))
1047        ;; SBCL-specific:
1048        ((sb!ext:truly-the)     (eval-the (cdr exp) env))
1049        ;; Not a special form, but a macro whose expansion wouldn't be
1050        ;; handled correctly by the evaluator.
1051        ((sb!sys:with-pinned-objects) (eval-with-pinned-objects (cdr exp) env))
1052        (t
1053         (let ((dispatcher (getf *eval-dispatch-functions* (car exp))))
1054           (cond
1055             (dispatcher
1056              (funcall dispatcher exp env))
1057             ;; CLHS 3.1.2.1.2.4 Lambda Forms
1058             ((and (consp (car exp)) (eq (caar exp) 'lambda))
1059              (interpreted-apply (eval-function (list (car exp)) env)
1060                                 (eval-args (cdr exp) env)))
1061             (t
1062              (multiple-value-bind (function kind) (get-function (car exp) env)
1063                (ecase kind
1064                  ;; CLHS 3.1.2.1.2.3 Function Forms
1065                  (:function (%apply function (eval-args (cdr exp) env)))
1066                  ;; CLHS 3.1.2.1.2.2 Macro Forms
1067                  (:macro
1068                   (let ((hook *macroexpand-hook*))
1069                     ;; Having an interpreted function as the
1070                     ;; macroexpander hook could cause an infinite
1071                     ;; loop.
1072                     (unless (compiled-function-p
1073                              (etypecase hook
1074                                (function hook)
1075                                (symbol (symbol-function hook))))
1076                       (error 'macroexpand-hook-type-error
1077                              :datum hook
1078                              :expected-type 'compiled-function))
1079                     (%eval (funcall hook
1080                                     function
1081                                     exp
1082                                     (env-native-lexenv env))
1083                            env)))))))))))))
1084
1085 (defun %eval (exp env)
1086   (incf *eval-calls*)
1087   (if *eval-verbose*
1088       ;; Dynamically binding *EVAL-LEVEL* will prevent tail call
1089       ;; optimization. So only do it when its value will be used for
1090       ;; printing debug output.
1091       (let ((*eval-level* (1+ *eval-level*)))
1092         (let ((*print-circle* t))
1093           (format t "~&~vA~S~%" *eval-level* "" `(%eval ,exp)))
1094         (%%eval exp env))
1095       (%%eval exp env)))
1096
1097 (defun %apply (fun args)
1098   (etypecase fun
1099     (interpreted-function (interpreted-apply fun args))
1100     (function (apply fun args))
1101     (symbol (apply fun args))))
1102
1103 (defun interpreted-apply (fun args)
1104   (let ((lambda-list (interpreted-function-lambda-list fun))
1105         (env (interpreted-function-env fun))
1106         (body (interpreted-function-body fun))
1107         (declarations (interpreted-function-declarations fun)))
1108     (call-with-new-env-full-parsing
1109      env lambda-list args declarations
1110      #'(lambda (env)
1111          (eval-progn body env)))))
1112
1113 ;;; We need separate conditions for the different *-TOO-COMPLEX-ERRORs to
1114 ;;; avoid spuriously triggering the handler in EVAL-IN-NATIVE-ENVIRONMENT
1115 ;;; on code like:
1116 ;;;
1117 ;;;   (let ((sb-ext:*evaluator-mode* :interpret))
1118 ;;;     (let ((fun (eval '(let ((a 1)) (lambda () a)))))
1119 ;;;         (eval `(compile nil ,fun))))
1120 ;;;
1121 ;;; FIXME: should these be exported?
1122 (define-condition interpreter-environment-too-complex-error (simple-error)
1123   ())
1124 (define-condition compiler-environment-too-complex-error (simple-error)
1125   ())
1126
1127 ;;; Try to compile an interpreted function. If the environment
1128 ;;; contains local functions or lexical variables we'll punt on
1129 ;;; compiling it.
1130 (defun prepare-for-compile (function)
1131   (let ((env (interpreted-function-env function)))
1132     (when (or (env-tags env)
1133               (env-blocks env)
1134               (find-if-not #'(lambda (x) (eq x *macro*))
1135                            (env-funs env) :key #'cdr)
1136               (find-if-not #'(lambda (x) (eq x *symbol-macro*))
1137                            (env-vars env)
1138                            :key #'cdr))
1139       (error 'interpreter-environment-too-complex-error
1140              :format-control
1141              "~@<Lexical environment of ~S is too complex to compile.~:@>"
1142              :format-arguments
1143              (list function)))
1144     (values
1145      `(sb!int:named-lambda ,(interpreted-function-name function)
1146           ,(interpreted-function-lambda-list function)
1147         (declare ,@(interpreted-function-declarations function))
1148         ,@(interpreted-function-body function))
1149      (env-native-lexenv env))))
1150
1151 ;;; Convert a compiler LEXENV to an interpreter ENV. This is needed
1152 ;;; for EVAL-IN-LEXENV.
1153 (defun make-env-from-native-environment (lexenv)
1154   (let ((native-funs (sb!c::lexenv-funs lexenv))
1155         (native-vars (sb!c::lexenv-vars lexenv)))
1156     (flet ((is-macro (thing)
1157              (and (consp thing) (eq (car thing) 'sb!sys:macro))))
1158       (when (or (sb!c::lexenv-blocks lexenv)
1159                 (sb!c::lexenv-cleanup lexenv)
1160                 (sb!c::lexenv-lambda lexenv)
1161                 (sb!c::lexenv-tags lexenv)
1162                 (sb!c::lexenv-type-restrictions lexenv)
1163                 (find-if-not #'is-macro native-funs :key #'cdr)
1164                 (find-if-not #'is-macro native-vars :key #'cdr))
1165         (error 'compiler-environment-too-complex-error
1166                :format-control
1167                "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
1168                :format-arguments
1169                (list lexenv))))
1170     (flet ((make-binding (native)
1171              (cons (car native) *symbol-macro*))
1172            (make-sm-binding (native)
1173              (cons (car native) (cddr native)))
1174            (make-fbinding (native)
1175              (cons (car native) *macro*))
1176            (make-mbinding (native)
1177              (cons (car native) (cddr native))))
1178       (%make-env nil
1179                  (mapcar #'make-binding native-vars)
1180                  (mapcar #'make-fbinding native-funs)
1181                  (mapcar #'make-mbinding native-funs)
1182                  (mapcar #'make-sm-binding native-vars)
1183                  nil
1184                  nil
1185                  nil
1186                  lexenv))))
1187
1188 (defun eval-in-environment (form env)
1189   (%eval form env))
1190
1191 (defun eval-in-native-environment (form lexenv)
1192   (handler-bind
1193       ((sb!impl::eval-error
1194          (lambda (condition)
1195            (error 'interpreted-program-error
1196                   :condition (sb!int:encapsulated-condition condition)
1197                   :form form))))
1198     (sb!c:with-compiler-error-resignalling
1199       (handler-case
1200           (let ((env (make-env-from-native-environment lexenv)))
1201             (%eval form env))
1202         (compiler-environment-too-complex-error (condition)
1203           (declare (ignore condition))
1204           (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex
1205                              :form form :lexenv lexenv)
1206           (sb!int:simple-eval-in-lexenv form lexenv))))))