167 lines
4.0 KiB
Scheme
167 lines
4.0 KiB
Scheme
#!r6rs
|
|
|
|
(library (tests r6rs records procedural)
|
|
(export run-records-procedural-tests)
|
|
(import (rnrs)
|
|
(tests r6rs test))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define rtd1
|
|
(make-record-type-descriptor
|
|
'rtd1 #f #f #f #f
|
|
'#((immutable x1) (immutable x2))))
|
|
|
|
(define rtd2
|
|
(make-record-type-descriptor
|
|
'rtd2 rtd1 #f #f #f
|
|
'#((immutable x3) (immutable x4))))
|
|
|
|
(define rtd3
|
|
(make-record-type-descriptor
|
|
'rtd3 rtd2 #f #f #f
|
|
'#((immutable x5) (immutable x6))))
|
|
|
|
(define protocol1
|
|
(lambda (p)
|
|
(lambda (a b c)
|
|
(p (+ a b) (+ b c)))))
|
|
|
|
(define protocol2
|
|
(lambda (n)
|
|
(lambda (a b c d e f)
|
|
(let ((p (n a b c)))
|
|
(p (+ d e) (+ e f))))))
|
|
|
|
(define protocol3
|
|
(lambda (n)
|
|
(lambda (a b c d e f g h i)
|
|
(let ((p (n a b c d e f)))
|
|
(p (+ g h) (+ h i))))))
|
|
|
|
(define cd1
|
|
(make-record-constructor-descriptor
|
|
rtd1 #f protocol1))
|
|
|
|
(define cd2
|
|
(make-record-constructor-descriptor
|
|
rtd2 cd1 protocol2))
|
|
|
|
(define cd3
|
|
(make-record-constructor-descriptor
|
|
rtd3 cd2 protocol3))
|
|
|
|
(define make-rtd1 (record-constructor cd1))
|
|
|
|
(define make-rtd2 (record-constructor cd2))
|
|
|
|
(define make-rtd3 (record-constructor cd3))
|
|
|
|
|
|
(define :point
|
|
(make-record-type-descriptor
|
|
'point #f
|
|
#f #f #f
|
|
'#((mutable x) (mutable y))))
|
|
|
|
(define :point-cd
|
|
(make-record-constructor-descriptor :point #f #f))
|
|
|
|
(define make-point (record-constructor :point-cd))
|
|
|
|
(define point? (record-predicate :point))
|
|
(define point-x (record-accessor :point 0))
|
|
(define point-y (record-accessor :point 1))
|
|
(define point-x-set! (record-mutator :point 0))
|
|
(define point-y-set! (record-mutator :point 1))
|
|
|
|
(define p1 (make-point 1 2))
|
|
|
|
(define :point2
|
|
(make-record-type-descriptor
|
|
'point2 :point
|
|
#f #f #f '#((mutable x) (mutable y))))
|
|
|
|
(define make-point2
|
|
(record-constructor
|
|
(make-record-constructor-descriptor :point2
|
|
#f #f)))
|
|
(define point2? (record-predicate :point2))
|
|
(define point2-xx (record-accessor :point2 0))
|
|
(define point2-yy (record-accessor :point2 1))
|
|
|
|
(define p2 (make-point2 1 2 3 4))
|
|
|
|
(define :point-cd/abs
|
|
(make-record-constructor-descriptor
|
|
:point #f
|
|
(lambda (new)
|
|
(lambda (x y)
|
|
(new (abs x) (abs y))))))
|
|
|
|
(define make-point/abs
|
|
(record-constructor :point-cd/abs))
|
|
|
|
(define :cpoint
|
|
(make-record-type-descriptor
|
|
'cpoint :point
|
|
#f #f #f
|
|
'#((mutable rgb))))
|
|
|
|
(define make-cpoint
|
|
(record-constructor
|
|
(make-record-constructor-descriptor
|
|
:cpoint :point-cd
|
|
(lambda (p)
|
|
(lambda (x y c)
|
|
((p x y) (color->rgb c)))))))
|
|
|
|
(define make-cpoint/abs
|
|
(record-constructor
|
|
(make-record-constructor-descriptor
|
|
:cpoint :point-cd/abs
|
|
(lambda (p)
|
|
(lambda (x y c)
|
|
((p x y) (color->rgb c)))))))
|
|
|
|
(define cpoint-rgb
|
|
(record-accessor :cpoint 0))
|
|
|
|
(define (color->rgb c)
|
|
(cons 'rgb c))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (run-records-procedural-tests)
|
|
|
|
(let ([r (make-rtd3 1 2 3 4 5 6 7 8 9)])
|
|
(test ((record-accessor rtd1 0) r) 3)
|
|
(test ((record-accessor rtd1 1) r) 5)
|
|
(test ((record-accessor rtd2 0) r) 9)
|
|
(test ((record-accessor rtd2 1) r) 11)
|
|
(test ((record-accessor rtd3 0) r) 15)
|
|
(test ((record-accessor rtd3 1) r) 17))
|
|
|
|
(test (point? p1) #t)
|
|
(test (point-x p1) 1)
|
|
(test (point-y p1) 2)
|
|
(test/unspec (point-x-set! p1 5))
|
|
(test (point-x p1) 5)
|
|
|
|
(test (point? p2) #t)
|
|
(test (point-x p2) 1)
|
|
(test (point-y p2) 2)
|
|
(test (point2-xx p2) 3)
|
|
(test (point2-yy p2) 4)
|
|
|
|
(test (point-x (make-point/abs -1 -2)) 1)
|
|
(test (point-y (make-point/abs -1 -2)) 2)
|
|
|
|
(test (cpoint-rgb (make-cpoint -1 -3 'red)) '(rgb . red))
|
|
(test (point-x (make-cpoint -1 -3 'red)) -1)
|
|
(test (point-x (make-cpoint/abs -1 -3 'red)) 1)
|
|
|
|
;;
|
|
))
|
|
|