0.6.12.33:

	added a few more type test regression tests
	merged MNA port of DTC CMU CL inline type test patches
		(sbcl-devel 2001-05-28)

package-data-list.lisp-expr

@@ -1262,7 +1262,8 @@ is a good idea, but see SB-SYS for blurring of boundaries."
              "MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
              "BYTE-FUNCTION-TYPE"
              "REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
-             "INSURED-FIND-CLASS"
+             "INSURED-FIND-CLASS" "ORDER-LAYOUT-INHERITS"
+             "STD-COMPUTE-CLASS-PRECEDENCE-LIST"
 
              ;; symbols from former SB!CONDITIONS
              "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*"

src/code/class.lisp

@@ -514,7 +514,130 @@
 
   (values))
 ); EVAL-WHEN
+
+;;; Arrange the inherited layouts to appear at their expected depth,
+;;; ensuring that hierarchical type tests succeed. Layouts with a
+;;; specific depth are placed first, then the non- hierarchical
+;;; layouts fill remaining elements. Any empty elements are filled
+;;; with layout copies ensuring that all elements have a valid layout.
+;;; This re-ordering may destroy CPL ordering so the inherits should
+;;; not be read as being in CPL order, and further duplicates may be
+;;; introduced.
+(defun order-layout-inherits (layouts)
+  (declare (simple-vector layouts))
+  (let ((length (length layouts))
+	(max-depth -1))
+    (dotimes (i length)
+      (let ((depth (layout-depthoid (svref layouts i))))
+	(when (> depth max-depth)
+	  (setf max-depth depth))))
+    (let* ((new-length (max (1+ max-depth) length))
+	   (inherits (make-array new-length)))
+      (dotimes (i length)
+	(let* ((layout (svref layouts i))
+	       (depth (layout-depthoid layout)))
+	  (unless (eql depth -1)
+	    (let ((old-layout (svref inherits depth)))
+	      (unless (or (eql old-layout 0) (eq old-layout layout))
+		(error "layout depth conflict: ~S~%" layouts)))
+	    (setf (svref inherits depth) layout))))
+      (do ((i 0 (1+ i))
+	   (j 0))
+	  ((>= i length))
+	(declare (type index i j))
+	(let* ((layout (svref layouts i))
+	       (depth (layout-depthoid layout)))
+	  (when (eql depth -1)
+	    (loop (when (eql (svref inherits j) 0)
+		    (return))
+		  (incf j))
+	    (setf (svref inherits j) layout))))
+      (do ((i (1- new-length) (1- i)))
+	  ((< i 0))
+	(declare (type fixnum i))
+	(when (eql (svref inherits i) 0)
+	  (setf (svref inherits i) (svref inherits (1+ i)))))
+      inherits)))
+
+;;;; class precedence lists
+
+;;; Topologically sort the list of objects to meet a set of ordering
+;;; constraints given by pairs (A . B) constraining A to precede B.
+;;; When there are multiple objects to choose, the tie-breaker
+;;; function is called with both the list of object to choose from and
+;;; the reverse ordering built so far.
+(defun topological-sort (objects constraints tie-breaker)
+  (declare (list objects constraints)
+	   (function tie-breaker))
+  (let ((obj-info (make-hash-table :size (length objects)))
+	(free-objs nil)
+	(result nil))
+    (dolist (constraint constraints)
+      (let ((obj1 (car constraint))
+	    (obj2 (cdr constraint)))
+	(let ((info2 (gethash obj2 obj-info)))
+	  (if info2
+	      (incf (first info2))
+	      (setf (gethash obj2 obj-info) (list 1))))
+	(let ((info1 (gethash obj1 obj-info)))
+	  (if info1
+	      (push obj2 (rest info1))
+	      (setf (gethash obj1 obj-info) (list 0 obj2))))))
+    (dolist (obj objects)
+      (let ((info (gethash obj obj-info)))
+	(when (or (not info) (zerop (first info)))
+	  (push obj free-objs))))
+    (loop
+     (flet ((next-result (obj)
+	      (push obj result)
+	      (dolist (successor (rest (gethash obj obj-info)))
+		(let* ((successor-info (gethash successor obj-info))
+		       (count (1- (first successor-info))))
+		  (setf (first successor-info) count)
+		  (when (zerop count)
+		    (push successor free-objs))))))
+       (cond ((endp free-objs)
+	      (dohash (obj info obj-info)
+		(unless (zerop (first info))
+		  (error "Topological sort failed due to constraint on ~S."
+			 obj)))
+	      (return (nreverse result)))
+	     ((endp (rest free-objs))
+	      (next-result (pop free-objs)))
+	     (t
+	      (let ((obj (funcall tie-breaker free-objs result)))
+		(setf free-objs (remove obj free-objs))
+		(next-result obj))))))))
+
+
+;;; standard class precedence list computation
+(defun std-compute-class-precedence-list (class)
+  (let ((classes nil)
+	(constraints nil))
+    (labels ((note-class (class)
+	       (unless (member class classes)
+		 (push class classes)
+		 (let ((superclasses (class-direct-superclasses class)))
+		   (do ((prev class)
+			(rest superclasses (rest rest)))
+		       ((endp rest))
+		     (let ((next (first rest)))
+		       (push (cons prev next) constraints)
+		       (setf prev next)))
+		   (dolist (class superclasses)
+		     (note-class class)))))
+	     (std-cpl-tie-breaker (free-classes rev-cpl)
+	       (dolist (class rev-cpl (first free-classes))
+		 (let* ((superclasses (class-direct-superclasses class))
+			(intersection (intersection free-classes
+						    superclasses)))
+		   (when intersection
+		     (return (first intersection)))))))
+      (note-class class)
+      (topological-sort classes constraints #'std-cpl-tie-breaker))))
 
+;;;; object types to represent classes
+
 ;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
 ;;; referenced layouts. Users should never see them.
 (def!struct (undefined-class (:include #-sb-xc sb!xc:class
@@ -1069,9 +1192,9 @@
 		generic-number)
      :codes (#.sb!vm:bignum-type))
     (stream
-     :hierarchical-p nil
      :state :read-only
-     :inherits (instance t)))))
+     :depth 3
+     :inherits (instance)))))
 
 ;;; comment from CMU CL:
 ;;;   See also type-init.lisp where we finish setting up the
@@ -1086,6 +1209,7 @@
 	      codes
 	      enumerable
 	      state
+              depth
 	      (hierarchical-p t) ; might be modified below
 	      (direct-superclasses (if inherits
 				     (list (car inherits))
@@ -1108,15 +1232,17 @@
 	(unless trans-p
 	  (setf (info :type :builtin name) class))
 	(let* ((inherits-vector
-		(map 'vector
+		(map 'simple-vector
 		     (lambda (x)
 		       (let ((super-layout
 			      (class-layout (sb!xc:find-class x))))
 			 (when (minusp (layout-depthoid super-layout))
 			   (setf hierarchical-p nil))
 			 super-layout))
 		     inherits-list))
-	       (depthoid (if hierarchical-p (length inherits-vector) -1)))
+	       (depthoid (if hierarchical-p
+                           (or depth (length inherits-vector))
+                           -1)))
 	  (register-layout
 	   (find-and-init-or-check-layout name
 					  0
@@ -1130,7 +1256,18 @@
 ;;; is loaded and the class defined.
 (!cold-init-forms
   (/show0 "about to define temporary STANDARD-CLASSes")
-  (dolist (x '((fundamental-stream (t instance stream))))
+  (dolist (x '(;; FIXME: The mysterious duplication of STREAM in the
+	       ;; list here here was introduced in sbcl-0.6.12.33, in
+	       ;; MNA's port of DTC's inline-type-tests patches for
+	       ;; CMU CL. I'm guessing that it has something to do
+	       ;; with preallocating just enough space in a table
+	       ;; later used by the final definition of
+	       ;; FUNDAMENTAL-STREAM (perhaps for Gray stream stuff?).
+	       ;; It'd be good to document this weirdness both here
+	       ;; and in the REGISTER-LAYOUT code which has to do the
+	       ;; right thing with the duplicates-containing
+	       ;; INHERITS-LIST.
+	       (fundamental-stream (t instance stream stream))))
     (/show0 "defining temporary STANDARD-CLASS")
     (let* ((name (first x))
 	   (inherits-list (second x))
@@ -1139,7 +1276,7 @@
       (setf (class-cell-class class-cell) class
 	    (info :type :class name) class-cell
 	    (info :type :kind name) :instance)
-      (let ((inherits (map 'vector
+      (let ((inherits (map 'simple-vector
 			   (lambda (x)
 			     (class-layout (sb!xc:find-class x)))
 			   inherits-list)))

src/code/late-target-error.lisp

@@ -117,10 +117,15 @@
 				parent-types)))))
 	 (cond-layout (info :type :compiler-layout 'condition))
 	 (olayout (info :type :compiler-layout name))
+	 ;; FIXME: Does this do the right thing in case of multiple
+	 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
+	 ;; it obvious what ANSI intends to be done in the case of
+	 ;; multiple inheritance, so it's not actually clear what the
+	 ;; right thing is..
 	 (new-inherits
-	  (concatenate 'simple-vector
-		       (layout-inherits cond-layout)
-		       (mapcar #'class-layout cpl))))
+	  (order-layout-inherits (concatenate 'simple-vector
+					      (layout-inherits cond-layout)
+					      (mapcar #'class-layout cpl)))))
     (if (and olayout
 	     (not (mismatch (layout-inherits olayout) new-inherits)))
 	olayout
@@ -299,19 +304,10 @@
 
     (setf (sb!xc:find-class name) class)
 
-    ;; Initialize CPL slot from layout.
-    (collect ((cpl))
-      (cpl class)
-      (let ((inherits (layout-inherits layout)))
-	(do ((i (1- (length inherits)) (1- i)))
-	    ((minusp i))
-	  (let ((super (sb!xc:find-class
-			(sb!xc:class-name
-			 (layout-class (svref inherits i))))))
-	    (when (typep super 'condition-class)
-	      (cpl super)))))
-      (setf (condition-class-cpl class) (cpl))))
-
+    ;; Initialize CPL slot.
+    (setf (condition-class-cpl class)
+	  (remove-if-not #'condition-class-p 
+			 (std-compute-class-precedence-list class))))
   (values))
 
 ) ; EVAL-WHEN

src/cold/warm.lisp

@@ -266,10 +266,3 @@
 		     (safety 1)
 		     (space 1)
 		     (speed 1)))
-
-;;; FIXME: It would be good to unintern stuff we will no longer need
-;;; before we go on to PURIFY. E.g.
-;;;  * various PCL stuff like INITIAL-CLASSES-AND-WRAPPERS; and
-;;;  * *BUILT-IN-CLASSES* (which can't actually be freed by UNINTERN at
-;;;    this point, since it passed through another PURIFY earlier
-;;;    at cold init time).

src/compiler/typetran.lisp

@@ -459,6 +459,24 @@
 				 (eq (svref (layout-inherits ,n-layout)
 					    ,depthoid)
 				     ',layout))))))))
+           ((and layout (>= (layout-depthoid layout) 0))
+	    ;; hierarchical layout depths for other things (e.g.
+	    ;; CONDITIONs)
+	    (let ((depthoid (layout-depthoid layout))
+		  (n-layout (gensym))
+		  (n-inherits (gensym)))
+	      `(and (,pred object)
+		    (let ((,n-layout (,get-layout object)))
+		      ,@(when (policy *lexenv* (>= safety speed))
+			  `((when (layout-invalid ,n-layout)
+			      (%layout-invalid-error object ',layout))))
+		      (if (eq ,n-layout ',layout)
+			  t
+			  (let ((,n-inherits (layout-inherits ,n-layout)))
+			    (declare (optimize (safety 0)))
+			    (and (> (length ,n-inherits) ,depthoid)
+				 (eq (svref ,n-inherits ,depthoid)
+				     ',layout))))))))
 	   (t
 	    (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
 	    `(and (,pred object)

src/pcl/braid.lisp

@@ -92,14 +92,8 @@
 ;;;; BOOTSTRAP-META-BRAID
 ;;;;
 ;;;; This function builds the base metabraid from the early class definitions.
-;;;;
-;;;; FIXME: This, like lotso the other stuff in PCL, is not needed in target
-;;;; Lisp, only at bootstrap time. Perhaps we should do something kludgy like
-;;;; putting a special character (#\$, perhaps) at the beginning of each
-;;;; needed-only-at-bootstrap-time symbol and then UNINTERN them all once we're
-;;;; done bootstrapping?
 
-(defmacro initial-classes-and-wrappers (&rest classes)
+(defmacro !initial-classes-and-wrappers (&rest classes)
   `(progn
      ,@(mapcar #'(lambda (class)
 		   (let ((wr (intern (format nil "~A-WRAPPER" class)
@@ -131,7 +125,7 @@
 	 standard-effective-slot-definition
 	 class-eq-specializer-wrapper class-eq-specializer
 	 standard-generic-function-wrapper standard-generic-function)
-    (initial-classes-and-wrappers
+    (!initial-classes-and-wrappers
      standard-class funcallable-standard-class
      slot-class built-in-class structure-class std-class
      standard-direct-slot-definition standard-effective-slot-definition
@@ -536,19 +530,9 @@
 			:metaclass 'structure-class
 			:name symbol
 			:direct-superclasses
-			(cond ;; Handle our CMU-CL-ish structure-based
-			      ;; conditions.
-			      ((cl:subtypep symbol 'condition)
-			       (mapcar #'cl:class-name
-				       (sb-kernel:class-direct-superclasses
-					(cl:find-class symbol))))
-			      ;; a hack to add the STREAM class as a
-			      ;; mixin to the LISP-STREAM class.
-			      ((eq symbol 'sb-kernel:lisp-stream)
-			       '(structure-object stream))
-			      ((structure-type-included-type-name symbol)
-			       (list (structure-type-included-type-name
-				      symbol))))
+                        (mapcar #'cl:class-name
+                                (sb-kernel:class-direct-superclasses
+                                 (cl:find-class symbol)))
 			:direct-slots
 			(mapcar #'slot-initargs-from-structure-slotd
 				(structure-type-slot-description-list
@@ -565,12 +549,13 @@
 	(let* ((default-method-function #'constantly-nil)
 	       (default-method-initargs (list :function
 					      default-method-function))
-	       (default-method (make-a-method 'standard-method
-					      ()
-					      (list 'object)
-					      (list *the-class-t*)
-					      default-method-initargs
-					      "class predicate default method")))
+	       (default-method (make-a-method
+				'standard-method
+				()
+				(list 'object)
+				(list *the-class-t*)
+				default-method-initargs
+				"class predicate default method")))
 	  (setf (method-function-get default-method-function :constant-value)
 		nil)
 	  (add-method gf default-method)))
@@ -593,8 +578,9 @@
   (let ((lclass (sb-kernel:layout-class layout)))
     (unless (eq (sb-kernel:class-layout lclass) layout)
       (setf (sb-kernel:layout-inherits layout)
-	    (map 'vector #'class-wrapper
-		 (reverse (rest (class-precedence-list class)))))
+              (sb-kernel:order-layout-inherits
+               (map 'simple-vector #'class-wrapper
+                    (reverse (rest (class-precedence-list class))))))
       (sb-kernel:register-layout layout :invalidate nil)
 
       ;; Subclasses of formerly forward-referenced-class may be

src/pcl/defclass.lisp

@@ -44,7 +44,7 @@
 ;;;
 ;;; After the metabraid has been setup, and the protocol for defining
 ;;; classes has been defined, the real definition of LOAD-DEFCLASS is
-;;; installed by the file defclass.lisp
+;;; installed by the file std-class.lisp
 (defmacro defclass (name direct-superclasses direct-slots &rest options)
   (expand-defclass name direct-superclasses direct-slots options))