(declare (usual-integrations))
\f
-(define-test 'scalar-value-list
+(define-test 'interesting-svl-round-trip
(lambda ()
- (list (run-random-svl-tests 0 1)
- (map (lambda (i)
- (run-random-svl-tests i 100))
- (iota 4 1))
- (run-random-svl-tests 100 100))))
+ (map (lambda (svl)
+ (run-sub-test
+ (lambda ()
+ (assert-equal-canonical-svls (named-call 'SVL-ROUND-TRIP
+ svl-round-trip svl)
+ svl))))
+ interesting-svls)))
-(define (run-random-svl-tests n-ranges n-iter)
+(define (svl-round-trip svl)
+ (char-set->scalar-values (scalar-values->char-set svl)))
+
+(define-test 'random-svl-round-trip
+ (lambda ()
+ (map (lambda (svl)
+ (run-sub-test
+ (lambda ()
+ (guarantee-well-formed-scalar-value-list svl)
+ (assert-equal-canonical-svls
+ (named-call '%CANONICALIZE-SCALAR-VALUE-LIST
+ %canonicalize-scalar-value-list
+ svl)
+ (svl-round-trip svl)))))
+ (append! (append-map! (lambda (i)
+ (make-random-svls i 100))
+ (iota 4 1))
+ (make-random-svls 100 100)))))
+
+(define (make-random-svls n-ranges n-iter)
(map (lambda (i)
i
- (run-random-svl-test n-ranges))
+ (make-random-svl n-ranges))
(iota n-iter)))
-(define (run-random-svl-test n-ranges)
- (let ((svl (make-random-svl n-ranges)))
- (guarantee-well-formed-scalar-value-list svl)
- (let ((svl1 (%canonicalize-scalar-value-list svl))
- (svl2 (char-set->scalar-values (scalar-values->char-set svl))))
- (list (assert-true `(canonical-svl? ,svl1)
- (canonical-svl? svl1))
- (assert-true `(canonical-svl? ,svl2)
- (canonical-svl? svl2))
- (assert-equal svl1 svl2)))))
-
(define (make-random-svl n-ranges)
- ;; Random modulus must exceed %LOW-LIMIT.
- (let ((modulus #x1000))
+ (let ((modulus (* %low-limit 2)))
(make-initialized-list n-ranges
(lambda (i)
(let loop ()
(if (= m 0)
n
(cons n (+ n m 1))))))))))
+\f
+(define-test 'invert
+ (lambda ()
+ (map (lambda (svl)
+ (run-sub-test
+ (lambda ()
+ (assert-equal (named-call 'SVL-INVERT-THRU
+ svl-invert-thru svl)
+ (named-call 'SVL-INVERT-DIRECT
+ svl-invert-DIRECT svl)))))
+ interesting-svls)))
+
+(define (svl-invert-thru svl)
+ (char-set->scalar-values (char-set-invert (scalar-values->char-set svl))))
+
+(define (svl-invert-direct svl)
+
+ (define (go svl prev-end)
+ (if (pair? svl)
+ (cons (make-segment prev-end
+ (segment-start (car svl)))
+ (go (cdr svl)
+ (segment-end (car svl))))
+ (if (< prev-end char-code-limit)
+ (list (make-segment prev-end char-code-limit))
+ '())))
+
+ (if (and (pair? svl)
+ (= (segment-start (car svl)) 0))
+ (go (cdr svl)
+ (segment-end (car svl)))
+ (go svl 0)))
+
+(define (make-binary-test name operation svl-direct)
+ (lambda ()
+ (map (lambda (svl1)
+ (map (lambda (svl2)
+ (run-sub-test
+ (lambda ()
+ (with-test-properties
+ (lambda ()
+ (assert-equal
+ (char-set->scalar-values
+ (operation (scalar-values->char-set svl1)
+ (scalar-values->char-set svl2)))
+ (svl-direct svl1 svl2)))
+ 'EXPRESSION `(,name ,svl1 ,svl2)))))
+ interesting-svls))
+ interesting-svls)))
+
+(define-test 'union
+ (make-binary-test 'CHAR-SET-UNION
+ char-set-union
+ (lambda (svl1 svl2)
+ (named-call 'SVL-UNION svl-union svl1 svl2))))
+
+(define (svl-union svl1 svl2)
+ (if (pair? svl1)
+ (if (pair? svl2)
+ (let ((s1 (segment-start (car svl1)))
+ (e1 (segment-end (car svl1)))
+ (s2 (segment-start (car svl2)))
+ (e2 (segment-end (car svl2))))
+ (cond ((< e1 s2)
+ (cons (car svl1)
+ (svl-union (cdr svl1) svl2)))
+ ((< e2 s1)
+ (cons (car svl2)
+ (svl-union svl1 (cdr svl2))))
+ (else
+ (let ((s3 (min s1 s2)))
+ (receive (e3 svl1 svl2)
+ (union:find-end (max e1 e2)
+ (cdr svl1)
+ (cdr svl2))
+ (cons (make-segment s3 e3)
+ (svl-union svl1 svl2)))))))
+ svl1)
+ svl2))
+
+(define (union:find-end e0 svl1 svl2)
+ (let ((s1
+ (if (pair? svl1)
+ (segment-start (car svl1))
+ #f))
+ (s2
+ (if (pair? svl2)
+ (segment-start (car svl2))
+ #f)))
+ (if (or (and (not s1) (not s2))
+ (< e0
+ (cond ((not s1) s2)
+ ((not s2) s1)
+ (else (min s1 s2)))))
+ (values e0 svl1 svl2)
+ (if (and s1
+ (or (not s2)
+ (< s1 s2)))
+ (union:find-end (max e0 (segment-end (car svl1)))
+ (cdr svl1)
+ svl2)
+ (union:find-end (max e0 (segment-end (car svl2)))
+ svl1
+ (cdr svl2))))))
+
+(define-test 'intersection
+ (make-binary-test 'CHAR-SET-INTERSECTION
+ char-set-intersection
+ (lambda (svl1 svl2)
+ (named-call 'SVL-INTERSECTION
+ svl-intersection svl1 svl2))))
+
+(define (svl-intersection svl1 svl2)
+ (let loop ((svl1 svl1) (svl2 svl2))
+ (if (and (pair? svl1) (pair? svl2))
+ (let ((s1 (segment-start (car svl1)))
+ (e1 (segment-end (car svl1)))
+ (s2 (segment-start (car svl2)))
+ (e2 (segment-end (car svl2))))
+ (cond ((<= e1 s2) (loop (cdr svl1) svl2))
+ ((<= e2 s1) (loop svl1 (cdr svl2)))
+ (else
+ (cons (make-segment (max s1 s2) (min e1 e2))
+ (cond ((< e1 e2)
+ (loop (cdr svl1) svl2))
+ ((> e1 e2)
+ (loop svl1 (cdr svl2)))
+ (else
+ (loop (cdr svl1) (cdr svl2))))))))
+ '())))
+
+(define-test 'difference
+ (make-binary-test 'CHAR-SET-DIFFERENCE
+ char-set-difference
+ (lambda (svl1 svl2)
+ (named-call 'SVL-DIFFERENCE svl-difference svl1 svl2))))
+
+(define (svl-difference svl1 svl2)
+ (let loop ((svl1 svl1) (svl2 svl2))
+ (if (pair? svl1)
+ (if (pair? svl2)
+ (let ((s1 (segment-start (car svl1)))
+ (e1 (segment-end (car svl1)))
+ (s2 (segment-start (car svl2)))
+ (e2 (segment-end (car svl2))))
+ (cond ((<= e1 s2)
+ (cons (car svl1)
+ (loop (cdr svl1) svl2)))
+ ((<= e2 s1)
+ (loop svl1 (cdr svl2)))
+ (else
+ (let ((tail
+ (cond ((< e1 e2)
+ (loop (cdr svl1)
+ (cons (make-segment e1 e2)
+ (cdr svl2))))
+ ((= e1 e2)
+ (loop (cdr svl1) (cdr svl2)))
+ (else
+ (loop (cons (make-segment e2 e1)
+ (cdr svl1))
+ (cdr svl2))))))
+ (if (< s1 s2)
+ (cons (make-segment s1 s2) tail)
+ tail)))))
+ svl1)
+ '())))
+\f
+(define (assert-equal-canonical-svls svl1 svl2)
+ (list (assert-canonical-svl svl1)
+ (assert-canonical-svl svl2)
+ (assert-equal svl1 svl2)))
+
+(define (assert-canonical-svl svl)
+ (assert-true `(CANONICAL-SVL? ,svl)
+ (canonical-svl? svl)))
+
+(define (named-call name operation . args)
+ (with-test-properties (lambda () (apply operation args))
+ 'EXPRESSION (cons name args)))
(define (canonical-svl? items)
(and (list-of-type? items
(every-tail (lambda (tail)
(if (and (pair? tail)
(pair? (cdr tail)))
- (< (let ((a (car tail)))
- (if (pair? a)
- (cdr a)
- (+ a 1)))
- (let ((b (cadr tail)))
- (if (pair? b)
- (car b)
- b)))
+ (< (segment-end (car tail))
+ (segment-start (cadr tail)))
#t))
items)))
+(define (make-segment start end)
+ (if (= (- end start) 1)
+ start
+ (cons start end)))
+
+(define (segment-start segment)
+ (if (pair? segment)
+ (car segment)
+ segment))
+
+(define (segment-end segment)
+ (if (pair? segment)
+ (cdr segment)
+ (+ segment 1)))
+
+(define (append-map-tail! procedure items)
+ (if (pair? items)
+ (append! (procedure items)
+ (append-map-tail! procedure (cdr items)))
+ '()))
+
(define (every-tail pred items)
(if (pair? items)
(and (pred items)
(every-tail pred (cdr items)))
- (pred items)))
\ No newline at end of file
+ (pred items)))
+\f
+(define interesting-points
+ (list 0
+ 1
+ (- %low-limit 1)
+ %low-limit
+ (+ %low-limit 1)
+ (- char-code-limit 1)
+ char-code-limit))
+
+(define (mapper->generator mapper)
+ (lambda (points)
+ (let loop ((points points))
+ (if (pair? points)
+ (append! (mapper (car points) (cdr points))
+ (loop (cdr points)))
+ '()))))
+
+(define 1-generator
+ (mapper->generator
+ (lambda (start ends)
+ (map (lambda (end)
+ (list (make-segment start end)))
+ ends))))
+
+(define (n+1-generator n-generator)
+ (mapper->generator
+ (lambda (start tails)
+ (append-map-tail! (lambda (tail)
+ (let ((segment (make-segment start (car tail))))
+ (map (lambda (segments)
+ (cons segment segments))
+ (n-generator (cdr tail)))))
+ tails))))
+
+(define 2-generator
+ (n+1-generator 1-generator))
+
+(define 3-generator
+ (n+1-generator 2-generator))
+
+(define interesting-svls
+ (cons (list)
+ (append! (1-generator interesting-points)
+ (2-generator interesting-points)
+ (3-generator interesting-points))))
\ No newline at end of file
(declare (usual-integrations))
\f
+(define (run-unit-test filename/s test-name #!optional environment)
+ (let ((port (notification-output-port)))
+ (let ((tests (load-unit-tests filename/s environment)))
+ (let ((test (assq test-name tests)))
+ (if (not test)
+ (error "Unknown test name:" test-name (map car tests)))
+ (run-and-report test port)))))
+
(define (run-unit-tests filename/s #!optional environment)
- (report-results
- (map run-unit-test
- (load-unit-tests filename/s environment))))
+ (let ((port (notification-output-port))
+ (pass? #t))
+ (for-each (lambda (test)
+ (if (not (run-and-report test port))
+ (set! pass? #f)))
+ (load-unit-tests filename/s environment))
+ pass?))
(define (load-unit-tests filename/s #!optional environment)
(let ((test-environment (make-test-environment! environment)))
test-definitions)
test-environment))
-(define (run-unit-test name.test)
- (cons (car name.test)
- (append-map! (lambda (named-sub-test)
- (name-and-flatten (car named-sub-test)
- (cdr named-sub-test)))
- (run-sub-tests (name-and-flatten "" (cdr name.test))))))
+(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 (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-for-tests (define-test name test . tests)
+ (register-test name
+ (if (null? tests)
+ test
+ (cons test tests)))
+ name)
+\f
+;;;; Test runner
+
+(define (run-and-report name.test port)
+ (let ((start-time (process-time-clock)))
+ (let ((results
+ (append-map! (lambda (named-sub-test)
+ (name-and-flatten (car named-sub-test)
+ (cdr named-sub-test)))
+ (run-sub-tests (name-and-flatten "" (cdr name.test))))))
+ (report-result (car name.test)
+ (internal-time/ticks->seconds
+ (- (process-time-clock) start-time))
+ results
+ port))))
(define (run-sub-tests named-sub-tests)
;; Runs sub-tests in left-to-right order.
(if (pair? named-sub-tests)
(loop (cdr named-sub-tests)
(cons (cons (caar named-sub-tests)
- (run-test-thunk (cdar named-sub-tests)))
+ ((cdar named-sub-tests)))
results))
(reverse! results))))
(if (list? items)
(append-map! flatten items)
(list items)))
-
-(define (run-test-thunk thunk)
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:error)
- (lambda (condition)
- (k (make-failure 'CONDITION condition)))
- thunk))))
\f
-(define (report-results results)
- (fold (lambda (a b) (and a b))
- #t
- (let ((port (notification-output-port)))
- (map (lambda (result)
- (report-result-group (car result) (cdr result) port))
- results))))
-
-(define (report-result-group test-name sub-test-results port)
- (let ((n-sub-test-results (length sub-test-results)))
- (cond ((> n-sub-test-results 1)
- (let ((n-failed (count failing-sub-test? sub-test-results)))
- (write test-name port)
- (write-string ": " port)
- (if (> n-failed 0)
- (begin
- (write-string "failed " port)
- (write n-failed port)
- (write-string " sub-tests out of " port)
- (write n-sub-test-results port)
- (write-string ":" port)
- (newline port)
- (for-each
- (lambda (sub-test-result)
- (if (failing-sub-test? sub-test-result)
- (report-test-failure " "
- (car sub-test-result)
- (cdr sub-test-result)
- port)))
- sub-test-results))
- (begin
- (write-string "passed " port)
- (write n-sub-test-results port)
- (write-string " sub-tests" port)
- (newline port)))))
- ((> n-sub-test-results 0)
- (report-test-failure ""
- (write-to-string test-name)
- (cdar sub-test-results)
- port))))
+;;;; Reporting
+
+(define (report-result test-name elapsed-time sub-test-results port)
+ (let ((n-sub-test-results (length sub-test-results))
+ (n-failed (count failing-sub-test? sub-test-results)))
+ (write test-name port)
+ (write-string ": " port)
+ (if (> n-failed 0)
+ (begin
+ (write-string "failed " port)
+ (write n-failed port)
+ (write-string " sub-tests out of " port)
+ (write n-sub-test-results port)
+ (report-test-time elapsed-time port)
+ (write-string ":" port)
+ (newline port)
+ (for-each
+ (lambda (sub-test-result)
+ (if (failing-sub-test? sub-test-result)
+ (report-test-failure " "
+ (car sub-test-result)
+ (cdr sub-test-result)
+ port)))
+ sub-test-results))
+ (begin
+ (write-string "passed " port)
+ (write n-sub-test-results port)
+ (write-string " sub-tests" port)
+ (report-test-time elapsed-time port)
+ (newline port))))
(every passing-sub-test? sub-test-results))
+(define (report-test-time elapsed-time port)
+ (write-string " in " port)
+ (write elapsed-time port)
+ (write-string " seconds" port))
+
(define (report-test-failure prefix name failure port)
(write-string prefix port)
(write-string name port)
(define (passing-sub-test? sub-test-result)
(not (cdr sub-test-result)))
\f
+(define condition-type:failure
+ (make-condition-type 'FAILURE #f '(FAILURE) #f))
+
+(define condition-failure
+ (condition-accessor condition-type:failure 'FAILURE))
+
(define-record-type <failure>
(%make-failure alist)
failure?
(define (make-failure . plist)
(%make-failure (keyword-list->alist plist)))
+(define (extend-failure failure plist)
+ (%make-failure
+ (append (failure-alist failure)
+ (keyword-list->alist plist))))
+
(define (failure-property key failure)
(assq key (failure-alist failure)))
(else
(error "Ill-formed failure:" failure))))
\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))))))
+;;;; Assertions
-(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-for-tests (run-sub-test thunk)
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handlers
+ (list condition-type:failure
+ (lambda (condition)
+ (k (access-condition condition 'FAILURE)))
+ condition-type:error
+ (lambda (condition)
+ (if (not throw-test-errors?)
+ (k (make-failure 'CONDITION condition)))))
+ (lambda ()
+ (thunk)
+ #f)))))
+
+(define-for-tests (with-test-properties thunk . properties)
+ (bind-condition-handlers
+ (list condition-type:failure
+ (lambda (condition)
+ (error
+ (remake-failure-condition
+ condition
+ (extend-failure (condition-failure condition)
+ properties))))
+ condition-type:error
+ (lambda (condition)
+ (if (not throw-test-errors?)
+ (apply fail 'CONDITION condition properties))))
+ thunk))
-(define test-definitions '())
+(define throw-test-errors? #f)
-(define-for-tests (define-test name test . tests)
- (register-test name
- (if (null? tests)
- test
- (cons test tests)))
- name)
+(define (bind-condition-handlers bindings thunk)
+ (if (pair? bindings)
+ (bind-condition-handler (list (car bindings))
+ (cadr bindings)
+ (lambda ()
+ (bind-condition-handlers (cddr bindings) thunk)))
+ (thunk)))
+
+(define-for-tests (fail . plist)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (error
+ (make-failure-condition continuation
+ (apply make-failure plist))))))
+
+(define (make-failure-condition continuation failure)
+ (make-condition condition-type:failure
+ continuation
+ 'BOUND-RESTARTS
+ (list 'FAILURE failure)))
+
+(define (remake-failure-condition condition failure)
+ (make-condition condition-type:failure
+ (condition/continuation condition)
+ (condition/restarts condition)
+ (list 'FAILURE failure)))
+\f
+(define-for-tests (assert predicate description value . properties)
+ (%assert predicate value description properties))
(define-for-tests (predicate-assertion predicate description)
(lambda (value . properties)
- (if (predicate value)
- #f
- (apply make-failure
- 'RESULT-OBJECT value
- 'EXPECTATION-DESCRIPTION description
- properties))))
+ (%assert predicate value 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 (%assert predicate value description properties)
+ (if (not (predicate value))
+ (apply fail
+ 'RESULT-OBJECT value
+ 'EXPECTATION-DESCRIPTION description
+ properties)))
+
+(define-for-tests assert-true
+ (predicate-assertion (lambda (x) x) "true"))
+
+(define-for-tests assert-false
+ (predicate-assertion not "false"))
(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
+ (if (not (comparator value expected))
+ (apply fail
'RESULT-OBJECT value
'EXPECTATION-OBJECT expected
properties))))
(define-for-tests (assert-error thunk condition-types . properties)
(call-with-current-continuation
(lambda (k)
- (apply make-failure
+ (apply fail
'RESULT-OBJECT
(bind-condition-handler condition-types
(lambda (condition)
projects / mit-scheme.git / commitdiff