1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Mike Sperber
4
5(define-test-suite r6rs-records-procedural-tests)
6
7(define :point
8  (make-record-type-descriptor
9   'point #f
10   #f #f #f
11   '#((mutable x) (mutable y))))
12(define :point-cd
13  (make-record-constructor-descriptor :point #f #f))
14(define make-point (record-constructor :point-cd))
15
16(define point? (record-predicate :point))
17(define point-x (record-accessor :point 0))
18(define point-y (record-accessor :point 1))
19(define point-x-set! (record-mutator :point 0))
20(define point-y-set! (record-mutator :point 1))
21
22(define-test-case point r6rs-records-procedural-tests
23  (let ((p1 (make-point 1 2)))
24
25    (check (point? p1))
26    (check (point-x p1) => 1)
27    (check (point-y p1) => 2)
28    (point-x-set! p1 5)
29    (check (point-x p1) => 5)))
30
31(define :point2
32  (make-record-type-descriptor
33    'point2 :point
34    #f #f #f '#((mutable x) (mutable y))))
35
36(define make-point2
37  (record-constructor
38    (make-record-constructor-descriptor :point2
39      #f #f)))
40
41(define point2? (record-predicate :point2))
42(define point2-xx (record-accessor :point2 0))
43(define point2-yy (record-accessor :point2 1))
44
45(define-test-case point2 r6rs-records-procedural-tests
46  (let ((p2 (make-point2 1 2 3 4)))
47    (check (point? p2) => #t)
48    (check (point-x p2) => 1)
49    (check (point-y p2) => 2)
50    (check (point2-xx p2) => 3)
51    (check (point2-yy p2) => 4)))
52
53(define :point-cd/abs
54  (make-record-constructor-descriptor
55   :point #f
56   (lambda (new)
57     (lambda (x y)
58       (new (abs x) (abs y))))))
59
60(define make-point/abs
61  (record-constructor :point-cd/abs))
62
63(define-test-case point/abs r6rs-records-procedural-tests
64  (check (point-x (make-point/abs -1 -2))
65	 => 1)
66  (check (point-y (make-point/abs -1 -2))
67	 => 2))
68
69(define :cpoint
70  (make-record-type-descriptor
71   'cpoint :point
72   #f #f #f
73   '#((mutable rgb))))
74
75(define make-cpoint
76  (record-constructor
77   (make-record-constructor-descriptor
78    :cpoint :point-cd
79    (lambda (p)
80      (lambda (x y c)
81        ((p x y) (color->rgb c)))))))
82
83(define make-cpoint/abs
84  (record-constructor
85   (make-record-constructor-descriptor
86    :cpoint :point-cd/abs
87    (lambda (p)
88      (lambda (x y c)
89        ((p x y) (color->rgb c)))))))
90
91(define cpoint-rgb
92  (record-accessor :cpoint 0))
93
94(define (color->rgb c)
95  (cons 'rgb c))
96
97(define-test-case cpoint r6rs-records-procedural-tests
98  (check (cpoint-rgb (make-cpoint -1 -3 'red))
99	 => '(rgb . red))
100  (check (point-x (make-cpoint -1 -3 'red))
101	 => -1)
102  (check (point-x (make-cpoint/abs -1 -3 'red))
103	 => 1))
104