X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=c25ae3b91582ac291895bcafad27e62bba84923b;hb=c8af15e61b030c8d4b0e950bc9b7618530044618;hp=b119f59b70d33153f371686a02f635c43084f0f1;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index b119f59..c25ae3b 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -14,9 +14,6 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
-  "$Header$")
-
 (!begin-collecting-cold-init-forms)
 
 ;;;; the CLASS structure
@@ -342,7 +339,7 @@
     (unless name
       (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
     ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
-    ;; we have to do this in two stages, a la the TREE-WITH-PARENT
+    ;; we have to do this in two stages, like the TREE-WITH-PARENT
     ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
     (values
      ;; "creation" form (which actually doesn't create a new LAYOUT if
@@ -413,7 +410,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
@@ -443,6 +440,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)
@@ -467,15 +465,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.
@@ -542,7 +540,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,
@@ -563,7 +561,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.
@@ -571,7 +569,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
 
@@ -641,7 +639,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
@@ -663,17 +661,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)
@@ -682,7 +680,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)))
@@ -692,34 +690,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
@@ -732,10 +735,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
 
@@ -992,6 +995,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
@@ -1049,22 +1068,6 @@
      :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
@@ -1074,7 +1077,6 @@
 ;;;   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
@@ -1121,13 +1123,15 @@
 					  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
+  (/show0 "about to define temporary STANDARD-CLASSes")
   (dolist (x '((fundamental-stream (t instance stream))))
+    (/show0 "defining temporary STANDARD-CLASS")
     (let* ((name (first x))
 	   (inherits-list (second x))
 	   (class (make-standard-class :name name))
@@ -1139,8 +1143,10 @@
 			   (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.