add sagittarius test, and non-working tr7 test

1 files changed, 440 insertions, 0 deletions

diff --git a/lib/cuprate-impl.scm b/lib/cuprate-impl.scm
new file mode 100644
index 0000000..8265571
--- /dev/null
+++ b/lib/cuprate-impl.scm
@@ -0,0 +1,440 @@
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Manipulating the test info
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define (modify-test-info! proc)
+  (set-test-info! (test-info) (inspect-test-info proc)))
+
+(define (inspect-test-info proc)
+  (proc (test-info-dict)))
+
+(define-syntax define-destructive-test-info-procedure
+  (syntax-rules ()
+    ((_ (name args ...) proc)
+     (define (name args ...)
+       (modify-test-info! (lambda (dictionary)
+                            (proc (test-dto) dictionary args ...)))))
+    ((_ (name . args) proc)
+     (define (name . other-args)
+       (modify-test-info! (lambda (dictionary)
+                            (apply proc (test-dto)
+                                   dictionary other-args)))))))
+
+(define-syntax define-inspecting-test-info-procedure
+  (syntax-rules ()
+    ((_ (name args ...) proc)
+     (define (name args ...)
+       (inspect-test-info (lambda (dictionary)
+                            (proc (test-dto)
+                                  dictionary args ...)))))
+    ((_ (name . args) proc)
+     (define (name . other-args)
+       (inspect-test-info (lambda (dictionary)
+                            (apply proc (test-dto)
+                                   dictionary other-args)))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Mutating operations on the test info
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-destructive-test-info-procedure
+    (test-set! . args) dict-set!)
+(define-destructive-test-info-procedure
+    (test-update! key updater . rest) dict-update!)
+(define-destructive-test-info-procedure
+    (test-update/default! key updater default) dict-update/default!)
+(define-destructive-test-info-procedure
+    (test-delete! . keys) dict-delete!)
+
+(define-inspecting-test-info-procedure
+    (test-contains? key) dict-contains?)
+(define-inspecting-test-info-procedure
+    (test-ref key . rest) dict-ref)
+(define-inspecting-test-info-procedure
+    (test-ref/default key default) dict-ref/default)
+(define-inspecting-test-info-procedure
+    (test-set . args) dict-set!)
+(define-inspecting-test-info-procedure
+    (test-update/default key value) dict-update/default!)
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Manipulating the parameter object
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (call/hooks before! setup! cleanup! skip? when-skipped after
+                    on-exception
+                    name thunk)
+  (define (body)
+    ;; This escapes the exception handler before attempting to re-raise
+    ;; the exception. This is to work around some bugs(?) in CHICKEN.
+    (call/cc
+     (lambda (return)
+       (define (handler ex)
+         (return (lambda ()
+                   (call/cc
+                    (lambda (return)
+                      ((test-ref on-exception) ex (lambda () (return #f)))
+                      (raise ex))))))
+       (with-exception-handler handler thunk)
+       (lambda () #f))))
+  (define (exec)
+    ((test-ref before!) name)
+    (parameterize ((test-info (test-info-dict)))
+      ((test-ref setup!) name)
+      ((body))
+      ((test-ref cleanup!) name)
+      (test-info-dict)))
+  (if ((test-ref skip?) name)
+      ((test-ref when-skipped) name)
+      ((test-ref after) (exec))))
+
+(define (call-as-test name thunk)
+  (call/hooks 'before-test!
+              'setup-test!
+              'cleanup-test!
+              'skip-test?
+              'when-test-skipped
+              'after-test
+              'on-exception-in-test
+              name thunk))
+
+(define (call-as-group name thunk)
+  (call/hooks 'before-group!
+              'setup-group!
+              'cleanup-group!
+              'skip-group?
+              'when-group-skipped
+              'after-group
+              'on-exception-in-group
+              name thunk))
+
+(define (setup-name! name)
+  (test-set! 'name name)
+  (when name
+    (test-update/default! 'name-stack
+                          (lambda (x) (cons name x))
+                          '())))
+
+;;; ;;;;;;;;;;
+;;; Default handlers for tests
+;;; ;;;;;;;;;;
+
+(define (default-skip-test? name) #f)
+(define (default-before-test! name) #f)
+
+(define (default-setup-test! name)
+  (test-delete! 'success?)
+  (setup-name! name))
+(define (default-cleanup-test! name) #f)
+
+(define (default-when-test-skipped name)
+  (test-update/default! 'skipped
+                        (lambda (x) (+ 1 x))
+                        0)
+  (test-update/default! 'tests
+                        (lambda (x) (+ x 1))
+                        0)
+  (display (string-append "SKIP        " (if name
+                                             (string-append "\"" name "\"")
+                                             "test")
+                          "\n")))
+
+(define (default-after-test previous-test-info)
+  (test-update/default! 'tests
+                        (lambda (x) (+ x 1))
+                        0)
+  (let ((success? (dict-ref/default (test-dto)
+                                    previous-test-info
+                                    'success?
+                                    #f)))
+    (test-update/default! (if success? 'passed 'failed)
+                          (lambda (x) (+ 1 x))
+                          0)
+    ((test-ref 'report-test) previous-test-info)))
+
+(define (display-report previous-dict)
+  (let ((never-print-dto (dict-ref (test-dto)
+                                   previous-dict
+                                   'never-print-dto))
+        (never-print (dict-ref (test-dto)
+                               previous-dict
+                               'never-print)))
+    (dict-for-each (test-dto)
+                   (lambda (key value)
+                     (unless (dict-contains? never-print-dto
+                                             never-print
+                                             key)
+                       (pretty-print
+                        (list (rewrite key)
+                              (rewrite value)))))
+                   previous-dict)))
+
+(define (default-report-test previous-test-info)
+  (let ((verbose? (test-ref/default 'verbose? #f))
+        (specifically-verbose? (dict-ref/default (test-dto)
+                                                 previous-test-info
+                                                 'verbose?
+                                                 #f))
+        (success? (dict-ref/default (test-dto)
+                                    previous-test-info
+                                    'success?
+                                    #f))
+        (name (cond
+                ((dict-ref (test-dto)
+                           previous-test-info
+                           'name))
+                (else ""))))
+    (cond
+      (success?
+       (when (or verbose? specifically-verbose?)
+         (display (string-append "PASS:           \"" name "\"\n"))))
+      (else
+       (display (string-append "FAIL:           \"" name "\"\n"))
+       (display-report previous-test-info)))
+    previous-test-info))
+
+(define (default-on-exception-in-test exn return)
+  (test-set! 'success? #f 'exception exn)
+  (return))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Default handlers for groups
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (default-skip-group? name) #f)
+(define (default-when-group-skipped name)
+  (display (string-append "SKIP GROUP      "
+                          (if name
+                              (string-append "\"" name "\"")
+                              "")
+                          "\n")))
+
+(define (default-before-group! name)
+  (when (test-ref/default 'verbose? #f)
+    (display (string-append "ENTER    " (if name name "group") "\n"))))
+
+(define (default-setup-group! name)
+  (test-set! 'tests 0 'passed 0 'failed 0 'skipped 0)
+  (setup-name! name))
+(define (default-cleanup-group! name) #f)
+
+(define (default-after-group previous-info)
+  (define (update/previous! name)
+    (test-update/default!
+     name
+     (lambda (x) (+ x (dict-ref/default (test-dto)
+                                        previous-info
+                                        name
+                                        0)))
+     0))
+  (for-each update/previous! '(tests passed failed skipped))
+  ((test-ref 'report-group) previous-info))
+
+(define (default-report-group previous-info)
+  (when (or (test-ref/default 'verbose? #f)
+            (dict-ref/default (test-dto) previous-info
+                              'verbose? #f))
+    (cond
+      ((dict-ref (test-dto) previous-info 'name)
+       => (lambda (name)
+            (display (string-append "EXIT \"" name "\"\n"))))
+      (else (display "EXIT group\n"))))
+  previous-info)
+
+(define (default-on-exception-in-group ex return)
+  (error 'on-exception-in-group
+         "exception in group"
+         (test-ref 'name-stack)
+         (rewrite ex)))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; test info
+;;; ;;;;;;;;;;;;;;;;
+
+(define default-test-info-dict
+  (alist->default-dictionary
+   `((skip-test? . ,default-skip-test?)
+     (when-test-skipped . ,default-when-test-skipped)
+     (before-test! . ,default-before-test!)
+     (setup-test! . ,default-setup-test!)
+     (cleanup-test! . ,default-cleanup-test!)
+     (after-test . ,default-after-test)
+     (report-test . ,default-report-test)
+     (on-exception-in-test . ,default-on-exception-in-test)
+     ;; groups
+     (skip-group? . ,default-skip-group?)
+     (when-group-skipped . ,default-when-group-skipped)
+     (before-group! . ,default-before-group!)
+     (setup-group! . ,default-setup-group!)
+     (cleanup-group! . ,default-cleanup-group!)
+     (after-group . ,default-after-group)
+     (report-group . ,default-report-group)
+     (on-exception-in-group . ,default-on-exception-in-group)
+     (passed . 0)
+     (failed . 0)
+     (skipped . 0)
+     (tests . 0)
+     (name . #f)
+     (name-stack . ())
+     (never-print-dto . ,equal-alist-dto)
+     (pretty-print . ,pretty-print)
+     (never-print . ,(map (lambda (x) (cons x x))
+                          '(skip-test? when-test-skipped before-test! setup-test!
+                                       cleanup-test! after-test report-test
+                                       on-exception-in-test
+                                       skip-group? when-group-skipped before-group!
+                                       setup-group! cleanup-group! after-group
+                                       report-group on-exception-in-group
+                                       never-print name rewriters
+                                       never-print-dto pretty-print))))))
+
+(define test-dto (make-parameter default-test-dto
+                                 (lambda (x)
+                                   (unless (dto? x)
+                                     (assertion-violation 'test-dto
+                                                          "must be a DTO"
+                                                          x))
+                                   x)))
+(define test-info (make-parameter default-test-info-dict
+                                  (lambda (x)
+                                    (if (test-info? x)
+                                        x
+                                        (wrap-test-info x)))))
+(define (test-info-dict) (unwrap-test-info (test-info)))
+
+;;; ;;;;;;;;;;;;
+;;; Wrappers and semi-compatability with SRFI-64
+;;; ;;;;;;;;;;;;
+
+(define-syntax test-named-application
+  (syntax-rules ()
+    ((_ test-name (%name %expr) ...)
+     (test-named-application "generate" test-name ((%name %expr) ...) ()))
+    ((_ "generate" test-name ((#f expr) rest ...) (acc ...))
+     (test-named-application "generate" test-name (rest ...) ((tmp expr) acc ...)))
+    ((_ "generate" test-name ((sym expr) rest ...) (acc ...))
+     (test-named-application "generate" test-name (rest ...)
+                       ((sym (let ((tmp expr))
+                               (test-set! (quote sym) tmp)
+                               tmp)) acc ...)))
+    ((_ "generate" test-name () (acc ...))
+     (test-named-application "reverse" test-name (acc ...) ()))
+    ((_ "reverse" test-name (a b ...) (c ...))
+     (test-named-application "reverse" test-name (b ...) (a c ...)))
+    ((_ "reverse" test-name () ((name expr) ...))
+     (call-as-test test-name
+                   (lambda ()
+                     (let ((name expr) ...) (test-set! 'success? (name ...))))))))
+
+(define-syntax test-application
+  (syntax-rules ()
+    ((_ test-name (%fun expr ...))
+     (test-application "generate-temporaries"
+                       test-name
+                       1
+                       (expr ...)
+                       (tmp)
+                       ((tmp (let ((tmp %fun))
+                               (test-set! 'fun tmp)
+                               tmp)))))
+    ((_ "generate-temporaries" test-name n (e expr ...) (tmps ...) (bindings ...))
+     (test-application "generate-temporaries"
+                       test-name
+                       (+ n 1)
+                       (expr ...)
+                       (tmp tmps ...)
+                       ((tmp (let ((tmp e))
+                               (test-set! (string->symbol
+                                           (string-append
+                                            "arg-"
+                                            (number->string n)))
+                                          e)))
+                        bindings ...)))
+    ((_ "generate-temporaries" test-name _ () (tmps ...) bindings)
+     (test-application "reverse"
+                       test-name
+                       (tmps ...)
+                       ()
+                       bindings))
+    ((_ "reverse" test-name (a b ...) (c ...) bindings)
+     (test-application "reverse"
+                       test-name
+                       (b ...)
+                       (a c ...)
+                       bindings))
+    ((_ "reverse" test-name () form bindings)
+     (call-as-test test-name
+                   (lambda ()
+                     (let bindings (test-set! 'success? form)))))))
+
+(define-syntax test-body
+  (syntax-rules ()
+    ((_ name body ...)
+     (call-as-test name (lambda ()
+                          (test-set! 'success?
+                                     (let () body ...)))))))
+
+(define-test-application test-equal ((equal?) expected actual))
+(define-test-application test-eqv ((eqv?) expected actual))
+(define-test-application test-eq ((eq?) expected actual))
+(define-test-application test-predicate (predicate value))
+(define-test-application test-binary (predicate expected actual))
+
+(define (%test-approximate expected actual error)
+  (<= (abs (- expected actual)) error))
+
+(define-test-application test-approximate
+  ((%test-approximate) expected actual error))
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ name error-predicate body ...)
+     (test-body name
+       (let ((p error-predicate))
+         (test-set! 'on-exception-in-test
+                    (lambda (ex return)
+                      (test-set! 'success? (p ex))
+                      (return))))
+       (let () body ...)
+       #f))))
+
+(define-syntax expect-to-fail
+  (syntax-rules ()
+    ((_ body ...)
+     (let ((outer-after-test (test-ref 'after-test)))
+       (test-group #f
+         (test-set! 'after-test
+                    (lambda (dict)
+                      (outer-after-test (dict-update! (test-dto) dict
+                                                      'success?
+                                                      not))))
+         (let () body ...))))))
+
+(define-syntax test-skip-all
+  (syntax-rules ()
+    ((_ body ...)
+     (test-group #f
+       (test-set! 'skip-test? (lambda (_) #t))
+       (let () body ...)))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name body ...)
+     (call-as-group name (lambda () body ...)))))
+
+(define-syntax with-test-group-cleanup
+  (syntax-rules ()
+    ((_ name body ... cleanup-expr)
+     (test-group name
+       (dynamic-wind
+        (lambda () #f)
+        (lambda () body ...)
+        (lambda () cleanup-expr))))))
+
+(define (test-exit)
+  (display "==== EXITING TEST SUITE =====\n")
+  (call-with-values (lambda () (inspect-test-info values))
+    display-report)
+  (exit (if (zero? (test-ref/default 'failed 0))
+            0
+            1)))