source: project/release/5/coops-utils/trunk/tests/coops-utils-test.scm @ 35790

Last change on this file since 35790 was 35790, checked in by Kon Lovett, 2 years ago

canonical

File size: 5.5 KB
Line 
1;;;; coops-utils test  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(import test)
5
6(test-begin "Coops Utils")
7
8;;;
9
10(import
11  (chicken syntax)
12  (chicken fixnum)
13  (srfi 1)
14  (srfi 13)
15  coops
16  coops-utils)
17
18;;
19
20(test-assert (class? <standard-class>))
21
22(test-assert (class? <standard-object>))
23
24;; setup test reference environment
25
26(define-class <s1xy> () ((x 's1xy-x) (y 's1xy-y)))
27(define-class <s1ab> () ((a 's1ab-a) (b 's1ab-b)))
28(define-class <s2xz> () ((x 's2xz-x) (z 's2xz-z)))
29(define-class <s2ac> () ((a 's2ac-a) (c 's2ac-c)))
30
31(define-class <s1xys1ab> (<s1xy> <s1ab>)
32  ((x 's1xys1ab-x) (y 's1xys1ab-y) (a 's1xys1ab-a) (b 's1xys1ab-b) (me '<s1xys1ab>)))
33(define-class <s2xzs2ac> (<s2xz> <s2ac>)
34  ((x 's2xzs2ac-x) (z 's2xzs2ac-z) (a 's2xzs2ac-a) (c 's2xzs2ac-c)))
35
36(define-class <s1xys2xz> (<s1xy> <s2xz>) ())
37(define-class <s2xzs1ab> (<s2xz> <s1ab>) ())
38
39(define-generic (foo abc xyz))
40
41(define-method (foo primary: (abc <s1xy>) (xyz <s1ab>)) 'primary-<s1xy><s1ab>)
42(define-method (foo before: (abc <s1xy>) (xyz <s1ab>)) 'before-<s1xy><s1ab>)
43(define-method (foo after: (abc <s1xy>) (xyz <s1ab>)) 'after-<s1xy><s1ab>)
44(define-method (foo around: (abc <s1xy>) (xyz <s1ab>)) 'around-<s1xy><s1ab>)
45
46(define-method (foo primary: (abc <s2xz>) (xyz <s2ac>)) 'primary-<s2xz><s2ac>)
47(define-method (foo before: (abc <s2xz>) (xyz <s2ac>)) 'before-<s2xz><s2ac>)
48(define-method (foo after: (abc <s2xz>) (xyz <s2ac>)) 'after-<s2xz><s2ac>)
49(define-method (foo around: (abc <s2xz>) (xyz <s2ac>)) 'around-<s2xz><s2ac>)
50
51(test (list <s2xz> <standard-object> <s1ab>) (class-precedence-list <s2xzs1ab>))
52(test '(x z a b) (class-slots <s2xzs1ab>))
53
54(test-assert (class? <s2xzs2ac>))
55(test (list <standard-object>) (class-direct-supers <s2ac>))
56(test '(a c) (class-direct-slots <s2ac>))
57
58(test-assert (class? <s1xys1ab>))
59(test (list <s1xy> <s1ab>) (class-direct-supers <s1xys1ab>))
60(test '(me) (class-direct-slots <s1xys1ab>))
61
62(test 'foo (generic-name foo))
63(test '(abc xyz) (generic-specialized-arguments foo))
64(test-assert (eq? 2 (length (generic-primary-methods foo))))
65(let ((primaries (generic-primary-methods foo)))
66  (for-each
67    (lambda (x)
68      (let ((specials (method-specializers x)))
69        (test-assert (list? specials))
70        (test-assert (every class? specials)) )
71      (test-assert (procedure? (method-procedure x)))
72      (test-assert (method? x)) )
73    primaries) )
74
75(define s1xy-inst (make <s1xy> 'x 1 'y 2))
76(test-assert (instance? s1xy-inst))
77(test-assert (instance-of? s1xy-inst <s1xy>))
78
79(describe-object s1xy-inst)
80
81#| FIXME - y = 's1xy-y ?
82(define s1xy-inst-x (make <s1xy> 'x 1))
83(test-assert (instance? s1xy-inst-x))
84(test-assert (instance-of? s1xy-inst-x <s1xy>))
85(describe-object s1xy-inst-x)
86;=>
87;coops instance of class `<s1xy>':
88;x: 1
89;y: s1xy-y
90|#
91
92(define-class <first> () (next))
93(define-class <second> (<first>) ())
94(define-class <third> (<second>) ())
95
96(define 1st (make <first> 'next (make <second> 'next (make <third> 'next "the end"))))
97
98(test "the end" (slot@ 1st next next next))
99(slot@ 1st next next next = "still the end")
100(test "still the end" (slot@ 1st next next next))
101
102;make-copy
103(let ((inst (make-copy s1xy-inst 'y 23)))
104  (test "make-copy" 23 (slot@ inst y)) )
105
106(let ()
107  (define-class city () (name (market-class reader: city-market-class) sellers buyers (goods accessor: city-goods)))
108  (define temphawa (make city 'name "Hawa" 'market-class 2))
109  (test-assert "make-copy temphawa" (make-copy temphawa)) )
110
111;primitive-instance?
112
113;---
114#|
115;; Named (has a name) "concept"
116
117(define-generic (name obj))
118(define-class <named> () (
119  (namsym #:reader name) ) )
120
121;; Moves foreward thru a set of values "concept"
122
123(define-generic (step-function obj))
124(define-class <stepper> () (
125  (nxtval #:reader step-function) ) )
126(define-generic (next-value obj))
127(define-method (next-value (obj <stepper>)) ((step-function obj)))
128
129;; Parameterized extension "concept"
130
131(define-generic (parameters obj))
132(define-generic (basis obj))
133(define-class <parameterized> () (
134  (parms #:reader parameters)
135  (src #:reader basis) ) )
136
137;; Parameterized generative set of random values "concept"
138
139(define-class <random-distribution> (<named> <parameterized> <stepper>) (
140  temp ) )
141
142;; Create an instance of <random-distribution> where the arguments are
143;; the same as the documented procedural distribution API.
144;;
145;; SRFI 27 API: ({some distribution constructor} arg...)
146;;      OO API: (make-random-distribution {some distribution constructor} arg...)
147
148(define-syntax make-random-distribution
149  (syntax-rules ()
150    ((_ ?ctor ?arg0 ...)
151      (make <random-distribution> 'temp (?ctor ?arg0 ...)) ) ) )
152
153(define-method (initialize-instance (obj <random-distribution>))
154  ; The 'ctor' should be a globally defined procedure compiled
155  ; with procedure-information. So if following nomenclature then the last
156  ; procedure name element will be the kind of distribution.
157  (let* (
158    (temp (slot-value obj 'temp))
159    (ctor (car temp))
160    (procinfo (procedure-information ctor))
161    (name (and procinfo (pair? procinfo) (symbol->string (car procinfo))))
162    (name
163      (and-let* (
164        (name)
165        (kndpos (string-index-right name #\-)))
166        (substring/shared name (fx+ kndpos 1)) ) )
167    (dstr-vals (receive (apply ctor (cdr temp))))
168    (parms (and (fx<= 2 (length dstr-vals)) (receive ((second dstr-vals))))) )
169    (set! (slot-value obj 'temp) #f) ;"free" the "any" slot
170    (set! (slot-value obj 'namsym) (string->symbol name))
171    (set! (slot-value obj 'nxtval) (first dstr-vals))
172    (set! (slot-value obj 'parms) (and parms (drop-right parms 1))) ) )
173|#
174
175;;;
176
177(test-end "Coops Utils")
178
179(test-exit)
Note: See TracBrowser for help on using the repository browser.