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=#(#�# 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