X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=515a222e98db51801a3cf074f2180a6b936237a4;hb=b3a419f10ad442a1c59d51edabdc70518f193648;hp=02f7edc4b497b20877ed84c7fc0ec6a53219374d;hpb=a96eb725c8b9082a576d2ea51a42cdc31fde3ea0;p=sbcl.git

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 02f7edc..515a222 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -148,9 +148,10 @@
 					 :object (coerce-to-class (car args))))
 	       (class-eq (class-eq-specializer (coerce-to-class (car args))))
 	       (eql      (intern-eql-specializer (car args))))))
-	((and (null args) (typep type 'cl:class))
-	 (or (sb-kernel:class-pcl-class type)
-	     (find-structure-class (cl:class-name type))))
+	;; FIXME: do we still need this?
+	((and (null args) (typep type 'classoid))
+	 (or (classoid-pcl-class type)
+	     (ensure-non-standard-class (classoid-name type))))
 	((specializerp type) type)))
 
 ;;; interface
@@ -216,7 +217,7 @@
     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
 					  (cdr type))))
     ((class class-eq) ; class-eq is impossible to do right
-     (sb-kernel:layout-class (class-wrapper (cadr type))))
+     (layout-classoid (class-wrapper (cadr type))))
     (eql type)
     (t (if (null (cdr type))
 	   (car type)
@@ -286,11 +287,8 @@
 (defvar *standard-method-combination*)
 
 (defun make-class-predicate-name (name)
-  (intern (format nil "~A::~A class predicate"
-		  (package-name (symbol-package name))
-		  name)
-	  *pcl-package*))
-
+  (list 'class-predicate name))
+  
 (defun plist-value (object name)
   (getf (object-plist object) name))
 
@@ -360,17 +358,17 @@
 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
 (defvar *built-in-classes*
   (labels ((direct-supers (class)
-	     (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
-	     (if (typep class 'cl:built-in-class)
-		 (sb-kernel:built-in-class-direct-superclasses class)
-		 (let ((inherits (sb-kernel:layout-inherits
-				  (sb-kernel:class-layout class))))
+	     (/noshow "entering DIRECT-SUPERS" (classoid-name class))
+	     (if (typep class 'built-in-classoid)
+		 (built-in-classoid-direct-superclasses class)
+		 (let ((inherits (layout-inherits
+				  (classoid-layout class))))
 		   (/noshow inherits)
 		   (list (svref inherits (1- (length inherits)))))))
 	   (direct-subs (class)
-	     (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
+	     (/noshow "entering DIRECT-SUBS" (classoid-name class))
 	     (collect ((res))
-	       (let ((subs (sb-kernel:class-subclasses class)))
+	       (let ((subs (classoid-subclasses class)))
 		 (/noshow subs)
 		 (when subs
 		   (dohash (sub v subs)
@@ -405,25 +403,26 @@
     (mapcar (lambda (kernel-bic-entry)
 	      (/noshow "setting up" kernel-bic-entry)
 	      (let* ((name (car kernel-bic-entry))
-		     (class (cl:find-class name)))
+		     (class (find-classoid name)))
 		(/noshow name class)
 		`(,name
-		  ,(mapcar #'cl:class-name (direct-supers class))
-		  ,(mapcar #'cl:class-name (direct-subs class))
+		  ,(mapcar #'classoid-name (direct-supers class))
+		  ,(mapcar #'classoid-name (direct-subs class))
 		  ,(map 'list
 			(lambda (x)
-			  (cl:class-name (sb-kernel:layout-class x)))
+			  (classoid-name
+			   (layout-classoid x)))
 			(reverse
-			 (sb-kernel:layout-inherits
-			  (sb-kernel:class-layout class))))
+			 (layout-inherits
+			  (classoid-layout class))))
 		  ,(prototype name))))
 	    (remove-if (lambda (kernel-bic-entry)
 			 (member (first kernel-bic-entry)
 				 ;; I'm not sure why these are removed from
 				 ;; the list, but that's what the original
 				 ;; CMU CL code did. -- WHN 20000715
-				 '(t sb-kernel:instance
-				     sb-kernel:funcallable-instance
+				 '(t instance
+				     funcallable-instance
 				     function stream)))
 		       sb-kernel::*built-in-classes*))))
 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
@@ -433,22 +432,22 @@
 (defclass t () ()
   (:metaclass built-in-class))
 
-(defclass sb-kernel:instance (t) ()
+(defclass instance (t) ()
   (:metaclass built-in-class))
 
 (defclass function (t) ()
   (:metaclass built-in-class))
 
-(defclass sb-kernel:funcallable-instance (function) ()
+(defclass funcallable-instance (function) ()
   (:metaclass built-in-class))
 
-(defclass stream (sb-kernel:instance) ()
+(defclass stream (instance) ()
   (:metaclass built-in-class))
 
 (defclass slot-object (t) ()
   (:metaclass slot-class))
 
-(defclass structure-object (slot-object sb-kernel:instance) ()
+(defclass structure-object (slot-object instance) ()
   (:metaclass structure-class))
 
 (defstruct (dead-beef-structure-object
@@ -458,10 +457,9 @@
 (defclass std-object (slot-object) ()
   (:metaclass std-class))
 
-(defclass standard-object (std-object sb-kernel:instance) ())
+(defclass standard-object (std-object instance) ())
 
-(defclass funcallable-standard-object (std-object
-				       sb-kernel:funcallable-instance)
+(defclass funcallable-standard-object (std-object funcallable-instance)
   ()
   (:metaclass funcallable-standard-class))
 
@@ -520,6 +518,16 @@
     :initform nil
     :reader class-predicate-name)))
 
+(def!method make-load-form ((class class) &optional env)
+  ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
+  ;; doesn't matter while all our environments are the same...
+  (declare (ignore env))
+  (let ((name (class-name class)))
+    (unless (and name (eq (find-class name nil) class))
+      (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
+	     class))
+    `(find-class ',name)))
+
 ;;; The class PCL-CLASS is an implementation-specific common
 ;;; superclass of all specified subclasses of the class CLASS.
 (defclass pcl-class (class)
@@ -565,6 +573,8 @@
 
 (defclass built-in-class (pcl-class) ())
 
+(defclass condition-class (pcl-class) ())
+
 (defclass structure-class (slot-class)
   ((defstruct-form
      :initform ()