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