From a29fb6bb708af5e3a5af6158e08051a5389d22f5 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 12 Nov 2002 15:33:39 +0000 Subject: [PATCH] 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 --- NEWS | 2 ++ src/pcl/cpl.lisp | 69 +++++++++++++++++++++++++++--------------------- src/pcl/std-class.lisp | 11 ++++++++ tests/clos.impure.lisp | 12 +++++++++ version.lisp-expr | 2 +- 5 files changed, 65 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index 9847d70..a3f4295 100644 --- 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 --- 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 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -667,6 +667,17 @@ (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 + "~@" + class)) + (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 --- 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)) +;;; 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))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 05c2852..6fce55c 100644 --- 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" -- 1.7.10.4