diff --git a/portable-condition-system.asd b/portable-condition-system.asd index 7f8b44f..0a7e285 100644 --- a/portable-condition-system.asd +++ b/portable-condition-system.asd @@ -9,7 +9,8 @@ :serial t :pathname "src" :depends-on (#:alexandria - #:split-sequence) + #:split-sequence + #:closer-mop) :components ((:file "package") (:file "conditions") (:file "condition-hierarchy") @@ -37,6 +38,7 @@ (:file "debugger") (:file "ansi-test-data") (:file "ansi-test-support") + (:file "more-tests") (:module "ansi-test" :components ((:file "condition") diff --git a/src/condition-hierarchy.lisp b/src/condition-hierarchy.lisp index 32de7d8..ec9ca72 100644 --- a/src/condition-hierarchy.lisp +++ b/src/condition-hierarchy.lisp @@ -139,3 +139,17 @@ function ABORT failed to transfer control outside of the function.") (:documentation "A condition type signaled when a case assertion (such as ECASE, ETYPECASE, CCASE, or CTYPECASE) fails to match its keyform.") (:report report-case-failure)) + +(defun report-invalid-superclass (condition stream) + (format stream "~S cannot superclass ~S:~%~S" + (invalid-superclass-class condition) + (invalid-superclass-superclass condition) + (invalid-superclass-reason condition))) + +(define-condition invalid-superclass (condition) + ((class :reader invalid-superclass-class :initarg :class) + (superclass :reader invalid-superclass-superclass :initarg :superclass) + (reason :reader invalid-superclass-reason :initarg :reason)) + (:documentation "A condition type signaled when a class tries to superclass an +invalid superclass; the violation being described by REASON.") + (:report report-invalid-superclass)) diff --git a/src/conditions.lisp b/src/conditions.lisp index e0cae4a..b844259 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -47,17 +47,44 @@ PRINT-OBJECT method defined on the class named by NAME." `(let ((,method (find-method #'print-object '() '(,name t) nil))) (when ,method (remove-method #'print-object ,method))))) +(defvar *in-define-condition-p* nil + "This will be dynamically binded to indicate an entry into DEFINE-CONDITION, +to distinguish its DEFCLASS from an external DEFCLASS.") + +(defmethod ensure-class-using-class :before (class name &rest args &key direct-superclasses &allow-other-keys) + "In DEFINE-CONDITION: Signals a TYPE-ERROR at the first direct superclass unconforming +with DEFINE-CONDITION, that is, the first encountered superclass in DIRECT-SUPERCLASSES +that is not a subtype of CONDITION. +In DEFCLASSes external to DEFINE-CONDITION: Signals an INVALID-SUPERCLASS at the first +encountered superclass that is subtype of CONDITION." + (declare (ignore args)) + (if *in-define-condition-p* + (loop :for superclass :in direct-superclasses + :do (when (not (subtypep superclass 'condition)) + (error 'type-error + :datum superclass + :expected-type 'condition))) + (loop :for superclass :in direct-superclasses + :do (when (subtypep superclass 'condition) + (error 'invalid-superclass + :class name + :superclass superclass + :reason (format nil "Only ~S should~% define a subtype of ~S" + 'define-condition 'condition)))))) + (defun expand-define-condition (name supertypes direct-slots options) "Defines a new condition type via DEFCLASS, handling the :REPORT options via defining a PRINT-object method on the newly created class." (let* ((report-option (find :report options :key #'car)) (other-options (remove report-option options)) (supertypes (or supertypes '(condition)))) - `(progn (defclass ,name ,supertypes ,direct-slots ,@other-options) - ,@(if report-option - `(,(expand-define-condition-report-method name report-option)) - `(,(expand-define-condition-remove-report-method name))) - ',name))) + `(progn + (let ((*in-define-condition-p* t)) + (defclass ,name ,supertypes ,direct-slots ,@other-options)) + ,@(if report-option + `(,(expand-define-condition-report-method name report-option)) + `(,(expand-define-condition-remove-report-method name))) + ',name))) (defmacro define-condition (name (&rest supertypes) direct-slots &rest options) "Defines or redefines a condition type." diff --git a/src/package.lisp b/src/package.lisp index 8397223..137b7a1 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -69,6 +69,7 @@ (:nicknames #:pcs) (:import-from #:split-sequence #:split-sequence) (:import-from #:alexandria #:parse-body) + (:import-from #:closer-mop #:ensure-class-using-class) (:shadow ,@symbols) (:export ,@symbols)) (uiop:define-package #:common-lisp+portable-condition-system diff --git a/t/ansi-test/define-condition.lisp b/t/ansi-test/define-condition.lisp index 693a811..c797e77 100644 --- a/t/ansi-test/define-condition.lisp +++ b/t/ansi-test/define-condition.lisp @@ -579,6 +579,41 @@ (notnot-mv (typep #'condition-27/s1 'generic-function)) t) +;;; Test non-CONDITION supertypes + +(defclass not-a-condition-1 nil nil) +(defclass not-a-condition-2 nil nil) + +(deftest condition-with-non-condition-supertype-1.1 + (signals-type-error not-a-condition 'not-a-condition-1 + (define-condition condition-with-non-condition-supertype-1a (not-a-condition-1) + () + (:report "condition-with-non-condition-supertype-1a"))) + t) + +(define-condition-with-tests condition-28a nil nil) +(define-condition-with-tests condition-28b nil nil) + +(deftest condition-with-non-condition-supertype-1.2 + (signals-type-error not-a-condition 'not-a-condition-1 + (define-condition condition-with-non-condition-supertype-1b (condition-28a + not-a-condition-1 + condition-28b) + () + (:report "condition-with-non-condition-sypertype-1b"))) + t) + +(deftest condition-with-non-condition-supertype-1.3 + (signals-type-error not-a-condition 'not-a-condition-2 + (define-condition condition-with-non-condition-supertype-1c (condition-28b + not-a-condition-2 + not-a-condition-1) + () + (:report "condition-with-non-condition-supertype-1c"))) + t) + +;;; + ;;; Documentation ;;; Pitman says this should have been in the spec, but it isn't really diff --git a/t/more-tests.lisp b/t/more-tests.lisp new file mode 100644 index 0000000..8e1add3 --- /dev/null +++ b/t/more-tests.lisp @@ -0,0 +1,26 @@ +;;;; t/more-tests.lisp + +(in-package #:portable-condition-system/test) + +;;; Test superclassing a CONDITION in DEFCLASS + +(defclass not-a-condition-0 nil nil) + +(define-condition-with-tests condition-in-super-1a nil nil) +(define-condition-with-tests condition-in-super-1b nil nil) + +(deftest condition-in-defclass-superclass-1.1 + (signals-error (defclass condition-in-defclass-superclass-1a (condition-in-super-1a) + ()) + portable-condition-system::invalid-superclass) + t) + +(deftest condition-in-defclass-superclass-1.2 + (signals-error (defclass condition-in-defclass-superclass-1b (not-a-condition-0 + condition-in-super-1b + condition-in-super-1a) + ()) + portable-condition-system::invalid-superclass) + t) + +;;;