1(import (rumble))
2
3(define (show v) (printf "~s\n" v) v)
4
5(define-syntax check
6  (syntax-rules ()
7    [(_ a b)
8     (let ([v a])
9       (unless (equal? v b)
10         (error 'check (format "failed ~s => ~s" 'a v))))]))
11
12;; ----------------------------------------
13
14(define-values (prop:x x? x-ref) (make-struct-type-property 'x))
15
16(define-values (struct:a make-a a? a-ref a-set!)
17  (make-struct-type 'a #f 2 0 #f (list (cons prop:x 5))))
18(define a-x (make-struct-field-accessor a-ref 0 'x))
19(define a-y (make-struct-field-accessor a-ref 1 'y))
20(define-values (struct:b make-b b? b-ref b-set!)
21  (make-struct-type 'b #f 2 0 #f (list
22                                  (cons prop:equal+hash
23                                        (list (lambda (o t eql?)
24                                                (eql? (b-x o) (b-x t)))
25                                              (lambda (o hc) 0)
26                                              (lambda (o hc) 0))))))
27(define b-x (make-struct-field-accessor b-ref 0 'x))
28(define b-y (make-struct-field-accessor b-ref 1 'y))
29
30(define an-a (make-a 1 2))
31(define b1 (make-b 3 4))
32(define b2 (make-b 3 4))
33
34(check (a-x an-a) 1)
35(check (|#%app| a-ref an-a 0) 1)
36(check (|#%app| a-ref an-a 1) 2)
37
38(time (let loop ([i 10000000] [v1 (make-b 3 4)] [v2 (make-b 3 4)])
39        (cond
40         [(= i 0) (list b1 b2)]
41         [else (loop (sub1 i) (if (equal? v1 v2) v2 v1) v1)])))
42
43
44(define-values (struct:p make-p p? p-ref p-set!)
45  (make-struct-type 'p #f 2 0 #f (list (cons prop:procedure 0)) (|#%app| current-inspector) #f '(0 1)))
46
47(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10))
48
49(check (procedure-arity (make-p add1 'x)) 1)
50(check (procedure-arity (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x))
51       (list 1 (|#%app| arity-at-least 3)))
52(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 0)
53       #f)
54(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 1)
55       #t)
56(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 2)
57       #f)
58(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3)
59       #t)
60(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3000)
61       #t)
62
63(define-values (struct:p0 make-p0 p0? p0-ref p0-set!)
64  (make-struct-type 'p0 #f 2 0 #f))
65(define-values (struct:p1 make-p1 p1? p1-ref p1-set!)
66  (make-struct-type 'p1 struct:p0 2 0 #f '() (|#%app| current-inspector) 0))
67
68(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10))
69(check (|#%app| (make-p1 'no 'nope (lambda (x) (list x x)) 'whatever) 11) '(11 11))
70
71(define-values (struct:p2 make-p2 p2? p2-ref p2-set!)
72  (make-struct-type 'p2 struct:p0 2 0 #f
73                    (list (cons prop:procedure
74                                (lambda (p2 x)
75                                  (list (|#%app| p2-ref p2 0) x))))))
76
77(check (|#%app| (make-p2 0 1 'a 'b) 'c) '(a c))
78(check (procedure-arity (make-p2 0 1 'a 'b)) 1)
79(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 1) #t)
80(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 2) #f)
81
82;; ----------------------------------------
83;; Inspectors and `struct->vector`
84
85(check (struct->vector an-a) '#(struct:a ...))
86
87(check (call-with-values (lambda () (struct-info an-a)) list) '(#f #t))
88(check (call-with-values (lambda () (struct-info 7)) list) '(#f #t))
89
90(define sub-i (make-inspector (|#%app| current-inspector)))
91(define-values (struct:q make-q q? q-ref q-set!)
92  (make-struct-type 'q #f 2 0 #f '() sub-i))
93
94(define a-q (make-q 9 10))
95(check (struct->vector a-q) '#(struct:q 9 10))
96(check (call-with-values (lambda () (struct-info a-q)) list) (list struct:q #f))
97(check ((struct-type-make-constructor struct:q) 9 10) a-q)
98(check ((struct-type-make-predicate struct:q) a-q) #t)
99
100(check (struct-accessor-procedure? q-ref) #t)
101(check (struct-mutator-procedure? q-set!) #t)
102
103(check (andmap (lambda (a b)
104                 (or (equal? a b)
105                     (and (struct-accessor-procedure? a)
106                          (struct-accessor-procedure? b))
107                     (and (struct-mutator-procedure? a)
108                          (struct-mutator-procedure? b))))
109               (call-with-values (lambda () (struct-type-info struct:q)) list)
110               (list 'q 2 0 q-ref q-set! '() #f #f))
111       #t)
112
113(define-values (struct:q+3 make-q+3 q+3? q+3-ref q+3-set!)
114  (make-struct-type 'q+3 struct:q 3 0))
115
116(define a-q+3 (make-q+3 9 10 'a 'b 'c))
117(check (|#%app| q+3-ref a-q+3 0) 'a)
118(check (|#%app| q+3-ref a-q+3 1) 'b)
119(check ((make-struct-field-accessor q+3-ref 1 'second) a-q+3) 'b)
120(check (struct->vector a-q+3) '#(struct:q+3 9 10 ...))
121
122(define-values (struct:q+3+2 make-q+3+2 q+3+2? q+3+2-ref q+3+2-set!)
123  (make-struct-type 'q+3+2 struct:q+3 2 0 #f '() sub-i))
124
125(check (struct->vector (make-q+3+2 9 10 'a 'b 'c "x" "y")) '#(struct:q+3+2 9 10 ... "x" "y"))
126
127;; ----------------------------------------
128;; Prefabs
129
130(check (prefab-key? 'a) #t)
131(check (prefab-key? '(a)) #t)
132(check (prefab-key? '(a 5)) #t)
133(check (prefab-key? '(a 5 (0 #f))) #t)
134(check (prefab-key? '(a 5 (3 #f))) #t)
135(check (prefab-key? '(a (0 #f))) #t)
136(check (prefab-key? '(a 3 (0 #f) #())) #t)
137(check (prefab-key? '(a 3 #())) #t)
138(check (prefab-key? '(a #())) #t)
139(check (prefab-key? '(a 3 (0 #f) #(1 2))) #t)
140(check (prefab-key? '(a 3 (10 #f) #(11 12))) #t)
141(check (prefab-key? '(a #(100 101 99))) #t)
142(check (prefab-key? '(a 3 (0 #f) #(2) b 1)) #t)
143(check (prefab-key? '(a 3 b 1)) #t)
144(check (prefab-key? '(a b 1)) #t)
145
146(check (prefab-key? "a") #f)
147(check (prefab-key? '(a a)) #f)
148(check (prefab-key? '(a . 5)) #f)
149(check (prefab-key? '(a 5 (x #f))) #f)
150(check (prefab-key? '(a 5 (2))) #f)
151(check (prefab-key? '(a 5 (3 #f 5))) #f)
152(check (prefab-key? '(a (x #f))) #f)
153(check (prefab-key? '(a 3 (0 #f) #(x))) #f)
154(check (prefab-key? '(a 3 (0 #f) #(-2))) #f)
155(check (prefab-key? '(a 3 (0 #f) #(3))) #f)
156(check (prefab-key? '(a 3 #(11 12))) #f)
157(check (prefab-key? '(a #(100 101 100))) #f)
158(check (prefab-key? '(a 3 (0 #f) #(2) b)) #f)
159(check (prefab-key? '(a 3 (0 #f) #(2) "b" 1)) #f)
160(check (prefab-key? '(a 3 (0 #f) #(2) b -1)) #f)
161
162(check (prefab-struct-key (make-prefab-struct 'a 1)) 'a)
163(check (prefab-struct-key (make-prefab-struct '(a 1) 1)) 'a)
164(check (prefab-struct-key (make-prefab-struct 'a 1 2)) 'a)
165(check (equal? (make-prefab-struct 'a 1 2)
166               (make-prefab-struct 'a 1 2))
167       #t)
168(check (equal? (make-prefab-struct 'a 1)
169               (make-prefab-struct 'a 1 2))
170       #f)
171
172(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f) #()) 1)) 'a)
173(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f)) 1)) 'a)
174(check (prefab-struct-key (make-prefab-struct '(a 1 #()) 1)) 'a)
175(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #()) 1)) 'a)
176(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #(0)) 1)) '(a #(0)))
177
178(let ()
179  (define-values (struct:f make-f f? f-ref f-set!)
180    (make-struct-type 'f #f 1 0 #f '() 'prefab #f '(0)))
181  (define-values (struct:g make-g g? g-ref g-set!)
182    (make-struct-type 'g struct:f 2 0 #f '() 'prefab #f '(0 1)))
183  (define-values (struct:h make-h h? h-ref h-set!)
184    (make-struct-type 'h struct:g 3 0 #f '() 'prefab #f '(0 1 2)))
185
186  (check (prefab-struct-key (make-f 1)) 'f)
187  (check (prefab-struct-key (make-g 1 2 3)) '(g f 1))
188  (check (prefab-struct-key (make-h 1 2 3 4 5 6)) '(h g 2 f 1))
189
190  (void))
191
192;; ----------------------------------------
193;; Guards
194
195(define checked-names '())
196
197(define-values (struct:ga make-ga ga? ga-ref ga-set!)
198  (make-struct-type 'ga #f 2 0 #f null (|#%app| current-inspector) #f '(0 1)
199                    (lambda (a b name)
200                      (set! checked-names (cons name checked-names))
201                      (values a (box b)))))
202
203(check (|#%app| ga-ref (|#%app| make-ga 1 2) 1) (box 2))
204(check checked-names '(ga))
205
206(define-values (struct:gb make-gb gb? gb-ref gb-set!)
207  (make-struct-type 'gb struct:ga 1 0 #f null (|#%app| current-inspector) #f '(0)
208                    (lambda (a b c name)
209                      (values a (list b) c))))
210
211(check (|#%app| ga-ref (|#%app| make-gb 1 2 3) 1) (box (list 2)))
212(check checked-names '(gb ga))
213
214;; ----------------------------------------
215;; Graphs
216
217(let* ([p (make-placeholder #f)]
218       [c (cons 1 p)])
219  (placeholder-set! p c)
220  (check (make-reader-graph p)
221         '#0=(1 . #0#)))
222
223(let* ([p (make-placeholder #f)]
224       [v (vector-immutable p 2 3)]
225       [b (box-immutable v)])
226  (placeholder-set! p b)
227  (check (make-reader-graph v)
228         '#0=#(#&#0# 2 3)))
229
230(let* ([p (make-placeholder #f)]
231       [hp (make-hash-placeholder (list (cons 1 'a) (cons 2 p)))])
232  (placeholder-set! p hp)
233  (let ([ht (make-reader-graph p)])
234    (check (hash-ref ht 1) 'a)
235    (check (hash-ref (hash-ref ht 2) 1) 'a)))
236
237(let* ([p (make-placeholder #f)]
238       [a (make-prefab-struct 'a 1 2 p)])
239  (define-values (struct:a make-a a? a-ref a-set!)
240    (make-struct-type 'a #f 3 0 #f '() 'prefab #f '(0 1 2)))
241  (placeholder-set! p a)
242  (check (|#%app| a-ref (|#%app| a-ref (|#%app| a-ref (make-reader-graph a) 2) 2) 0)
243         1))
244
245;; ----------------------------------------
246
247(let ()
248  (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!)
249    (make-struct-type 'x #f 2 0 #f (list (cons prop:x 5))))
250  (define s-a-x (make-struct-field-accessor s-a-ref 0 'x))
251  (let ([an-a (make-s-a 1 2)])
252    (time
253     (let loop ([i 10000000] [v 0])
254       (if (zero? i)
255           v
256           (loop (sub1 i) (+ v (s-a-x an-a))))))))
257
258(let ()
259  (define struct:s-a (make-record-type-descriptor 's #f #f #f #f '#((mutable x) (mutable y))))
260  (define make-s-a (record-constructor
261                    (make-record-constructor-descriptor struct:s-a #f #f)))
262  (define s-a-x (record-accessor struct:s-a 0))
263  (let ([an-a (make-s-a 1 2)])
264    (time
265     (let loop ([i 10000000] [v 0])
266       (if (zero? i)
267           v
268           (loop (sub1 i) (+ v (s-a-x an-a))))))))
269
270(let ()
271  (define-record r-a (x y))
272
273  (let ([an-a (make-r-a 1 2)])
274    (time
275     (let loop ([i 10000000] [v 0])
276       (if (zero? i)
277           v
278           (loop (sub1 i) (+ v (r-a-x an-a))))))))
279