From 3fa1d7213711795cbeb3caf1c39aa91841263ec7 Mon Sep 17 00:00:00 2001 From: Mike Appleby <86076+appleby@users.noreply.github.com> Date: Sat, 1 Jan 2022 12:25:17 -0600 Subject: [PATCH] Fix ASSERTIONS test in FIASCO-BASIC-SELF-TESTS Don't modify the suite's CHILDREN-OF hash-table while (potentially) traversing it. Adding elements to the hash-table while traversing it is undefined behavior according to the spec (3.6 Traversal Rules and Side Effects). On recent versions of SBCL on my macbook, this was signaling the following error due to hash-table corruption if a single new DEFTEST form was added in test/basic.lisp. UNEXPECTED-ERROR when running FIASCO-SUITES::FIASCO-BASIC-SELF-TESTS There is no applicable method for the generic function # when called with arguments (0). See also: The ANSI Standard, Section 7.6.6 The call to AUTO-CALL? that was failing occurs in one of the LOOP clauses in the DEFTEST form in the macro-expansion of DEFSUITE in src/suite.lisp while iterating over the HASH-VALUES of the CHILDREN-OF of the current suite. Saving and restoring the CHILDREN-OF the current suite in the body of the ASSERTIONS test fixes the issue. --- test/basic.lisp | 110 +++++++++++++++++++++++++++--------------------- 1 file changed, 62 insertions(+), 48 deletions(-) diff --git a/test/basic.lisp b/test/basic.lisp index 507b9cb..64c4530 100644 --- a/test/basic.lisp +++ b/test/basic.lisp @@ -11,6 +11,7 @@ (:import-from #:fiasco #:*suite* #:name-of #:parent-of + #:children-of #:delete-test #:count-tests @@ -88,55 +89,68 @@ t) (deftest assertions (&key (test-name (gensym "TEMP-TEST"))) - (unwind-protect - (eval `(deftest ,test-name () - (is (= 42 42)) - (is (= 1 42)) ; fails - (is (not (= 42 42))) ; fails - (is (true-macro)) - (is (true-macro) "Oh yes, glad that it's ~a" "true") - (is (not (false-macro))) - - (signals serious-condition (error "foo")) - (signals serious-condition 'not) ; fails - - (not-signals warning (warn "foo")) ; fails - (not-signals warning 'not) + (let* ((this-suite (find-test 'fiasco-suites::fiasco-basic-self-tests)) + (old-children (children-of this-suite))) + (unwind-protect + (progn + ;; The DEFTEST form will modify the (CHILDREN-OF THIS-SUITE), but we + ;; might currently be iterating over that HASH-TABLE, e.g. if this + ;; test was invoked via FIASCO:ALL-TESTS or similar. According to the + ;; spec, the consequences are undefined if you add a new element to a + ;; HASH-TABLE while traversing it, so make a copy here and restore + ;; the old value below. + (setf (children-of this-suite) (alexandria:copy-hash-table old-children)) + (eval `(deftest ,test-name () + (is (= 42 42)) + (is (= 1 42)) ; fails + (is (not (= 42 42))) ; fails + (is (true-macro)) + (is (true-macro) "Oh yes, glad that it's ~a" "true") + (is (not (false-macro))) + + (signals serious-condition (error "foo")) + (signals serious-condition 'not) ; fails + + (not-signals warning (warn "foo")) ; fails + (not-signals warning 'not) - (with-expected-failures - (ignore-errors - (finishes (error "expected failure")))) ; fails - (finishes 42) - (ignore-errors ; fails - (finishes (error "foo"))))) - (progn - ;; this uglyness here is due to testing the test framework which is inherently - ;; not nestable, so we need to backup and restore some state - (let* ((context *context*) - (old-assertion-count (length (assertions-of context))) - (old-failure-description-count (length (failures-of context)))) - (unwind-protect - (progn - (let ((*debug-on-unexpected-error* nil) - (*debug-on-assertion-failure* nil) - (*print-test-run-progress* nil)) - (funcall test-name)))) - (is (= (length (assertions-of context)) - (+ old-assertion-count 14))) ; also includes the current assertion - (is (= (length (failures-of context)) - (+ old-failure-description-count 6))) - (is (= 1 (count-if 'expected-p (failures-of context)))) - (is (= 1 (length (children-contexts-of context)))) - ;; drop the subtest by the test-test - ;; - (setf (parent-context-of (first (children-contexts-of context))) nil) - (is (= 0 (length (children-contexts-of context))))) - ;; Take this occasion to test some deleting, too - ;; - (delete-test test-name :otherwise nil) - (signals error (delete-test test-name :otherwise :error)) - (is (not (find-test test-name :otherwise nil))) - )) + (with-expected-failures + (ignore-errors + (finishes (error "expected failure")))) ; fails + (finishes 42) + (ignore-errors ; fails + (finishes (error "foo")))))) + (progn + ;; this uglyness here is due to testing the test framework which is inherently + ;; not nestable, so we need to backup and restore some state + (let* ((context *context*) + (old-assertion-count (length (assertions-of context))) + (old-failure-description-count (length (failures-of context)))) + (unwind-protect + (progn + (let ((*debug-on-unexpected-error* nil) + (*debug-on-assertion-failure* nil) + (*print-test-run-progress* nil)) + (funcall test-name)))) + (is (= (length (assertions-of context)) + (+ old-assertion-count 14))) ; also includes the current assertion + (is (= (length (failures-of context)) + (+ old-failure-description-count 6))) + (is (= 1 (count-if 'expected-p (failures-of context)))) + (is (= 1 (length (children-contexts-of context)))) + ;; drop the subtest by the test-test + ;; + (setf (parent-context-of (first (children-contexts-of context))) nil) + (is (= 0 (length (children-contexts-of context))))) + ;; Take this occasion to test some deleting, too + ;; + (delete-test test-name :otherwise nil) + (signals error (delete-test test-name :otherwise :error)) + (is (not (find-test test-name :otherwise nil))) + ;; Restore children + ;; + (setf (children-of this-suite) old-children) + ))) (values)) (deftest slightly-verbose-test ()