source: project/misc-extn/trunk/tests/misc-extn-test.scm @ 6202

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

Rmvd extra dsssl-fixup, put test of dsssl-fixup back in testbase test, works w/ hygienic macros.

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