1 files changed, 115 insertions, 0 deletions
diff --git a/src/legacy/testiere.lisp~ b/src/legacy/testiere.lisp~
new file mode 100644
index 0000000..b606b9f
--- /dev/null
+++ b/src/legacy/testiere.lisp~
@@ -0,0 +1,115 @@
+;;;; 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))))))))
+
+
+
+