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

Last change on this file since 37674 was 37674, checked in by Kon Lovett, 4 months ago

reflow gloss.incl

File size: 1.5 KB
Line 
1
2;;;test "Gloss" API
3
4(define (assq-ref ls key . o)
5  (cond ((assq key ls) => cdr)
6        ((pair? o) (car o))
7        (else #f)))
8
9(define (test-group-ref group field . o)
10  (apply assq-ref (cdr group) field o))
11
12(begin
13  (import (chicken process-context))
14  (define *test-indent-width*
15    (or (cond ((get-environment-variable "TEST_INDENT_WIDTH") => string->number) (else #f))
16        4))
17  (define *test-first-indentation*
18    (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") => string->number) (else #f))
19        1))
20  (define *test-max-indentation*
21    (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") => string->number) (else #f))
22        5)))
23
24(define test-indent-width (lambda () *test-indent-width*))
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(define-constant *test-gloss-marker* "--> ")
37
38(define gloss
39  (case-lambda
40    (()
41      (newline))
42    ((obj)
43      (print (test-group-indent-string (current-test-group)) *test-gloss-marker* obj))))
44
45(define (glossf fmt . args)
46  (begin
47    (import (only (chicken format) format))
48    (gloss (apply format #f fmt args)) ) )
Note: See TracBrowser for help on using the repository browser.