source: project/release/3/procedure-surface/tests/procedure-surface-test.scm @ 7892

Last change on this file since 7892 was 7892, checked in by Kon Lovett, 12 years ago

Testbase expansion options are #f, except "catching", by default.

File size: 17.9 KB
Line 
1;;;; procedure-surface-test.scm
2
3(use testbase testbase-output-human)
4(use procedure-surface)
5(use srfi-1 mathh)
6
7;; List equals, order independent
8
9(define-inline (->boolean obj)
10  (and obj #t) )
11
12(define (alist-same? al1 al2)
13  (every
14    (lambda (pair)
15      (let ([v2 (alist-ref (car pair) al2 equal?)])
16        (and v2 (equal? v2 (cdr pair))) ) )
17    al1) )
18
19(define (list-same? l1 l2)
20  (->boolean (every (cut member <> l2) l1)) )
21
22;;;
23
24(define-expect-unary procedure? procedure "procedure")
25(define-expect-binary list-same? list-same "lists same")
26(define-expect-binary alist-same? alist-same "alists same")
27
28;;;
29
30(define-test signature-type-test "Signature Type"
31
32  (expect-true (signature-type? 'extended-procedure))
33  (expect-true (signature-type? (signature-type-ref 'array)))
34  (expect-false (signature-type? 'foo))
35
36  (expect-true (signature-type-a-kind-of? 'procedure 'object))
37  (expect-false (signature-type-a-kind-of? 'procedure 'extended-procedure))
38  (expect-true (signature-type-a-kind-of? 'extended-procedure 'procedure))
39
40  (expect-eq 'array (signature-type-name 'array))
41  (expect-procedure (signature-type-predicate (signature-type-ref 'array)))
42
43  (expect-failure (signature-type-predicate 'foo))
44
45  (expect-equal `(,(signature-type-ref 'procedure)) (signature-type-extends 'extended-procedure))
46
47  (expect-success (make-signature-type 'foo #f (lambda (x) 'foo)))
48  (expect-success (signature-type-predicate 'foo))
49  (expect-success (signature-type-delete! 'foo))
50  (expect-failure (signature-type-predicate 'foo))
51
52  (expect-success (make-signature-type 'foo #f (lambda (x) 'foo)))
53  (expect-success (make-signature-type 'bar 'foo (lambda (x) 'bar)))
54  (expect-true (signature-type-a-kind-of? 'bar 'foo))
55  (expect-true (signature-leaf-type? 'bar))
56  (expect-true (signature-extended-type? 'foo))
57
58  (expect-success (signature-type-replace! 'foo 'baz #f (lambda (x) 'baz)))
59  (expect-true (signature-type-a-kind-of? 'bar 'baz))
60
61  (expect-failure (signature-type-replace! 'bar #f 'baz (lambda (x) 'bar)))
62)
63
64(define-test procedure-surface-test "Procedure Surface"
65
66  (test/case "Dummy Unitary Procedure Surface Immutable" (
67      [ps1 #f]
68    )
69
70    (expect-set! ps1
71      (make-procedure-surface #:name 'PS1 #:immutable #t
72        'foo '((-> number number number) (procedure number))
73        'bar '(or (-> number number number) (procedure number))
74        'baz '(-> (array (rank 2)) object (values integer complex vector object))))
75
76    (expect-true (procedure-surface? ps1))
77    (expect-false (procedure-surface? 1))
78    (expect-true (procedure-surface-immutable? ps1))
79    (expect-false (procedure-surface-mutable? ps1))
80    (expect-false (composite-procedure-surface? ps1))
81
82    (expect-equal 'PS1 (procedure-surface-name ps1))
83
84    (expect-true (procedure-signature? (procedure-surface-ref ps1 'foo)))
85    (expect-true (procedure-signature? (procedure-surface-ref ps1 'bar)))
86    (expect-true (procedure-signature? (procedure-surface-ref ps1 'baz)))
87
88    (expect-success (procedure-surface->alist ps1))
89    (expect-alist-same
90      (list
91        (cons 'foo (procedure-surface-ref ps1 'foo))
92        (cons 'bar (procedure-surface-ref ps1 'bar))
93        (cons 'baz (procedure-surface-ref ps1 'baz)))
94      (procedure-surface->alist ps1))
95
96    (expect-failure (procedure-surface-set! ps1 'ack '() 'arc '()))
97    (expect-failure (procedure-surface-delete! ps1 'bar))
98  )
99
100  (test/case "Dummy Unitary Procedure Surface Mutable" (
101      [ps1 #f]
102    )
103
104    (expect-set! ps1
105      (make-procedure-surface #:name 'PS1
106        'foo '()
107        'bar '()
108        'baz '(-> (array (rank 2)) object (values integer complex vector object))))
109
110    (expect-false (procedure-surface-immutable? ps1))
111    (expect-true (procedure-surface-mutable? ps1))
112
113    (expect-success (procedure-surface-set! ps1 'ack '() 'arc '()))
114    (expect-true (procedure-signature? (procedure-surface-ref ps1 'ack)))
115    (expect-true (procedure-signature? (procedure-surface-ref ps1 'arc)))
116
117    (expect-success (procedure-surface-delete! ps1 'bar))
118    (expect-false (procedure-surface-ref ps1 'bar))
119
120    (expect-failure (procedure-surface-set! ps1 'ack 'arc '()))
121    (expect-failure (procedure-surface-set! ps1 'ack))
122    (expect-failure (procedure-surface-set! ps1 2 '()))
123
124    (expect-alist-same
125      (list
126        (cons 'foo (procedure-surface-ref ps1 'foo))
127        (cons 'ack (procedure-surface-ref ps1 'ack))
128        (cons 'arc (procedure-surface-ref ps1 'arc))
129        (cons 'baz (procedure-surface-ref ps1 'baz)))
130      (procedure-surface->alist ps1))
131  )
132
133  (test/case "Dummy Composite Procedure Surface Immutable" (
134      [ps1 #f]
135      [ps2 #f]
136      [ps3 #f]
137      [cps1 #f]
138      [cps2 #f]
139    )
140
141    (expect-set! ps1
142      (make-procedure-surface #:name 'PS1 #:immutable #t
143        'foo '()
144        'bar '()
145        'baz '(-> (array (rank 2)) object (values integer complex vector object))))
146
147    (expect-set! ps2
148      (make-procedure-surface #:name 'PS2
149        'abc '()
150        'nbc '()))
151
152    (expect-set! ps3
153      (make-procedure-surface #:name 'PS3
154        'cbs '()
155        'pbs '()
156        'cnn '()
157        'fox '()))
158
159    (expect-set! cps1 (make-composite-procedure-surface ps1 ps2))
160    (expect-true (composite-procedure-surface? cps1))
161    (expect-true (procedure-surface-immutable? cps1))
162
163    (expect-list-same
164      '(PS1 PS2) (procedure-surface-name cps1))
165
166    (expect-alist-same
167      (list
168        (cons 'foo (procedure-surface-ref ps1 'foo))
169        (cons 'abc (procedure-surface-ref ps2 'abc))
170        (cons 'nbc (procedure-surface-ref ps2 'nbc))
171        (cons 'bar (procedure-surface-ref ps1 'bar))
172        (cons 'baz (procedure-surface-ref ps1 'baz)))
173      (procedure-surface->alist cps1))
174
175    (expect-failure (procedure-surface-set! cps1 'ack '() 'arc '()))
176    (expect-failure (procedure-surface-delete! cps1 'bar))
177
178    (expect-set! cps2 (make-composite-procedure-surface ps3 cps1))
179    (expect-true (composite-procedure-surface? cps2))
180    (expect-true (procedure-surface-immutable? cps2))
181
182    (expect-list-same
183      '(PS1 PS2 PS3) (procedure-surface-name cps2))
184
185    (expect-alist-same
186      (list
187        (cons 'cbs (procedure-surface-ref ps3 'cbs))
188        (cons 'pbs (procedure-surface-ref ps3 'pbs))
189        (cons 'cnn (procedure-surface-ref ps3 'cnn))
190        (cons 'fox (procedure-surface-ref ps3 'fox))
191        (cons 'foo (procedure-surface-ref ps1 'foo))
192        (cons 'abc (procedure-surface-ref ps2 'abc))
193        (cons 'nbc (procedure-surface-ref ps2 'nbc))
194        (cons 'bar (procedure-surface-ref ps1 'bar))
195        (cons 'baz (procedure-surface-ref ps1 'baz)))
196      (procedure-surface->alist cps2))
197
198    (expect-failure (procedure-surface-set! cps2 'ack '()))
199    (expect-failure (procedure-surface-delete! cps2 'bar))
200
201    (expect-failure (make-composite-procedure-surface cps2 cps1))
202  )
203
204  (test/case "Dummy Composite Procedure Surface Mutable" (
205      [ps1 #f]
206      [ps2 #f]
207      [ps3 #f]
208      [cps1 #f]
209      [cps2 #f]
210    )
211
212    (expect-set! ps1
213      (make-procedure-surface #:name 'PS1
214        'foo '()
215        'bar '()
216        'baz '(-> (array (rank 2)) object (values integer complex vector object))))
217
218    (expect-set! ps2
219      (make-procedure-surface #:name 'PS2
220        'abc '()
221        'nbc '()))
222
223    (expect-set! ps3
224      (make-procedure-surface #:name 'PS3
225        'cbs '()
226        'pbs '()
227        'cnn '()
228        'fox '()))
229
230    (expect-set! cps1 (make-composite-procedure-surface ps1 ps2))
231    (expect-true (composite-procedure-surface? cps1))
232    (expect-false (procedure-surface-immutable? cps1))
233
234    (expect-success (procedure-surface-set! cps1 'ack '() 'arc '()))
235    (expect-true (procedure-signature? (procedure-surface-ref cps1 'ack)))
236    (expect-true (procedure-signature? (procedure-surface-ref cps1 'arc)))
237
238    (expect-success (procedure-surface-delete! cps1 'bar))
239    (expect-false (procedure-surface-ref cps1 'bar))
240
241    (expect-set! cps2 (make-composite-procedure-surface ps3 cps1))
242    (expect-true (composite-procedure-surface? cps2))
243    (expect-false (procedure-surface-immutable? cps2))
244
245    (expect-list-same
246      '(PS1 PS2 PS3) (procedure-surface-name cps2))
247
248    (expect-alist-same
249      (list
250        (cons 'ack (procedure-surface-ref cps1 'ack))
251        (cons 'arc (procedure-surface-ref cps1 'arc))
252        (cons 'cbs (procedure-surface-ref ps3 'cbs))
253        (cons 'pbs (procedure-surface-ref ps3 'pbs))
254        (cons 'cnn (procedure-surface-ref ps3 'cnn))
255        (cons 'fox (procedure-surface-ref ps3 'fox))
256        (cons 'foo (procedure-surface-ref ps1 'foo))
257        (cons 'abc (procedure-surface-ref ps2 'abc))
258        (cons 'nbc (procedure-surface-ref ps2 'nbc))
259        (cons 'baz (procedure-surface-ref ps1 'baz)))
260      (procedure-surface->alist cps2))
261
262    (expect-success
263      (procedure-surface-set! cps2
264        'ack '(-> (array (rank 2)) object (values integer complex vector object))))
265    (expect-success (procedure-surface-delete! cps2 'bar))
266  )
267)
268
269(define-test procedure-means-test "Procedure Surface Means"
270
271  (test/case "Dummy Unitary Procedure Surface Means Immutable" (
272      [ps1 (make-procedure-surface #:name 'PS1 #:immutable #t 'foo '() 'bar '() 'baz '())]
273      [psm1 #f]
274    )
275
276    (expect-set! psm1
277      (make-procedure-means ps1 #:immutable #t
278        'foo 'off
279        'bar 'rab
280        'baz 'zab))
281
282    (expect-failure
283      (make-procedure-means ps1 #:library #:extension
284        'foo 'off
285        'bar 'rab
286        'baz 'zab))
287    (expect-failure
288      (make-procedure-means ps1 #:pathname #:unitname
289        'foo 'off
290        'bar 'rab
291        'baz 'zab))
292    (expect-failure
293      (make-procedure-means ps1 #:extension 23
294        'foo 'off
295        'bar 'rab
296        'baz 'zab))
297
298    (expect-true (procedure-means? psm1))
299    (expect-false (procedure-means? 1))
300    (expect-true (procedure-means-immutable? psm1))
301    (expect-false (procedure-means-mutable? psm1))
302    (expect-false (composite-procedure-means? psm1))
303
304    (expect-true (procedure-unbound? (procedure-means-ref psm1 'foo)))
305    (expect-true (procedure-unbound? (procedure-means-ref psm1 'bar)))
306    (expect-true (procedure-unbound? (procedure-means-ref psm1 'baz)))
307
308    (expect-success (procedure-means->alist psm1))
309    (expect-alist-same
310      (list
311        (cons 'foo (procedure-means-ref psm1 'foo))
312        (cons 'bar (procedure-means-ref psm1 'bar))
313        (cons 'baz (procedure-means-ref psm1 'baz)))
314      (procedure-means->alist psm1))
315
316    (expect-failure (procedure-surface-set! psm1 'ack 'kca 'arc 'cra))
317    (expect-failure (procedure-surface-delete! psm1 'bar))
318  )
319
320  (test/case "Dummy Unitary Procedure Surface Means Mutable" (
321      [ps1 (make-procedure-surface #:name 'PS1 'foo '() 'bar '() 'baz '())]
322      [psm1 #f]
323    )
324
325    (expect-set! psm1
326      (make-procedure-means ps1 'foo 'off 'bar 'rab 'baz 'zab))
327    (expect-false (procedure-means-immutable? psm1))
328    (expect-true (procedure-means-mutable? psm1))
329
330    (expect-success (procedure-means-set! psm1 'ack 'kac 'arc 'cra))
331    (expect-true (procedure-unbound? (procedure-means-ref psm1 'ack)))
332    (expect-true (procedure-unbound? (procedure-means-ref psm1 'arc)))
333
334    (expect-success (procedure-means-delete! psm1 'bar))
335    (expect-false (procedure-means-ref psm1 'bar))
336
337    (expect-failure (procedure-means-set! psm1 'ack 2))
338    (expect-failure (procedure-means-set! psm1 'ack))
339    (expect-failure (procedure-means-set! psm1 2 'kca))
340
341    (expect-alist-same
342      (list
343        (cons 'foo (procedure-means-ref psm1 'foo))
344        (cons 'ack (procedure-means-ref psm1 'ack))
345        (cons 'arc (procedure-means-ref psm1 'arc))
346        (cons 'baz (procedure-means-ref psm1 'baz)))
347      (procedure-means->alist psm1))
348  )
349
350  (test/case "Dummy Composite Procedure Surface Means Immutable" (
351      [ps1 (make-procedure-surface #:immutable #t #:name 'PS1 'foo '() 'bar '() 'baz '())]
352      [ps2 (make-procedure-surface #:immutable #t #:name 'PS2 'abc '() 'nbc '())]
353      [ps3 (make-procedure-surface #:immutable #t #:name 'PS3 'cbs '() 'pbs '() 'cnn '() 'fox '())]
354      [cps1 #f]
355      [cps2 #f]
356      [psm1 #f]
357      [psm2 #f]
358      [psm3 #f]
359      [cpsm1 #f]
360      [cpsm2 #f]
361    )
362
363    (expect-set! cps1 (make-composite-procedure-surface ps1 ps2))
364    (expect-set! cps2 (make-composite-procedure-surface ps3 cps1))
365
366    (expect-set! psm1
367      (make-procedure-means ps1 'foo 'off 'bar 'rab 'baz 'zab #:immutable #t))
368    (expect-set! psm2
369      (make-procedure-means ps2 'abc 'cba 'nbc 'cbn))
370    (expect-set! psm3
371      (make-procedure-means ps3 'cbs 'sbc 'pbs 'sbp 'cnn 'nnc 'fox 'xof))
372
373    (expect-set! cpsm1 (make-composite-procedure-means psm1 psm2))
374    (expect-true (composite-procedure-means? cpsm1))
375    (expect-true (procedure-means-immutable? cpsm1))
376    (expect-false (procedure-means-mutable? cpsm1))
377
378    (expect-list-same "composite-implements-same"
379      (list ps1 ps2) (procedure-means-implements cpsm1))
380
381    (expect-alist-same
382      (list
383        (cons 'foo (procedure-means-ref psm1 'foo))
384        (cons 'abc (procedure-means-ref psm2 'abc))
385        (cons 'nbc (procedure-means-ref psm2 'nbc))
386        (cons 'bar (procedure-means-ref psm1 'bar))
387        (cons 'baz (procedure-means-ref psm1 'baz)))
388      (procedure-means->alist cpsm1))
389
390    (expect-failure (procedure-means-set! cpsm1 'ack 'kca 'arc 'cra))
391    (expect-failure (procedure-means-delete! cpsm1 'bar))
392
393    (expect-set! cpsm2 (make-composite-procedure-means psm3 cpsm1))
394    (expect-true (composite-procedure-means? cpsm2))
395    (expect-true (procedure-means-immutable? cpsm2))
396
397    (expect-list-same "composite-implements-same"
398      (list ps1 ps2 ps3) (procedure-means-implements cpsm2))
399
400    (expect-alist-same
401      (list
402        (cons 'cbs (procedure-means-ref psm3 'cbs))
403        (cons 'pbs (procedure-means-ref psm3 'pbs))
404        (cons 'cnn (procedure-means-ref psm3 'cnn))
405        (cons 'fox (procedure-means-ref psm3 'fox))
406        (cons 'foo (procedure-means-ref psm1 'foo))
407        (cons 'abc (procedure-means-ref psm2 'abc))
408        (cons 'nbc (procedure-means-ref psm2 'nbc))
409        (cons 'bar (procedure-means-ref psm1 'bar))
410        (cons 'baz (procedure-means-ref psm1 'baz)))
411      (procedure-means->alist cpsm2))
412
413    (expect-failure (procedure-means-set! cpsm2 'ack '()))
414    (expect-failure (procedure-means-delete! cpsm2 'bar))
415
416    (expect-failure (make-composite-procedure-means cpsm2 cpsm1))
417  )
418
419  (test/case "Dummy Composite Procedure Surface Means Mutable" (
420      [ps1 (make-procedure-surface #:immutable #t #:name 'PS1 'foo '() 'bar '() 'baz '())]
421      [ps2 (make-procedure-surface #:immutable #t #:name 'PS2 'abc '() 'nbc '())]
422      [ps3 (make-procedure-surface #:immutable #t #:name 'PS3 'cbs '() 'pbs '() 'cnn '() 'fox '())]
423      [cps1 #f]
424      [cps2 #f]
425      [psm1 #f]
426      [psm2 #f]
427      [psm3 #f]
428      [cpsm1 #f]
429      [cpsm2 #f]
430    )
431
432      ; Could be done w/ internal 'let'
433    (expect-set! cps1 (make-composite-procedure-surface ps1 ps2))
434    (expect-set! cps2 (make-composite-procedure-surface ps3 cps1))
435
436    (expect-set! psm1
437      (make-procedure-means ps1 'foo 'off 'bar 'rab 'baz 'zab))
438    (expect-set! psm2
439      (make-procedure-means ps2 'abc 'cba 'nbc 'cbn))
440    (expect-set! psm3
441      (make-procedure-means ps3 'cbs 'sbc 'pbs 'sbp 'cnn 'nnc 'fox 'xof))
442
443    (expect-set! cpsm1 (make-composite-procedure-means psm1 psm2))
444
445    (expect-success (procedure-means-set! cpsm1 'ack 'kca 'arc 'cra))
446    (expect-true (procedure-unbound? (procedure-means-ref cpsm1 'ack)))
447    (expect-true (procedure-unbound? (procedure-means-ref cpsm1 'arc)))
448
449    (expect-success (procedure-means-delete! cpsm1 'bar))
450    (expect-false (procedure-means-ref cpsm1 'bar))
451
452    (expect-set! cpsm2 (make-composite-procedure-means psm3 cpsm1))
453
454    (expect-alist-same
455      (list
456        (cons 'ack (procedure-means-ref cpsm1 'ack))
457        (cons 'arc (procedure-means-ref cpsm1 'arc))
458        (cons 'cbs (procedure-means-ref psm3 'cbs))
459        (cons 'pbs (procedure-means-ref psm3 'pbs))
460        (cons 'cnn (procedure-means-ref psm3 'cnn))
461        (cons 'fox (procedure-means-ref psm3 'fox))
462        (cons 'foo (procedure-means-ref psm1 'foo))
463        (cons 'abc (procedure-means-ref psm2 'abc))
464        (cons 'nbc (procedure-means-ref psm2 'nbc))
465        (cons 'baz (procedure-means-ref psm1 'baz)))
466      (procedure-means->alist cpsm2))
467
468    (expect-success
469      (procedure-means-set! cpsm2 'ack 'foo-bar))
470    (expect-success (procedure-means-delete! cpsm2 'bar))
471
472    (expect-alist-same "composite-incompletes-same"
473      (list (cons 'bar ps1))
474      (procedure-means-incompletes cpsm2))
475  )
476)
477
478(define-test procedure-means-test-load "Procedure Surface Means Load Explicit"
479
480  ; - Test explicit & implicit loading
481  ; - Test unbounds (incompletes already tested using dummies)
482
483  (test/case "Unitary Procedure Surface Means Immutable" (
484      [ps1 (make-procedure-surface #:name 'PS1 #:immutable #t
485             'foo '(-> object (or (list pair) null) #!optional (-> object object boolean) object object)
486             'bar '(-> object (or (list pair) null) #!optional (-> object object boolean) object)
487             'local '(-> object boolean))]
488      [psm1 #f]
489    )
490
491    (gloss (conc "Foo: " (procedure-signature-contract (procedure-surface-ref ps1 'foo))))
492    (gloss (conc "Bar: " (procedure-signature-contract (procedure-surface-ref ps1 'bar))))
493    (gloss (conc "Local: " (procedure-signature-contract (procedure-surface-ref ps1 'local))))
494
495    (expect-set! psm1
496      (make-procedure-means ps1 #:immutable #t #:extension 'misc-extn-list-support
497        'foo 'alist-inverse-ref
498        'bar 'alist-delete-first
499        'local number?))
500
501    (expect-procedure (procedure-means-ref psm1 'local))
502    (expect-true ((procedure-means-ref psm1 'local) 23.0))
503
504    (expect-false (procedure-means-bound? psm1))
505    (expect-alist-same
506      (list
507        (cons 'foo ps1)
508        (cons 'bar ps1))
509      (procedure-means-unbounds psm1))
510
511    (expect-success (procedure-means-load! psm1))
512
513    (expect-eq 'bar ((procedure-means-closure psm1 'foo) 1 '((foo . 2) (bar . 1))))
514    (expect-equal '((foo . 2)) ((procedure-means-ref psm1 'bar) 'bar '((foo . 2) (bar . 1))))
515  )
516)
517
518(test::for-each (cut test::styler-set! <> test::output-style-human))
519(run-test "Procedure Surface Tests")
Note: See TracBrowser for help on using the repository browser.