X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=534a6c2d4b9f0c84e1bf71f019550dab7c2d9000;hb=ae47ad0774edd8cb376772ae7e615428295f979e;hp=ba5ccd4b54f049c76086afebe61e79070477a237;hpb=2f1b1aa900279de818d450935f472684e728d54d;p=sbcl.git

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index ba5ccd4..534a6c2 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -83,50 +83,6 @@
   (parse-gspec spec
     (name (fdefine-carefully name new-value))))
 
-(declaim (special *the-class-t*
-		  *the-class-vector* *the-class-symbol*
-		  *the-class-string* *the-class-sequence*
-		  *the-class-rational* *the-class-ratio*
-		  *the-class-number* *the-class-null* *the-class-list*
-		  *the-class-integer* *the-class-float* *the-class-cons*
-		  *the-class-complex* *the-class-character*
-		  *the-class-bit-vector* *the-class-array*
-		  *the-class-stream*
-
-		  *the-class-slot-object*
-		  *the-class-structure-object*
-		  *the-class-std-object*
-		  *the-class-standard-object*
-		  *the-class-funcallable-standard-object*
-		  *the-class-class*
-		  *the-class-generic-function*
-		  *the-class-built-in-class*
-		  *the-class-slot-class*
-		  *the-class-structure-class*
-		  *the-class-std-class*
-		  *the-class-standard-class*
-		  *the-class-funcallable-standard-class*
-		  *the-class-method*
-		  *the-class-standard-method*
-		  *the-class-standard-reader-method*
-		  *the-class-standard-writer-method*
-		  *the-class-standard-boundp-method*
-		  *the-class-standard-generic-function*
-		  *the-class-standard-effective-slot-definition*
-
-		  *the-eslotd-standard-class-slots*
-		  *the-eslotd-funcallable-standard-class-slots*))
-
-(declaim (special *the-wrapper-of-t*
-		  *the-wrapper-of-vector* *the-wrapper-of-symbol*
-		  *the-wrapper-of-string* *the-wrapper-of-sequence*
-		  *the-wrapper-of-rational* *the-wrapper-of-ratio*
-		  *the-wrapper-of-number* *the-wrapper-of-null*
-		  *the-wrapper-of-list* *the-wrapper-of-integer*
-		  *the-wrapper-of-float* *the-wrapper-of-cons*
-		  *the-wrapper-of-complex* *the-wrapper-of-character*
-		  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
-
 ;;;; type specifier hackery
 
 ;;; internal to this file
@@ -148,9 +104,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 +173,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)
@@ -259,19 +216,13 @@
 
 (defun get-built-in-class-symbol (class-name)
   (or (cadr (assq class-name *built-in-class-symbols*))
-      (let ((symbol (intern (format nil
-				    "*THE-CLASS-~A*"
-				    (symbol-name class-name))
-			    *pcl-package*)))
+      (let ((symbol (make-class-symbol class-name)))
 	(push (list class-name symbol) *built-in-class-symbols*)
 	symbol)))
 
 (defun get-built-in-wrapper-symbol (class-name)
   (or (cadr (assq class-name *built-in-wrapper-symbols*))
-      (let ((symbol (intern (format nil
-				    "*THE-WRAPPER-OF-~A*"
-				    (symbol-name class-name))
-			    *pcl-package*)))
+      (let ((symbol (make-wrapper-symbol class-name)))
 	(push (list class-name symbol) *built-in-wrapper-symbols*)
 	symbol)))
 
@@ -286,11 +237,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))
 
@@ -303,74 +251,22 @@
 
 ;;;; built-in classes
 
-;;; FIXME: This was the portable PCL way of setting up
-;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
-;;; entirely wasted motion, since it's immediately overwritten by a
-;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
-;;; we can't just delete it, since the fifth element from each entry
-;;; (a prototype of the class) is still in the final result. It would
-;;; be nice to clean this up so that the other, never-used stuff is
-;;; gone, perhaps finding a tidier way to represent examples of each
-;;; class, too.
-;;;
-;;; FIXME: This can probably be blown away after bootstrapping.
-;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
-#|
-(defvar *built-in-classes*
-  ;; name       supers     subs		     cdr of cpl
-  ;; prototype
-  '(;(t	 ()	 (number sequence array character symbol) ())
-    (number     (t)	(complex float rational) (t))
-    (complex    (number)   ()		       (number t)
-     #c(1 1))
-    (float      (number)   ()		       (number t)
-     1.0)
-    (rational   (number)   (integer ratio)	  (number t))
-    (integer    (rational) ()		       (rational number t)
-     1)
-    (ratio      (rational) ()		       (rational number t)
-     1/2)
-
-    (sequence   (t)	(list vector)	    (t))
-    (list       (sequence) (cons null)	      (sequence t))
-    (cons       (list)     ()		       (list sequence t)
-     (nil))
-
-    (array      (t)	(vector)		 (t)
-     #2A((nil)))
-    (vector     (array
-		 sequence) (string bit-vector)      (array sequence t)
-     #())
-    (string     (vector)   ()		       (vector array sequence t)
-     "")
-    (bit-vector (vector)   ()		       (vector array sequence t)
-     #*1)
-    (character  (t)	()		       (t)
-     #\c)
-
-    (symbol     (t)	(null)		   (t)
-     symbol)
-    (null       (symbol
-		 list)     ()		       (symbol list sequence t)
-     nil)))
-|#
-
 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 (/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)
@@ -378,53 +274,40 @@
 		     (/noshow sub)
 		     (when (member class (direct-supers sub))
 		       (res sub)))))
-	       (res)))
-	   (prototype (class-name)
-	     (let ((assoc (assoc class-name
-				 '((complex    . #c(1 1))
-				   (float      . 1.0)
-				   (integer    . 1)
-				   (ratio      . 1/2)
-				   (sequence   . nil)
-				   (list       . nil)
-				   (cons       . (nil))
-				   (array      . #2a((nil)))
-				   (vector     . #())
-				   (string     . "")
-				   (bit-vector . #*1)
-				   (character  . #\c)
-				   (symbol     . symbol)
-				   (null       . nil)))))
-	       (if assoc
-		   (cdr assoc)
-		   ;; This is the default prototype value which was
-		   ;; used, without explanation, by the CMU CL code
-		   ;; we're derived from. Evidently it's safe in all
-		   ;; relevant cases.
-		   42))))
+	       (res))))
     (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))
+		     (prototype-form
+		      (getf (cdr kernel-bic-entry) :prototype-form)))
 		(/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))))
-		  ,(prototype name))))
+			 (layout-inherits
+			  (classoid-layout class))))
+		  ,(if prototype-form
+		       (eval prototype-form)
+		       ;; This is the default prototype value which
+		       ;; was used, without explanation, by the CMU CL
+		       ;; code we're derived from. Evidently it's safe
+		       ;; in all relevant cases.
+		       42))))
 	    (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
-				     function stream)))
+				 '(t instance
+				     funcallable-instance
+				     function stream 
+				     file-stream string-stream)))
 		       sb-kernel::*built-in-classes*))))
 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 
@@ -433,22 +316,31 @@
 (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 file-stream (stream) ()
+  (:metaclass built-in-class))
+
+(defclass string-stream (stream) ()
   (:metaclass built-in-class))
 
 (defclass slot-object (t) ()
   (:metaclass slot-class))
 
-(defclass structure-object (slot-object sb-kernel:instance) ()
+(defclass condition (slot-object instance) ()
+  (:metaclass condition-class))
+
+(defclass structure-object (slot-object instance) ()
   (:metaclass structure-class))
 
 (defstruct (dead-beef-structure-object
@@ -458,10 +350,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))
 
@@ -483,10 +374,6 @@
     :accessor object-plist))
   (:metaclass std-class))
 
-(defclass documentation-mixin (plist-mixin)
-  ()
-  (:metaclass std-class))
-
 (defclass dependent-update-mixin (plist-mixin)
   ()
   (:metaclass std-class))
@@ -494,8 +381,7 @@
 ;;; The class CLASS is a specified basic class. It is the common
 ;;; superclass of any kind of class. That is, any class that can be a
 ;;; metaclass must have the class CLASS in its class precedence list.
-(defclass class (documentation-mixin
-		 dependent-update-mixin
+(defclass class (dependent-update-mixin
 		 definition-source-mixin
 		 specializer)
   ((name
@@ -518,13 +404,33 @@
     :initform (cons nil nil))
    (predicate-name
     :initform nil
-    :reader class-predicate-name)))
+    :reader class-predicate-name)
+   (documentation
+    :initform nil
+    :initarg :documentation)
+   (finalized-p
+    :initform nil
+    :reader class-finalized-p)))
+
+(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)
   ((class-precedence-list
     :reader class-precedence-list)
+   ;; KLUDGE: see note in CPL-OR-NIL
+   (cpl-available-p
+    :reader cpl-available-p
+    :initform nil)
    (can-precede-list
     :initform ()
     :reader class-can-precede-list)
@@ -544,10 +450,7 @@
     :accessor class-direct-slots)
    (slots
     :initform ()
-    :accessor class-slots)
-   (initialize-info
-    :initform nil
-    :accessor class-initialize-info)))
+    :accessor class-slots)))
 
 ;;; The class STD-CLASS is an implementation-specific common
 ;;; superclass of the classes STANDARD-CLASS and
@@ -565,6 +468,8 @@
 
 (defclass built-in-class (pcl-class) ())
 
+(defclass condition-class (slot-class) ())
+
 (defclass structure-class (slot-class)
   ((defstruct-form
      :initform ()
@@ -634,7 +539,7 @@
     :initarg :type
     :accessor slot-definition-type)
    (documentation
-    :initform ""
+    :initform nil
     :initarg :documentation)
    (class
     :initform nil
@@ -645,7 +550,21 @@
   ((allocation
     :initform :instance
     :initarg :allocation
-    :accessor slot-definition-allocation)))
+    :accessor slot-definition-allocation)
+   (allocation-class
+    :initform nil
+    :initarg :allocation-class
+    :accessor slot-definition-allocation-class)))
+
+(defclass condition-slot-definition (slot-definition)
+  ((allocation
+    :initform :instance
+    :initarg :allocation
+    :accessor slot-definition-allocation)
+   (allocation-class
+    :initform nil
+    :initarg :allocation-class
+    :accessor slot-definition-allocation-class)))
 
 (defclass structure-slot-definition (slot-definition)
   ((defstruct-accessor-symbol
@@ -684,6 +603,14 @@
     :initform nil
     :accessor slot-definition-location)))
 
+(defclass condition-direct-slot-definition (condition-slot-definition
+					    direct-slot-definition)
+  ())
+
+(defclass condition-effective-slot-definition (condition-slot-definition
+					       effective-slot-definition)
+  ())
+
 (defclass structure-direct-slot-definition (structure-slot-definition
 					    direct-slot-definition)
   ())
@@ -717,11 +644,9 @@
     :initform nil
     :initarg :fast-function		;no writer
     :reader method-fast-function)
-;;;     (documentation
-;;;	:initform nil
-;;;	:initarg  :documentation
-;;;	:reader method-documentation)
-  ))
+   (documentation
+    :initform nil
+    :initarg :documentation)))
 
 (defclass standard-accessor-method (standard-method)
   ((slot-name :initform nil
@@ -739,11 +664,13 @@
 
 (defclass generic-function (dependent-update-mixin
 			    definition-source-mixin
-			    documentation-mixin
 			    funcallable-standard-object)
-  (;; We need to make a distinction between the methods initially set
+  ((documentation
+    :initform nil
+    :initarg :documentation)
+   ;; We need to make a distinction between the methods initially set
    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
-   ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
+   ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
    ;; an already-DEFGENERICed function clears the methods set by the
    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
    ;; this distinction seems a little kludgy, but it has the positive
@@ -772,6 +699,10 @@
    (method-combination
     :initarg :method-combination
     :accessor generic-function-method-combination)
+   (declarations
+    :initarg :declarations
+    :initform ()
+    :accessor generic-function-declarations)
    (arg-info
     :initform (make-arg-info)
     :reader gf-arg-info)
@@ -782,20 +713,29 @@
   (:default-initargs :method-class *the-class-standard-method*
 		     :method-combination *standard-method-combination*))
 
-(defclass method-combination (standard-object) ())
+(defclass method-combination (standard-object)
+  ((documentation
+    :reader method-combination-documentation
+    :initform nil
+    :initarg :documentation)))
 
 (defclass standard-method-combination (definition-source-mixin
-					method-combination)
+				       method-combination)
   ((type
     :reader method-combination-type
     :initarg :type)
-   (documentation
-    :reader method-combination-documentation
-    :initarg :documentation)
    (options
     :reader method-combination-options
     :initarg :options)))
 
+(defclass long-method-combination (standard-method-combination)
+  ((function
+    :initarg :function
+    :reader long-method-combination-function)
+   (args-lambda-list
+    :initarg :args-lambda-list
+    :reader long-method-combination-args-lambda-list)))
+
 (defparameter *early-class-predicates*
   '((specializer specializerp)
     (exact-class-specializer exact-class-specializer-p)
@@ -806,6 +746,7 @@
     (std-class std-class-p)
     (standard-class standard-class-p)
     (funcallable-standard-class funcallable-standard-class-p)
+    (condition-class condition-class-p)
     (structure-class structure-class-p)
     (forward-referenced-class forward-referenced-class-p)
     (method method-p)
@@ -816,5 +757,6 @@
     (standard-boundp-method standard-boundp-method-p)
     (generic-function generic-function-p)
     (standard-generic-function standard-generic-function-p)
-    (method-combination method-combination-p)))
+    (method-combination method-combination-p)
+    (long-method-combination long-method-combination-p)))