[uim-commit] r2828 - branches/r5rs/sigscheme/test

[yamaken at freedesktop.org]

Author: yamaken
Date: 2006-01-06 20:46:33 -0800 (Fri, 06 Jan 2006)
New Revision: 2828

Modified:
   branches/r5rs/sigscheme/test/test-r4rs.scm
   branches/r5rs/sigscheme/test/unittest.scm
Log:
* sigscheme/test/unittest.scm
  - (assert, test-name): Protect primitive functions from being
    redefined
* sigscheme/test/test-r4rs.scm
  - Adapt to unittest.scm
  - (tn-section): New procedure
  - (SECTION, test): Insert the adaptation


Modified: branches/r5rs/sigscheme/test/test-r4rs.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-r4rs.scm	2006-01-07 04:17:51 UTC (rev 2827)
+++ branches/r5rs/sigscheme/test/test-r4rs.scm	2006-01-07 04:46:33 UTC (rev 2828)
@@ -41,26 +41,45 @@
 
 ;;; send corrections or additions to agj @ alum.mit.edu
 
+(require "test/unittest.scm")
+
+(define tn test-name)
+(define tn-section
+  (lambda (digits)
+    (let ((name (apply string-append
+                       (cons
+                        "section "
+                        (apply append
+                               (map (lambda (d)
+                                      (list (number->string d) "."))
+                                    digits))))))
+      (tn name))))
 (define cur-section '())(define errs '())
 (define SECTION (lambda args
-;		  (display "SECTION") (write args) (newline)
-		  (set! cur-section args) #t))
+		  ;;(display "SECTION") (write args) (newline)
+		  (set! cur-section args)
+                  (tn-section args)
+                  #t))
 (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
 
 (define test
   (lambda (expect fun . args)
-;    (write (cons fun args))
-;    (display "  ==> ")
+    ;;(write (cons fun args))
+    ;;(display "  ==> ")
     ((lambda (res)
-;      (write res)
-;      (newline)
-      (cond ((not (equal? expect res))
-	     (record-error (list res expect (cons fun args)))
-;	     (display " BUT EXPECTED ")
-;	     (write expect)
-;	     (newline)
-	     #f)
-	    (else #t)))
+       ;;(write res)
+       ;;(newline)
+       (let ((name (tn)))
+         (cond ((not (equal? expect res))
+                (record-error (list res expect (cons fun args)))
+                ;;(display " BUT EXPECTED ")
+                ;;(write expect)
+                ;;(newline)
+                (assert name name #f)
+                #f)
+               (else
+                (assert name name #t)
+                #t))))
      (if (procedure? fun) (apply fun args) (car args)))))
 (define (report-errs)
   (newline)
@@ -1242,3 +1261,5 @@
 (display "(test-cont) (test-sc4) (test-delay)")
 (newline)
 "last item in file"
+
+(total-report)

Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm	2006-01-07 04:17:51 UTC (rev 2827)
+++ branches/r5rs/sigscheme/test/unittest.scm	2006-01-07 04:46:33 UTC (rev 2828)
@@ -84,19 +84,24 @@
     (newline)))
 
 (define assert
-  (lambda (test-name err-msg exp)
-    (set! *total-assertions* (+ *total-assertions* 1))
-    (if *test-track-progress*
-        (begin
-          (display "done: ")
-          (display test-name)
-          (newline)))
-    (if exp
-	#t
-	(begin
-	  (set! *total-failures* (+ *total-failures* 1))
-	  (report-error err-msg)
-	  #f))))
+  ;; to be protected from redifinitions in tests
+  (let ((+ +)
+        (set! set!)
+        (display display)
+        (newline newline))
+    (lambda (test-name err-msg exp)
+      (set! *total-assertions* (+ *total-assertions* 1))
+      (if *test-track-progress*
+          (begin
+            (display "done: ")
+            (display test-name)
+            (newline)))
+      (if exp
+          #t
+          (begin
+            (set! *total-failures* (+ *total-failures* 1))
+            (report-error err-msg)
+            #f)))))
 
 ;;
 ;; assertions for test writers
@@ -174,7 +179,10 @@
 
 (define test-name
   (let ((name "anonymous test")
-        (serial 0))
+        (serial 0)
+        (+ +)
+        (set! set!)
+        (null? null?))
     (lambda args
       (if (null? args)
           (begin