source: project/release/4/F-operator/tags/3.0.0/tests/run.scm @ 33417

Last change on this file since 33417 was 33417, checked in by Kon Lovett, 3 years ago

use setup-helper-mode. remove % forms (segfault).

File size: 10.2 KB
Line 
1;;;; F-operator-test.scm
2;;;; Kon Lovett, Apr 6 '06
3
4(use test)
5(use shift-reset bshift-breset gshift-greset reflect-reify range)
6(use srfi-1)
7
8;; Generated value saving
9
10(define (make-collector)
11  (let ((lst '()))
12    (lambda v
13      (if (null? v) (reverse! lst)
14        (begin
15          (set-cdr! v lst)
16          (set! lst v))))))
17
18;; Monads
19
20(define-unit maybe obj)
21
22(define-bind maybe (and monad (func monad)))
23
24(define (maybe-foo x)
25  (if (zero? x) (reflect maybe #f)  ; exception
26      (/ 1 x) ) )
27
28(define (maybe-bar x)
29  (+ x x) )
30
31(define (maybe-baz x)
32  (if (zero? x) (reflect maybe #f)
33      (/ 1 x) ) )
34
35;; Generalized shift/reset implementations of some control operators
36
37(define-syntax prompt
38  (syntax-rules ()
39    ((_ e) (greset hr-stop e)) ) )
40
41(define-syntax control
42  (syntax-rules ()
43    ((_ f e) (gshift hs-prop f e)) ) )
44
45(define-syntax prompt0
46  (syntax-rules ()
47    ((_ e) (greset hr-prop e)) ) )
48
49(define-syntax shift0
50  (syntax-rules ()
51    ((_ f e) (gshift hs-stop f e)) ) )
52
53;;;
54
55(test-group "Shift/Reset Family"
56
57  #; ;REMOVED
58  (test-group "%shift/%reset"
59
60    (test 5
61      (+ 1 (%reset (* 2 (%shift k 4)))))
62
63    (test 117
64      (+ 10 (%reset (+ 2 (%shift k (+ 100 (k (k 3))))))))
65
66    (test 60
67      (* 10 (%reset (* 2 (%shift g (%reset (* 5 (%shift f (+ (f 1) 1)))))))))
68
69    (test 121
70      (let ((f (lambda (x) (%shift k (k (k x))))))
71        (+ 1 (%reset (+ 10 (f 100))))))
72
73    (test '(a)
74      (%reset
75        (let ((x (%shift f (cons 'a (f '())))))
76          (%shift g x))))
77
78    (test '(a 1 b b c) ; not '(a b 1 b b c)
79      (cons 'a (%reset (cons 'b (%shift f (cons 1 (f (f (cons 'c '())))))))))
80
81    (test-error (%shift t 'x))
82  )
83
84  (test-group "shift/reset"
85
86    (test 5
87      (+ 1 (reset (* 2 (shift k 4)))))
88
89    (test 117
90      (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))
91
92    (test 60
93      (* 10 (reset (* 2 (shift g (reset (* 5 (shift f (+ (f 1) 1)))))))))
94
95    (test 121
96      (let ((f (lambda (x) (shift k (k (k x))))))
97        (+ 1 (reset (+ 10 (f 100))))))
98
99    (test '(a)
100      (reset
101        (let ((x (shift f (cons 'a (f '())))))
102          (shift g x))))
103
104    (test '(a 1 b b c) ; not '(a b 1 b b c)
105      (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c '())))))))))
106
107    (test-error (shift t 'x))
108  )
109
110  #; ;REMOVED
111  (test-group "%shift-values/%reset-values"
112
113    (test 5
114      (+ 1 (%reset-values (* 2 (%shift-values k 4)))))
115
116    (test 117
117      (+ 10 (%reset-values (+ 2 (%shift-values k (+ 100 (k (k 3))))))))
118
119    (test 60
120      (* 10 (%reset-values (* 2 (%shift-values g (%reset-values (* 5 (%shift-values f (+ (f 1) 1)))))))))
121
122    (test 121
123      (let ((f (lambda (x) (%shift-values k (k (k x))))))
124        (+ 1 (%reset-values (+ 10 (f 100))))))
125
126    (test '(a)
127      (%reset-values
128        (let ((x (%shift-values f (cons 'a (f '())))))
129          (%shift-values g x))))
130
131    (test '(a 1 b b c)
132      (cons 'a (%reset-values (cons 'b (%shift-values f (cons 1 (f (f (cons 'c '())))))))))
133
134    (test-error (%shift-values t 'x))
135
136    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
137      (cons 'a
138        (%reset-values
139          (cons 'b
140            (let-values (((x y) (%shift-values f (cons 1 (f '2 (f 3 '()))))))
141              (cons x y))))))
142  )
143
144  (test-group "shift-values/reset-values"
145
146    (test 5
147      (+ 1 (reset-values (* 2 (shift-values k 4)))))
148
149    (test 117
150      (+ 10 (reset-values (+ 2 (shift-values k (+ 100 (k (k 3))))))))
151
152    (test 60
153      (* 10 (reset-values (* 2 (shift-values g (reset-values (* 5 (shift-values f (+ (f 1) 1)))))))))
154
155    (test 121
156      (let ((f (lambda (x) (shift-values k (k (k x))))))
157        (+ 1 (reset-values (+ 10 (f 100))))))
158
159    (test '(a)
160      (reset-values
161        (let ((x (shift-values f (cons 'a (f '())))))
162          (shift-values g x))))
163
164    (test '(a 1 b b c)
165      (cons 'a (reset-values (cons 'b (shift-values f (cons 1 (f (f (cons 'c '())))))))))
166
167    (test-error (shift-values t 'x))
168
169    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
170      (cons 'a
171        (reset-values
172          (cons 'b
173            (let-values (((x y) (shift-values f (cons 1 (f '2 (f 3 '()))))))
174              (cons x y))))))
175  )
176
177  #; ;REMOVED
178  (test-group "%bshift/%breset"
179
180    (let ((gather (make-collector)))
181
182      (define (fact n) (let loop ((n n)) (if (<= n 0) 1 (* n (loop (- n 1))))))
183
184      (test "step 1" '(1 2 6 24 120)
185        (begin
186          (%breset r
187            (gather (fact (%range r 1 5))))
188          (gather)))
189      (set! gather (make-collector))
190
191      (test "step 2" '(1 6 120 5040 362880 39916800 6227020800)
192        (begin
193          (%breset r
194            (gather (fact (%range r 1 2 14))))
195          (gather)))
196      (set! gather (make-collector))
197
198      (test "two %ranges" '(101 111 121 102 112 122)
199        (begin
200          (%breset r1
201            (%breset r2 (gather (+ (%range r1 1 2) (%range r2 100 10 120)))))
202          (gather)))
203      (set! gather (make-collector))
204
205      (test "collect" 120
206        (%breset r1
207          (%breset r2
208            (%bshift r1 f
209              (let ((n (%range r2 1 5))
210                    (nprev (f #f)))
211                (* n (if (range-empty? nprev) 1 nprev)))))))
212
213      (test "%range-collect" '(120 120 60 20 5)
214        (begin
215          (%breset r3
216            (gather
217              (%breset r1
218                (%breset r2
219                  (%bshift r1 f
220                    (let ((n (%range r2 (%range r3 1 5) 5))
221                          (nprev (f #f)))
222                      (* n (if (range-empty? nprev) 1 nprev))))))))
223          (gather)))
224      (set! gather (make-collector))
225
226      (test '(11 14 17)
227        (begin
228          (%breset r
229            (let* ((k (%range r 1 3 9))
230                  (j (+ 10 k)))
231              (gather j)))
232          (gather)))
233      (set! gather (make-collector))
234
235      (test '(1 2 3)
236        (begin
237          (%breset out
238            (%breset r
239              (let ((k (%range r 1 4)))
240                (gather k)
241                (when (> k 2)
242                  (%bshift out f #f)))))
243          (gather)))
244      (set! gather (make-collector))
245
246      (test '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
247        (begin
248          (%breset r
249            (let ((k (%range r 1 4)))
250              (%breset inner
251                (let ((j (%range inner 10 k (* 10 k))))
252                  (when (odd? k)
253                    (%bshift r f #f))
254                  (gather (list k j))))))
255          (gather)))
256      (set! gather (make-collector)) )
257  )
258
259  (test-group "bshift/breset"
260
261    (let ((gather (make-collector)))
262
263      (define (fact n) (let loop ((n n)) (if (<= n 0) 1 (* n (loop (- n 1))))))
264
265      (test "step 1" '(1 2 6 24 120)
266        (begin
267          (breset r
268            (gather (fact (range r 1 5))))
269          (gather)))
270      (set! gather (make-collector))
271
272      (test "step 2" '(1 6 120 5040 362880 39916800 6227020800)
273        (begin
274          (breset r
275            (gather (fact (range r 1 2 14))))
276          (gather)))
277      (set! gather (make-collector))
278
279      (test "two ranges" '(101 111 121 102 112 122)
280        (begin
281          (breset r1
282            (breset r2 (gather (+ (range r1 1 2) (range r2 100 10 120)))))
283          (gather)))
284      (set! gather (make-collector))
285
286      (test "collect" 120
287        (breset r1
288          (breset r2
289            (bshift r1 f
290              (let ((n (range r2 1 5))
291                    (nprev (f #f)))
292                (* n (if (range-empty? nprev) 1 nprev)))))))
293
294      (test "range-collect" '(120 120 60 20 5)
295        (begin
296          (breset r3
297            (gather
298              (breset r1
299                (breset r2
300                  (bshift r1 f
301                    (let ((n (range r2 (range r3 1 5) 5))
302                          (nprev (f #f)))
303                      (* n (if (range-empty? nprev) 1 nprev))))))))
304          (gather)))
305      (set! gather (make-collector))
306
307      (test '(11 14 17)
308        (begin
309          (breset r
310            (let* ((k (range r 1 3 9))
311                  (j (+ 10 k)))
312              (gather j)))
313          (gather)))
314      (set! gather (make-collector))
315
316      (test '(1 2 3)
317        (begin
318          (breset out
319            (breset r
320              (let ((k (range r 1 4)))
321                (gather k)
322                (when (> k 2)
323                  (bshift out f #f)))))
324          (gather)))
325      (set! gather (make-collector))
326
327      (test '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
328        (begin
329          (breset r
330            (let ((k (range r 1 4)))
331              (breset inner
332                (let ((j (range inner 10 k (* 10 k))))
333                  (when (odd? k)
334                    (bshift r f #f))
335                  (gather (list k j))))))
336          (gather)))
337      (set! gather (make-collector)) )
338  )
339
340  #; ;REMOVED
341  (test-group "%bshift-values/%breset-values"
342
343    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
344      (cons 'a
345        (%breset-values r
346          (cons 'b
347            (let-values (((x y) (%bshift-values r f (cons 1 (f '2 (f 3 '()))))))
348              (cons x y))))))
349  )
350
351  (test-group "bshift-values/breset-values"
352
353    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
354      (cons 'a
355        (breset-values r
356          (cons 'b
357            (let-values (((x y) (bshift-values r f (cons 1 (f '2 (f 3 '()))))))
358              (cons x y))))))
359  )
360
361  (test-group "gshift/greset"
362
363    (test 117 (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3))))))))
364
365    (test '() (prompt (let ((x (control f (cons 'a (f '()))))) (control g x))))
366
367    (test 2 (prompt ((lambda (x) (control l 2)) (control l (+ 1 (l 0))))))
368
369    (test '(a) (prompt (control f (cons 'a (f '())))))
370
371    (test '(a) (prompt (let ((x (control f (cons 'a (f '()))))) (control g (g x)))))
372
373    (test 117 (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))))
374
375    (test '() (prompt0 (prompt0 (let ((x (control f (cons 'a (f '()))))) (control g x)))))
376
377    (test 117 (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3))))))))
378
379    (test '() (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))
380
381    (test '(a) (prompt0 (cons 'a (prompt0 (prompt0 (shift0 f (shift0 g '())))))))
382  )
383
384  (test-group "reflect/reify"
385
386    (test 0.5
387      (reify maybe
388        (maybe-baz
389          (maybe-bar
390            (reflect maybe
391              (or (reify maybe (maybe-foo 0))
392                        (reify maybe (maybe-foo 1))))))))
393  )
394)
395
396(test-exit)
Note: See TracBrowser for help on using the repository browser.