anchor.diff: -;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved.
  +;;; Copyright (c) 2014, James M. Lawrence. All rights reserved.
   ;;;
   ;;; Redistribution and use in source and binary forms, with or without
   ;;; modification, are permitted provided that the following conditions
  
positive.code: ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  ;;; 1am implements a minimal subset of the 5am/eos testing API. Some
  ;;; reasons for its existence:
  ;;;
  ;;; * Compiling tests is ~8x faster than 5am/eos configured with
  
negative.code:      (passed)))
  
  (defun check-signals (expected fn)
    (flet ((failed (got)
             (error "Expected to signal ~s, but got ~a." expected got)))
      (handler-case (progn
                      (funcall fn)
                      (failed "nothing"))
        (condition (condition)
          (if (typep condition expected)
              (passed)
              (failed (type-of condition)))))))
  
  (defmacro signals (condition &body body)
    `(check-signals ',condition (lambda () ,@body)))
  
  (defun report (tests)
    (format t "~&~%Success: ~s test~:p, ~s check~:p.~%"
            (length tests) *pass-count*)
    (values))
  
  (defun shuffle (vector)
    (loop
       :for i :downfrom (- (length vector) 1) :to 1
       :do (rotatef (aref vector i) (aref vector (random (1+ i)))))
    vector)
  
  (defun run (&optional (tests *tests*))
    (setf *pass-count* 0)
    (let ((*running* t))
      (map nil #'funcall (let ((*random-state* (make-random-state t)))
                           (shuffle (map 'vector #'identity tests)))))
    (report tests))
  
  (defun call-standalone-test (name fn)
    (setf *pass-count* 0)
    (multiple-value-prog1 (funcall fn)
      (report (list name))))
  
  (defun call-test (name fn)
    (format t "~&~a~%" name)
    (finish-output)
    (if *running*
        (funcall fn)
        (call-standalone-test name fn)))
  
  (defmacro test (name &body body)
    `(progn
       (defun ,name ()
         (call-test ',name (lambda () ,@body)))
       (pushnew ',name *tests*)
       ',name))
  