source: project/release/3/misc-extn/trunk/tests/misc-extn-test.scm @ 10987

Last change on this file since 10987 was 9954, checked in by Kon Lovett, 14 years ago

Rel 3.1.1 w/ Explict use of SRFI 69.

File size: 3.4 KB
Line 
1;;;; misc-extn-test.scm
2
3(use srfi-69)
4(use testbase testbase-output-human)
5#;(use misc-extn-condition)
6(use misc-extn-control)
7(use misc-extn-io)
8(use misc-extn-list)
9(use misc-extn-numeric)
10(use misc-extn-posix)
11(use misc-extn-record)
12(use misc-extn-symbol)
13(use misc-extn-dsssl)
14
15;;;
16
17;;
18
19(define-test misc-extn-control-test "Control"
20  (initial
21    (define x (void))
22    (define y (void))
23  )
24
25  (test-let ([ht (make-hash-table)])
26    (hash-table-set! ht "wow" 'wow)
27    (hash-table-set! ht 'bar "bar")
28    (expect-equal/values
29      (values 'wow "bar")
30      (hash-let ([bar (foo "wow")] ht)
31        (values foo bar) ) ) )
32 
33  (side-effect (stiff-set! x 1 y 2))
34  (expect-eqv 1 x)
35  (expect-eqv 2 y)
36
37  (side-effect (fluid-set! x y y x))
38  (expect-eqv 2 x)
39  (expect-eqv 1 y)
40
41  (side-effect (swap-set! x y))
42  (expect-eqv 1 x)
43  (expect-eqv 2 y)
44 
45  (expect-eq
46    'foobar
47    (typecase* 'foobar
48      [(procedure macro)  #f]
49      [string             #t]
50      [(vector list)      '()]
51      [else               it]))
52)
53
54;;
55
56(define-test misc-extn-list-test "Lists" 
57  (initial
58    (define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
59        )
60       
61        (expect-true (length=0? '()))
62        (expect-false (length=0? '(1)))
63        (expect-true (length=1? '(1)))
64        (expect-false (length=1? '()))
65        (expect-false (length=1? '(1 2)))
66        (expect-true (length=2? '(1 2)))
67        (expect-false (length=2? '()))
68        (expect-false (length=2? '(1)))
69        (expect-false (length=2? '(1 2 3)))
70        (expect-true (length>1? '(1 2)))
71        (expect-false (length>1? '()))
72        (expect-false (length>1? '(1)))
73
74  (expect-equal '(1) (ensure-list '(1)))
75  (expect-equal '(1) (ensure-list 1))
76
77  (expect-equal '(1) (not-null? '(1)))
78  (expect-false (not-null? '()))
79
80  (test-let ([lst '(1 2)])
81    (expect-eqv 1 (shift!/set lst))
82    (expect-equal '(2) lst)
83    (expect-eqv 2 (shift!/set lst))
84    (expect-equal '() lst)
85    (expect-false (shift!/set lst))
86    (expect-equal '() lst)
87  )
88
89  (expect-equal/values (values '(a b) '((1) (2))) (unzip-alist '((a 1) (b 2))))
90  (expect-equal '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
91  (expect-equal '((a 1) (b 2)) (zip-alist '(a b) '((1) (2))))
92
93  (expect-equal '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete/count 'b alst1 eq? 2))
94  (expect-equal '((a 1) (c 4) (a 6) (d 7)) (alist-delete/count 'b alst1 eq?))
95  (expect-equal '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6)) (alist-delete/count 'd alst1 eq?))
96  (expect-equal '((a 1) (b 2) (b 3) (b 5) (a 6) (d 7)) (alist-delete/count 'c alst1 eq?))
97  (expect-equal '((b 2) (b 3) (c 4) (b 5) (a 6) (d 7)) (alist-delete/count 'a alst1 eq? 1))
98
99  (expect-equal '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete!/count 'b alst1 eq? 2))
100  (expect-equal '((a 1) (c 4) (a 6) (d 7)) (alist-delete!/count 'b alst1 eq?))
101  (expect-equal '((a 1) (c 4) (a 6)) (alist-delete!/count 'd alst1 eq?))
102  (expect-equal '((a 1) (a 6)) (alist-delete!/count 'c alst1 eq?))
103  (expect-equal '((a 6)) (alist-delete!/count 'a alst1 eq? 1))
104)
105
106;;
107
108(define-test misc-extn-dsssl-test "DSSSL" 
109  (initial
110    (define (foo a1 a2 #!optional (o1 'x) (o2 'y) #!rest rest #!key (k1 100) (k2 200))
111      (dsssl-fixup (#:k1 #:k2) ((o1 'x) (o2 'y)) rest
112        (list a1 a2 o1 o2 k1 k2 rest) ) ) )
113
114  (expect-equal '(1 2 x y 100 200 ()) (foo 1 2))
115  (expect-equal '(1 2 3 4 100 200 (5)) (foo 1 2 3 4 5))
116  (expect-equal '(1 2 3 y 100 2000 (5)) (foo 1 2 3 #:k2 2000 5))
117)
118
119;;;
120
121(test::for-each (cut test::styler-set! <> test::output-style-human))
122(run-test "Misc-Extn Tests")
Note: See TracBrowser for help on using the repository browser.