Added chain-same-class? in with-condition-translation in src/macros.lisp

* src/macros.lisp (with-condition-translation): accept chain-same-class?
  parameter which controls whether conditions which already are
  instances of the target condition class should still be wrapped in an
  instance of the target condition class
* test/macros.lisp
  (test with-condition-translation.smoke/chain-same-class): new test
  case; test supplying different values for the new chain-same-class?
  parameter of the `with-condition-translation' macro
* more-conditions.asd (+version-revision+): bumped 4 -> 5

more-conditions.asd

@@ -23,7 +23,7 @@
 (defparameter +version-minor+ 4
   "Minor component of version number.")
 
-(defparameter +version-revision+ 4
+(defparameter +version-revision+ 5
   "Revision component of version number.")
 
 (defun version/list ()

src/macros.lisp

@@ -40,15 +40,20 @@
    MUFFLE? controls whether the original condition should be muffled
    after the translation has been performed. \(This is useful for
    `cl:warning's and generic `cl:condition's which would not get
-   handled by resignaling via e.g. `cl:warn')."
+   handled by resignaling via e.g. `cl:warn').
+
+   CHAIN-SAME-CLASS? controls whether conditions which already are
+   instances of TO-CONDITION should still be wrapped in a TO-CONDITION
+   instance. The default is false."
   (flet ((do-clause (clause)
            (destructuring-bind
                  ((from-condition to-condition
                    &key
-                   (var            (gensym) var-supplied?)
-                   (cause-initarg  :cause)
-                   (signal-via     'error)
-                   (muffle?        (subtypep from-condition 'warning)))
+                   (var              (gensym) var-supplied?)
+                   (cause-initarg    :cause)
+                   (signal-via       'error)
+                   (muffle?          (subtypep from-condition 'warning))
+                   chain-same-class?)
                   &body initargs)
                clause
              (when var-supplied?
@@ -58,7 +63,9 @@
              (check-type cause-initarg  symbol)
              (check-type signal-via     symbol)
 
-             `((and ,from-condition (not ,to-condition))
+             `((and ,from-condition
+                    ,@(unless chain-same-class?
+                        `((not ,to-condition))))
                (lambda (,var)
                  ,@(unless (or var-supplied? cause-initarg muffle?)
                      `((declare (ignore ,var))))

test/macros.lisp

@@ -47,6 +47,41 @@
         (is (eq source   (cause                 condition)))
         (is (eq source   (root-cause            condition)))))))
 
+(test with-condition-translation.smoke/chain-same-class
+  "Smoke test for chaining causing conditions of the same class in
+   nested translations."
+
+  (let ((source (make-condition 'source-condition)))
+    ;; Without chaining causing conditions of the same class (the
+    ;; default), SOURCE should be wrapped in one
+    ;; `target-condition/cause' condition.
+    (handler-case
+        (with-condition-translation (((error target-condition/cause
+                                             :chain-same-class? nil)))
+          (with-condition-translation (((error target-condition/cause)))
+            (error source)))
+      (target-condition/cause (condition)
+        (is (eq :default (target-condition-slot condition)))
+        (is (eq source   (cause                 condition)))
+        (is (eq source   (root-cause            condition)))))
+
+    ;; With chaining causing conditions of the same class, SOURCE
+    ;; should be wrapped in two `target-condition/cause' conditions.
+    (handler-case
+        (with-condition-translation (((error target-condition/cause
+                                       :chain-same-class? t)))
+          (with-condition-translation (((error target-condition/cause)))
+            (error source)))
+      (target-condition/cause (condition)
+        (is (eq :default (target-condition-slot condition)))
+        (is (eq :default (target-condition-slot (cause condition))))
+
+        (is (typep (cause condition) 'target-condition/cause))
+        (is (eq source   (cause                 (cause condition))))
+
+        (is (eq source   (root-cause            condition)))
+        (is (eq source   (root-cause            (cause condition))))))))
+
 (def-fixture with-mock-generic-function/foo ()
   (unwind-protect
        (progn