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