diff options
Diffstat (limited to 'testiere.lisp')
| -rw-r--r-- | testiere.lisp | 115 |
1 files changed, 0 insertions, 115 deletions
diff --git a/testiere.lisp b/testiere.lisp deleted file mode 100644 index b606b9f..0000000 --- a/testiere.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;;; testiere.lisp - -(in-package #:testiere) - -(defun build-test (name spec) - (match spec - ((list :fails inputs) - `(assert - (handler-case (progn (,name ,@inputs) nil) - (error (e) (declare (ignore e)) t)))) - - ((list :signals inputs condition) - `(assert - (handler-case (progn (,name ,@inputs) nil) - (,condition (c) (declare (ignore c)) t) - (condition (c) (declare (ignore c)) nil)))) - - ((list* :program function-name args) - `(when (fboundp ',function-name) - (funcall ',function-name ,@args))) - - ((list* :with-stubs redefs more-specs) - (let* ((assoc-vars - (loop for (stub-name . more) in redefs - collect (list stub-name (gensym (symbol-name stub-name))))) - (cache-binding-forms - (loop for (stub-name tmp-var) in assoc-vars - collect `(,tmp-var (fdefinition ',stub-name)))) - (redef-forms - (loop for (stub-name lambda-list . body) in redefs - collect `(setf (fdefinition ',stub-name) - (function (lambda ,lambda-list ,@body))))) - (clean-up - (loop for (stub-name . more) in redefs - for binding = (assoc stub-name assoc-vars) - collect `(setf (fdefinition ',stub-name) ,(second binding))))) - `(let ,cache-binding-forms - (unwind-protect - (progn - ,@redef-forms - ,@(mapcar (lambda (s) (build-test name s)) more-specs)) - ,@clean-up)))) - ((list* :let bindings more-specs) - `(let ,bindings - ,@(mapcar (lambda (s) (build-test name s)) more-specs))) - ((list :afterp inputs thunk-test) - `(progn (,name ,@inputs) - (assert (funcall ,thunk-test)))) - ((list :outputp inputs output-test) - `(assert (funcall ,output-test (,name ,@inputs)))) - ((list comparator-function inputs expected-output) - `(assert (,comparator-function (,name ,@inputs) ,expected-output))))) - -(defun extract-tests (name body) - (let ((end-pos (position :end body)) - (start-pos (position :tests body))) - (when (and end-pos start-pos) - (let ((specs (subseq body (1+ start-pos) end-pos)) - (before (subseq body 0 start-pos)) - (after (nthcdr (1+ end-pos) body))) - (list (mapcar (lambda (spec) (build-test name spec)) specs) - (append before after)))))) - -(defmacro with-stub ((name lambda-list &body body) &body forms) - "Runs forms in a context where NAME is temporarily rebound to a -different function. If NAME is not FBOUNDP then it is temporarily -defined." - (let ((cached (gensym))) - `(let ((,cached - (when (fboundp ',name) - (fdefinition ',name)))) - (unwind-protect - (progn - (setf (fdefinition ',name) - (lambda ,lambda-list ,@body)) - ,@forms) - (if ,cached - (setf (fdefinition ',name) - ,cached) - (fmakunbound ',name)))))) - -(defmacro with-stubs (redefinitions &body forms) - "Like WITH-STUB, but REDEFINITIONS is a list of (NAME LAMBDA-LIST -. BODY) list, suitable for defining a function." - (loop - with inner = `(progn ,@forms) - for (name lambda-list . body) in (reverse redefinitions) - do (setf inner `(with-stub (,name ,lambda-list ,@body) - ,inner)) - finally (return inner))) - - -(defmacro defun/t (name lambda-list &body body) - "Like regular DEFUN, but with embedded unit tests. If those tests - would fail, the function fails to be defined. " - (destructuring-bind (tests function-body) (extract-tests name body) - (let ((cached (gensym))) - `(let ((,cached - (when (fboundp ',name) - (fdefinition ',name)))) - (restart-case - (eval-when (:compile-toplevel :load-toplevel :execute) - (progn - (defun ,name ,lambda-list ,@function-body) - ,@tests)) - (make-unbound () (fmakunbound ',name)) - (revert-to-last-good-version () - (if ,cached - (setf (symbol-function ',name) - ,cached) - (fmakunbound ',name)))))))) - - - - |