From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 27 Sep 2009 07:15:23 +0000 (-0700)
Subject: Build unit-test framework.
X-Git-Tag: 20100708-Gtk~309
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7e09f11f7ab28a72e9f1bd66ed305a1d92c2e7b9;p=mit-scheme.git

Build unit-test framework.
---

diff --git a/tests/load.scm b/tests/load.scm
new file mode 100644
index 000000000..0d3f9df4b
--- /dev/null
+++ b/tests/load.scm
@@ -0,0 +1,30 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(let ((environment (make-top-level-environment)))
+  (environment-link-name environment '(runtime mit-macros) 'PARSE-DEFINE-FORM)
+  (load (merge-pathnames "unit-testing" (current-load-pathname))
+	environment)
+  (environment-link-name system-global-environment environment 'RUN-UNIT-TESTS))
\ No newline at end of file
diff --git a/tests/runtime/test-regsexp.scm b/tests/runtime/test-regsexp.scm
index a455d2af4..e2002e2b3 100644
--- a/tests/runtime/test-regsexp.scm
+++ b/tests/runtime/test-regsexp.scm
@@ -27,145 +27,138 @@ USA.
 
 (declare (usual-integrations))
 
-(define (test-string pattern string expected)
-  (assert-equal `(match-string ',pattern ,string)
-		 (match-string pattern string)
-		 expected))
-
 (define (match-string pattern string)
   (regsexp-match-string (compile-regsexp pattern) string))
 
-(define (assert-equal expr value expected)
-  (if (not (equal? value expected))
-      (begin
-	(fluid-let ((*unparse-abbreviate-quotations?* #t))
-	  (write expr))
-	(write-string " => ")
-	(write value)
-	(write-string " but expected ")
-	(write expected)
-	(newline))))
-
-(define (test-strings pattern entries)
-  (for-each (lambda (p)
-	      (test-string pattern (car p) (cadr p)))
-	    entries))
-
-(define (test-no-groups pattern entries)
-  (test-strings pattern
-		(map (lambda (p)
-		       (list (car p)
-			     (and (cadr p)
-				  (list (cadr p)))))
-		     entries)))
-
-(define (no-groups-tester strings)
-  (lambda (pattern indices)
-    (test-no-groups pattern
-		    (map list strings indices))))
-
-(define (run-tests)
-  (test-no-groups '(any-char)
+(define ((match-string-test pattern string expected))
+  (assert-equal (match-string pattern string)
+		expected
+		'EXPRESSION `(match-string ',pattern ,string)))
+
+(define (match-strings-test pattern entries)
+  (map (lambda (p)
+	 (match-string-test pattern (car p) (cadr p)))
+       entries))
+
+(define (no-groups-test pattern entries)
+  (match-strings-test pattern
+		      (map (lambda (p)
+			     (list (car p)
+				   (and (cadr p)
+					(list (cadr p)))))
+			   entries)))
+
+(define-test 'any-char
+  (no-groups-test '(any-char)
 		  '(("" #f)
 		    ("a" 1)
 		    ("b" 1)
-		    ("\n" #f)))
+		    ("\n" #f))))
 
-  (test-no-groups '(* (any-char))
+(define-test '*any-char
+  (no-groups-test '(* (any-char))
 		  '(("" 0)
 		    ("a" 1)
 		    ("ab" 2)
 		    ("abc" 3)
 		    ("ab\n" 2)
-		    ("a\nb" 1)))
-
-  (test-string '(seq "a" "b") "ab" '(2))
-
-  (let ((test (no-groups-tester '("" "a" "b" "ab" "ba" "aab"))))
-    (let ((equivalents
-	   (lambda (indices . patterns)
-	     (for-each (lambda (pattern)
-			 (test pattern indices))
-		       patterns))))
-
-      (equivalents '(0 0 0 0 0 0)
-		   ""
-		   '(repeat> 0 0 "a")
-		   '(repeat< 0 0 "a")
-		   '(seq "" ""))
-
-      (equivalents '(#f 1 #f 1 #f 1)
-		   "a"
-		   '(repeat> 1 1 "a")
-		   '(repeat< 1 1 "a")
-		   '(seq "a" "")
-		   '(seq "" "a"))
-
-      (equivalents '(#f #f #f #f #f 2)
-		   "aa"
-		   '(repeat> 2 2 "a")
-		   '(repeat< 2 2 "a")
-		   '(seq "a" "a")
-		   '(seq "aa" "")
-		   '(seq "" "aa"))
-
-      (equivalents '(0 1 0 1 0 2)
-		   '(* "a")
-		   '(repeat> 0 #f "a"))
-
-      (equivalents '(0 0 0 0 0 0)
-		   '(*? "a")
-		   '(repeat< 0 #f "a"))
-
-      (equivalents '(#f 1 #f 1 #f 2)
-		   '(+ "a")
-		   '(seq "a" (* "a"))
-		   '(repeat> 1 #f "a"))
-
-      (equivalents '(#f 1 #f 1 #f 1)
-		   '(+? "a")
-		   '(seq "a" (*? "a"))
-		   '(repeat< 1 #f "a"))
-
-      (equivalents '(0 1 0 1 0 1)
-		   '(? "a")
-		   '(repeat> 0 1 "a"))
-
-      (equivalents '(0 0 0 0 0 0)
-		   '(?? "a")
-		   '(repeat< 0 1 "a"))))
-
-  (test-string '(seq (? "a") "a") "aab" '(2))
-  (test-string '(seq (? "a") "ab") "aab" '(3))
-
-  (test-string '(seq (?? "a") "a") "aab" '(1))
-  (test-string '(seq (?? "a") "ab") "aab" '(3))
-
-  (test-string '(repeat> 1 2 "a") "aab" '(2))
-  (test-string '(seq (repeat> 1 2 "a") "b") "aab" '(3))
-
-  (test-string '(repeat< 1 2 "a") "aab" '(1))
-  (test-string '(seq (repeat< 1 2 "a") "b") "aab" '(3))
-
-  (test-string '(repeat> 1 3 "a") "aaab" '(3))
-  (test-string '(seq (repeat> 1 3 "a") "b") "aaab" '(4))
-
-  (test-string '(repeat< 1 3 "a") "aaab" '(1))
-  (test-string '(seq (repeat< 1 3 "a") "b") "aaab" '(4))
-
-  (test-string '(seq (group foo (? "a")) "a") "aab" '(2 (foo 0 1)))
-  (test-string '(seq (group foo (? "a")) "ab") "aab" '(3 (foo 0 1)))
-  (test-string '(seq (group foo (? "a")) "aab") "aab" '(3 (foo 0 0)))
-
-  (test-string '(seq (group foo (?? "a")) "a") "aab" '(1 (foo 0 0)))
-  (test-string '(seq (group foo (?? "a")) "ab") "aab" '(3 (foo 0 1)))
-  (test-string '(seq (group foo (?? "a")) "aab") "aab" '(3 (foo 0 0)))
-
-  (test-string '(seq (group foo (* "a")) "b") "aab" '(3 (foo 0 2)))
-  (test-string '(seq (group foo (* "a")) "ab") "aab" '(3 (foo 0 1)))
-  (test-string '(seq (group foo (* "a")) "aab") "aab" '(3 (foo 0 0)))
-
-  (test-string '(seq (group foo (*? "a")) "b") "aab" '(3 (foo 0 2)))
-  (test-string '(seq (group foo (*? "a")) "ab") "aab" '(3 (foo 0 1)))
-  (test-string '(seq (group foo (*? "a")) "aab") "aab" '(3 (foo 0 0)))
-  )
\ No newline at end of file
+		    ("a\nb" 1))))
+
+(define-test 'simple-seq
+  (match-string-test '(seq "a" "b") "ab" '(2)))
+
+(define-test 'repeat-equivalences-test
+  (let ((equivalents
+	 (lambda (indices . patterns)
+	   (map (let ((strings '("" "a" "b" "ab" "ba" "aab")))
+		  (lambda (pattern)
+		    (no-groups-test pattern
+				    (map list
+					 strings
+					 indices))))
+		patterns))))
+    (list
+     (equivalents '(0 0 0 0 0 0)
+		  ""
+		  '(repeat> 0 0 "a")
+		  '(repeat< 0 0 "a")
+		  '(seq "" ""))
+
+     (equivalents '(#f 1 #f 1 #f 1)
+		  "a"
+		  '(repeat> 1 1 "a")
+		  '(repeat< 1 1 "a")
+		  '(seq "a" "")
+		  '(seq "" "a"))
+
+     (equivalents '(#f #f #f #f #f 2)
+		  "aa"
+		  '(repeat> 2 2 "a")
+		  '(repeat< 2 2 "a")
+		  '(seq "a" "a")
+		  '(seq "aa" "")
+		  '(seq "" "aa"))
+
+     (equivalents '(0 1 0 1 0 2)
+		  '(* "a")
+		  '(repeat> 0 #f "a"))
+
+     (equivalents '(0 0 0 0 0 0)
+		  '(*? "a")
+		  '(repeat< 0 #f "a"))
+
+     (equivalents '(#f 1 #f 1 #f 2)
+		  '(+ "a")
+		  '(seq "a" (* "a"))
+		  '(repeat> 1 #f "a"))
+
+     (equivalents '(#f 1 #f 1 #f 1)
+		  '(+? "a")
+		  '(seq "a" (*? "a"))
+		  '(repeat< 1 #f "a"))
+
+     (equivalents '(0 1 0 1 0 1)
+		  '(? "a")
+		  '(repeat> 0 1 "a"))
+
+     (equivalents '(0 0 0 0 0 0)
+		  '(?? "a")
+		  '(repeat< 0 1 "a")))))
+
+(define-test 'more-repeat-tests
+  (list
+   (match-string-test '(seq (? "a") "a") "aab" '(2))
+   (match-string-test '(seq (? "a") "ab") "aab" '(3))
+
+   (match-string-test '(seq (?? "a") "a") "aab" '(1))
+   (match-string-test '(seq (?? "a") "ab") "aab" '(3))
+
+   (match-string-test '(repeat> 1 2 "a") "aab" '(2))
+   (match-string-test '(seq (repeat> 1 2 "a") "b") "aab" '(3))
+
+   (match-string-test '(repeat< 1 2 "a") "aab" '(1))
+   (match-string-test '(seq (repeat< 1 2 "a") "b") "aab" '(3))
+
+   (match-string-test '(repeat> 1 3 "a") "aaab" '(3))
+   (match-string-test '(seq (repeat> 1 3 "a") "b") "aaab" '(4))
+
+   (match-string-test '(repeat< 1 3 "a") "aaab" '(1))
+   (match-string-test '(seq (repeat< 1 3 "a") "b") "aaab" '(4))
+
+   (match-string-test '(seq (group foo (? "a")) "a") "aab" '(2 (foo 0 1)))
+   (match-string-test '(seq (group foo (? "a")) "ab") "aab" '(3 (foo 0 1)))
+   (match-string-test '(seq (group foo (? "a")) "aab") "aab" '(3 (foo 0 0)))
+
+   (match-string-test '(seq (group foo (?? "a")) "a") "aab" '(1 (foo 0 0)))
+   (match-string-test '(seq (group foo (?? "a")) "ab") "aab" '(3 (foo 0 1)))
+   (match-string-test '(seq (group foo (?? "a")) "aab") "aab" '(3 (foo 0 0)))
+
+   (match-string-test '(seq (group foo (* "a")) "b") "aab" '(3 (foo 0 2)))
+   (match-string-test '(seq (group foo (* "a")) "ab") "aab" '(3 (foo 0 1)))
+   (match-string-test '(seq (group foo (* "a")) "aab") "aab" '(3 (foo 0 0)))
+
+   (match-string-test '(seq (group foo (*? "a")) "b") "aab" '(3 (foo 0 2)))
+   (match-string-test '(seq (group foo (*? "a")) "ab") "aab" '(3 (foo 0 1)))
+   (match-string-test '(seq (group foo (*? "a")) "aab") "aab" '(3 (foo 0 0)))
+
+   ))
\ No newline at end of file
diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
new file mode 100644
index 000000000..726cffb09
--- /dev/null
+++ b/tests/unit-testing.scm
@@ -0,0 +1,226 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Unit-test framework
+
+(declare (usual-integrations))
+
+(define (run-unit-tests filename/s #!optional environment)
+  (report-results
+   (map run-test
+	(load-unit-tests filename/s environment))))
+
+(define (load-unit-tests filename/s #!optional environment)
+  (let ((test-environment
+	 (if (default-object? environment)
+	     (make-top-level-environment)
+	     (extend-top-level-environment environment))))
+    (initialize-test-environment! test-environment)
+    (fluid-let ((*registered-tests* '()))
+      (load filename/s test-environment)
+      (reverse! *registered-tests*))))
+
+(define (register-test name test)
+  (set! *registered-tests* (cons (cons name test) *registered-tests*))
+  unspecific)
+
+(define *registered-tests*)
+
+(define (initialize-test-environment! test-environment)
+  (for-each (lambda (p)
+	      (environment-define test-environment (car p) (cdr p)))
+	    test-definitions))
+
+(define (add-test-definition name value)
+  (let ((p (assq name test-definitions)))
+    (if p
+	(set-cdr! p value)
+	(begin
+	  (set! test-definitions (cons (cons name value) test-definitions))
+	  unspecific))))
+
+(define test-definitions '())
+
+(define (report-results results)
+  (let ((port (notification-output-port)))
+    (for-each (lambda (result)
+		(write (car result) port)
+		(write-string ": " port)
+		(cond ((not (cdr result))
+		       (write-string "passed" port))
+		      ((failure? (cdr result))
+		       (report-failure (cdr result) port))
+		      (else
+		       (error "Ill-formed result:" result)))
+		(newline port))
+	      results))
+  ;; Value is true iff all tests passed.
+  (every (lambda (result)
+	   (not (cdr result)))
+	 results))
+
+(define (run-test test)
+  (cons (car test)
+	(call-with-current-continuation
+	 (lambda (k)
+	   (bind-condition-handler (list condition-type:error)
+	       (lambda (condition)
+		 (k (make-failure 'CONDITION condition)))
+	     (cdr test))))))
+
+(define-record-type <failure>
+    (%make-failure alist)
+    failure?
+  (alist failure-alist))
+
+(define (make-failure . plist)
+  (%make-failure (keyword-list->alist plist)))
+
+(define (failure-property key failure)
+  (assq key (failure-alist failure)))
+
+(define (write-string-property tag p port)
+  (write-tag tag port)
+  (write-string (cdr p) port))
+
+(define (write-object-property tag p port)
+  (write-tag tag port)
+  (write (cdr p) port))
+
+(define (write-expr-property tag p port)
+  (write-tag tag port)
+  (fluid-let ((*unparse-abbreviate-quotations?* #t))
+    (write (cdr p) port)))
+
+(define (write-tag tag port)
+  (if tag
+      (begin
+	(write-string " " port)
+	(write-string tag port)
+	(write-string " " port))))
+
+(define (failure-feature feature failure)
+  (or (failure-property (symbol feature '-DESCRIPTION) failure)
+      (failure-property (symbol feature '-OBJECT) failure)))
+
+(define (write-feature tag p port)
+  (if (string-suffix-ci? "-DESCRIPTION" (symbol-name (car p)))
+      (write-string-property tag p port)
+      (write-object-property tag p port)))
+
+(define (report-failure failure port)
+  (let ((result (failure-feature 'RESULT failure)))
+    (if result
+	(begin
+	  (write-string "value" port)
+	  (let ((expr (failure-property 'EXPRESSION failure)))
+	    (if expr
+		(write-expr-property "of" expr port)))
+	  (write-feature "was" result port)
+	  (let ((expectation (failure-feature 'EXPECTATION failure)))
+	    (if expectation
+		(write-feature "but expected" expectation port))))
+	(write-string (or (failure-property 'DESCRIPTION failure)
+			  "failed for an unknown reason")
+		      port))))
+
+(define-syntax define-for-tests
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare
+     (receive (name value)
+	 (parse-define-form form rename)
+       `(,(rename 'BEGIN)
+	 (,(rename 'DEFINE) ,name ,value)
+	 (,(rename 'ADD-TEST-DEFINITION) ',name ,name))))))
+
+(define-for-tests (define-test name . tests)
+  (let ((tests (flatten tests)))
+    (if (pair? tests)
+	(if (pair? (cdr tests))
+	    (for-each (lambda (test index)
+			(register-test (symbol name '/ index) test))
+		      tests
+		      (iota (length tests)))
+	    (register-test name (car tests)))))
+  name)
+
+(define (flatten tests)
+  (append-map! (lambda (test)
+		 (if (list? test)
+		     (flatten test)
+		     (list test)))
+	       tests))
+
+(define-for-tests (predicate-assertion predicate description)
+  (lambda (value . properties)
+    (if (predicate value)
+	#f
+	(apply make-failure
+	       'RESULT-OBJECT value
+	       'EXPECTATION-DESCRIPTION description
+	       properties))))
+
+(define-for-tests (assert predicate description value . properties)
+  (apply (predicate-assertion predicate description)
+	 value
+	 properties))
+
+(define-for-tests (assert-true expr value)
+  (if value
+      #f
+      (make-failure 'EXPRESSION expr
+		    'RESULT-DESCRIPTION "false"
+		    'EXPECTATION-DESCRIPTION "true")))
+
+(define-for-tests (assert-false expr value)
+  (if value
+      (make-failure 'EXPRESSION expr
+		    'RESULT-DESCRIPTION "true"
+		    'EXPECTATION-DESCRIPTION "false")
+      #f))
+
+(define-for-tests assert-null
+  (predicate-assertion null? "an empty list"))
+
+(define-for-tests (binary-assertion comparator)
+  (lambda (value expected . properties)
+    (if (comparator value expected)
+	#f
+	(apply make-failure
+	       'RESULT-OBJECT value
+	       'EXPECTATION-OBJECT expected
+	       properties))))
+
+(define-for-tests assert-eq (binary-assertion eq?))
+(define-for-tests assert-eqv (binary-assertion eqv?))
+(define-for-tests assert-equal (binary-assertion equal?))
+
+(define-for-tests assert-= (binary-assertion =))
+(define-for-tests assert-!= (binary-assertion (lambda (v e) (not (= v e)))))
+(define-for-tests assert-< (binary-assertion <))
+(define-for-tests assert-<= (binary-assertion <=))
+(define-for-tests assert-> (binary-assertion >))
+(define-for-tests assert->= (binary-assertion >=))
\ No newline at end of file