├── .gitignore ├── .travis.yml ├── fiasco.asd ├── src ├── streams.lisp ├── package.lisp ├── test.lisp ├── asserts.lisp ├── suite.lisp └── infrastructure.lisp ├── test ├── suite-tests.lisp ├── intro-example.lisp └── basic.lisp ├── LICENCE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *Changelog* 2 | *.*fasl* 3 | *~ 4 | \#*\# 5 | .\#* 6 | 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: lisp 2 | sudo: required 3 | 4 | env: 5 | matrix: 6 | # - LISP=abcl 7 | # - LISP=allegro 8 | - LISP=sbcl 9 | # - LISP=sbcl32 10 | # - LISP=ccl 11 | # - LISP=ccl32 12 | # - LISP=clisp 13 | # - LISP=clisp32 14 | # - LISP=cmucl 15 | # - LISP=ecl 16 | 17 | matrix: 18 | allow_failures: 19 | # CIM not available for CMUCL 20 | - env: LISP=cmucl 21 | 22 | install: 23 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 24 | 25 | script: 26 | - cl -e '(push *default-pathname-defaults* ql:*local-project-directories*) 27 | (ql:quickload :fiasco) 28 | (ql:quickload :fiasco-self-tests) 29 | (unless (fiasco:run-tests 30 | (quote (:fiasco-basic-self-tests 31 | :fiasco-intro-example 32 | :fiasco-suite-tests 33 | ))) 34 | (uiop:quit 1))' -------------------------------------------------------------------------------- /fiasco.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors, 4 | ;;; 2014-2015 João Távora 5 | ;;; 6 | ;;; See LICENCE for details. 7 | 8 | (asdf:defsystem #:fiasco 9 | :description "A Common Lisp test framework that treasures your failures, logical continuation of Stefil." 10 | :author "João Távora " 11 | :license "BSD 2-clause" 12 | :depends-on (#:alexandria #:trivial-gray-streams) 13 | :components 14 | ((:module "src" 15 | :serial t 16 | :components 17 | ((:file "package") 18 | (:file "streams") 19 | (:file "infrastructure") 20 | (:file "asserts") 21 | (:file "test") 22 | (:file "suite"))))) 23 | 24 | (asdf:defsystem #:fiasco-self-tests 25 | :licence "BSD / Public domain" 26 | :depends-on (#:fiasco) 27 | :serial t 28 | :components ((:module "test" 29 | :serial t 30 | :components 31 | ((:file "basic") 32 | (:file "intro-example") 33 | (:file "suite-tests"))))) 34 | 35 | 36 | ;; Local Variables: 37 | ;; coding: utf-8-unix 38 | ;; End: 39 | -------------------------------------------------------------------------------- /src/streams.lisp: -------------------------------------------------------------------------------- 1 | (in-package :fiasco) 2 | 3 | (defclass column-counting-output-stream 4 | (trivial-gray-streams:fundamental-character-output-stream) 5 | ((column :initform 0 :accessor output-column) 6 | (understream :initarg :understream :initform (error "required!")))) 7 | 8 | (defmethod trivial-gray-streams:stream-write-sequence 9 | ((s column-counting-output-stream) 10 | seq start end &key) 11 | "Write SEQ to stream S." 12 | (let ((newline-pos (position #\Newline seq :from-end t))) 13 | (when newline-pos 14 | (setf (output-column s) (- (length seq) newline-pos 1)))) 15 | (write-sequence seq (slot-value s 'understream) :start start :end end)) 16 | 17 | (defmethod trivial-gray-streams:stream-line-column 18 | ((s column-counting-output-stream)) 19 | "Tell column number that stream S is currently at." 20 | (output-column s)) 21 | 22 | (defmethod trivial-gray-streams:stream-start-line-p 23 | ((s column-counting-output-stream)) 24 | "Tell if stream S is already at start of fresh new line." 25 | (zerop (output-column s))) 26 | 27 | (defmethod trivial-gray-streams:stream-write-char 28 | ((s column-counting-output-stream) char) 29 | "Write CHAR to stream S." 30 | (if (char= char #\Newline) 31 | (setf (output-column s) 0) 32 | (incf (output-column s))) 33 | (write-char char (slot-value s 'understream))) 34 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors, 2014 João Távora 4 | ;;; 5 | ;;; See LICENCE for details. 6 | 7 | (in-package :common-lisp-user) 8 | 9 | (defpackage :fiasco 10 | (:use :alexandria 11 | :common-lisp) 12 | 13 | (:export #:find-test 14 | #:deftest 15 | #:is 16 | #:signals 17 | #:not-signals 18 | #:skip 19 | #:skip-unless 20 | #:finishes 21 | #:with-expected-failures 22 | #:root-suite 23 | #:defsuite 24 | #:without-debugging 25 | #:without-test-progress-printing 26 | #:funcall-test-with-feedback-message 27 | #:run-failed-tests 28 | #:extract-test-run-statistics 29 | 30 | #:*test-progress-print-right-margin* 31 | #:*test-result-history* 32 | #:*last-test-result* 33 | 34 | ;; these are the defaults from which the test context is initialized 35 | #:*print-test-run-progress* 36 | #:*debug-on-unexpected-error* 37 | #:*debug-on-assertion-failure* 38 | #:*always-show-failed-sexp* 39 | #:*ignore-package-suite-mismatch* 40 | #:*warn-about-test-redefinitions* 41 | #:all-tests 42 | #:define-test-package 43 | #:run-tests 44 | #:run-package-tests 45 | #:describe-failed-tests 46 | #:run-suite-tests)) 47 | -------------------------------------------------------------------------------- /test/suite-tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package (#:fiasco-suite-tests :in fiasco::root-suite) 2 | ;; HACK: We exceptionally hang the resulting test suite in 3 | ;; FIASCO::ROOT-SUITE (not FIASCO-SUITES::ALL-TESTS) so that 4 | ;; FIASCO:ALL-TESTS doesn't call it. This prevent an infinite loop 5 | ;; later on. 6 | ;; 7 | (:use :cl :fiasco)) 8 | (in-package #:fiasco-suite-tests) 9 | 10 | (defvar *foo*) 11 | (defvar *bar*) 12 | (defvar *baz*) 13 | 14 | ;;; Test basic suite parenting and interaction with 15 | ;;; DEFINE-TEST-PACKAGE. 16 | ;;; 17 | ;;; Define four test suites: one parent suite, two children, and 18 | ;;; another unrelated suite. Except for the parent suite, all of them 19 | ;;; are defined with DEFINE-TEST-PACKAGE and carry single test that 20 | ;;; signals a flag. 21 | ;;; 22 | (defsuite (dummy-parent-suite :in fiasco-suites::all-tests)) 23 | 24 | (define-test-package (child-suite-foo :in fiasco-suite-tests::dummy-parent-suite) 25 | (:use :cl :fiasco)) 26 | (in-package child-suite-foo) 27 | 28 | (deftest dummy-foo () (setq fiasco-suite-tests::*foo* t)) 29 | 30 | (define-test-package (child-suite-bar :in fiasco-suite-tests::dummy-parent-suite) 31 | (:use :cl :fiasco)) 32 | (in-package child-suite-bar) 33 | 34 | (deftest dummy-bar () (setq fiasco-suite-tests::*bar* t)) 35 | 36 | (define-test-package (child-suite-baz) 37 | (:use :cl :fiasco)) 38 | (in-package child-suite-baz) 39 | 40 | (deftest dummy-baz () (setq fiasco-suite-tests::*baz* t)) 41 | 42 | (in-package #:fiasco-suite-tests) 43 | 44 | (deftest test-nested-suites () 45 | (let ((*bar* nil) 46 | (*foo* nil) 47 | (*baz* nil)) 48 | (dummy-parent-suite) 49 | (is *foo*) 50 | (is *bar*) 51 | (is (not *baz*)))) 52 | 53 | (deftest test-top-suites () 54 | (let ((*bar* nil) 55 | (*foo* nil) 56 | (*baz* nil)) 57 | ;; This call would trigger an infinite loop if fiasco-suite-tests 58 | ;; wasn't unparented as above. 59 | ;; 60 | (all-tests) 61 | (is *foo*) 62 | (is *bar*) 63 | (is *baz*))) 64 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Fiasco is public domain software: 2 | 3 | Authors dedicate this work to public domain, for the benefit of the 4 | public at large and to the detriment of the authors' heirs and 5 | successors. Authors intends this dedication to be an overt act of 6 | relinquishment in perpetuity of all present and future rights under 7 | copyright law, whether vested or contingent, in the work. Authors 8 | understands that such relinquishment of all rights includes the 9 | relinquishment of all rights to enforce (by lawsuit or otherwise) 10 | those copyrights in the work. 11 | 12 | Authors recognize that, once placed in the public domain, the work 13 | may be freely reproduced, distributed, transmitted, used, modified, 14 | built upon, or otherwise exploited by anyone for any purpose, 15 | commercial or non-commercial, and in any way, including by methods 16 | that have not yet been invented or conceived. 17 | 18 | In those legislations where public domain dedications are not 19 | recognized or possible, Fiasco is distributed under the following 20 | terms and conditions: 21 | 22 | Permission is hereby granted, free of charge, to any person 23 | obtaining a copy of this software and associated documentation files 24 | (the "Software"), to deal in the Software without restriction, 25 | including without limitation the rights to use, copy, modify, merge, 26 | publish, distribute, sublicense, and/or sell copies of the Software, 27 | and to permit persons to whom the Software is furnished to do so, 28 | subject to the following conditions: 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 31 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 32 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 33 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 34 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 35 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 36 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 37 | -------------------------------------------------------------------------------- /test/intro-example.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:fiasco-example-time (:use #:cl) 2 | (:export #:seconds #:hours-and-minutes)) 3 | (in-package #:fiasco-example-time) 4 | 5 | (defun seconds (hours-and-minutes) 6 | (+ (* 3600 (first hours-and-minutes)) 7 | (* G0 (second hours-and-minutes)))) 8 | 9 | (defun hours-and-minutes (seconds) 10 | (list (truncate seconds 3600) 11 | (truncate seconds 60))) 12 | 13 | (fiasco:define-test-package #:fiasco-examples 14 | (:use #:fiasco-example-time)) 15 | (in-package #:fiasco-examples) 16 | 17 | (deftest test-conversion-to-hours-and-minutes () 18 | (is (equal (hours-and-minutes 180) '(0 3))) 19 | (is (equal (hours-and-minutes 4500) '(1 15)))) 20 | 21 | (deftest test-conversion-to-seconds () 22 | (is (= 60 (seconds '(0 1)))) 23 | (is (= 4500 (seconds '(1 15))))) 24 | 25 | (deftest double-conversion () 26 | (is (= 3600 (seconds (hours-and-minutes 3600)))) 27 | (is (= 1234 (seconds (hours-and-minutes 1234))))) 28 | 29 | (deftest test-skip-test () 30 | (skip) 31 | ;; These should not affect the test statistics below. 32 | (is (= 1 1)) 33 | (is (= 1 2))) 34 | 35 | 36 | (fiasco:define-test-package #:fiasco-intro-example 37 | (:import-from #:fiasco)) 38 | (in-package #:fiasco-intro-example) 39 | 40 | ;; define a metatest to test the other tests 41 | ;; 42 | (deftest intro-metatest () 43 | (multiple-value-bind (success runs) 44 | (run-package-tests :package :fiasco-examples) 45 | (is (not success)) 46 | (is (= 1 (length runs))) 47 | (destructuring-bind (&key number-of-tests-run 48 | number-of-assertions 49 | number-of-failures 50 | number-of-failed-assertions 51 | number-of-unexpected-errors 52 | number-of-expected-failures 53 | number-of-skips 54 | &allow-other-keys) 55 | (extract-test-run-statistics (first runs)) 56 | ;; There are 4 = 6 - 2 assertions because the 57 | ;; last IS of TEST-CONVERSION-TO-SECONDS and 58 | ;; DOUBLE-CONVERSION don't get to execute because 59 | ;; of the unexpected errors in the previous IS. 60 | ;; 61 | (is (= 4 number-of-assertions)) 62 | ;; Remember that the suite itself counts as a 63 | ;; test. FIXME: this is confusing as hell 64 | ;; 65 | (is (= 5 number-of-tests-run)) 66 | (is (= 3 number-of-failures)) 67 | (is (= 1 number-of-failed-assertions)) 68 | (is (= 2 number-of-unexpected-errors)) 69 | (is (= 0 number-of-expected-failures)) 70 | (is (= 1 number-of-skips))) 71 | (values))) 72 | 73 | #+nil 74 | (defun seconds (hours-and-minutes) 75 | (+ (* 3600 (first hours-and-minutes)) 76 | (* 60 (second hours-and-minutes)))) 77 | #+nil 78 | (defun hours-and-minutes (seconds) 79 | (list (truncate seconds 3600) 80 | (/ (rem seconds 3600) 60))) 81 | 82 | ;; Local Variables: 83 | ;; coding: utf-8-unix 84 | ;; End: 85 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/joaotavora/fiasco.svg?branch=master)](https://travis-ci.org/joaotavora/fiasco) 2 | 3 | Fiasco 4 | ====== 5 | 6 | Fiasco is a simple and powerful test framework for Common Lisp, with 7 | a focus on interactive debugging. 8 | 9 | It's a fork of the abandoned [Stefil][stefil] by Attila Lendvai, Tamás 10 | Borbély and Levente Mészáros. 11 | 12 | Up and running 13 | -------------- 14 | 15 | Assuming you're using [quicklisp][quicklisp], type 16 | `(ql:quickload :fiasco)` somewhere in your REPL and create some Lisp 17 | file with: 18 | 19 | ```lisp 20 | (defpackage #:example-time (:export #:seconds #:hours-and-minutes)) 21 | (in-package #:example-time) 22 | 23 | (defun seconds (hours-and-minutes) 24 | (+ (* 3600 (first hours-and-minutes)) 25 | (* 60 (seconds hours-and-minutes)))) 26 | 27 | (defun hours-and-minutes (seconds) 28 | (list (truncate seconds 3600) 29 | (truncate seconds 60))) 30 | 31 | (fiasco:define-test-package #:fiasco-examples 32 | (:use #:example-time)) 33 | (in-package #:fiasco-examples) 34 | 35 | (deftest test-conversion-to-hours-and-minutes () 36 | (is (equal (hours-and-minutes 180) '(0 3))) 37 | (is (equal (hours-and-minutes 4500) '(1 15)))) 38 | 39 | (deftest test-conversion-to-seconds () 40 | (is (= 60 (seconds '(0 1)))) 41 | (is (= 4500 (seconds '(1 15))))) 42 | 43 | (deftest double-conversion () 44 | (is (= 3600 (seconds (hours-and-minutes 3600)))) 45 | (is (= 1234 (seconds (hours-and-minutes 1234))))) 46 | ``` 47 | load or compile it, and in your REPL run 48 | 49 | > (in-package :fiasco-examples) 50 | FIASCO-EXAMPLES> (run-package-tests) 51 | FIASCO-EXAMPLES (Suite) 52 | TEST-CONVERSION-TO-SECONDS [FAIL] 53 | TEST-CONVERSION-TO-HOURS-AND-MINUTES [FAIL] 54 | DOUBLE-CONVERSION [FAIL] 55 | 56 | Fiasco! (3 failures) 57 | 58 | Failure 1: UNEXPECTED-ERROR when running FIASCO-EXAMPLES::TEST-CONVERSION-TO-SECONDS 59 | Stack overflow (signal 1000) 60 | 61 | Failure 2: FAILED-ASSERTION when running FIASCO-EXAMPLES::TEST-CONVERSION-TO-HOURS-AND-MINUTES 62 | Binary predicate (EQUAL X Y) failed. 63 | x: (FIASCO-EXAMPLES::HOURS-AND-MINUTES 4500) => (1 75) 64 | y: '(1 15) => (1 15) 65 | 66 | Failure 3: UNEXPECTED-ERROR when running FIASCO-EXAMPLES::DOUBLE-CONVERSION 67 | Stack overflow (signal 1000) 68 | # 69 | 70 | Yay, everything fails! 71 | 72 | Debugging failures 73 | ------------------ 74 | 75 | Run the example again, with `:interactive t` to bring up the Lisp debugger 76 | every time a test failure happens. They are caused by error conditions or 77 | test assertion failures. We have two of the former and one of the latter. 78 | 79 | In this case, we see that the the stack overflow erros are due to a typo 80 | (`seconds` should be `second` in line 6) and that `hours-and-minutes` should 81 | be rewritten like: 82 | 83 | ```lisp 84 | (defun hours-and-minutes (seconds) 85 | (list (truncate seconds 3600) 86 | (/ (rem seconds 3600) 60))) 87 | ``` 88 | 89 | After that, you'll see a nice 90 | 91 | > (in-package :fiasco-examples) 92 | FIASCO-EXAMPLES> (run-package-tests) 93 | FIASCO-EXAMPLES (Suite) 94 | TEST-CONVERSION-TO-SECONDS [ OK ] 95 | TEST-CONVERSION-TO-HOURS-AND-MINUTES [ OK ] 96 | DOUBLE-CONVERSION [ OK ] 97 | # 98 | 99 | Skipping tests 100 | -------------- 101 | 102 | You can conditionally skip tests with `fiasco:skip` and `fiasco:skip-unless` 103 | 104 | ``` lisp 105 | (deftest test-a-platform-specific-test () 106 | (when (wrong-platform) 107 | (skip)) 108 | (is ...)) 109 | ;; or using skip-unless 110 | (deftest test-a-platform-specific-test () 111 | (skip-unless (correct-platform)) 112 | (is ...)) 113 | ``` 114 | 115 | Support 116 | ------- 117 | 118 | To discuss matters open an [issue][issues] for now or perhaps ask in 119 | the [#lisp][sharp-lisp] IRC channel. 120 | 121 | 122 | [stefil]: http://common-lisp.net/project/stefil/index-old.shtml 123 | [quicklisp]: http://quicklisp.org 124 | [asdf]: http://common-lisp.net/project/asdf/ 125 | [sharp-lisp]: irc://irc.freenode.net/#lisp 126 | [issues]: https://github.com/luismbo/fiasco/issues 127 | -------------------------------------------------------------------------------- /src/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors. 4 | ;;; 5 | ;;; See LICENCE for details. 6 | 7 | (in-package :fiasco) 8 | 9 | (defclass test (testable) 10 | ((package :initform nil :accessor package-of :initarg :package) 11 | (lambda-list :initform nil :accessor lambda-list-of :initarg :lambda-list) 12 | (compile-before-run :initform t :accessor compile-before-run-p 13 | :initarg :compile-before-run :type boolean) 14 | (declarations :initform nil :accessor declarations-of 15 | :initarg :declarations) 16 | (documentation :initform nil :accessor documentation-of 17 | :initarg :documentation) 18 | (body :initform nil :accessor body-of 19 | :initarg :body))) 20 | 21 | (defun ensure-test (name &rest args &key &allow-other-keys) 22 | (let ((test (find-test name :otherwise nil))) 23 | (if test 24 | (apply #'reinitialize-instance test args) 25 | (apply #'make-instance 'test :name name args)))) 26 | 27 | (defun call-with-test-handlers (function) 28 | ;; NOTE: the order of the bindings in this handler-bind is important 29 | (handler-bind 30 | ((failure 31 | (lambda (c) 32 | (declare (ignore c)) 33 | (unless *debug-on-assertion-failure* 34 | (continue)))) 35 | (serious-condition 36 | (lambda (c) 37 | (record-failure 'unexpected-error :error c) 38 | (unless *debug-on-unexpected-error* 39 | (return-from call-with-test-handlers))))) 40 | (funcall function))) 41 | 42 | (defun run-test-body-in-handlers (test function) 43 | (declare (type test test) 44 | (type function function)) 45 | (signal 'test-started :test test) 46 | (labels ((run-test-body () 47 | (restart-case 48 | (let* ((*package* (package-of test)) 49 | (*readtable* (copy-readtable)) 50 | (start-time (get-internal-run-time))) 51 | (multiple-value-prog1 52 | (funcall function) 53 | (setf (internal-realtime-spent-with-test-of *context*) 54 | (- (get-internal-run-time) start-time)))) 55 | (continue () 56 | :report (lambda (stream) 57 | (format stream "~ 58 | ~@" (name-of test))) 60 | (values)) 61 | (retest () 62 | :report (lambda (stream) 63 | (format stream "~@" 64 | (name-of test))) 65 | (reinitialize-instance *context*) 66 | (return-from run-test-body (run-test-body)))))) 67 | (call-with-test-handlers 68 | (lambda () 69 | (run-test-body))))) 70 | 71 | (defvar *run-test-function* 'run-test-body-in-handlers) 72 | 73 | (defmacro deftest (&whole whole name args &body body) 74 | (multiple-value-bind (remaining-forms declarations documentation) 75 | (parse-body body :documentation t :whole whole) 76 | (destructuring-bind (name &rest test-args &key (in nil in-provided?) 77 | timeout &allow-other-keys) 78 | (ensure-list name) 79 | (remove-from-plistf test-args :in) 80 | (with-unique-names (body-sym) 81 | `(progn 82 | (eval-when (:load-toplevel :execute) 83 | (ensure-test ',name 84 | :package ,*package* 85 | :lambda-list ',args 86 | :declarations ',declarations 87 | :documentation ',documentation 88 | :body ',remaining-forms 89 | ,@(when in-provided? 90 | `(:in (find-test ',in))) 91 | ,@test-args)) 92 | (defun ,name ,args 93 | ,@(when documentation (list documentation)) 94 | ,@declarations 95 | (let* ((*current-test* (find-test ',name)) 96 | (parent-context *context*) 97 | (*context* nil)) 98 | (labels ((,name () ,@remaining-forms) ; for clarity in debugger 99 | (,body-sym () 100 | (setq *context* 101 | (progn 102 | (make-instance 103 | 'context 104 | :test *current-test* 105 | :actual-test-arguments ,(lambda-list-to-value-list-expression args) 106 | :parent-context parent-context))) 107 | (handler-bind 108 | ((test-skipped 109 | (lambda (condition) 110 | (setf (skipped-p *context*) t) 111 | (continue condition))) 112 | (test-assertion 113 | (lambda (a) 114 | (push a (slot-value *context* 'self-assertions)) 115 | (muffle-warning))) 116 | (test-started 117 | (lambda (c) (declare (ignore c))))) 118 | (when ,timeout 119 | (error "TODO: timeouts are not implemented yet in Fiasco.")) 120 | (funcall *run-test-function* *current-test* #',name)))) 121 | (if parent-context 122 | (,body-sym) 123 | (with-toplevel-restarts 124 | (let ((*standard-output* (eval *test-run-standard-output*)) 125 | (*debug-on-assertion-failure* *debug-on-assertion-failure*) 126 | (*debug-on-unexpected-error* *debug-on-unexpected-error*) 127 | (*print-test-run-progress* *print-test-run-progress*) 128 | (*progress-char-count* *progress-char-count*)) 129 | (unwind-protect 130 | (let ((results (multiple-value-list (,body-sym)))) 131 | (multiple-value-prog1 132 | (values-list 133 | (append results 134 | (list *context*))) 135 | (when *print-test-run-progress* 136 | (terpri *debug-io*)))) 137 | (push *context* *test-result-history*) 138 | (setq *last-test-result* *context*))))))))))))) 139 | 140 | 141 | ;; Local Variables: 142 | ;; coding: utf-8-unix 143 | ;; End: 144 | -------------------------------------------------------------------------------- /test/basic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors. 4 | ;;; 5 | ;;; See LICENCE for details. 6 | (fiasco:define-test-package #:fiasco-basic-self-tests 7 | (:use #:cl) 8 | 9 | ;; These tests are testing FIASCO's own internals, so its 10 | ;; more-or-less OK to explicitly import some of it. Or is it? 11 | (:import-from #:fiasco #:*suite* 12 | #:name-of 13 | #:parent-of 14 | #:delete-test 15 | #:count-tests 16 | 17 | #:failures-of 18 | #:assertions-of 19 | 20 | #:expected-p 21 | #:children-contexts-of 22 | #:parent-context-of 23 | 24 | #:*context* 25 | 26 | #:lambda-list-to-value-list-expression 27 | #:lambda-list-to-funcall-expression 28 | #:lambda-list-to-variable-name-list)) 29 | (in-package #:fiasco-basic-self-tests) 30 | 31 | (deftest lifecycle () 32 | (let* ((original-test-count (count-tests *suite*)) 33 | (suite-name (gensym "TEMP-SUITE")) 34 | (test-name (gensym "TEMP-TEST")) 35 | (transient-test-name (gensym "TRANSIENT-TEST")) 36 | (transient-suite-name (gensym "TRANSIENT-SUITE")) 37 | (temp-suite (eval `(defsuite (,suite-name :in ,*suite*)))) 38 | (transient-suite (eval `(defsuite (,transient-suite-name :in ,*suite*))))) 39 | (unwind-protect 40 | (progn 41 | ;; The suites are freshly defined, test some things 42 | ;; 43 | (is (eq (parent-of temp-suite) *suite*)) 44 | (is (= (count-tests *suite*) (+ 2 original-test-count))) 45 | (is (eq (find-test (name-of temp-suite)) temp-suite)) 46 | (is (= (count-tests temp-suite) 0)) 47 | 48 | ;; Now define a test 49 | ;; 50 | (eval `(deftest (,test-name :in ,suite-name ) ())) 51 | (is (= (count-tests temp-suite) 1)) 52 | 53 | ;; redefining a test should keep the original test object 54 | ;; identity 55 | (let ((test (find-test test-name))) 56 | (eval `(deftest ,test-name ())) 57 | (is (eq test (find-test test-name)))) 58 | 59 | ;; Define a second test in the same TEMP-SUITE 60 | (eval `(deftest (,transient-test-name :in ,suite-name) ())) 61 | (is (= (count-tests temp-suite) 2)) 62 | 63 | (let ((transient-test (find-test transient-test-name))) 64 | (is (eq temp-suite (parent-of transient-test))) 65 | ;; Now redefine in another suite, TRANSIENT-SUITE 66 | (eval `(deftest (,transient-test-name :in ,transient-suite-name) ())) 67 | (is (eq transient-suite (parent-of transient-test))) 68 | (is (= (count-tests temp-suite) 1)) 69 | (is (= (count-tests transient-suite) 1)))) 70 | (setf (find-test suite-name) nil) 71 | (setf (find-test transient-suite-name) nil)) 72 | (signals error (find-test transient-test-name)) 73 | (signals error (find-test suite-name)))) 74 | 75 | (defparameter *global-counter-for-lexical-test* 0) 76 | 77 | (let ((counter 0)) 78 | (setf *global-counter-for-lexical-test* 0) 79 | (deftest counter-in-lexical-environment () 80 | (incf counter) 81 | (incf *global-counter-for-lexical-test*) 82 | (is (= counter *global-counter-for-lexical-test*)))) 83 | 84 | (defmacro false-macro () 85 | nil) 86 | 87 | (defmacro true-macro () 88 | t) 89 | 90 | (deftest assertions (&key (test-name (gensym "TEMP-TEST"))) 91 | (unwind-protect 92 | (eval `(deftest ,test-name () 93 | (is (= 42 42)) 94 | (is (= 1 42)) ; fails 95 | (is (not (= 42 42))) ; fails 96 | (is (true-macro)) 97 | (is (true-macro) "Oh yes, glad that it's ~a" "true") 98 | (is (not (false-macro))) 99 | 100 | (signals serious-condition (error "foo")) 101 | (signals serious-condition 'not) ; fails 102 | 103 | (not-signals warning (warn "foo")) ; fails 104 | (not-signals warning 'not) 105 | 106 | (with-expected-failures 107 | (ignore-errors 108 | (finishes (error "expected failure")))) ; fails 109 | (finishes 42) 110 | (ignore-errors ; fails 111 | (finishes (error "foo"))))) 112 | (progn 113 | ;; this uglyness here is due to testing the test framework which is inherently 114 | ;; not nestable, so we need to backup and restore some state 115 | (let* ((context *context*) 116 | (old-assertion-count (length (assertions-of context))) 117 | (old-failure-description-count (length (failures-of context)))) 118 | (unwind-protect 119 | (progn 120 | (let ((*debug-on-unexpected-error* nil) 121 | (*debug-on-assertion-failure* nil) 122 | (*print-test-run-progress* nil)) 123 | (funcall test-name)))) 124 | (is (= (length (assertions-of context)) 125 | (+ old-assertion-count 14))) ; also includes the current assertion 126 | (is (= (length (failures-of context)) 127 | (+ old-failure-description-count 6))) 128 | (is (= 1 (count-if 'expected-p (failures-of context)))) 129 | (is (= 1 (length (children-contexts-of context)))) 130 | ;; drop the subtest by the test-test 131 | ;; 132 | (setf (parent-context-of (first (children-contexts-of context))) nil) 133 | (is (= 0 (length (children-contexts-of context))))) 134 | ;; Take this occasion to test some deleting, too 135 | ;; 136 | (delete-test test-name :otherwise nil) 137 | (signals error (delete-test test-name :otherwise :error)) 138 | (is (not (find-test test-name :otherwise nil))) 139 | )) 140 | (values)) 141 | 142 | (deftest slightly-verbose-test () 143 | (format *error-output* "~&Watch out for me") 144 | (is t)) 145 | 146 | (deftest slightly-verbose-test-2 () 147 | (format *error-output* "...And me") 148 | (is t)) 149 | 150 | (deftest lambda-list-processing () 151 | (is (equal (lambda-list-to-value-list-expression '(p1 p2 &optional o1 (o2 "o2") &key k1 (k2 "k2") &allow-other-keys)) 152 | '(list (cons 'p1 p1) (cons 'p2 p2) (cons 'o1 o1) (cons 'o2 o2) (cons 'k1 k1) 153 | (cons 'k2 k2)))) 154 | (is (equal (lambda-list-to-funcall-expression 'foo '(p1 p2 &optional o1 (o2 "o2") &key k1 (k2 "k2") &allow-other-keys)) 155 | '(FUNCALL FOO P1 P2 O1 O2 :K1 K1 :K2 K2))) 156 | (is (equal (lambda-list-to-funcall-expression 'foo '(&optional &key &allow-other-keys)) 157 | '(FUNCALL FOO))) 158 | (is (equal (lambda-list-to-funcall-expression 'foo '(&optional &rest args &key &allow-other-keys)) 159 | '(APPLY FOO args))) 160 | (is (equal (lambda-list-to-funcall-expression 'foo '(p1 p2 &optional o1 (o2 "o2") &rest args &key k1 (k2 "k2") &allow-other-keys)) 161 | '(APPLY FOO P1 P2 O1 O2 :K1 K1 :K2 K2 ARGS))) 162 | (is (equal (lambda-list-to-variable-name-list '(&whole whole p1 p2 &optional o1 (o2 "o2") &body body) 163 | :macro t :include-specials t) 164 | '(WHOLE P1 P2 O1 O2 BODY))) 165 | (is (equal (multiple-value-list 166 | (lambda-list-to-variable-name-list '(&whole whole &environment env p1 p2 &optional o1 (o2 "o2") &body body) 167 | :macro t :include-specials nil)) 168 | '((P1 P2 O1 O2) 169 | BODY 170 | WHOLE 171 | ENV))) 172 | (dolist (entry '((p1 &whole) 173 | (&allow-other-keys) 174 | (&key k1 &optional o1) 175 | (&aux x1 &key k1))) 176 | (signals error 177 | (lambda-list-to-variable-name-list entry))) 178 | (dolist (entry '((p1 &whole) 179 | (&allow-other-keys) 180 | (&key k1 &optional o1) 181 | (&aux x1 &key k1) 182 | (a &rest rest &body body) 183 | (&aux a &body body))) 184 | (signals error 185 | (lambda-list-to-variable-name-list entry :macro t)))) 186 | 187 | ;; Local Variables: 188 | ;; coding: utf-8-unix 189 | ;; End: 190 | -------------------------------------------------------------------------------- /src/asserts.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors. 4 | ;;; 5 | ;;; See LICENCE for details. 6 | 7 | (in-package :fiasco) 8 | 9 | (defun extract-assert-expression-and-message (input-form) 10 | (let* ((negatedp nil) 11 | (predicate) 12 | (arguments '())) 13 | (labels ((process (form) 14 | (if (consp form) 15 | (case (first form) 16 | ((not) 17 | (assert (= (length form) 2)) 18 | (setf negatedp (not negatedp)) 19 | (process (second form))) 20 | (t (setf predicate (first form)) 21 | (setf arguments (rest form)))) 22 | (setf predicate form)))) 23 | (process input-form) 24 | (cond ((ignore-errors 25 | (macro-function predicate)) 26 | (values '() input-form "Macro expression ~S evaluated to false." 27 | (list `(quote ,input-form)))) 28 | ((and (ignore-errors 29 | (fdefinition predicate)) 30 | ;; let's just skip CL:IF and don't change its evaluation 31 | ;; semantics while trying to be more informative... 32 | (not (eq predicate 'if))) 33 | (cond ((= (length arguments) 0) 34 | (values '() 35 | input-form 36 | "Expression ~A evaluated to false." 37 | (list `(quote ,input-form)))) 38 | ((= (length arguments) 2) 39 | (with-unique-names (x y) 40 | (values `((,x ,(first arguments)) 41 | (,y ,(second arguments))) 42 | (if negatedp 43 | `(not (,predicate ,x ,y)) 44 | `(,predicate ,x ,y)) 45 | "Binary predicate ~A failed.~%~ 46 | x: ~S => ~S~%~ 47 | y: ~S => ~S" 48 | (list (if negatedp 49 | `(quote (not (,predicate x y))) 50 | `(quote (,predicate x y))) 51 | `(quote ,(first arguments)) x 52 | `(quote ,(second arguments)) y)))) 53 | (t (let* ((arg-values (mapcar (lambda (el) 54 | (unless (keywordp el) 55 | (gensym))) 56 | arguments)) 57 | (bindings (loop 58 | :for arg :in arguments 59 | :for arg-value :in arg-values 60 | :when arg-value 61 | :collect `(,arg-value ,arg))) 62 | (expression-values 63 | (mapcar (lambda (arg-value argument) 64 | (or arg-value argument)) 65 | arg-values 66 | arguments)) 67 | (expression 68 | (if negatedp 69 | `(not (,predicate ,@expression-values)) 70 | `(,predicate ,@expression-values)))) 71 | (loop 72 | :with message = "Expression ~A evaluated to ~A" 73 | :for arg :in arguments 74 | :for idx :upfrom 0 75 | :for arg-value :in arg-values 76 | :when arg-value 77 | :do (setf message (concatenate 78 | 'string message 79 | "~%~D: ~A => ~S")) 80 | :and :append `(,idx (quote ,arg) ,arg-value) 81 | :into message-args 82 | :finally 83 | (return 84 | (values bindings 85 | expression 86 | message 87 | (nconc 88 | (list `(quote (,predicate ,@arguments)) 89 | (if negatedp "true" "false")) 90 | message-args)))))))) 91 | (t 92 | (values '() input-form "Expression ~A evaluated to false." 93 | (list `(quote ,input-form)))))))) 94 | 95 | 96 | (defvar *progress-char-count* 0) 97 | 98 | (defun write-progress-char (char) 99 | (when *print-test-run-progress* 100 | (when (and (not (zerop *progress-char-count*)) 101 | (zerop (mod *progress-char-count* 102 | *test-progress-print-right-margin*))) 103 | (terpri *debug-io*)) 104 | (incf *progress-char-count*) 105 | (write-char char *debug-io*))) 106 | 107 | (defun register-assertion-was-successful () 108 | (write-progress-char #\.)) 109 | 110 | (defun record-failure (condition-type &rest args) 111 | (assert (subtypep condition-type 'failure)) 112 | (let ((failure (apply #'make-condition condition-type args))) 113 | ;; Remember that FIASCO:IS might be called in any context 114 | ;; and so *CONTEXT* might be nil. 115 | ;; 116 | (when *context* 117 | (push failure (slot-value *context* 'self-failures))) 118 | (write-progress-char (progress-char-of failure)) 119 | (unless (eq condition-type 'unexpected-error) 120 | (restart-case 121 | (error failure) 122 | (continue () 123 | :report (lambda (stream) 124 | (if *context* 125 | (format stream "~@") 126 | (format stream "~@")))))))) 127 | 128 | (defmacro is (&whole whole form 129 | &optional (message nil message-p) &rest message-args) 130 | (multiple-value-bind (bindings expression 131 | expression-message 132 | expression-message-args) 133 | (extract-assert-expression-and-message form) 134 | (with-unique-names (result format-control format-arguments) 135 | `(progn 136 | (warn 'is-assertion :form ',form :message ,message :message-args ',message-args) 137 | (let* (,@bindings 138 | (,result (multiple-value-list ,expression))) 139 | (multiple-value-bind (,format-control ,format-arguments) 140 | ,(if message-p 141 | `(if *always-show-failed-sexp* 142 | (values (format nil "~A~%~%~A" ,message ,expression-message) 143 | (list ,@message-args ,@expression-message-args)) 144 | (values ,message (list ,@message-args))) 145 | `(values ,expression-message 146 | (list ,@expression-message-args))) 147 | 148 | (if (first ,result) 149 | (register-assertion-was-successful) 150 | (record-failure 'failed-assertion 151 | :form ',whole 152 | :format-control ,format-control 153 | :format-arguments ,format-arguments))) 154 | (values-list ,result)))))) 155 | 156 | (defmacro signals (&whole whole what &body body) 157 | (declare (ignore whole)) 158 | (let* ((condition-type what)) 159 | (unless (symbolp condition-type) 160 | (error "SIGNALS expects a symbol as condition-type! (Is ~ 161 | there a superfulous quote at ~S?)" condition-type)) 162 | `(progn 163 | (warn 'signals-assertion :expected-condition-type ',what) 164 | (block test-block 165 | (handler-bind ((,condition-type 166 | (lambda (c) 167 | (register-assertion-was-successful) 168 | (return-from test-block c)))) 169 | ,@body) 170 | (record-failure 'missing-condition 171 | :expected-condition-type ',what 172 | :form ',body) 173 | (values))))) 174 | 175 | (defmacro not-signals (&whole whole what &body body) 176 | (declare (ignore whole)) 177 | (let* ((condition-type what)) 178 | (unless (symbolp condition-type) 179 | (error "SIGNALS expects a symbol as condition-type! (Is ~ 180 | there a superfulous quote at ~S?)" condition-type)) 181 | `(progn 182 | (warn 'not-signals-assertion :expected-condition-type ',what) 183 | (block test-block 184 | (multiple-value-prog1 185 | (handler-bind ((,condition-type 186 | (lambda (c) 187 | (record-failure 'unwanted-condition 188 | :expected-condition-type ',what 189 | :observed-condition c 190 | :form ',body) 191 | (return-from test-block c)))) 192 | ,@body) 193 | (register-assertion-was-successful)))))) 194 | 195 | (defmacro finishes (&whole whole_ &body body) 196 | ;; could be `(not-signals t ,@body), but that would register a 197 | ;; confusing failed-assertion 198 | (with-unique-names (success? whole ;; context 199 | ) 200 | `(let* ((,success? nil) 201 | (,whole ',whole_) 202 | ;; (,context *context*) 203 | ) 204 | (warn 'finishes-assertion) 205 | (unwind-protect 206 | (multiple-value-prog1 207 | (progn 208 | ,@body) 209 | (setf ,success? t) 210 | (register-assertion-was-successful)) 211 | (unless ,success? 212 | ;; TODO painfully broken: when we don't finish due to a restart, then 213 | ;; we don't want this here to be triggered... 214 | ;; 215 | (record-failure 'failed-assertion 216 | :form ,whole 217 | :format-control "FINISHES block did not finish: ~S" 218 | :format-arguments ,whole)))))) 219 | 220 | (defun skip () 221 | (signal 'test-skipped)) 222 | 223 | (defmacro skip-unless (condition) 224 | `(unless ,condition (skip))) 225 | 226 | ;; Local Variables: 227 | ;; coding: utf-8-unix 228 | ;; End: 229 | -------------------------------------------------------------------------------- /src/suite.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors. 4 | ;;; 5 | ;;; See LICENCE for details. 6 | 7 | (in-package :fiasco) 8 | 9 | (defun find-suite-for-package (package) 10 | (gethash package *package-bound-suites*)) 11 | 12 | (defun make-suite (name &rest args &key &allow-other-keys) 13 | (apply #'make-instance 'test :name name args)) 14 | 15 | (defmacro defsuite (name-or-name-with-args &optional args) 16 | (destructuring-bind (name &rest deftest-args) 17 | (ensure-list name-or-name-with-args) 18 | (let ((bind-to-package (getf deftest-args :bind-to-package))) 19 | (setq bind-to-package 20 | (if (eq t bind-to-package) 21 | *package* 22 | (find-package bind-to-package))) 23 | (remf deftest-args :bind-to-package) 24 | (with-unique-names (test) 25 | `(progn 26 | (deftest (,name ,@deftest-args) ,args 27 | (let* ((,test (find-test ',name))) 28 | (loop 29 | :for subtest :being :the :hash-values 30 | :of (children-of ,test) 31 | :when (and (auto-call? subtest) 32 | (or (zerop (length 33 | (lambda-list-of subtest))) 34 | (member (first 35 | (lambda-list-of subtest)) 36 | '(&rest &key &optional)))) 37 | :do (funcall (name-of subtest)))) 38 | (values)) 39 | (let ((suite (find-test ',name))) 40 | ,(when bind-to-package 41 | `(setf (gethash ,bind-to-package *package-bound-suites*) suite)) 42 | (values suite))))))) 43 | 44 | (setf *root-suite* (make-suite 'root-suite :documentation "Root Suite" :in nil)) 45 | (setf *suite* *root-suite*) 46 | 47 | 48 | ;;; define-test-package and friends 49 | (defpackage :fiasco-suites 50 | (:use) 51 | (:documentation "~ 52 | Namespace for Fiasco suites defined via DEFINE-TEST-PACKAGE.")) 53 | 54 | (defsuite (fiasco-suites::all-tests :in root-suite)) 55 | 56 | (defun all-tests () 57 | "Run all currently defined tests." 58 | (run-tests 'fiasco-suites::all-tests)) 59 | 60 | (defmacro define-test-package (name-or-name-with-args &body package-options) 61 | "Defines a new package and binds to it a new test suite. 62 | 63 | The binding between package and suite means that tests defined while 64 | inside this package are automatically added to the associated 65 | suite. Inside the new package, the function RUN-PACKAGE-TESTS is the 66 | preferred way to execute the suite. To run the tests from outside, use 67 | RUN-TESTS. 68 | 69 | NAME-OR-NAME-WITH-ARGS names the package and suite to create. It is 70 | either a single symbol NAME, or a list (NAME :IN PARENT-SUITE) where 71 | PARENT-SUITE designated the Fiasco suite previously created with 72 | DEFSUITE that should parent the newly created suite. 73 | 74 | Package NAME is defined via normal `defpackage', and in addition to 75 | processing PACKAGE-OPTIONS, automatically USES the :FIASCO and :CL 76 | packages." 77 | (destructuring-bind (name &key (in 'fiasco-suites::all-tests)) 78 | (alexandria:ensure-list name-or-name-with-args) 79 | (unless (find-package name) 80 | (make-package name :use nil)) 81 | (let ((suite-sym (intern (string name) :fiasco-suites))) 82 | `(progn 83 | (defpackage ,name 84 | ,@(append `((:use :fiasco :cl)) 85 | package-options)) 86 | (defsuite (,suite-sym :bind-to-package ,name 87 | :in ,in)))))) 88 | 89 | (defvar *pretty-log-stream* nil) 90 | (defvar *pretty-log-verbose-p* nil) 91 | 92 | (defun run-tests (testable &key 93 | (describe-failures t) 94 | verbose 95 | (stream *standard-output*) 96 | interactive) 97 | "Execute tests designated by TESTABLE. 98 | 99 | Returns two values: 100 | 101 | 1. A boolean indicating whether all tests were successful, and 102 | 2. A list of objects containing test results for each executed suite. 103 | 104 | TESTABLE can be a test or suite designator as accepted by 105 | FIND-TEST, or a package designator for a package associated with a 106 | test suite, or a list composed of any combination of the above. 107 | 108 | With optional INTERACTIVE, run tests interactively, i.e. break on 109 | errors and unexpected assertion failures. 110 | 111 | With optional DESCRIBE-FAILURES, T by default, describe failures to 112 | optional STREAM, which defaults to *STANDARD-OUTPUT*. 113 | 114 | With optional VERBOSE print more information about each test run, like 115 | its docstring." 116 | (loop for thing in (alexandria:ensure-list testable) 117 | ;; `suite' is used though it needn't be a test suite, might be 118 | ;; just a single TESTABLE. 119 | ;; 120 | for suite = (etypecase thing 121 | (testable thing) 122 | (package (find-suite-for-package thing)) 123 | (symbol (or (find-test thing :otherwise nil) 124 | (find-suite-for-package 125 | (find-package thing))))) 126 | for result = (progn 127 | (assert suite 128 | nil 129 | "Can't find anything testable designated by ~a" 130 | thing) 131 | (run-suite-tests suite 132 | :verbose verbose 133 | :stream stream 134 | :interactive interactive) 135 | *last-test-result*) 136 | collect result into results 137 | do (unless (or interactive 138 | (not describe-failures) 139 | (zerop (length (failures-of result)))) 140 | (describe-failed-tests :result result :stream stream)) 141 | 142 | finally 143 | (return (values (every #'zerop 144 | (mapcar #'length 145 | (mapcar #'failures-of results))) 146 | results)))) 147 | 148 | (defun run-package-tests (&key (package *package* package-supplied-p) 149 | (packages (list *package*) packages-supplied-p) 150 | (describe-failures t) 151 | verbose 152 | (stream *standard-output*) 153 | interactive) 154 | "Execute test suite(s) associated with PACKAGE or PACKAGES. 155 | 156 | PACKAGE defaults to the current package. Don't supply both both 157 | PACKAGE and PACKAGES. 158 | 159 | See RUN-TESTS for the meaning of the remaining keyword arguments." 160 | (assert (not (and packages-supplied-p package-supplied-p)) 161 | nil 162 | "Supply either :PACKAGE or :PACKAGES, not both") 163 | (run-tests (if packages-supplied-p 164 | packages 165 | package) 166 | :describe-failures describe-failures 167 | :verbose verbose 168 | :stream stream 169 | :interactive interactive)) 170 | 171 | (defun run-suite-tests (suite-designator &key verbose (stream t) interactive) 172 | (let ((*debug-on-unexpected-error* interactive) 173 | (*debug-on-assertion-failure* interactive) 174 | (*print-test-run-progress* nil) 175 | (*pretty-log-stream* 176 | (make-instance 'column-counting-output-stream :understream stream)) 177 | (*pretty-log-verbose-p* verbose) 178 | (*run-test-function* #'pretty-run-test) 179 | (*context* nil)) 180 | (funcall (etypecase suite-designator 181 | (symbol suite-designator) 182 | (test (name-of suite-designator)))) 183 | (terpri stream) 184 | (values))) 185 | 186 | (defvar *within-non-suite-test* nil 187 | "True within the scope of a non-suite test. Used to suppress printing test 188 | status for recursive test calls.") 189 | 190 | (defun pretty-run-test (test function) 191 | ;; HACK: until printing of recursive tests is implemented nicely we avoid 192 | ;; reporting non-toplevel tests altogether. 193 | (when *within-non-suite-test* 194 | (return-from pretty-run-test (run-test-body-in-handlers test function))) 195 | (labels 196 | ((depth-of (context) 197 | (let ((depth 0)) 198 | (loop while (setf context (parent-context-of context)) 199 | do (incf depth)) 200 | depth)) 201 | (pp (format-control &rest format-args) 202 | ;; format magic courtesy of Robert Smith (github #24) 203 | (format *pretty-log-stream* "~&~v@{~C~:*~}" 204 | (* (depth-of *context*) 2) #\Space) 205 | (apply #'format *pretty-log-stream* format-control format-args)) 206 | (suite-p () 207 | (not (zerop (hash-table-count (children-of test)))))) 208 | (if (suite-p) 209 | (pp "~A (Suite)" (name-of test)) 210 | (pp "~A" (name-of test))) 211 | (let* ((*error-output* *pretty-log-stream*) 212 | (*standard-output* *pretty-log-stream*) 213 | (*within-non-suite-test* (not (suite-p))) 214 | (retval-v-list (multiple-value-list 215 | (run-test-body-in-handlers test function))) 216 | (failures (failures-of *context*)) 217 | (skipped (skipped-p *context*))) 218 | (unless (suite-p) 219 | (format *pretty-log-stream* "~v@{~C~:*~}" 220 | (max 1 (- *test-progress-print-right-margin* 221 | (output-column *pretty-log-stream*) 222 | (length "[FAIL]"))) 223 | #\.) 224 | (format *pretty-log-stream* "[~A]~%" 225 | (cond 226 | (skipped "SKIP") 227 | (failures "FAIL") 228 | (t " OK "))) 229 | (when (and *pretty-log-verbose-p* (not skipped)) 230 | (pp " (~A)" 231 | (or (documentation (name-of test) 'function) 232 | "no docstring for this test")) 233 | (pp " (~A assertions, ~A failed, ~A errors, ~A expected)~%" 234 | (length (assertions-of *context*)) 235 | (count-if (alexandria:rcurry #'typep 'failed-assertion) failures) 236 | (count-if (alexandria:rcurry #'typep 'unexpected-error) failures) 237 | (count-if 'expected-p failures)))) 238 | (values-list retval-v-list)))) 239 | 240 | (defun indented-format (level stream format-control &rest format-arguments) 241 | (let ((line-prefix (make-string level :initial-element #\Space))) 242 | (let ((output (format nil "~?~%" format-control format-arguments))) 243 | (with-input-from-string (s output) 244 | (loop for line = (read-line s nil nil) until (null line) 245 | do (format stream "~A~A~%" line-prefix line)))))) 246 | 247 | (defun describe-failed-tests (&key (result *last-test-result* result-provided-p) 248 | (stream t)) 249 | "Prints out a report for RESULT in STREAM. 250 | 251 | RESULT defaults to `*last-test-result*' and STREAM defaults to t" 252 | (check-type result (or null context)) 253 | ;; Check if there was a last run. 254 | (when (null result) 255 | (unless result-provided-p 256 | (format stream "~&~%No tests have been run yet.~%")) 257 | (return-from describe-failed-tests)) 258 | 259 | ;; Guaranteed that RESULT is an object of type CONTEXT. 260 | (let* ((failures (failures-of result)) 261 | (nfailures (length failures))) 262 | (cond ((zerop nfailures) 263 | (format stream "~&~%Test run had no failures.~%")) 264 | (t 265 | (format stream "~&~%Test run had ~D failure~:P:~%" nfailures) 266 | (loop for failure in failures 267 | for test-num from 1 268 | do (format stream "~% Failure ~A: ~A when running ~S~%" 269 | test-num 270 | (type-of failure) 271 | (name-of (test-of (context-of failure)))) 272 | (indented-format 4 stream "~a" (describe-object failure nil))))))) 273 | 274 | 275 | ;; Local Variables: 276 | ;; coding: utf-8-unix 277 | ;; End: 278 | -------------------------------------------------------------------------------- /src/infrastructure.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2006 by the authors. 4 | ;;; 5 | ;;; See LICENCE for details. 6 | 7 | (in-package :fiasco) 8 | 9 | 10 | ;;; Special variables 11 | ;;; 12 | ;; Warning: setf-ing these variables in not a smart idea because other 13 | ;; systems may rely on their default value. It's smarter to rebind 14 | ;; them in an :around method from your .asd or shadow fiasco:deftest 15 | ;; with your own that sets their keyword counterparts. 16 | (defvar *suite*) 17 | (defvar *root-suite*) 18 | (defvar *package-bound-suites* (make-hash-table)) 19 | (defvar *print-test-run-progress* t) 20 | (defvar *test-progress-print-right-margin* 80) 21 | (defvar *debug-on-unexpected-error* t) 22 | (defvar *debug-on-assertion-failure* t) 23 | (defvar *test-result-history* '()) 24 | (defvar *last-test-result* nil) 25 | (defvar *failures-and-errors-are-expected* nil) 26 | (defvar *always-show-failed-sexp* nil) 27 | (defvar *warn-about-test-redefinitions* nil) 28 | 29 | ;; TODO introduce *progress-output* 30 | (defvar *test-run-standard-output* '*standard-output* 31 | "*STANDARD-OUTPUT* is bound to (eval *test-run-standard-output*) at 32 | the toplevel entry point to any test.") 33 | 34 | (defvar *tests* (make-hash-table :test 'eql)) ; this is not thread-safe, but... 35 | 36 | (defmacro without-debugging (&body body) 37 | `(let* ((*debug-on-unexpected-error* nil) 38 | (*debug-on-assertion-failure* nil)) 39 | ,@body)) 40 | 41 | 42 | ;;; Testable class 43 | ;;; 44 | (defclass testable () 45 | ((name :accessor name-of :initarg :name :type symbol) 46 | (parent :initform nil :accessor parent-of :type (or null testable)) 47 | (children :initform (make-hash-table) :accessor children-of 48 | :initarg :children 49 | :documentation "A mapping from testable names to testables") 50 | (auto-call :initform t :accessor auto-call? :initarg :auto-call :type boolean 51 | :documentation "Controls whether to automatically call 52 | this test when its parent suite is invoked. Enabled by default."))) 53 | 54 | (defmethod print-object ((self testable) s) 55 | (print-unreadable-object (self s :type nil :identity nil) 56 | (format s "test ~s" (name-of self)) 57 | (let* ((children (count-tests self))) 58 | (unless (zerop children) (format s " :tests ~s" children)))) 59 | self) 60 | 61 | (defvar *ignore-package-suite-mismatch* nil) 62 | 63 | (defmethod shared-initialize :after 64 | ((self testable) slot-names &key (in (or (parent-of self) 65 | (find-suite-for-package *package*) 66 | (and (boundp '*suite*) 67 | *suite*)) 68 | in-supplied-p)) 69 | (declare (ignore slot-names)) 70 | (assert (name-of self)) 71 | (setf (find-test (name-of self)) self) 72 | ;; make sure the specialized writer below is triggered 73 | (let ((*ignore-package-suite-mismatch* in-supplied-p)) 74 | (setf (parent-of self) in))) 75 | 76 | (defmethod (setf parent-of) :around (new-parent (self testable)) 77 | (assert (typep new-parent '(or null testable))) 78 | (when (and new-parent 79 | (symbol-package (name-of self)) ; leave alone tests named 80 | ; by uninterned symbols 81 | (not (eq new-parent *root-suite*)) 82 | (not (eq (symbol-package (name-of new-parent)) 83 | (symbol-package (name-of self)))) 84 | (not *ignore-package-suite-mismatch*) 85 | (not (gethash (package-of self) *package-bound-suites*))) 86 | (warn 'test-style-warning 87 | :test self 88 | :format-control "Adding test under parent ~S which is in a~ 89 | different package (parent: ~A, child: ~A). Maybe a~ 90 | missing (in-root-suite)?" 91 | :format-arguments (list new-parent (symbol-package 92 | (name-of new-parent)) 93 | (symbol-package (name-of self))))) 94 | (let* ((old-parent (parent-of self))) 95 | (when old-parent 96 | (remhash (name-of self) (children-of old-parent))) 97 | (prog1 98 | (call-next-method) 99 | (when new-parent 100 | (setf (gethash (name-of self) (children-of new-parent)) self))))) 101 | 102 | (defgeneric count-tests (testable) 103 | (:method ((self testable)) 104 | (+ (hash-table-count (children-of self)) 105 | (loop 106 | :for child :being :the :hash-values :of (children-of self) 107 | :summing (count-tests child))))) 108 | 109 | 110 | ;;; The object that represents a particular test run. 111 | ;;; 112 | ;;; Curiously called a "context" 113 | ;;; 114 | (defvar *context* nil 115 | "Status and progress info for a particular test run.") 116 | 117 | 118 | (defvar *current-test* nil 119 | "Current singleton instance of TEST executing its associated DEFTEST lambda.") 120 | 121 | (defmacro check-required (sym) `(error "Must provide ~a" ,sym)) 122 | 123 | (defclass context () 124 | ((test :accessor test-of :initarg :test) 125 | (internal-realtime-spent-with-test 126 | :initform nil 127 | :accessor internal-realtime-spent-with-test-of 128 | :initarg :internal-realtime-spent-with-test) 129 | (actual-test-arguments :accessor actual-test-arguments-of 130 | :initarg :actual-test-arguments 131 | :initform (check-required 'actual-test-arguments)) 132 | ;; recording 133 | ;; 134 | (self-failures :initform nil) 135 | (self-assertions :initform nil) 136 | (self-skipped :initform nil :accessor skipped-p) 137 | ;; tree structure 138 | ;; 139 | (parent-context 140 | :initarg :parent-context :initform nil :accessor parent-context-of) 141 | (children-contexts 142 | :initform nil :accessor children-contexts-of))) 143 | 144 | (defgeneric failures-of (context) 145 | (:method ((context context)) 146 | (reduce #'append (mapcar (alexandria:rcurry #'slot-value 'self-failures) 147 | (all-test-runs-of context))))) 148 | 149 | (defgeneric assertions-of (context) 150 | (:method ((context context)) 151 | (reduce #'append (mapcar (alexandria:rcurry #'slot-value 'self-assertions) 152 | (all-test-runs-of context))))) 153 | 154 | (defgeneric skips-of (context) 155 | (:method ((context context)) 156 | (count t (mapcar #'skipped-p (all-test-runs-of context))))) 157 | 158 | (defmethod initialize-instance :after ((obj context) &key parent-context &allow-other-keys) 159 | (setf (parent-context-of obj) parent-context)) 160 | 161 | (defmethod (setf parent-context-of) :before (new-parent (obj context)) 162 | (declare (ignore new-parent)) 163 | (let ((ex-parent (parent-context-of obj))) 164 | (when ex-parent 165 | (setf (children-contexts-of ex-parent) 166 | (remove obj (children-contexts-of ex-parent)))))) 167 | 168 | (defmethod (setf parent-context-of) :after (new-parent (obj context)) 169 | (when new-parent 170 | (push obj (children-contexts-of new-parent)))) 171 | 172 | (defmethod shared-initialize ((obj context) slots &rest args) 173 | (declare (ignore slots args)) 174 | (call-next-method) 175 | (with-slots (self-failures self-assertions children-contexts) obj 176 | (setq self-failures nil self-assertions nil children-contexts nil))) 177 | 178 | (defgeneric real-time-spent-in-seconds (context) 179 | (:method ((self context)) 180 | (let* ((time-spent (internal-realtime-spent-with-test-of self))) 181 | (when time-spent 182 | (coerce (/ time-spent 183 | internal-time-units-per-second) 184 | 'float))))) 185 | 186 | 187 | ;;; Conditions 188 | ;;; 189 | 190 | (define-condition test-assertion (warning) 191 | () 192 | (:documentation "Signalled when an assertion such as IS is encountered")) 193 | 194 | (define-condition is-assertion (test-assertion) 195 | ((form :initarg :form 196 | :initform (check-required 'form) 197 | :accessor form-of) 198 | (message :initarg :message 199 | :initform (check-required 'message) 200 | :accessor message-of) 201 | (message-args :initarg :message-args 202 | :initform (check-required 'message-args) 203 | :accessor message-args-of))) 204 | 205 | (define-condition signals-assertion (test-assertion) 206 | ((expected-condition-type :initarg :expected-condition-type 207 | :accessor expected-condition-type-of))) 208 | 209 | (define-condition not-signals-assertion (test-assertion) 210 | ((expected-condition-type :initarg :expected-condition-type 211 | :accessor expected-condition-type-of))) 212 | 213 | (define-condition finishes-assertion (test-assertion) ()) 214 | 215 | (define-condition test-related-condition () 216 | ((test :initform (check-required 'test) :accessor test-of :initarg :test))) 217 | 218 | (define-condition test-started (test-related-condition) ()) 219 | 220 | (define-condition test-style-warning (style-warning test-related-condition 221 | simple-warning) 222 | ()) 223 | 224 | (define-condition failure (simple-condition) 225 | ((context :initform *context* :accessor context-of 226 | :documentation "Might perfectly well be NIL") 227 | (progress-char :initform #\X :accessor progress-char-of 228 | :initarg :progress-char :allocation :class) 229 | (expected :initarg :expected :initform *failures-and-errors-are-expected* 230 | :accessor expected-p))) 231 | 232 | (define-condition failed-assertion (failure) 233 | ((form :accessor form-of :initarg :form)) 234 | (:report (lambda (c stream) 235 | (if (context-of c) 236 | (format stream "Test assertion failed when running ~a:~%~%" 237 | (name-of (test-of (context-of c)))) 238 | (format stream "Test assertion failed:~%~%")) 239 | (describe c stream)))) 240 | 241 | (defmethod describe-object ((self failed-assertion) stream) 242 | (let ((*print-circle* nil)) 243 | ;; (format stream "Form ~S inside test chain: ~{~A~^,~}" 244 | ;; (form-of self) 245 | ;; (mapcar (compose #'name-of #'test-of) 246 | ;; (loop for context = (context-of self) then (parent-context-of context) 247 | ;; while context collect context))) 248 | (handler-case (apply #'format stream (simple-condition-format-control self) 249 | (simple-condition-format-arguments self)) 250 | (error () 251 | (format stream "Can't format custom message for ~a form ~a" 252 | 'failed-assertion (form-of self)))))) 253 | 254 | (define-condition missing-condition (failure) 255 | ((expected-condition-type :initarg :expected-condition-type 256 | :accessor expected-condition-type-of) 257 | (form :accessor form-of :initarg :form))) 258 | 259 | (defmethod describe-object ((self missing-condition) stream) 260 | (let ((*print-circle* nil)) 261 | (format stream "~S failed to signal a condition of type ~S" (form-of self) 262 | (expected-condition-type-of self)))) 263 | 264 | (define-condition unwanted-condition (failure) 265 | ((expected-condition-type :initarg :expected-condition-type :accessor expected-condition-type-of) 266 | (observed-condition :initarg :observed-condition :accessor observed-condition-of) 267 | (form :accessor form-of :initarg :form))) 268 | 269 | (defmethod describe-object ((self unwanted-condition) stream) 270 | (let ((*print-circle* nil)) 271 | (format stream "~S signaled an unwanted condition ~S" 272 | (form-of self) (observed-condition-of self)))) 273 | 274 | (define-condition unexpected-error (failure) 275 | ((error :accessor error-of :initform (error "Must provide ~S" 'error) 276 | :initarg :error) 277 | (progress-char :initform #\E :accessor progress-char-of 278 | :initarg :progress-char :allocation :class)) 279 | (:report (lambda (c stream) 280 | (if (context-of c) 281 | (format stream "Unexpected error when running ~a:~%~%" 282 | (name-of (test-of (context-of c)))) 283 | (format stream "Unexpected error:~%~%")) 284 | (describe c stream)))) 285 | 286 | (defmethod describe-object ((self unexpected-error) stream) 287 | (format stream "~a" (error-of self))) 288 | 289 | (defmethod print-object ((self unexpected-error) stream) 290 | (print-unreadable-object (self stream :identity nil :type nil) 291 | (format stream "error ~{~A~^,~}: ~S" 292 | (mapcar (compose #'name-of #'test-of) 293 | (loop for context = (context-of self) then (parent-context-of context) 294 | while context collect context)) 295 | (error-of self)))) 296 | 297 | (define-condition test-skipped (warning) 298 | () 299 | (:documentation "Signalled when test is skipped")) 300 | 301 | 302 | ;;; Test repository 303 | ;;; 304 | (defun find-test (name &key (otherwise :error)) 305 | "Find and return test associated with NAME. 306 | 307 | If no such thing is found, OTHERWISE says what do to: if :ERROR, 308 | signal error; if a function, call it; else return OTHERWISE." 309 | (multiple-value-bind (test found-p) 310 | (if (typep name 'testable) 311 | (values name t) 312 | (gethash name *tests*)) 313 | (when (and (not found-p) 314 | otherwise) 315 | (typecase otherwise 316 | (symbol (ecase otherwise 317 | (:error (error "Testable called ~A was not found" name)))) 318 | (function (funcall otherwise)) 319 | (t (setf test otherwise)))) 320 | (values test found-p))) 321 | 322 | (defun (setf find-test) (new-value key) 323 | (if new-value 324 | (progn 325 | (when (and *warn-about-test-redefinitions* 326 | (gethash key *tests*)) 327 | (warn 'test-style-warning 328 | :format-control "redefining test ~A" 329 | :format-arguments (list 330 | (let ((*package* #.(find-package "KEYWORD"))) 331 | (format nil "~S" key))))) 332 | (setf (gethash key *tests*) new-value)) 333 | (delete-test key))) 334 | 335 | (defun delete-test (name &rest args) 336 | (let* ((test (apply #'find-test name args)) 337 | (name (name-of test)) 338 | (parent (when test 339 | (parent-of test)))) 340 | (when test 341 | (assert (or (not (eq *suite* test)) 342 | (parent-of test)) 343 | () "You can not remove a test which is the current suite~ 344 | and has no parent") 345 | (remhash name *tests*) 346 | (setf (parent-of test) nil) 347 | (fmakunbound (name-of test)) 348 | (loop 349 | :for subtest :being :the :hash-values :of (children-of test) 350 | :do (delete-test (name-of subtest))) 351 | (when (eq *suite* test) 352 | (setf *suite* parent))) 353 | test)) 354 | 355 | 356 | ;;;;;; 357 | ;;; the real thing 358 | 359 | (defun all-test-runs-of (context) 360 | (cons context 361 | (loop for context in (children-contexts-of context) 362 | append (all-test-runs-of context)))) 363 | 364 | (defun extract-test-run-statistics (context) 365 | (let* ((failures (failures-of context)) 366 | (failed-assertion-count (count-if (of-type '(or 367 | failed-assertion 368 | missing-condition 369 | unwanted-condition)) 370 | failures)) 371 | (unexpected-error-count (count-if (of-type 'unexpected-error) 372 | failures)) 373 | (expected-count (count-if 'expected-p failures)) 374 | (skips-count (skips-of context))) 375 | (list :number-of-tests-run (length (all-test-runs-of context)) 376 | :number-of-assertions (length (assertions-of context)) 377 | :number-of-failures (length failures) 378 | :number-of-expected-failures expected-count 379 | :number-of-failed-assertions failed-assertion-count 380 | :number-of-unexpected-errors unexpected-error-count 381 | :number-of-skips skips-count))) 382 | 383 | (defmethod print-object ((self context) stream) 384 | (print-unreadable-object (self stream :identity nil :type nil) 385 | (destructuring-bind (&key number-of-tests-run 386 | number-of-assertions 387 | number-of-failures 388 | number-of-failed-assertions 389 | number-of-unexpected-errors 390 | number-of-expected-failures 391 | &allow-other-keys) 392 | (extract-test-run-statistics self) 393 | (format stream "test-run of ~a: ~A test~:P, ~A assertion~:P, ~A failure~:P in ~ 394 | ~A sec~[~:; (~A failed assertion~:P, ~A error~:P, ~A expected)~]" 395 | (name-of (test-of self)) 396 | number-of-tests-run 397 | number-of-assertions 398 | number-of-failures 399 | (real-time-spent-in-seconds self) 400 | number-of-failures ; index in the ~[] conditional 401 | number-of-failed-assertions 402 | number-of-unexpected-errors 403 | (cond ((= number-of-expected-failures number-of-failures) 404 | "all") 405 | ((zerop number-of-expected-failures) 406 | "none") 407 | (t number-of-expected-failures)))))) 408 | 409 | (defmacro without-test-progress-printing (&body body) 410 | (with-unique-names (old-state) 411 | `(let ((,old-state *print-test-run-progress*)) 412 | (unwind-protect 413 | (progn 414 | (setf *print-test-run-progress* nil) 415 | ,@body) 416 | (setf *print-test-run-progress* ,old-state))))) 417 | 418 | (defmacro with-toplevel-restarts (&body body) 419 | `(block restart-wrapper 420 | (restart-bind 421 | ((continue-without-debugging 422 | (lambda () 423 | (setf *debug-on-unexpected-error* nil 424 | *debug-on-assertion-failure* nil) 425 | (continue)) 426 | :report-function (lambda (stream) 427 | (format stream "~ 428 | ~@"))) 430 | (continue-without-debugging-errors 431 | (lambda () 432 | (setf *debug-on-unexpected-error* nil) 433 | (continue)) 434 | :report-function (lambda (stream) 435 | (format stream "~ 436 | ~@"))) 438 | (continue-without-debugging-assertions 439 | (lambda () 440 | (setf *debug-on-assertion-failure* nil) 441 | (continue)) 442 | :report-function (lambda (stream) 443 | (format stream "~ 444 | ~@"))) 446 | (abort-testing 447 | (lambda () 448 | (return-from restart-wrapper)) 449 | :report-function (lambda (stream) 450 | (format stream "~@")))) 452 | ,@body))) 453 | 454 | (defun run-failed-tests (&optional (test-run *last-test-result*)) 455 | (warn "Re-running failed tests without considering their dynamic 456 | environment, which may affect their behaviour!") 457 | (with-toplevel-restarts 458 | (loop 459 | :for failure in (failures-of test-run) 460 | :do (apply (name-of (test-of (context-of failure))) 461 | (actual-test-arguments-of (context-of failure)))) 462 | (when *print-test-run-progress* 463 | (terpri *debug-io*)))) 464 | 465 | (defmacro with-expected-failures* (&whole whole condition &body body) 466 | "Run BODY and registering failure conditions as expected failure iff 467 | CONDITION." 468 | (with-unique-names (with-expected-failures-block starting-failure-count) 469 | `(let* ((*failures-and-errors-are-expected* ,condition) 470 | (,starting-failure-count 471 | (length (failures-of *context*)))) 472 | (block ,with-expected-failures-block 473 | (restart-case 474 | (handler-bind ((serious-condition 475 | ;; TODO comment on why it's needed here... 476 | (lambda (error) 477 | (record-failure 'unexpected-error :error error) 478 | (return-from ,with-expected-failures-block 479 | (values))))) 480 | (multiple-value-prog1 481 | (progn ,@body) 482 | (unless (< ,starting-failure-count 483 | (length (failures-of *context*))) 484 | (warn "The following ~S block ran without any failures: ~S" 485 | 'with-expected-failures* ',whole)))) 486 | (continue () 487 | :report (lambda (stream) 488 | (format stream "~ 489 | ~@")) 491 | (values))))))) 492 | 493 | (defmacro with-expected-failures (&body body) 494 | "Run BODY registering failured conditions as expected failures." 495 | `(with-expected-failures* t ,@body)) 496 | 497 | 498 | ;;;;;; 499 | ;;; some utils 500 | 501 | (define-condition illegal-lambda-list (error) 502 | ((lambda-list :accessor lambda-list-of :initarg :lambda-list))) 503 | 504 | (defun illegal-lambda-list (lambda-list) 505 | (error 'illegal-lambda-list :lambda-list lambda-list)) 506 | 507 | (defun parse-lambda-list (lambda-list visitor &key macro) 508 | ;; TODO delme, and use alexandria:parse-ordinary-lambda-list 509 | (declare #+nil (optimize (speed 3)) 510 | (type list lambda-list) 511 | (type (or symbol function) visitor)) 512 | (let ((args lambda-list)) 513 | (labels 514 | ((fail () 515 | (illegal-lambda-list lambda-list)) 516 | (process-&whole () 517 | (assert (eq (first args) '&whole)) 518 | (pop args) 519 | (unless macro 520 | (fail)) 521 | (let ((whole (pop args))) 522 | (unless whole 523 | (fail)) 524 | (funcall visitor '&whole whole whole)) 525 | (case (first args) 526 | (&key (entering-&key)) 527 | (&rest (process-&rest)) 528 | (&optional (entering-&optional)) 529 | (&body (process-&body)) 530 | (&environment (process-&environment)) 531 | ((&whole &aux &allow-other-keys) (fail)) 532 | (t (process-required)))) 533 | (process-&body () 534 | (assert (eq (first args) '&body)) 535 | (pop args) 536 | (unless macro 537 | (fail)) 538 | (let ((body (pop args))) 539 | (unless (null args) 540 | (fail)) 541 | (unless body 542 | (fail)) 543 | (funcall visitor '&body body body))) 544 | (process-&environment () 545 | (assert (eq (first args) '&environment)) 546 | (pop args) 547 | (unless macro 548 | (fail)) 549 | (let ((env (pop args))) 550 | (unless env 551 | (fail)) 552 | (funcall visitor '&environment env env)) 553 | (case (first args) 554 | (&key (entering-&key)) 555 | (&rest (process-&rest)) 556 | (&optional (entering-&optional)) 557 | (&body (process-&body)) 558 | (&aux (process-&aux)) 559 | ((&whole &environment &allow-other-keys) (fail)) 560 | (t (process-required)))) 561 | (process-required () 562 | (unless args 563 | (done)) 564 | (case (first args) 565 | (&key (entering-&key)) 566 | (&rest (process-&rest)) 567 | (&optional (entering-&optional)) 568 | (&body (process-&body)) 569 | (&environment (process-&environment)) 570 | ((&whole &allow-other-keys) (fail)) 571 | (&aux (entering-&aux)) 572 | (t 573 | (let ((arg (pop args))) 574 | (funcall visitor nil arg arg)) 575 | (process-required)))) 576 | (process-&rest () 577 | (assert (eq (first args) '&rest)) 578 | (pop args) 579 | (let ((rest (pop args))) 580 | (unless rest 581 | (fail)) 582 | (funcall visitor '&rest rest rest)) 583 | (unless args 584 | (done)) 585 | (case (first args) 586 | (&key (entering-&key)) 587 | (&environment (process-&environment)) 588 | ((&whole &optional &rest &body &allow-other-keys) (fail)) 589 | (&aux (entering-&aux)) 590 | (t (fail)))) 591 | (entering-&optional () 592 | (assert (eq (first args) '&optional)) 593 | (pop args) 594 | (process-&optional)) 595 | (process-&optional () 596 | (unless args 597 | (done)) 598 | (case (first args) 599 | (&key (entering-&key)) 600 | (&rest (process-&rest)) 601 | (&body (process-&body)) 602 | ((&whole &optional &environment &allow-other-keys) (fail)) 603 | (&aux (entering-&aux)) 604 | (t 605 | (let* ((arg (ensure-list (pop args))) 606 | (name (first arg)) 607 | (default (second arg))) 608 | (funcall visitor '&optional name arg nil default)) 609 | (process-&optional)))) 610 | (entering-&key () 611 | (assert (eq (first args) '&key)) 612 | (pop args) 613 | (process-&key)) 614 | (process-&key () 615 | (unless args 616 | (done)) 617 | (case (first args) 618 | (&allow-other-keys (funcall visitor '&allow-other-keys nil nil)) 619 | ((&key &optional &whole &environment &body) (fail)) 620 | (&aux (entering-&aux)) 621 | (t 622 | (let* ((arg (ensure-list (pop args))) 623 | (name-part (first arg)) 624 | (default (second arg)) 625 | (external-name (if (consp name-part) 626 | (progn 627 | (unless (= (length name-part) 2) 628 | (illegal-lambda-list lambda-list)) 629 | (first name-part)) 630 | (intern (symbol-name name-part) 631 | #.(find-package "KEYWORD")))) 632 | (local-name (if (consp name-part) 633 | (second name-part) 634 | name-part))) 635 | (funcall visitor '&key local-name arg external-name default)) 636 | (process-&key)))) 637 | (entering-&aux () 638 | (assert (eq (first args) '&aux)) 639 | (pop args) 640 | (process-&aux)) 641 | (process-&aux () 642 | (unless args 643 | (done)) 644 | (case (first args) 645 | ((&whole &optional &key &environment 646 | &allow-other-keys &aux &body) (fail)) 647 | (t 648 | (let ((arg (ensure-list (pop args)))) 649 | (funcall visitor '&aux (first arg) arg)) 650 | (process-&aux)))) 651 | (done () 652 | (return-from parse-lambda-list (values)))) 653 | (when args 654 | (case (first args) 655 | (&whole (process-&whole)) 656 | (t (process-required))))))) 657 | 658 | (defun lambda-list-to-funcall-list (args) 659 | (multiple-value-bind (requireds optionals rest keywords) 660 | (parse-ordinary-lambda-list args) 661 | (values (append requireds 662 | (loop 663 | :for entry :in optionals 664 | :collect (first entry)) 665 | (loop 666 | :for entry :in keywords 667 | :appending (list (first (first entry)) 668 | (second (first entry))))) 669 | rest))) 670 | 671 | (defun lambda-list-to-funcall-expression (function args) 672 | (multiple-value-bind (arg-list rest-variable) 673 | (lambda-list-to-funcall-list args) 674 | (if rest-variable 675 | `(apply ,function ,@arg-list ,rest-variable) 676 | `(funcall ,function ,@arg-list)))) 677 | 678 | (defun lambda-list-to-value-list-expression (args) 679 | ;; TODO use alexandria:parse-ordinary-lambda-list 680 | ;; JT@15/08/14: Seconded 681 | `(list ,@(let ((result (list))) 682 | (parse-lambda-list args 683 | (lambda (kind name entry 684 | &optional external-name default) 685 | (declare (ignore entry external-name default)) 686 | (case kind 687 | (&allow-other-keys) 688 | (t (push `(cons ',name ,name) result))))) 689 | (nreverse result)))) 690 | 691 | (defun lambda-list-to-variable-name-list (args &key macro include-specials) 692 | ;; TODO use alexandria:parse-ordinary-lambda-list 693 | (let ((result (list)) 694 | (rest-variable-name nil) 695 | (whole-variable-name nil) 696 | (env-variable-name nil)) 697 | (parse-lambda-list args 698 | (lambda (kind name entry &optional external-name default) 699 | (declare (ignore entry external-name default)) 700 | (case kind 701 | (&allow-other-keys ) 702 | (&environment (setf env-variable-name name) 703 | (when include-specials 704 | (push name result))) 705 | (&whole (setf whole-variable-name name) 706 | (when include-specials 707 | (push name result))) 708 | ((&rest &body) (setf rest-variable-name name) 709 | (when include-specials 710 | (push name result))) 711 | (t (push name result)))) 712 | :macro macro) 713 | (values (nreverse result) 714 | rest-variable-name 715 | whole-variable-name 716 | env-variable-name))) 717 | 718 | (defun funcall-test-with-feedback-message (test-function &rest args) 719 | "Run TEST non-interactively and print results to *STANDARD-OUTPUT*. 720 | This function is ideal for ASDF:TEST-OP's." 721 | (let* ((*test-run-standard-output* (make-broadcast-stream)) 722 | (result (without-debugging (apply test-function args))) 723 | (*package* (find-package :common-lisp))) 724 | (format *standard-output* 725 | "The result of ~S is: 726 | 727 | ~A 728 | 729 | For more details run it from the REPL." 730 | test-function result) 731 | result)) 732 | 733 | 734 | 735 | ;; Local Variables: 736 | ;; coding: utf-8-unix 737 | ;; End: 738 | --------------------------------------------------------------------------------