1.0.2.20:

[sbcl.git] / src / code / class.lisp

diff --git a/src/code/class.lisp b/src/code/class.lisp
index dc0b524..4e06f52 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -847,6 +847,11 @@ NIL is returned when no such class exists."
     (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.
@@ -908,6 +913,22 @@ NIL is returned when no such class exists."
          ;; uncertain, since a subclass of both might be defined
          nil)))
 
+;;; KLUDGE: we need this for the special-case SEQUENCE type, which
+;;; (because of multiple inheritance with ARRAY for the VECTOR types)
+;;; doesn't have the nice hierarchical properties we want.  This is
+;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for
+;;; SEQUENCE/ARRAY interactions.
+(!define-type-method (classoid :complex-intersection2) (type1 class2)
+  (cond
+    ((and (eq class2 (find-classoid 'sequence))
+          (array-type-p type1))
+     (type-intersection2 (specifier-type 'vector) type1))
+    (t
+     (let ((method (type-class-complex-intersection2 (type-class-info type1))))
+       (if (and method (not (eq method #'delegate-complex-intersection2)))
+           :call-other-method
+           (hierarchical-intersection2 type1 class2))))))
+
 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
 ;;; discovered that this was incompatible with the MOP class
@@ -945,10 +966,10 @@ NIL is returned when no such class exists."
 ;;; FUNCALLABLE-STANDARD-CLASS.
 (def!struct (standard-classoid (:include classoid)
                                (:constructor make-standard-classoid)))
-;;; a metaclass for miscellaneous PCL structure-like objects (at the
-;;; moment, only CTOR objects).
-(def!struct (random-pcl-classoid (:include 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)))
 \f
 ;;;; built-in classes
 
@@ -1091,7 +1112,8 @@ NIL is returned when no such class exists."
       :inherits (array)
       :prototype-form (make-array nil))
      (sequence
-      :translation (or cons (member nil) vector))
+      :state :read-only
+      :depth 2)
      (vector
       :translation vector :codes (#.sb!vm:complex-vector-widetag)
       :direct-superclasses (array sequence)