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