Utility predicates for packing: UNBOUNDED-SC-P and UNBOUNDED-TN-P

[sbcl.git] / src / pcl / low.lisp

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index db01419..0d06027 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -39,7 +39,7 @@
 \f
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defvar *optimize-speed*
-  '(optimize (speed 3) (safety 0)))
+  '(optimize (speed 3) (safety 0) (sb-ext:inhibit-warnings 3)))
 ) ; EVAL-WHEN
 
 (defmacro dotimes-fixnum ((var count &optional (result nil)) &body body)
@@ -51,22 +51,20 @@
 (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))
+           (,drop-pos sb-vm:n-fixnum-bits))
        (declare (fixnum ,drops)
-                (type (integer 0 #.n-fixnum-bits) ,drop-pos))
+                (type (integer 0 #.sb-vm: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))))))
+                 ,drop-pos sb-vm:n-fixnum-bits))))))
 \f
 ;;;; early definition of WRAPPER
 ;;;;
@@ -92,8 +90,7 @@
                       (for-std-class-p t))
             (:constructor make-wrapper-internal)
             (:copier nil))
-  (instance-slots-layout nil :type list)
-  (class-slots nil :type list))
+  (slots () :type list))
 #-sb-fluid (declaim (sb-ext:freeze-type wrapper))
 \f
 ;;;; PCL's view of funcallable instances
@@ -120,8 +117,14 @@
 (import 'sb-kernel:funcallable-instance-p)
 
 (defun set-funcallable-instance-function (fin new-value)
-  (declare (type function new-value))
-  (aver (funcallable-instance-p fin))
+  (declare (type function new-value)
+           ;; KLUDGE: it might be nice to restrict
+           ;; SB-MOP:SET-FUNCALLABLE-INSTANCE-FUNCTION to operate only
+           ;; on generalized instances of
+           ;; SB-MOP:FUNCALLABLE-STANDARD-OBJECT; at present, even
+           ;; PCL's internal use of SET-FUNCALLABLE-INSTANCE-FUNCTION
+           ;; doesn't obey this restriction.
+           (type funcallable-instance fin))
   (setf (funcallable-instance-fun fin) new-value))
 
 ;;; FIXME: these macros should just go away.  It's not clear whether
@@ -179,7 +182,7 @@
 ;;; otherwise dealing with STANDARD-INSTANCE-ACCESS becomes harder
 ;;; -- and slower -- than it needs to be.
 (defconstant +slot-unbound+ '..slot-unbound..
-  "SBCL specific extentions to MOP: if this value is read from an
+  "SBCL specific extensions to MOP: if this value is read from an
 instance using STANDARD-INSTANCE-ACCESS, the slot is unbound.
 Similarly, an :INSTANCE allocated slot can be made unbound by
 assigning this to it using (SETF STANDARD-INSTANCE-ACCESS).
@@ -351,6 +354,12 @@ comparison.")
                        (member (dsd-name included-slot) slot-overrides :test #'eq))
               collect slot)))))
 
+(defun uninitialized-accessor-function (type slotd)
+  (lambda (&rest args)
+    (declare (ignore args))
+    (error "~:(~A~) function~@[ for ~S ~] not yet initialized."
+           type slotd)))
+
 (defun structure-slotd-name (slotd)
   (dsd-name slotd))
 
@@ -358,13 +367,19 @@ comparison.")
   (dsd-accessor-name slotd))
 
 (defun structure-slotd-reader-function (slotd)
-  (fdefinition (dsd-accessor-name slotd)))
+  (let ((name (dsd-accessor-name slotd)))
+    (if (fboundp name)
+        (fdefinition name)
+        (uninitialized-accessor-function :reader slotd))))
 
 (defun structure-slotd-writer-function (type slotd)
   (if (dsd-read-only slotd)
       (let ((dd (find-defstruct-description type)))
         (coerce (slot-setter-lambda-form dd slotd) 'function))
-      (fdefinition `(setf ,(dsd-accessor-name slotd)))))
+      (let ((name `(setf ,(dsd-accessor-name slotd))))
+        (if (fboundp name)
+            (fdefinition name)
+            (uninitialized-accessor-function :writer slotd)))))
 
 (defun structure-slotd-type (slotd)
   (dsd-type slotd))