From ccc896921cc79c8d183deef4f3fe0d755235a25b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Sun, 19 Nov 2023 15:28:38 +0100 Subject: [PATCH] Recognise Sharpsign Single-Quote function names in DEFINE-TESTCASE --- src/testcase.lisp | 62 ++++++++++++++++++++++++++-------------- testsuite/testcase.lisp | 33 +++++++++++++-------- testsuite/utilities.lisp | 19 ++++++++++++ 3 files changed, 80 insertions(+), 34 deletions(-) diff --git a/src/testcase.lisp b/src/testcase.lisp index a1474b8..9d5bc04 100644 --- a/src/testcase.lisp +++ b/src/testcase.lisp @@ -40,6 +40,9 @@ Usually TESTSUITE but commonly used values are ACCEPTANCE, INTEGRATION, PREFLIGH (defparameter *testsuite-id* nil "A unique identfier for the current testsuite run batch.") +(defparameter *last-testsuite-result* nil + "The results of the last testsuite that ran.") + ;;;; ;;;; TESTSUITE-IDENTIFICATION @@ -192,14 +195,26 @@ guarantees that conditions triggered by the evaluation of arguments are recorded (defun define-testcase/wrap-confidence-forms (body-forms) "Walks through BODY-FORMS and wrap assertion forms in a RESTART-CASE." (labels - ((is-funcall-p (form) + ((function-name (form) + (cond + ((symbolp form) + form) + ((and (listp form) (eq (first form) 'quote)) + (second form)) + ((and (listp form) (eq (first form) 'function)) + (second form)))) + (is-funcall-p (form) + "Predicate recognising forms which are function calls. +When the form is a function call, the returned value is the +symbol of this function." (when (and (listp form) (not (null form)) (symbolp (first form)) (listp (rest form))) (case (first form) ((funcall apply) - (second form)) + (function-name (second form))) (t (first form))))) (is-assert-name-p (symbol) (and + (symbolp symbol) (>= (length (symbol-name symbol)) 7) (and (string= (symbol-name symbol) "ASSERT" :end1 6) (position (char (symbol-name symbol) 6) "-=<>")) @@ -242,13 +257,16 @@ guarantees that conditions triggered by the evaluation of arguments are recorded (describe result stream)))) (defun maybe-perform-testsuite-epilogue () - "When invoked from a testsuite, prints datails about the results." + "When invoked from a testsuite, performs testsuite epilogue. +The testsuite epilogue prints details about the current testcase +result and saves the result as the *LAST-TESTSUITE-RESULT*." (when (< 1 (length *testcase-path*)) - (return-from maybe-perform-testsuite-epilogue *current-testcase-result*)) + (return-from maybe-perform-testsuite-epilogue + *current-testcase-result*)) (when (>= 1 (length *testcase-path*)) - (setf *testsuite-last-result* *current-testcase-result*) - (describe *testsuite-last-result*) - (format t "~&"))) + (setf *last-testsuite-result* *current-testcase-result*) + (describe *last-testsuite-result*) + (terpri))) (defmacro define-testcase (testcase-name testcase-args &body body) "Define a test case function TESTCASE-NAME, accepting TESTCASE-ARGS with BODY. @@ -270,18 +288,18 @@ reflecting the failure or success of tests." ,@(when doc-string (list doc-string)) ,@declarations (declare (optimize (safety 3) (debug 3))) - (let ((*testsuite-id* - (or *testsuite-id* (make-testsuite-id))) - (*current-testcase-result* - (make-instance - 'testcase-result - :results nil - :name (quote ,testcase-name) - :path *testcase-path*)) - (*testcase-path* - (cons (quote ,testcase-name) *testcase-path*))) - ,@(define-testcase/wrap-confidence-forms remaining-forms) - (maybe-perform-testsuite-epilogue))) + (let ((*testsuite-id* + (or *testsuite-id* (make-testsuite-id))) + (*current-testcase-result* + (make-instance + 'testcase-result + :results nil + :name (quote ,testcase-name) + :path *testcase-path*)) + (*testcase-path* + (cons (quote ,testcase-name) *testcase-path*))) + ,@(define-testcase/wrap-confidence-forms remaining-forms) + (maybe-perform-testsuite-epilogue))) (export (quote ,testcase-name)) (set-testcase-properties ',testcase-name)))) @@ -296,14 +314,14 @@ reflecting the failure or success of tests." (let ((exit-code-success 0) (exit-code-failure 1) (exit-code-configuration 78)) - (unless *testsuite-last-result* + (unless *last-testsuite-result* (format t "~&Error: There was no testsuite performed.~%") (uiop:quit exit-code-configuration)) - (with-slots (success total) *testsuite-last-result* + (with-slots (success total) *last-testsuite-result* (when (= 0 total) (format t "~&Error: There was a testsuite performed but no test result recorded.~%") (uiop:quit exit-code-configuration)) - (export-testcase-result *testsuite-last-result*) + (export-testcase-result *last-testsuite-result*) (if (< success total) (uiop:quit exit-code-failure) (uiop:quit exit-code-success))))) diff --git a/testsuite/testcase.lisp b/testsuite/testcase.lisp index 95fc59f..4d080df 100644 --- a/testsuite/testcase.lisp +++ b/testsuite/testcase.lisp @@ -13,15 +13,6 @@ (in-package #:org.melusina.confidence/testsuite) -(defun make-actual-testcase-result () - (let ((confidence::*testcase-path* - nil) - (confidence::*current-testcase-result* - nil) - (confidence:*testcase-interactive-p* t)) - (funcall (intern "VALIDATE-SUPERVISE-ASSERTION" - (find-package "ORG.MELUSINA.CONFIDENCE/TESTSUITE"))))) - (define-testcase validate-supervise-assertion () ;; Mask the following assertion ;; which is currently triggering a SIGILL (illegal CPU instruction) @@ -40,6 +31,9 @@ (assert-t (error "An intentional error condition"))) 'assertion-condition)) +(define-testcase a-successful-testsuite () + (assert-t t)) + (define-testcase a-failing-argument-testsuite () (assert-t nil) (assert-eq 0 (+ 1 1)) @@ -50,12 +44,27 @@ (assert-t nil) (assert-eq 0 (+ 1 1))) +(define-testcase a-succesful-testsuite-with-function-calls () + (funcall 'a-successful-testsuite) + (funcall #'a-successful-testsuite) + (apply 'a-successful-testsuite nil) + (apply #'a-successful-testsuite nil) + (loop :for a :in '(1 2) + :do (funcall #'a-successful-testsuite))) + (define-testcase validate-define-testcase () - (let ((testcase-result - (make-actual-testcase-result))) - (assert-eq 3 (length (slot-value testcase-result 'confidence::results))))) + (with-testcase-result testcase-result (validate-supervise-assertion) + (assert-type testcase-result 'confidence:testcase-result) + (assert-eq 2 (length (slot-value testcase-result 'confidence::results))))) + +(define-testcase ensure-that-define-testcase-recognises-sharpsign-single-quote-in-function-names () + (with-testcase-result testcase-result (a-succesful-testsuite-with-function-calls) + (assert-type testcase-result 'confidence:testcase-result) + (assert-eq 6 (length (slot-value testcase-result 'confidence::results))))) (define-testcase testsuite-testcase () + (validate-define-testcase) + (ensure-that-define-testcase-recognises-sharpsign-single-quote-in-function-names) (validate-supervise-assertion)) ;;;; End of file `testcase.lisp' diff --git a/testsuite/utilities.lisp b/testsuite/utilities.lisp index 1709634..40815e6 100644 --- a/testsuite/utilities.lisp +++ b/testsuite/utilities.lisp @@ -62,6 +62,25 @@ has the required type." (confidence::supervise-assertion ,(ensure-unwrap form)) ,condition-type)) + +;;;; +;;;; WITH-TESTCASE-RESULT +;;;; + +(defmacro with-testcase-result (var form &body body) + "Bind the testcase result of FORM in VAR and execute BODY." + `(let ((,var + (let ((*standard-output* + (make-string-output-stream)) + (confidence::*testcase-path* + '(with-testcase-result)) + (confidence::*current-testcase-result* + nil) + (confidence:*testcase-interactive-p* + t)) + ,form))) + ,@body)) + ;;;; ;;;; Testing STRING-MATCH