source: project/release/5/bloom-filter/trunk/tests/test-gloss.incl.scm @ 37662

Last change on this file since 37662 was 37662, checked in by kon, 6 weeks ago

unsafe test is not default, add test gloss facility

File size: 1.4 KB
Line 
1
2;;;test "Gloss" API
3
4;;test internals
5
6(define (assq-ref ls key . o)
7  (cond ((assq key ls) => cdr)
8        ((pair? o) (car o))
9        (else #f)))
10
11(define (test-group-ref group field . o)
12  (apply assq-ref (cdr group) field o))
13
14(define-constant *test-indent-width* 4)
15
16(begin
17  (import (chicken process-context))
18  (define *test-first-indentation*
19    (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") => string->number) (else #f))
20        1))
21  (define *test-max-indentation*
22    (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") => string->number) (else #f))
23        5)))
24
25(define test-first-indentation (lambda () *test-first-indentation*))
26(define test-max-indentation (lambda () *test-max-indentation*))
27
28(define (test-group-indent-width group)
29  (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
30                              (test-first-indentation))))))
31    (* *test-indent-width* (min level (test-max-indentation)))))
32
33(define (test-group-indent-string group)
34  (make-string (test-group-indent-width group) #\space) )
35
36;;test gloss
37
38(define-constant *test-gloss-marker* "--> ")
39
40(define gloss
41  (case-lambda
42    (()
43      (newline))
44    ((obj)
45      (print
46        (test-group-indent-string (current-test-group))
47        *test-gloss-marker*
48        obj))))
49
50(define (glossf fmt . args)
51  (begin
52    (import (only (chicken format) format))
53    (gloss (apply format #f fmt args)) ) )
Note: See TracBrowser for help on using the repository browser.