--- /dev/null
+#| -*-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
(declare (usual-integrations))
\f
-(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")))))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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))))))
+\f
+(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))))
+\f
+(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
projects / mit-scheme.git / commitdiff