+
+(with-test-prefix "foreign slots"
+ (define-class <foreign-test> ()
+ (a #:init-keyword #:a #:class <foreign-slot>
+ #:accessor test-a)
+ (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
+ #:accessor test-b))
+
+ (pass-if-equal "constructing, no initargs"
+ '(0 3)
+ (let ((x (make <foreign-test>)))
+ (list (slot-ref x 'a)
+ (slot-ref x 'b))))
+
+ (pass-if-equal "constructing, initargs"
+ '(1 2)
+ (let ((x (make <foreign-test> #:a 1 #:b 2)))
+ (list (slot-ref x 'a)
+ (slot-ref x 'b))))
+
+ (pass-if-equal "getters"
+ '(0 3)
+ (let ((x (make <foreign-test>)))
+ (list (test-a x) (test-b x))))
+
+ (pass-if-equal "setters"
+ '(10 20)
+ (let ((x (make <foreign-test>)))
+ (set! (test-a x) 10)
+ (set! (test-b x) 20)
+ (list (test-a x) (test-b x))))
+
+ (pass-if-exception "out of range"
+ exception:out-of-range
+ (make <foreign-test> #:a (ash 1 64))))
+
+(with-test-prefix "#:each-subclass"
+ (let* ((<subclass-allocation-test>
+ (class ()
+ (test #:init-value '() #:allocation #:each-subclass)
+ #:name '<subclass-allocation-test>))
+ (a (make <subclass-allocation-test>)))
+ (pass-if-equal '() (slot-ref a 'test))
+ (let ((b (make <subclass-allocation-test>)))
+ (pass-if-equal '() (slot-ref b 'test))
+ (slot-set! a 'test 100)
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+
+ ;; #:init-value of the class shouldn't reinitialize slot when
+ ;; instances are allocated.
+ (make <subclass-allocation-test>)
+
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+
+ (let ((<test-subclass>
+ (class (<subclass-allocation-test>))))
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (let ((c (make <test-subclass>)))
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (pass-if-equal '() (slot-ref c 'test))
+ (slot-set! c 'test 200)
+ (pass-if-equal 200 (slot-ref c 'test))
+
+ (make <test-subclass>)
+
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (pass-if-equal 200 (slot-ref c 'test)))))))
+
+(with-test-prefix "accessor slots"
+ (let* ((a-accessor (make-accessor 'a))
+ (b-accessor (make-accessor 'b))
+ (<a> (class ()
+ (a #:init-keyword #:a #:accessor a-accessor)
+ #:name '<a>))
+ (<b> (class ()
+ (b #:init-keyword #:b #:accessor b-accessor)
+ #:name '<b>))
+ (<ab> (class (<a> <b>) #:name '<ab>))
+ (<ba> (class (<b> <a>) #:name '<ba>))
+ (<cab> (class (<ab>)
+ (a #:init-keyword #:a)
+ #:name '<cab>))
+ (<cba> (class (<ba>)
+ (a #:init-keyword #:a)
+ #:name '<cba>))
+ (a (make <a> #:a 'a))
+ (b (make <b> #:b 'b))
+ (ab (make <ab> #:a 'a #:b 'b))
+ (ba (make <ba> #:a 'a #:b 'b))
+ (cab (make <cab> #:a 'a #:b 'b))
+ (cba (make <cba> #:a 'a #:b 'b)))
+ (pass-if-equal "a accessor on a" 'a (a-accessor a))
+ (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
+ (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
+ (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
+ (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
+ (pass-if-equal "b accessor on a" 'b (b-accessor b))
+ (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
+ (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
+ (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
+ (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))