+
+(declaim (inline random-fixnum))
+(defun random-fixnum ()
+ (random (1+ most-positive-fixnum)))
+
+(defconstant n-fixnum-bits #.(integer-length most-positive-fixnum))
+
+;;; Lambda which executes its body (or not) randomly. Used to drop
+;;; random cache entries.
+(defmacro randomly-punting-lambda (lambda-list &body body)
+ (with-unique-names (drops drop-pos)
+ `(let ((,drops (random-fixnum))
+ (,drop-pos n-fixnum-bits))
+ (declare (fixnum ,drops)
+ (type (integer 0 #.n-fixnum-bits) ,drop-pos))
+ (lambda ,lambda-list
+ (when (logbitp (the unsigned-byte (decf ,drop-pos)) ,drops)
+ (locally ,@body))
+ (when (zerop ,drop-pos)
+ (setf ,drops (random-fixnum)
+ ,drop-pos n-fixnum-bits))))))
+\f
+;;;; early definition of WRAPPER
+;;;;
+;;;; Most WRAPPER stuff is defined later, but the DEFSTRUCT itself
+;;;; is here early so that things like (TYPEP .. 'WRAPPER) can be
+;;;; compiled efficiently.
+
+;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or
+;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but
+;;; this shouldn't matter, since the only two slots that WRAPPER adds
+;;; are meaningless in those cases.
+(defstruct (wrapper
+ (:include layout
+ ;; KLUDGE: In CMU CL, the initialization default
+ ;; for LAYOUT-INVALID was NIL. In SBCL, that has
+ ;; changed to :UNINITIALIZED, but PCL code might
+ ;; still expect NIL for the initialization
+ ;; default of WRAPPER-INVALID. Instead of trying
+ ;; to find out, I just overrode the LAYOUT
+ ;; default here. -- WHN 19991204
+ (invalid nil)
+ ;; This allows quick testing of wrapperness.
+ (for-std-class-p t))
+ (:constructor make-wrapper-internal)
+ (:copier nil))
+ (instance-slots-layout nil :type list)
+ (class-slots nil :type list))
+#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
+\f
+;;;; PCL's view of funcallable instances
+
+(!defstruct-with-alternate-metaclass standard-funcallable-instance
+ ;; KLUDGE: Note that neither of these slots is ever accessed by its
+ ;; accessor name as of sbcl-0.pre7.63. Presumably everything works
+ ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
+ :slot-names (clos-slots name hash-code)
+ :boa-constructor %make-standard-funcallable-instance
+ :superclass-name function
+ :metaclass-name standard-classoid
+ :metaclass-constructor make-standard-classoid
+ :dd-type funcallable-structure
+ ;; Only internal implementation code will access these, and these
+ ;; accesses (slot readers in particular) could easily be a
+ ;; bottleneck, so it seems reasonable to suppress runtime type
+ ;; checks.
+ ;;
+ ;; (Except note KLUDGE above that these accessors aren't used at all
+ ;; (!) as of sbcl-0.pre7.63, so for now it's academic.)
+ :runtime-type-checks-p nil)
+
+(import 'sb-kernel:funcallable-instance-p)
+
+(defun set-funcallable-instance-function (fin new-value)
+ (declare (type function new-value))
+ (aver (funcallable-instance-p fin))
+ (setf (funcallable-instance-fun fin) new-value))
+
+;;; FIXME: these macros should just go away. It's not clear whether
+;;; the inline functions defined by
+;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS are as efficient as they could
+;;; be; ordinary defstruct accessors are defined as source transforms.
+(defun fsc-instance-p (fin)
+ (funcallable-instance-p fin))
+(define-compiler-macro fsc-instance-p (fin)
+ `(funcallable-instance-p ,fin))
+(defmacro fsc-instance-wrapper (fin)
+ `(%funcallable-instance-layout ,fin))
+(defmacro fsc-instance-slots (fin)
+ `(%funcallable-instance-info ,fin 1))
+(defmacro fsc-instance-hash (fin)
+ `(%funcallable-instance-info ,fin 3))