From 89d5c724e9008bddad5ea421b321630349988277 Mon Sep 17 00:00:00 2001 From: Luan Date: Sun, 21 Feb 2021 15:39:39 -0400 Subject: [PATCH 1/2] Change DEFINE-CONDITION to handle only CONDITION's subtypes. Add DEFINE-CONDITION-INTERNAL to handle internal conditions (DEFINE-CONDITION-INTERNAL is necessary because we don't know beforehand the relationship between the internal conditions and CONDITION, needed by COERCE-CONDITION-SUPERTYPES.) --- src/condition-hierarchy.lisp | 64 ++++++++++++++++++------------------ src/conditions.lisp | 23 ++++++++++++- 2 files changed, 54 insertions(+), 33 deletions(-) diff --git a/src/condition-hierarchy.lisp b/src/condition-hierarchy.lisp index 32de7d8..c57c482 100644 --- a/src/condition-hierarchy.lisp +++ b/src/condition-hierarchy.lisp @@ -8,13 +8,13 @@ ;;; documentation strings due to the repetitiveness of the contents of this ;;; file. -(define-condition warning (condition) ()) +(define-condition-internal warning (condition) ()) -(define-condition serious-condition (condition) ()) +(define-condition-internal serious-condition (condition) ()) -(define-condition error (serious-condition) ()) +(define-condition-internal error (serious-condition) ()) -(define-condition style-warning (warning) ()) +(define-condition-internal style-warning (warning) ()) (defun report-simple-condition (condition stream) (let ((format-control (simple-condition-format-control condition)) @@ -24,7 +24,7 @@ (format stream "Condition ~S was signaled with format arguments ~S." (type-of condition) format-args)))) -(define-condition simple-condition () +(define-condition-internal simple-condition () ((format-control :reader simple-condition-format-control :initarg :format-control) (format-arguments :reader simple-condition-format-arguments @@ -32,43 +32,43 @@ (:default-initargs :format-control nil :format-arguments '()) (:report report-simple-condition)) -(define-condition simple-warning (simple-condition warning) ()) +(define-condition-internal simple-warning (simple-condition warning) ()) -(define-condition simple-error (simple-condition error) ()) +(define-condition-internal simple-error (simple-condition error) ()) -(define-condition storage-condition (serious-condition) ()) +(define-condition-internal storage-condition (serious-condition) ()) (defun report-type-error (condition stream) (format stream "~@" (type-error-datum condition) (type-error-expected-type condition))) -(define-condition type-error (error) +(define-condition-internal type-error (error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report report-type-error)) -(define-condition simple-type-error (simple-condition type-error) ()) +(define-condition-internal simple-type-error (simple-condition type-error) ()) -(define-condition control-error (error) ()) +(define-condition-internal control-error (error) ()) -(define-condition program-error (error) ()) +(define-condition-internal program-error (error) ()) -(define-condition cell-error (error) +(define-condition-internal cell-error (error) ((name :reader cell-error-name :initarg :name))) (defun report-unbound-variable (condition stream) (format stream "The variable ~S is unbound." (cell-error-name condition))) -(define-condition unbound-variable (cell-error) () +(define-condition-internal unbound-variable (cell-error) () (:report report-unbound-variable)) (defun report-undefined-function (condition stream) (format stream "The function ~S is undefined." (cell-error-name condition))) -(define-condition undefined-function (cell-error) () +(define-condition-internal undefined-function (cell-error) () (:report report-undefined-function)) (defun report-unbound-slot (condition stream) @@ -76,45 +76,45 @@ (cell-error-name condition) (unbound-slot-instance condition))) -(define-condition unbound-slot (cell-error) +(define-condition-internal unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance)) (:report report-unbound-slot)) -(define-condition stream-error (error) +(define-condition-internal stream-error (error) ((stream :reader stream-error-stream :initarg :stream))) -(define-condition end-of-file (stream-error) ()) +(define-condition-internal end-of-file (stream-error) ()) -(define-condition parse-error (error) (stream)) +(define-condition-internal parse-error (error) (stream)) -(define-condition reader-error (parse-error stream-error) ()) +(define-condition-internal reader-error (parse-error stream-error) ()) -(define-condition package-error (error) +(define-condition-internal package-error (error) ((package :reader package-error-package :initarg :package))) -(define-condition arithmetic-error (error) +(define-condition-internal arithmetic-error (error) ((operation :reader operation-error-operation :initarg :operation) (operands :reader operands-error-operands :initarg :operands))) -(define-condition division-by-zero (arithmetic-error) ()) +(define-condition-internal division-by-zero (arithmetic-error) ()) -(define-condition floating-point-invalid-operation (arithmetic-error) ()) +(define-condition-internal floating-point-invalid-operation (arithmetic-error) ()) -(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition-internal floating-point-inexact (arithmetic-error) ()) -(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition-internal floating-point-overflow (arithmetic-error) ()) -(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition-internal floating-point-underflow (arithmetic-error) ()) -(define-condition file-error (error) +(define-condition-internal file-error (error) ((pathname :reader pathname-error-pathname :initarg :pathname))) -(define-condition print-not-readable (error) +(define-condition-internal print-not-readable (error) ((object :reader print-not-readable-object :initarg :object))) ;;; Non-standard condition types -(define-condition restart-not-found (control-error) +(define-condition-internal restart-not-found (control-error) ((restart-name :reader restart-not-found-restart-name :initarg :restart-name)) (:documentation "A condition type signaled when a restart with a given name was not found, even thought it was expected.") @@ -122,7 +122,7 @@ was not found, even thought it was expected.") (format stream "Restart ~S is not active." (restart-not-found-restart-name condition))))) -(define-condition abort-failure (control-error) () +(define-condition-internal abort-failure (control-error) () (:documentation "A condition type signaled when the ABORT restart invoked by function ABORT failed to transfer control outside of the function.") (:report "An ABORT restart failed to transfer control.")) @@ -133,7 +133,7 @@ function ABORT failed to transfer control outside of the function.") (case-failure-name condition) (case-failure-possibilities condition))) -(define-condition case-failure (type-error) +(define-condition-internal case-failure (type-error) ((name :reader case-failure-name :initarg :name) (possibilities :reader case-failure-possibilities :initarg :possibilities)) (:documentation "A condition type signaled when a case assertion diff --git a/src/conditions.lisp b/src/conditions.lisp index e0cae4a..a85cc37 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -47,12 +47,33 @@ 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))))) +(defmacro define-condition-internal (name (&rest supertypes) direct-slots &rest options) + "Defines a new condition type via DEFCLASS, handling the :REPORT options via +defining a PRINT-object method on the newly created class. +This is for internal use, allowing any SUPERTYPES." + (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))) + +(defun coerce-condition-supertypes (supertypes) + "Ensures that CONDITION is present in the SUPERTYPES list and that all of SUPERTYPES +members themselves are subclasses of CONDITION." + (let ((only-condition-subtypes (remove-if #'(lambda (x) + (not (subtypep x 'condition))) + supertypes))) + (or only-condition-subtypes '(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)))) + (supertypes (coerce-condition-supertypes supertypes))) `(progn (defclass ,name ,supertypes ,direct-slots ,@other-options) ,@(if report-option `(,(expand-define-condition-report-method name report-option)) From 9bc7c96aeb4f20d80c46f533235f0bd22dbdca29 Mon Sep 17 00:00:00 2001 From: Luan Date: Sun, 21 Feb 2021 15:39:39 -0400 Subject: [PATCH 2/2] Change DEFINE-CONDITION: signals a TYPE-ERROR if trying to supertype a non-CONDITION Other changes: Adds a INVALID-SUPERCLASS condition. Signals INVALID-SUPERCLASS when a DEFCLASS outside of DEFINE-CONDITION tries to superclass a CONDITION. --- portable-condition-system.asd | 4 +++- src/condition-hierarchy.lisp | 14 ++++++++++++ src/conditions.lisp | 37 ++++++++++++++++++++++++++----- src/package.lisp | 1 + t/ansi-test/define-condition.lisp | 35 +++++++++++++++++++++++++++++ t/more-tests.lisp | 26 ++++++++++++++++++++++ 6 files changed, 111 insertions(+), 6 deletions(-) create mode 100644 t/more-tests.lisp 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) + +;;;