mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
73d0a3bccb
* module/ice-9/boot-9.scm (record-type-uid): New accessor.
(make-record-type): Record UID in record type properties.
* module/rnrs/conditions.scm (define-condition-type): Fix invalid
invocation of make-record-type.
* module/rnrs/records/inspection.scm: Rewrite to use core record
inspection facilities.
* module/rnrs/records/procedural.scm: Rewrite to use core
make-record-type. Incidentally the result is that instances of
derived R6RS record types are now flat instead of nested.
* test-suite/tests/r6rs-records-procedural.test
("make-record-type-descriptor"): Relax a couple condition type checks,
while we redo the exception system.
251 lines
9 KiB
Text
251 lines
9 KiB
Text
;;; r6rs-records-procedural.test --- Test suite for R6RS
|
||
;;; (rnrs records procedural)
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(define-module (test-suite test-rnrs-records-procedural)
|
||
:use-module ((rnrs conditions) :version (6))
|
||
:use-module ((rnrs exceptions) :version (6))
|
||
:use-module ((rnrs records procedural) :version (6))
|
||
:use-module (test-suite lib))
|
||
|
||
(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 :voxel (make-record-type-descriptor
|
||
'voxel :point #f #f #f '#((mutable z))))
|
||
(define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))
|
||
|
||
(with-test-prefix "make-record-type-descriptor"
|
||
(pass-if "simple"
|
||
(let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
|
||
(make-point (record-constructor :point-cd))
|
||
(point? (record-predicate :point))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1))
|
||
(point-x-set! (record-mutator :point 0))
|
||
(point-y-set! (record-mutator :point 1))
|
||
(p1 (make-point 1 2)))
|
||
(point? p1)
|
||
(eqv? (point-x p1) 1)
|
||
(eqv? (point-y p1) 2)
|
||
(unspecified? (point-x-set! p1 5))
|
||
(eqv? (point-x p1) 5)))
|
||
|
||
(pass-if "sealed records cannot be subtyped"
|
||
(let* ((:sealed-point (make-record-type-descriptor
|
||
'sealed-point #f #f #t #f '#((mutable x)
|
||
(mutable y))))
|
||
(success #f))
|
||
(call/cc
|
||
(lambda (continuation)
|
||
(with-exception-handler
|
||
(lambda (condition)
|
||
;; FIXME: While R6RS specifies an assertion violation, by
|
||
;; building on core Guile records we just see a Guile
|
||
;; condition, which is just &serious.
|
||
(set! success (serious-condition? condition))
|
||
(continuation))
|
||
(lambda () (make-record-type-descriptor
|
||
'sealed-point-subtype :sealed-point #f #f #f
|
||
'#((mutable z)))))))
|
||
success))
|
||
|
||
(pass-if "non-generative records with same uid are eq"
|
||
(let* ((:rtd-1 (make-record-type-descriptor
|
||
'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
|
||
(:rtd-2 (make-record-type-descriptor
|
||
'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
|
||
(eq? :rtd-1 :rtd-2)))
|
||
|
||
(pass-if "&assertion raised on conflicting non-generative types"
|
||
(let* ((:rtd-1 (make-record-type-descriptor
|
||
'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
|
||
(success 0)
|
||
(check-definition
|
||
(lambda (thunk)
|
||
(call/cc
|
||
(lambda (continuation)
|
||
(with-exception-handler
|
||
(lambda (condition)
|
||
;; FIXME: While R6RS specifies an assertion
|
||
;; violation, by building on core Guile records we
|
||
;; just see a Guile condition, which is just
|
||
;; &serious.
|
||
(if (serious-condition? condition)
|
||
(set! success (+ success 1)))
|
||
(continuation))
|
||
thunk))))))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
|
||
(check-definition
|
||
(lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
|
||
(check-definition
|
||
(lambda ()
|
||
(make-record-type-descriptor
|
||
'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
|
||
(eqv? success 7))))
|
||
|
||
(with-test-prefix "make-record-constructor-descriptor"
|
||
(pass-if "simple protocol"
|
||
(let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
|
||
(:point-protocol-cd (make-record-constructor-descriptor
|
||
:point #f :point-protocol))
|
||
(make-point (record-constructor :point-protocol-cd))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1))
|
||
(point (make-point 1 2)))
|
||
(and (eqv? (point-x point) 2)
|
||
(eqv? (point-y point) 3))))
|
||
|
||
(pass-if "protocol delegates to parent with protocol"
|
||
(let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
|
||
(:point-protocol-cd (make-record-constructor-descriptor
|
||
:point #f :point-protocol))
|
||
(:voxel-protocol (lambda (n)
|
||
(lambda (x y z)
|
||
(let ((p (n x y))) (p (+ z 100))))))
|
||
(:voxel-protocol-cd (make-record-constructor-descriptor
|
||
:voxel :point-protocol-cd :voxel-protocol))
|
||
(make-voxel (record-constructor :voxel-protocol-cd))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1))
|
||
(voxel-z (record-accessor :voxel 0))
|
||
(voxel (make-voxel 1 2 3)))
|
||
(and (eqv? (point-x voxel) 2)
|
||
(eqv? (point-y voxel) 3)
|
||
(eqv? (voxel-z voxel) 103)))))
|
||
|
||
(with-test-prefix "record-type-descriptor?"
|
||
(pass-if "simple"
|
||
(record-type-descriptor?
|
||
(make-record-type-descriptor 'test #f #f #f #f '#()))))
|
||
|
||
(with-test-prefix "record-constructor"
|
||
(pass-if "simple"
|
||
(let* ((make-point (record-constructor :point-cd))
|
||
(point? (record-predicate :point))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1))
|
||
(point (make-point 1 2)))
|
||
(and (point? point)
|
||
(eqv? (point-x point) 1)
|
||
(eqv? (point-y point) 2))))
|
||
|
||
(pass-if "construct record subtype"
|
||
(let* ((make-voxel (record-constructor :voxel-cd))
|
||
(voxel? (record-predicate :voxel))
|
||
(voxel-z (record-accessor :voxel 0))
|
||
(voxel (make-voxel 1 2 3)))
|
||
(and (voxel? voxel)
|
||
(eqv? (voxel-z voxel) 3)))))
|
||
|
||
(with-test-prefix "record-predicate"
|
||
(pass-if "simple"
|
||
(let* ((make-point (record-constructor :point-cd))
|
||
(point (make-point 1 2))
|
||
(point? (record-predicate :point)))
|
||
(point? point)))
|
||
|
||
(pass-if "predicate returns true on subtype"
|
||
(let* ((make-voxel (record-constructor :voxel-cd))
|
||
(voxel (make-voxel 1 2 3))
|
||
(point? (record-predicate :point)))
|
||
(point? voxel)))
|
||
|
||
(pass-if "predicate returns false on supertype"
|
||
(let* ((make-point (record-constructor :point-cd))
|
||
(point (make-point 1 2))
|
||
(voxel? (record-predicate :voxel)))
|
||
(not (voxel? point)))))
|
||
|
||
(with-test-prefix "record-accessor"
|
||
(pass-if "simple"
|
||
(let* ((make-point (record-constructor :point-cd))
|
||
(point (make-point 1 2))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1)))
|
||
(and (eqv? (point-x point) 1)
|
||
(eqv? (point-y point) 2))))
|
||
|
||
(pass-if "accessor for supertype applied to subtype"
|
||
(let* ((make-voxel (record-constructor :voxel-cd))
|
||
(voxel (make-voxel 1 2 3))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1)))
|
||
(and (eqv? (point-x voxel) 1)
|
||
(eqv? (point-y voxel) 2)))))
|
||
|
||
(with-test-prefix "record-mutator"
|
||
(pass-if "simple"
|
||
(let* ((make-point (record-constructor :point-cd))
|
||
(point (make-point 1 2))
|
||
(point-set-x! (record-mutator :point 0))
|
||
(point-set-y! (record-mutator :point 1))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1)))
|
||
(point-set-x! point 3)
|
||
(point-set-y! point 4)
|
||
(and (eqv? (point-x point) 3)
|
||
(eqv? (point-y point) 4))))
|
||
|
||
(pass-if "&assertion raised on request for immutable field"
|
||
(let* ((:immutable-point (make-record-type-descriptor
|
||
'point #f #f #f #f '#((immutable x)
|
||
(immutable y))))
|
||
(success #f))
|
||
(call/cc
|
||
(lambda (continuation)
|
||
(with-exception-handler
|
||
(lambda (condition)
|
||
(set! success (assertion-violation? condition))
|
||
(continuation))
|
||
(lambda () (record-mutator :immutable-point 0)))))
|
||
success))
|
||
|
||
(pass-if "mutator for supertype applied to subtype"
|
||
(let* ((make-voxel (record-constructor :voxel-cd))
|
||
(voxel (make-voxel 1 2 3))
|
||
(point-set-x! (record-mutator :point 0))
|
||
(point-set-y! (record-mutator :point 1))
|
||
(point-x (record-accessor :point 0))
|
||
(point-y (record-accessor :point 1)))
|
||
(point-set-x! voxel 3)
|
||
(point-set-y! voxel 4)
|
||
(and (eqv? (point-x voxel) 3)
|
||
(eqv? (point-y voxel) 4)))))
|
||
|