X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=ce413de6aa0a6831469971e434e4821167b08607;hb=bc1783335d78be988465e4fc7cf9c5fdb88a3fa4;hp=fe779690022fcc6d4dbf9d95f8b1518785093041;hpb=3ecee4526a55b3b4e6d7f86d69dc411f074968ec;p=sbcl.git

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index fe77969..ce413de 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -30,13 +30,13 @@
 ;;; so we've left 'em in.)
 (when (eq *boot-state* 'complete)
   (error "Trying to load (or compile) PCL in an environment in which it~%~
-	  has already been loaded. This doesn't work, you will have to~%~
-	  get a fresh lisp (reboot) and then load PCL."))
+          has already been loaded. This doesn't work, you will have to~%~
+          get a fresh lisp (reboot) and then load PCL."))
 (when *boot-state*
   (cerror "Try loading (or compiling) PCL anyways."
-	  "Trying to load (or compile) PCL in an environment in which it~%~
-	   has already been partially loaded. This may not work, you may~%~
-	   need to get a fresh lisp (reboot) and then load PCL."))
+          "Trying to load (or compile) PCL in an environment in which it~%~
+           has already been partially loaded. This may not work, you may~%~
+           need to get a fresh lisp (reboot) and then load PCL."))
 
 ;;; comments from CMU CL version of PCL:
 ;;;     This is like fdefinition on the Lispm. If Common Lisp had
@@ -50,7 +50,7 @@
 ;;;   which has a 'real' function spec mechanism can use that instead
 ;;;   and in that way get rid of setf generic function names.
 (defmacro parse-gspec (spec
-		       (non-setf-var . non-setf-case))
+                       (non-setf-var . non-setf-case))
   `(let ((,non-setf-var ,spec)) ,@non-setf-case))
 
 ;;; If symbol names a function which is traced, return the untraced
@@ -83,57 +83,13 @@
   (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
 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
   (if (symbolp class)
       (or (find-class class (not make-forward-referenced-class-p))
-	  (ensure-class class))
+          (ensure-class class))
       class))
 
 ;;; interface
@@ -141,48 +97,49 @@
   (when (consp type)
     (setq args (cdr type) type (car type)))
   (cond ((symbolp type)
-	 (or (and (null args) (find-class type))
-	     (ecase type
-	       (class    (coerce-to-class (car args)))
-	       (prototype (make-instance 'class-prototype-specializer
-					 :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))))
-	((specializerp type) type)))
+         (or (and (null args) (find-class type))
+             (ecase type
+               (class    (coerce-to-class (car args)))
+               (prototype (make-instance 'class-prototype-specializer
+                                         :object (coerce-to-class (car args))))
+               (class-eq (class-eq-specializer (coerce-to-class (car args))))
+               (eql      (intern-eql-specializer (car args))))))
+        ;; 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
 (defun type-from-specializer (specl)
   (cond ((eq specl t)
-	 t)
-	((consp specl)
-	 (unless (member (car specl) '(class prototype class-eq eql))
-	   (error "~S is not a legal specializer type." specl))
-	 specl)
-	((progn
-	   (when (symbolp specl)
-	     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
-	     (setq specl (find-class specl)))
-	   (or (not (eq *boot-state* 'complete))
-	       (specializerp specl)))
-	 (specializer-type specl))
-	(t
-	 (error "~S is neither a type nor a specializer." specl))))
+         t)
+        ((consp specl)
+         (unless (member (car specl) '(class prototype class-eq eql))
+           (error "~S is not a legal specializer type." specl))
+         specl)
+        ((progn
+           (when (symbolp specl)
+             ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
+             (setq specl (find-class specl)))
+           (or (not (eq *boot-state* 'complete))
+               (specializerp specl)))
+         (specializer-type specl))
+        (t
+         (error "~S is neither a type nor a specializer." specl))))
 
 (defun type-class (type)
   (declare (special *the-class-t*))
   (setq type (type-from-specializer type))
   (if (atom type)
       (if (eq type t)
-	  *the-class-t*
-	  (error "bad argument to TYPE-CLASS"))
+          *the-class-t*
+          (error "bad argument to TYPE-CLASS"))
       (case (car type)
-	(eql (class-of (cadr type)))
-	(prototype (class-of (cadr type))) ;?
-	(class-eq (cadr type))
-	(class (cadr type)))))
+        (eql (class-of (cadr type)))
+        (prototype (class-of (cadr type))) ;?
+        (class-eq (cadr type))
+        (class (cadr type)))))
 
 (defun class-eq-type (class)
   (specializer-type (class-eq-specializer class)))
@@ -193,34 +150,34 @@
 ;;; class objects or types where they should.
 (defun *normalize-type (type)
   (cond ((consp type)
-	 (if (member (car type) '(not and or))
-	     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
-	     (if (null (cdr type))
-		 (*normalize-type (car type))
-		 type)))
-	((symbolp type)
-	 (let ((class (find-class type nil)))
-	   (if class
-	       (let ((type (specializer-type class)))
-		 (if (listp type) type `(,type)))
-	       `(,type))))
-	((or (not (eq *boot-state* 'complete))
-	     (specializerp type))
-	 (specializer-type type))
-	(t
-	 (error "~S is not a type." type))))
+         (if (member (car type) '(not and or))
+             `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
+             (if (null (cdr type))
+                 (*normalize-type (car type))
+                 type)))
+        ((symbolp type)
+         (let ((class (find-class type nil)))
+           (if class
+               (let ((type (specializer-type class)))
+                 (if (listp type) type `(,type)))
+               `(,type))))
+        ((or (not (eq *boot-state* 'complete))
+             (specializerp type))
+         (specializer-type type))
+        (t
+         (error "~S is not a type." type))))
 
 ;;; internal to this file...
 (defun convert-to-system-type (type)
   (case (car type)
     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
-					  (cdr 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)
-	   type))))
+           (car type)
+           type))))
 
 ;;; Writing the missing NOT and AND clauses will improve the quality
 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
@@ -228,52 +185,46 @@
 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
 ;;;
 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
-;;; in the compiler. Could we share some of it here? 
+;;; in the compiler. Could we share some of it here?
 (defun *subtypep (type1 type2)
   (if (equal type1 type2)
       (values t t)
       (if (eq *boot-state* 'early)
-	  (values (eq type1 type2) t)
-	  (let ((*in-precompute-effective-methods-p* t))
-	    (declare (special *in-precompute-effective-methods-p*))
-	    ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
-	    ;; good name. It changes the way
-	    ;; CLASS-APPLICABLE-USING-CLASS-P works.
-	    (setq type1 (*normalize-type type1))
-	    (setq type2 (*normalize-type type2))
-	    (case (car type2)
-	      (not
-	       (values nil nil)) ; XXX We should improve this.
-	      (and
-	       (values nil nil)) ; XXX We should improve this.
-	      ((eql wrapper-eq class-eq class)
-	       (multiple-value-bind (app-p maybe-app-p)
-		   (specializer-applicable-using-type-p type2 type1)
-		 (values app-p (or app-p (not maybe-app-p)))))
-	      (t
-	       (subtypep (convert-to-system-type type1)
-			 (convert-to-system-type type2))))))))
+          (values (eq type1 type2) t)
+          (let ((*in-precompute-effective-methods-p* t))
+            (declare (special *in-precompute-effective-methods-p*))
+            ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
+            ;; good name. It changes the way
+            ;; CLASS-APPLICABLE-USING-CLASS-P works.
+            (setq type1 (*normalize-type type1))
+            (setq type2 (*normalize-type type2))
+            (case (car type2)
+              (not
+               (values nil nil)) ; XXX We should improve this.
+              (and
+               (values nil nil)) ; XXX We should improve this.
+              ((eql wrapper-eq class-eq class)
+               (multiple-value-bind (app-p maybe-app-p)
+                   (specializer-applicable-using-type-p type2 type1)
+                 (values app-p (or app-p (not maybe-app-p)))))
+              (t
+               (subtypep (convert-to-system-type type1)
+                         (convert-to-system-type type2))))))))
 
 (defvar *built-in-class-symbols* ())
 (defvar *built-in-wrapper-symbols* ())
 
 (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*)))
-	(push (list class-name symbol) *built-in-class-symbols*)
-	symbol)))
+      (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*)))
-	(push (list class-name symbol) *built-in-wrapper-symbols*)
-	symbol)))
+      (let ((symbol (make-wrapper-symbol class-name)))
+        (push (list class-name symbol) *built-in-wrapper-symbols*)
+        symbol)))
 
 (pushnew '%class *var-declarations*)
 (pushnew '%variable-rebinding *var-declarations*)
@@ -286,10 +237,7 @@
 (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))
@@ -298,134 +246,69 @@
   (if new-value
       (setf (getf (object-plist object) name) new-value)
       (progn
-	(remf (object-plist object) name)
-	nil)))
+        (remf (object-plist object) name)
+        nil)))
 
 ;;;; 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 inherits)
-		   (list (svref inherits (1- (length inherits)))))))
-	   (direct-subs (class)
-	     (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
-	     (collect ((res))
-	       (let ((subs (sb-kernel:class-subclasses class)))
-		 (/noshow subs)
-		 (when subs
-		   (dohash (sub v subs)
-		     (declare (ignore v))
-		     (/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))))
+             (/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" (classoid-name class))
+             (collect ((res))
+               (let ((subs (classoid-subclasses class)))
+                 (/noshow subs)
+                 (when subs
+                   (dohash (sub v subs)
+                     (declare (ignore v))
+                     (/noshow sub)
+                     (when (member class (direct-supers sub))
+                       (res sub)))))
+               (res))))
     (mapcar (lambda (kernel-bic-entry)
-	      (/noshow "setting up" kernel-bic-entry)
-	      (let* ((name (car kernel-bic-entry))
-		     (class (cl:find-class name)))
-		(/noshow name class)
-		`(,name
-		  ,(mapcar #'cl:class-name (direct-supers class))
-		  ,(mapcar #'cl:class-name (direct-subs class))
-		  ,(map 'list
-			(lambda (x)
-			  (cl:class-name (sb-kernel:layout-class x)))
-			(reverse
-			 (sb-kernel:layout-inherits
-			  (sb-kernel:class-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
-				     function stream)))
-		       sb-kernel::*built-in-classes*))))
+              (/noshow "setting up" kernel-bic-entry)
+              (let* ((name (car kernel-bic-entry))
+                     (class (find-classoid name))
+                     (prototype-form
+                      (getf (cdr kernel-bic-entry) :prototype-form)))
+                (/noshow name class)
+                `(,name
+                  ,(mapcar #'classoid-name (direct-supers class))
+                  ,(mapcar #'classoid-name (direct-subs class))
+                  ,(map 'list
+                        (lambda (x)
+                          (classoid-name
+                           (layout-classoid x)))
+                        (reverse
+                         (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 instance
+                                     funcallable-instance
+                                     function stream
+                                     file-stream string-stream)))
+                       sb-kernel::*built-in-classes*))))
 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 
 ;;;; the classes that define the kernel of the metabraid
@@ -433,35 +316,43 @@
 (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 (instance) ()
   (:metaclass built-in-class))
 
-(defclass stream (sb-kernel:instance) ()
+(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
-	    (:constructor |STRUCTURE-OBJECT class constructor|)
-	    (:copier nil)))
+            (:constructor |STRUCTURE-OBJECT class constructor|)
+            (:copier nil)))
 
 (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,10 +381,9 @@
 ;;; 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
-		 definition-source-mixin
-		 specializer)
+(defclass class (dependent-update-mixin
+                 definition-source-mixin
+                 specializer)
   ((name
     :initform nil
     :initarg  :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 ()
@@ -581,26 +486,26 @@
 (defclass exact-class-specializer (specializer) ())
 
 (defclass class-eq-specializer (exact-class-specializer
-				specializer-with-object)
+                                specializer-with-object)
   ((object :initarg :class
-	   :reader specializer-class
-	   :reader specializer-object)))
+           :reader specializer-class
+           :reader specializer-object)))
 
 (defclass class-prototype-specializer (specializer-with-object)
   ((object :initarg :class
-	   :reader specializer-class
-	   :reader specializer-object)))
+           :reader specializer-class
+           :reader specializer-object)))
 
 (defclass eql-specializer (exact-class-specializer specializer-with-object)
   ((object :initarg :object :reader specializer-object
-	   :reader eql-specializer-object)))
+           :reader eql-specializer-object)))
 
 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 
 (defun intern-eql-specializer (object)
   (or (gethash object *eql-specializer-table*)
       (setf (gethash object *eql-specializer-table*)
-	    (make-instance 'eql-specializer :object object))))
+            (make-instance 'eql-specializer :object object))))
 
 ;;;; slot definitions
 
@@ -634,7 +539,7 @@
     :initarg :type
     :accessor slot-definition-type)
    (documentation
-    :initform ""
+    :initform nil
     :initarg :documentation)
    (class
     :initform nil
@@ -651,6 +556,16 @@
     :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
      :initform nil
@@ -679,33 +594,41 @@
     :initform 0)))
 
 (defclass standard-direct-slot-definition (standard-slot-definition
-					   direct-slot-definition)
+                                           direct-slot-definition)
   ())
 
 (defclass standard-effective-slot-definition (standard-slot-definition
-					      effective-slot-definition)
+                                              effective-slot-definition)
   ((location ; nil, a fixnum, a cons: (slot-name . value)
     :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)
+                                            direct-slot-definition)
   ())
 
 (defclass structure-effective-slot-definition (structure-slot-definition
-					       effective-slot-definition)
+                                               effective-slot-definition)
   ())
 
 (defclass method (standard-object) ())
 
 (defclass standard-method (definition-source-mixin plist-mixin method)
   ((generic-function
-    :initform nil	
+    :initform nil
     :accessor method-generic-function)
 ;;;     (qualifiers
-;;;	:initform ()
-;;;	:initarg  :qualifiers
-;;;	:reader method-qualifiers)
+;;;     :initform ()
+;;;     :initarg  :qualifiers
+;;;     :reader method-qualifiers)
    (specializers
     :initform ()
     :initarg  :specializers
@@ -716,24 +639,22 @@
     :reader method-lambda-list)
    (function
     :initform nil
-    :initarg :function)			;no writer
+    :initarg :function)                 ;no writer
    (fast-function
     :initform nil
-    :initarg :fast-function		;no writer
+    :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
-	      :initarg :slot-name
-	      :reader accessor-method-slot-name)
+              :initarg :slot-name
+              :reader accessor-method-slot-name)
    (slot-definition :initform nil
-		    :initarg :slot-definition
-		    :reader accessor-method-slot-definition)))
+                    :initarg :slot-definition
+                    :reader accessor-method-slot-definition)))
 
 (defclass standard-reader-method (standard-accessor-method) ())
 
@@ -742,12 +663,14 @@
 (defclass standard-boundp-method (standard-accessor-method) ())
 
 (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
+                            definition-source-mixin
+                            funcallable-standard-object)
+  ((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
@@ -777,7 +700,11 @@
     :initarg :method-combination
     :accessor generic-function-method-combination)
    (declarations
+    ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
+    ;; :DECLARE.  Allow either (but FIXME: maybe a note or a warning
+    ;; might be appropriate).
     :initarg :declarations
+    :initarg :declare
     :initform ()
     :accessor generic-function-declarations)
    (arg-info
@@ -788,22 +715,31 @@
     :accessor gf-dfun-state))
   (:metaclass funcallable-standard-class)
   (:default-initargs :method-class *the-class-standard-method*
-		     :method-combination *standard-method-combination*))
+                     :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)
@@ -814,6 +750,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)
@@ -824,5 +761,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)))