src/code/early-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 (defparameter *eval-level* -1)
  15 (defparameter *eval-calls* 0)
  16 (defparameter *eval-verbose* nil)
  17
  18 (defun !full-eval-cold-init ()
  19   (setf *eval-level* -1
  20         *eval-calls* 0
  21         *eval-verbose* nil
  22         *evaluator-mode* :compile))
  23
  24 ;; !defstruct-with-alternate-metaclass is unslammable and the
  25 ;; RECOMPILE restart doesn't work on it.  This is the main reason why
  26 ;; this stuff is split out into its own file.  Also, it lets the
  27 ;; INTERPRETED-FUNCTION type be declared before it is used in
  28 ;; compiler/main and code/deftypes-for-target.
  29 (sb!kernel::!defstruct-with-alternate-metaclass
  30  interpreted-function
  31  :slot-names (name lambda-list env declarations documentation body source-location)
  32  :boa-constructor %make-interpreted-function
  33  :superclass-name function
  34  :metaclass-name static-classoid
  35  :metaclass-constructor make-static-classoid
  36  :dd-type funcallable-structure
  37  :runtime-type-checks-p nil)
  38
  39 #-sb-xc-host
  40 (progn
  41   (defun make-interpreted-function
  42       (&key name lambda-list env declarations documentation body source-location)
  43     (let ((function (%make-interpreted-function
  44                      name lambda-list env declarations documentation body
  45                      source-location)))
  46       (setf (sb!kernel:funcallable-instance-fun function)
  47             #'(lambda (&rest args)
  48                 (interpreted-apply function args)))
  49       function))
  50
  51   (defun interpreted-function-p (function)
  52     (typep function 'interpreted-function))
  53
  54   (sb!int:def!method print-object ((obj interpreted-function) stream)
  55     (print-unreadable-object (obj stream
  56                               :identity (not (interpreted-function-name obj)))
  57       (format stream "~A ~A" '#:interpreted-function
  58               (interpreted-function-name obj)))))