0.7.9.45:

	Merge patch from Gerd Moellmann cmucl-imp 2002-10-29
		"COMPUTE-CLASS-PRECEDENCE-LIST and AMOP"
	... make COMPUTE-CLASS-PRECEDENCE-LIST specialize on CLASS, not
		SLOT-CLASS
	... catch some forward-referenced-class cases that slipped
		through the net
	write a FINALIZE-INHERITANCE method for forward-referenced-class

diff --git a/NEWS b/NEWS
index 9847d70..a3f4295 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1371,6 +1371,8 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9:
        CHANGE-CLASS;
     ** DEFMETHOD signals errors when methods with longer incongruent
        lambda lists are added to generic functions;
+    ** COMPUTE-CLASS-PRECEDENCE-LIST now has a method specialized on
+       CLASS, as specified in AMOP;
   * fixed some bugs shown by Paul Dietz' test suite:
     ** DOLIST puts its body in TAGBODY
     ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the

diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp
index f834b1a..f64d72a 100644 (file)
--- a/src/pcl/cpl.lisp
+++ b/src/pcl/cpl.lisp
@@ -74,7 +74,7 @@
 ;;;    any point. If there is more than one, the specified tiebreaker
 ;;;    rule is used to choose among them.
 
-(defmethod compute-class-precedence-list ((root slot-class))
+(defmethod compute-class-precedence-list ((root class))
   (compute-std-cpl root (class-direct-superclasses root)))
 
 (defstruct (class-precedence-description
@@ -90,17 +90,22 @@
   (cpd-count  0))
 
 (defun compute-std-cpl (class supers)
-  (cond ((null supers)                         ;First two branches of COND
-        (list class))                          ;are implementing the single
-       ((null (cdr supers))                    ;inheritance optimization.
-        (cons class
-              (compute-std-cpl (car supers)
-                               (class-direct-superclasses (car supers)))))
-       (t
-        (multiple-value-bind (all-cpds nclasses)
-            (compute-std-cpl-phase-1 class supers)
-          (compute-std-cpl-phase-2 all-cpds)
-          (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+  (cond
+    ;; the first two branches of this COND are implementing an
+    ;; optimization for single inheritance.
+    ((and (null supers)
+         (not (forward-referenced-class-p class)))
+     (list class))
+    ((and (null (cdr supers))
+         (not (forward-referenced-class-p (car supers))))
+     (cons class
+          (compute-std-cpl (car supers)
+                           (class-direct-superclasses (car supers)))))
+    (t
+     (multiple-value-bind (all-cpds nclasses)
+        (compute-std-cpl-phase-1 class supers)
+       (compute-std-cpl-phase-2 all-cpds)
+       (compute-std-cpl-phase-3 class all-cpds nclasses)))))
 
 (defvar *compute-std-cpl-class->entry-table-size* 60)
 
@@ -201,26 +206,30 @@
           (if (class-name class)
               (format nil "named ~S" (class-name class))
               class)))
-    (let ((names (mapcar #'class-or-name
-                        (cdr (find-superclass-chain class forward-class)))))
-      (cpl-error class
-                "The class ~A is a forward referenced class.~@
-                 The class ~A is ~A."
-                (class-or-name forward-class)
-                (class-or-name forward-class)
-                (if (null (cdr names))
-                    (format nil
-                            "a direct superclass of the class ~A"
-                            (class-or-name class))
-                    (format nil
-                            "reached from the class ~A by following~@
+    (if (eq class forward-class)
+       (cpl-error class
+                  "The class ~A is a forward referenced class."
+                  (class-or-name class))
+       (let ((names (mapcar #'class-or-name
+                            (cdr (find-superclass-chain class forward-class)))))
+         (cpl-error class
+                    "The class ~A is a forward referenced class.~@
+                      The class ~A is ~A."
+                    (class-or-name forward-class)
+                    (class-or-name forward-class)
+                    (if (null (cdr names))
+                        (format nil
+                                "a direct superclass of the class ~A"
+                                (class-or-name class))
+                        (format nil
+                                "reached from the class ~A by following~@
                              the direct superclass chain through: ~A~
                              ~%  ending at the class ~A"
-                            (class-or-name class)
-                            (format nil
-                                    "~{~%  the class ~A,~}"
-                                    (butlast names))
-                            (car (last names))))))))
+                                (class-or-name class)
+                                (format nil
+                                        "~{~%  the class ~A,~}"
+                                        (butlast names))
+                                (car (last names)))))))))
 
 (defun find-superclass-chain (bottom top)
   (labels ((walk (c chain)

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 5e5f933..bed8169 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -667,6 +667,17 @@
 \f
 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
+
+(defmethod finalize-inheritance ((class forward-referenced-class))
+  ;; FIXME: should we not be thinking a bit about what kinds of error
+  ;; we're throwing?  Maybe we need a clos-error type to mix in?  Or
+  ;; possibly a forward-referenced-class-error, though that's
+  ;; difficult given e.g. class precedence list calculations...
+  (error
+   "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
+       ~2I~_~S~:>"
+   class))
+
 \f
 (defun class-has-a-forward-referenced-superclass-p (class)
   (or (forward-referenced-class-p class)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 753dd4c..174fe3d 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -416,6 +416,18 @@
 (assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
 (assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
 \f
+;;; Attempting to instantiate classes with forward references in their
+;;; CPL should signal errors (FIXME: of what type?)
+(defclass never-finished-class (this-one-unfinished-too) ())
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'never-finished-class))
+  (assert (null result))
+  (assert (typep error 'error)))
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'this-one-unfinished-too))
+  (assert (null result))
+  (assert (typep error 'error)))
+\f
 ;;;; success
 
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 05c2852..6fce55c 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.44"
+"0.7.9.45"