Change DEFINE-CONDITION: signals a TYPE-ERROR if trying to supertype a non-CONDITION

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")

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))

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."

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

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

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)
+
+;;;