X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=c3af80d3fceb023ca87b42b4ddf204a44066098b;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=c0d7ed0e6b530134787ff41941ee9fdf90c705eb;hpb=dbfdac9e56e044b1df898bcb7e1763997b03efa2;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index c0d7ed0..c3af80d 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -772,7 +772,18 @@ NIL is returned when no such class exists."
 
      (remhash name *forward-referenced-layouts*)
      (%note-type-defined name)
-     (setf (info :type :kind name) :instance)
+     ;; we need to handle things like
+     ;;   (setf (find-class 'foo) (find-class 'integer))
+     ;; and
+     ;;   (setf (find-class 'integer) (find-class 'integer))
+     (cond
+       ((built-in-classoid-p new-value)
+        (setf (info :type :kind name) (or (info :type :kind name) :defined))
+        (let ((translation (built-in-classoid-translation new-value)))
+          (when translation
+            (setf (info :type :translator name)
+                  (lambda (c) (declare (ignore c)) translation)))))
+       (t (setf (info :type :kind name) :instance)))
      (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
      (unless (eq (info :type :compiler-layout name)
                  (classoid-layout new-value))
@@ -809,6 +820,38 @@ NIL is returned when no such class exists."
 
 (!define-type-class classoid)
 
+;;; We might be passed classoids with invalid layouts; in any pairwise
+;;; class comparison, we must ensure that both are valid before
+;;; proceeding.
+(defun ensure-classoid-valid (classoid layout)
+  (aver (eq classoid (layout-classoid layout)))
+  (when (layout-invalid layout)
+    (if (typep classoid 'standard-classoid)
+        (let ((class (classoid-pcl-class classoid)))
+          (cond
+            ((sb!pcl:class-finalized-p class)
+             (sb!pcl::force-cache-flushes class))
+            ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
+             (error "Invalid, unfinalizeable class ~S (classoid ~S)."
+                    class classoid))
+            (t (sb!pcl:finalize-inheritance class))))
+        (error "Don't know how to ensure validity of ~S (not ~
+                a STANDARD-CLASSOID)." classoid))))
+
+(defun ensure-both-classoids-valid (class1 class2)
+  (do ((layout1 (classoid-layout class1) (classoid-layout class1))
+       (layout2 (classoid-layout class2) (classoid-layout class2))
+       (i 0 (+ i 1)))
+      ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
+    (aver (< i 2))
+    (ensure-classoid-valid class1 layout1)
+    (ensure-classoid-valid class2 layout2)))
+
+(defun update-object-layout-or-invalid (object layout)
+  (if (typep (classoid-of object) 'standard-classoid)
+      (sb!pcl::check-wrapper-validity object)
+      (%layout-invalid-error object layout)))
+
 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 ;;; the two classes are equal, since there are EQ checks in those
 ;;; operations.
@@ -818,6 +861,7 @@ NIL is returned when no such class exists."
 
 (!define-type-method (classoid :simple-subtypep) (class1 class2)
   (aver (not (eq class1 class2)))
+  (ensure-both-classoids-valid class1 class2)
   (let ((subclasses (classoid-subclasses class2)))
     (if (and subclasses (gethash class1 subclasses))
         (values t t)
@@ -841,6 +885,7 @@ NIL is returned when no such class exists."
 
 (!define-type-method (classoid :simple-intersection2) (class1 class2)
   (declare (type classoid class1 class2))
+  (ensure-both-classoids-valid class1 class2)
   (cond ((eq class1 class2)
          class1)
         ;; If one is a subclass of the other, then that is the
@@ -899,12 +944,16 @@ NIL is returned when no such class exists."
 
 ;;;; PCL stuff
 
-(def!struct (std-classoid (:include classoid)
-                          (:constructor nil)))
-(def!struct (standard-classoid (:include std-classoid)
+;;; the CLASSOID that we use to represent type information for
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.  The type system
+;;; side does not need to distinguish between STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
+(def!struct (standard-classoid (:include classoid)
                                (:constructor make-standard-classoid)))
-(def!struct (random-pcl-classoid (:include std-classoid)
-                                 (:constructor make-random-pcl-classoid)))
+;;; a metaclass for classes which aren't standardlike but will never
+;;; change either.
+(def!struct (static-classoid (:include classoid)
+                             (:constructor make-static-classoid)))
 
 ;;;; built-in classes
 
@@ -1474,8 +1523,11 @@ NIL is returned when no such class exists."
                 (dolist (code codes)
                   (setf (svref res code) layout)))))))
   (setq *null-classoid-layout*
-        (locally
-            (declare (notinline find-classoid))
+        ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to
+        ;; work around a bug in the LOCALLY handling in the fopcompiler
+        ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16
+        (let ()
+          (declare (notinline find-classoid))
           (classoid-layout (find-classoid 'null))))
   #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))