X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=ccfb4994666f22a7a526f2e222b295cbd3672109;hb=f61bddabbb69f1347b81b8ab76e709635a7a0739;hp=bd6d3611369c2fba3adaf5639c39328da9bbc2f1;hpb=3aff5655417da74a19ce576f55b2cb6999cda6c5;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index bd6d361..ccfb499 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -180,7 +180,7 @@
 	 ;; be a SB-PCL:CLASS under some circumstances? What goes here
 	 ;; when the LAYOUT is in fact a PCL::WRAPPER?
 	 :type #-sb-xc sb!xc:class #+sb-xc cl:class)
-  ;; The value of this slot can be
+  ;; The value of this slot can be:
   ;;   * :UNINITIALIZED if not initialized yet;
   ;;   * NIL if this is the up-to-date layout for a class; or
   ;;   * T if this layout has been invalidated (by being replaced by 
@@ -188,14 +188,15 @@
   ;;   * something else (probably a list) if the class is a PCL wrapper
   ;;     and PCL has made it invalid and made a note to itself about it
   (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
-  ;; The layouts for all classes we inherit. If hierarchical these are
-  ;; in order from most general down to (but not including) this
-  ;; class.
+  ;; the layouts for all classes we inherit. If hierarchical, i.e. if
+  ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS,
+  ;; so that each inherited layout appears at its expected depth,
+  ;; i.e. at its LAYOUT-DEPTHOID value.
   ;;
-  ;; FIXME: Couldn't this be (SIMPLE-ARRAY LAYOUT 1) instead of
-  ;; SIMPLE-VECTOR?
+  ;; Remaining elements are filled by the non-hierarchical layouts or,
+  ;; if they would otherwise be empty, by copies of succeeding layouts.
   (inherits #() :type simple-vector)
-  ;; If inheritance is hierarchical, this is -1. If inheritance is not
+  ;; If inheritance is not hierarchical, this is -1. If inheritance is 
   ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
   ;; Note:
   ;;  (1) This turns out to be a handy encoding for arithmetically
@@ -410,7 +411,7 @@
 (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
 		check-layout))
 (defun check-layout (layout class length inherits depthoid)
-  (assert (eq (layout-class layout) class))
+  (aver (eq (layout-class layout) class))
   (when (redefine-layout-warning "current" layout
 				 "compile time" length inherits depthoid)
     ;; Classic CMU CL had more options here. There are several reasons
@@ -440,6 +441,7 @@
 (declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
 		find-and-init-or-check-layout))
 (defun find-and-init-or-check-layout (name length inherits depthoid)
+  (/show0 "entering FIND-AND-INIT-OR-CHECK-LAYOUT")
   (let ((layout (find-layout name)))
     (init-or-check-layout layout
 			  (or (sb!xc:find-class name nil)
@@ -464,15 +466,15 @@
 	 (class-layout (class-layout class))
 	 (subclasses (class-subclasses class)))
 
-    ;; Attempting to register ourselves with a temporary cookie is
-    ;; almost certainly a programmer error. (I should know, I did it.)
-    ;; -- WHN 19990927
-    (assert (not (undefined-class-p class)))
+    ;; Attempting to register ourselves with a temporary undefined
+    ;; class placeholder is almost certainly a programmer error. (I
+    ;; should know, I did it.) -- WHN 19990927
+    (aver (not (undefined-class-p class)))
 
     ;; This assertion dates from classic CMU CL. The rationale is
     ;; probably that calling REGISTER-LAYOUT more than once for the
     ;; same LAYOUT is almost certainly a programmer error.
-    (assert (not (eq class-layout layout)))
+    (aver (not (eq class-layout layout)))
 
     ;; Figure out what classes are affected by the change, and issue
     ;; appropriate warnings and invalidations.
@@ -513,7 +515,132 @@
 
   (values))
 ); EVAL-WHEN
+
+;;; Arrange the inherited layouts to appear at their expected depth,
+;;; ensuring that hierarchical type tests succeed. Layouts with 
+;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
+;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
+;;; layouts are placed in remaining elements. Then, any still-empty
+;;; elements are filled with their successors, ensuring that each
+;;; element contains a valid layout.
+;;;
+;;; This reordering may destroy CPL ordering, so the inherits should
+;;; not be read as being in CPL order.
+(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
@@ -539,7 +666,7 @@
   (translation nil :type (or ctype (member nil :initializing))))
 (defun make-built-in-class (&rest rest)
   (apply #'bare-make-built-in-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+	 (rename-key-args '((:name :%name)) rest)))
 
 ;;; FIXME: In CMU CL, this was a class with a print function, but not
 ;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
@@ -560,7 +687,7 @@
   (constructor nil :type (or function null)))
 (defun make-structure-class (&rest rest)
   (apply #'bare-make-structure-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+	 (rename-key-args '((:name :%name)) rest)))
 
 ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
 ;;; structures, which are used to implement generic functions.
@@ -568,7 +695,7 @@
 					 (:constructor bare-make-funcallable-structure-class)))
 (defun make-funcallable-structure-class (&rest rest)
   (apply #'bare-make-funcallable-structure-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+	 (rename-key-args '((:name :%name)) rest)))
 
 ;;;; class namespace
 
@@ -638,7 +765,7 @@
 ;;; always of the desired class. The second result is any existing
 ;;; LAYOUT for this name.
 (defun insured-find-class (name predicate constructor)
-  (declare (function predicate constructor))
+  (declare (type function predicate constructor))
   (let* ((old (sb!xc:find-class name nil))
 	 (res (if (and old (funcall predicate old))
 		  old
@@ -660,17 +787,17 @@
 
 ;;;; CLASS type operations
 
-(define-type-class sb!xc:class)
+(!define-type-class sb!xc:class)
 
 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 ;;; the two classes are equal, since there are EQ checks in those
 ;;; operations.
-(define-type-method (sb!xc:class :simple-=) (type1 type2)
-  (assert (not (eq type1 type2)))
+(!define-type-method (sb!xc:class :simple-=) (type1 type2)
+  (aver (not (eq type1 type2)))
   (values nil t))
 
-(define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
-  (assert (not (eq class1 class2)))
+(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
+  (aver (not (eq class1 class2)))
   (let ((subclasses (class-subclasses class2)))
     (if (and subclasses (gethash class1 subclasses))
 	(values t t)
@@ -679,7 +806,7 @@
 ;;; When finding the intersection of a sealed class and some other
 ;;; class (not hierarchically related) the intersection is the union
 ;;; of the currently shared subclasses.
-(defun sealed-class-intersection (sealed other)
+(defun sealed-class-intersection2 (sealed other)
   (declare (type sb!xc:class sealed other))
   (let ((s-sub (class-subclasses sealed))
 	(o-sub (class-subclasses other)))
@@ -689,34 +816,39 @@
 	    (declare (ignore layout))
 	    (when (gethash subclass o-sub)
 	      (res (specifier-type subclass))))
-	  (values (res) t))
-	(values *empty-type* t))))
+	  (res))
+	*empty-type*)))
 
-;;; If one is a subclass of the other, then that is the intersection,
-;;; but we can only be sure the intersection is otherwise empty if
-;;; they are structure classes, since a subclass of both might be
-;;; defined. If either class is sealed, we can eliminate this
-;;; possibility.
-(define-type-method (sb!xc:class :simple-intersection) (class1 class2)
+(!define-type-method (sb!xc:class :simple-intersection2) (class1 class2)
   (declare (type sb!xc:class class1 class2))
-  (cond ((eq class1 class2) class1)
+  (cond ((eq class1 class2)
+	 class1)
+	;; If one is a subclass of the other, then that is the
+	;; intersection.
 	((let ((subclasses (class-subclasses class2)))
 	   (and subclasses (gethash class1 subclasses)))
-	 (values class1 t))
+	 class1)
 	((let ((subclasses (class-subclasses class1)))
 	   (and subclasses (gethash class2 subclasses)))
-	 (values class2 t))
+	 class2)
+	;; Otherwise, we can't in general be sure that the
+	;; intersection is empty, since a subclass of both might be
+	;; defined. But we can eliminate it for some special cases.
 	((or (basic-structure-class-p class1)
 	     (basic-structure-class-p class2))
-	 (values *empty-type* t))
+	 ;; No subclass of both can be defined.
+	 *empty-type*)
 	((eq (class-state class1) :sealed)
-	 (sealed-class-intersection class1 class2))
+	 ;; checking whether a subclass of both can be defined:
+	 (sealed-class-intersection2 class1 class2))
 	((eq (class-state class2) :sealed)
-	 (sealed-class-intersection class2 class1))
+	 ;; checking whether a subclass of both can be defined:
+	 (sealed-class-intersection2 class2 class1))
 	(t
-	 (values class1 nil))))
+	 ;; uncertain, since a subclass of both might be defined
+	 nil)))
 
-(define-type-method (sb!xc:class :unparse) (type)
+(!define-type-method (sb!xc:class :unparse) (type)
   (class-proper-name type))
 
 ;;;; PCL stuff
@@ -729,10 +861,10 @@
 			      (:constructor bare-make-random-pcl-class)))
 (defun make-standard-class (&rest rest)
   (apply #'bare-make-standard-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+	 (rename-key-args '((:name :%name)) rest)))
 (defun make-random-pcl-class (&rest rest)
   (apply #'bare-make-random-pcl-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+	 (rename-key-args '((:name :%name)) rest)))
 
 ;;;; built-in classes
 
@@ -790,7 +922,7 @@
      (system-area-pointer :codes (#.sb!vm:sap-type))
      (weak-pointer :codes (#.sb!vm:weak-pointer-type))
      (code-component :codes (#.sb!vm:code-header-type))
-     #!-gengc (lra :codes (#.sb!vm:return-pc-header-type))
+     (lra :codes (#.sb!vm:return-pc-header-type))
      (fdefn :codes (#.sb!vm:fdefn-type))
      (random-class) ; used for unknown type codes
 
@@ -989,6 +1121,22 @@
 		array sequence
 		generic-string generic-vector generic-array mutable-sequence
 		mutable-collection generic-sequence collection))
+    (list
+     :translation (or cons (member nil))
+     :inherits (sequence mutable-sequence mutable-collection
+		generic-sequence collection))
+    (cons
+     :codes (#.sb!vm:list-pointer-type)
+     :translation cons
+     :inherits (list sequence
+		mutable-sequence mutable-collection
+		generic-sequence collection))
+    (null
+     :translation (member nil)
+     :inherits (list sequence
+		mutable-sequence mutable-collection
+		generic-sequence collection symbol)
+     :direct-superclasses (list symbol))
     (generic-number :state :read-only)
     (number :translation number :inherits (generic-number))
     (complex
@@ -1046,32 +1194,15 @@
      :inherits (integer rational real number
 		generic-number)
      :codes (#.sb!vm:bignum-type))
-
-    (list
-     :translation (or cons (member nil))
-     :inherits (sequence mutable-sequence mutable-collection
-		generic-sequence collection))
-    (cons
-     :codes (#.sb!vm:list-pointer-type)
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection))
-    (null
-     :translation (member nil)
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection symbol)
-     :direct-superclasses (list symbol))
     (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
 ;;;   translations for built-in types.
 (!cold-init-forms
-  #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
   (dolist (x *built-in-classes*)
     #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
     (destructuring-bind
@@ -1081,21 +1212,22 @@
 	      codes
 	      enumerable
 	      state
+              depth
 	      (hierarchical-p t) ; might be modified below
 	      (direct-superclasses (if inherits
 				     (list (car inherits))
 				     '(t))))
 	x
       (declare (ignore codes state translation))
-      (let ((inherits-list (if (eq name 't)
-			     ()
-			     (cons 't (reverse inherits))))
+      (let ((inherits-list (if (eq name t)
+			       ()
+			       (cons t (reverse inherits))))
 	    (class (make-built-in-class
 		    :enumerable enumerable
 		    :name name
 		    :translation (if trans-p :initializing nil)
 		    :direct-superclasses
-		    (if (eq name 't)
+		    (if (eq name t)
 		      nil
 		      (mapcar #'sb!xc:find-class direct-superclasses)))))
 	(setf (info :type :kind name) :primitive
@@ -1103,7 +1235,7 @@
 	(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))))
@@ -1111,20 +1243,43 @@
 			   (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
 					  inherits-vector
 					  depthoid)
 	   :invalidate nil)))))
-  #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
+  (/show0 "done with loop over *BUILT-IN-CLASSES*"))
 
 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
-;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
+;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
 ;;; is loaded and the class defined.
 (!cold-init-forms
-  (dolist (x '((fundamental-stream (t instance stream))))
+  (/show0 "about to define temporary STANDARD-CLASSes")
+  (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
+               ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
+               ;; a vector containing the elements of the list below,
+               ;; i.e. '(T INSTANCE STREAM STREAM), is created, and
+               ;; this is what the function ORDER-LAYOUT-INHERITS
+               ;; would do, too.
+               ;;
+               ;; So, the purpose is to guarantee a valid layout for
+               ;; the FUNDAMENTAL-STREAM class, matching what
+               ;; ORDER-LAYOUT-INHERITS would do.
+               ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
+               ;; in the INHERITS(-VECTOR). Index 2 would not be
+               ;; filled, so STREAM is duplicated there (as
+               ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
+               ;; duplicate definition could be removed (removing a
+               ;; STREAM element), because FUNDAMENTAL-STREAM is
+               ;; redefined after PCL is set up, anyway. But to play
+               ;; it safely, we define the class with a valid INHERITS
+               ;; vector.
+	       (fundamental-stream (t instance stream stream))))
+    (/show0 "defining temporary STANDARD-CLASS")
     (let* ((name (first x))
 	   (inherits-list (second x))
 	   (class (make-standard-class :name name))
@@ -1132,12 +1287,14 @@
       (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)))
+	#-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
 	(register-layout (find-and-init-or-check-layout name 0 inherits -1)
-			 :invalidate nil)))))
+			 :invalidate nil))))
+  (/show0 "done defining temporary STANDARD-CLASSes"))
 
 ;;; Now that we have set up the class heterarchy, seal the sealed
 ;;; classes. This must be done after the subclasses have been set up.