implemented top-level lookups, with scoping

svn: r2174

collects/tests/mztake/mztake-test.ss

@@ -0,0 +1,7 @@
+(require (as-is mzscheme load)
+         (as-is "test-harness.ss" test))
+(load "../demos/dijkstra/dijkstra-mztake.ss") 
+(map-e (lambda (e)
+         (unless e
+           (test (dv:vector-length (t-data heap)) 5)))
+       (debug-process-running-e (current-process)))

collects/tests/mztake/test-harness.ss

@@ -0,0 +1,76 @@
+(module test-harness mzscheme
+  (provide (all-defined))
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           (lib "pretty.ss"))
+  
+  (define print-tests (make-parameter #f))
+  (define test-inspector (make-parameter (current-inspector)))
+  (define test-inexact-epsilon (make-parameter 0.01))
+  
+  (define-struct (exn:test exn) ())
+  
+  (define (install-test-inspector)
+    (test-inspector (current-inspector))
+    (current-inspector (make-inspector))
+    (print-struct #t))
+  
+  (define (may-print-result result)
+    (parameterize ([current-inspector (test-inspector)]
+                   [print-struct #t])
+      (when (or (eq? (print-tests) (first result))
+                (eq? (print-tests) #t))
+        
+        (pretty-print result))
+      (when (and (eq? (print-tests) 'stop)
+                 (eq? (first result) 'bad))
+        (raise (make-exn:test (string->immutable-string (format "test failed: ~a" result))
+                              (current-continuation-marks))))))
+  
+  
+  (define test 
+    (opt-lambda (result expected [compare equal?])
+      (let* ([test-result
+              (cond [(or (and (number? result) (not (exact? result)))
+                         (and (number? expected) (not (exact? expected))))
+                     (< (abs (- result expected)) (test-inexact-epsilon))]
+                    [else
+                     (parameterize ([current-inspector (test-inspector)])
+                       (compare result expected))])]
+             [to-print (if test-result 
+                           (list 'good result expected)
+                           (list 'bad result expected))])
+        
+        (may-print-result to-print)
+        to-print)))
+  
+  (define (test/pred result pred)
+    (let* ([test-result (pred result)]
+           [to-print (if test-result
+                         (list 'good result test-result)
+                         (list 'bad result test-result))])
+      (may-print-result to-print)
+      to-print))
+  
+  (define (test/exn thunk expected-exception-msg)
+    (unless (and (procedure? thunk)
+                 (procedure-arity-includes? thunk 0))
+      (error (format
+              "the first argument to test/exn should be a function of no arguments (a \"thunk\"), got ~a"
+              thunk)))
+    (let* ([result
+            (with-handlers 
+                ([void (lambda (exn) exn)])
+              (thunk))]
+           [test-result
+            (if (and (exn? result)
+                     (regexp-match expected-exception-msg (exn-message result)))
+                (list 'good result expected-exception-msg)
+                (list 'bad result expected-exception-msg))])
+      (may-print-result test-result)
+      test-result))
+  
+  (install-test-inspector)
+  )
+
+