From: Nikodemus Siivola Date: Tue, 15 Jan 2008 18:10:45 +0000 (+0000) Subject: 1.0.13.40: CLASS-SLOTS signals an error for unfinalized classes X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ef43bf713ac67d3acf4727a5111567e70675df44;p=sbcl.git 1.0.13.40: CLASS-SLOTS signals an error for unfinalized classes * AMOP requirement, reported by Levente Meszaros on sbcl-devel 2007-04-20. * New condition class for convenience: SB-INT:SIMPLE-REFERENCE-ERROR. --- diff --git a/NEWS b/NEWS index ad29cd8..74b5bbd 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,8 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13: Maciej Katafiasz) * bug fix: sb-aclrepl now correctly understands how to inspect single-floats on 64-bit platforms where single-floats are not boxed. + * bug fix: SB-MOP:CLASS-SLOTS now signals an error if the class has not + yet been finalized. (reported by Levente Meszaros) * DESCRIBE and (DOCUMENTATION ... 'OPTIMIZE) describe meaning of SBCL-specific optimize qualities. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4833596..f69ef45 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -853,7 +853,9 @@ possibly temporariliy, because it might be used internally." "INTERPRETED-PROGRAM-ERROR" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" - "SIMPLE-READER-ERROR" "SIMPLE-READER-PACKAGE-ERROR" + "SIMPLE-READER-ERROR" + "SIMPLE-READER-PACKAGE-ERROR" + "SIMPLE-REFERENCE-CONDITION" "SIMPLE-STREAM-ERROR" "SIMPLE-STORAGE-CONDITION" "SIMPLE-STYLE-WARNING" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index d2762ec..594b3ac 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -900,6 +900,9 @@ (unless (null (cdr rs)) (terpri s))))))) +(define-condition simple-reference-error (reference-condition simple-error) + ()) + (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index e301b76..5532c12 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1280,8 +1280,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (writer (cadr specializers)))) (specl-cpl (if early-p (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) + (when (class-finalized-p specl) + (class-precedence-list specl)))) (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) @@ -1296,17 +1296,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; all of its subclasses. If either SPECL or one of the subclasses ;; is not a standard-class, bail out. (labels ((aux (class) - ;; FIND-SLOT-DEFINITION might not be defined yet - (let ((slotd (find-if (lambda (x) - (eq (sb-pcl::slot-definition-name x) - slot-name)) - (sb-pcl::class-slots class)))) + (let ((slotd (find-slot-definition class slot-name))) (when slotd - (unless (or early-p - (slot-accessor-std-p slotd type)) + (unless (or early-p (slot-accessor-std-p slotd type)) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table)))) (dolist (subclass (sb-pcl::class-direct-subclasses class)) + (unless (class-finalized-p subclass) + (return-from make-accessor-table nil)) (aux subclass)))) (aux specl)))) (maphash (lambda (class specl+slotd-list) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index f406c6f..b6282b9 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -465,3 +465,10 @@ (declare (ignore initargs)) (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP +;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. +(defmethod class-slots :before ((class slot-class)) + (unless (class-finalized-p class) + (error 'simple-reference-error + :format-control "~S called on ~S, which is not yet finalized." + :format-arguments (list 'class-slots class) + :references (list '(:amop :generic-function class-slots))))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f8e62f9..ebfe865 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -99,7 +99,8 @@ type gf) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd '%class)) - (old-slotd (find-slot-definition class name)) + (old-slotd (when (class-finalized-p class) + (find-slot-definition class name))) (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) (if (eq *boot-state* 'complete) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 8b27b70..7be8b14 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -96,11 +96,11 @@ (backtrace (member (caar frame-specs) full-backtrace :key #'car :test #'equal))) - + (setf result condition) (unless backtrace - (format t "~&//~S not in backtrace:~% ~S~%" + (format t "~&//~S not in backtrace:~% ~S~%" (caar frame-specs) full-backtrace) (setf result nil)) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index f4c181d..6a49d02 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -519,5 +519,12 @@ :metaclass 'funcallable-standard-class) (assert (eq (class-of (find-class 'better-be-standard-class)) (find-class 'standard-class))) + +;;; CLASS-SLOTS should signal an error for classes that are not yet +;;; finalized. Reported by Levente Meszaros on sbcl-devel. +(defclass has-slots-but-isnt-finalized () (a b c)) +(let ((class (find-class 'has-slots-but-isnt-finalized))) + (assert (not (sb-mop:class-finalized-p class))) + (assert (raises-error? (sb-mop:class-slots class)))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index ec4f357..a731868 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.13.39" +"1.0.13.40"