mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Implementation and test cases for the R6RS (rnrs records inspection)
library.
* module/Makefile.am: Add module/rnrs/records/6/inspection.scm to RNRS_SOURCES.
* module/rnrs/records/6/inspection.scm: New file.
* module/rnrs/records/6/procedural.scm: Assorted refactoring:
Create index constants for record, rtd, and rcd field indexes;
record-type-vtable, record-constructor-vtable: More informative display
names;
(make-record-type-descriptor): fold left, not right when creating vtable;
store field names as vector, not list;
detect opaque parents
* test-suite/Makefile.am: Add test-suite/tests/r6rs-records-inspection.test to
SCM_TESTS.
* test-suite/tests/r6rs-records-inspection.test: New file.
This commit is contained in:
Julian Graham
parent
8b58ea4539
commit
55684b5e3b
5 changed files with 308 additions and 53 deletions
|
|
@ -263,10 +263,11 @@ RNRS_SOURCES = \
|
|||
rnrs/6/syntax-case.scm \
|
||||
rnrs/arithmetic/6/bitwise.scm \
|
||||
rnrs/bytevector.scm \
|
||||
rnrs/records/6/inspection.scm \
|
||||
rnrs/records/6/procedural.scm \
|
||||
rnrs/records/6/syntactic.scm \
|
||||
rnrs/io/ports.scm \
|
||||
rnrs/io.simple.scm
|
||||
rnrs/io/6/simple.scm
|
||||
|
||||
EXTRA_DIST += scripts/ChangeLog-2008
|
||||
EXTRA_DIST += scripts/README
|
||||
|
|
|
|||
83
module/rnrs/records/6/inspection.scm
Normal file
83
module/rnrs/records/6/inspection.scm
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
;;; inspection.scm --- Inspection support for R6RS records
|
||||
|
||||
;; 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
|
||||
|
||||
|
||||
(library (rnrs records inspection (6))
|
||||
(export record?
|
||||
record-rtd
|
||||
record-type-name
|
||||
record-type-parent
|
||||
record-type-uid
|
||||
record-type-generative?
|
||||
record-type-sealed?
|
||||
record-type-opaque?
|
||||
record-type-field-names
|
||||
record-field-mutable?)
|
||||
(import (rnrs base (6))
|
||||
(rnrs conditions (6))
|
||||
(rnrs exceptions (6))
|
||||
(rnrs records procedural (6))
|
||||
(only (guile) struct-ref vtable-index-layout))
|
||||
|
||||
(define record-internal? (@@ (rnrs records procedural) record-internal?))
|
||||
|
||||
(define record-index-rtd (@@ (rnrs records procedural) record-index-rtd))
|
||||
|
||||
(define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
|
||||
(define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
|
||||
(define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
|
||||
(define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
|
||||
(define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
|
||||
(define rtd-index-field-names
|
||||
(@@ (rnrs records procedural) rtd-index-field-names))
|
||||
(define rtd-index-field-vtable
|
||||
(@@ (rnrs records procedural) rtd-index-field-vtable))
|
||||
|
||||
(define (record? obj)
|
||||
(and (record-internal? obj)
|
||||
(not (record-type-opaque? (struct-ref obj record-index-rtd)))))
|
||||
|
||||
(define (record-rtd record)
|
||||
(or (and (record-internal? record)
|
||||
(let ((rtd (struct-ref record record-index-rtd)))
|
||||
(and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
|
||||
(raise (make-assertion-violation))))
|
||||
|
||||
(define (ensure-rtd rtd)
|
||||
(if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))
|
||||
|
||||
(define (record-type-name rtd)
|
||||
(ensure-rtd rtd) (struct-ref rtd rtd-index-name))
|
||||
(define (record-type-parent rtd)
|
||||
(ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
|
||||
(define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
|
||||
(define (record-type-generative? rtd)
|
||||
(ensure-rtd rtd) (and (record-type-uid rtd) #t))
|
||||
(define (record-type-sealed? rtd)
|
||||
(ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
|
||||
(define (record-type-opaque? rtd)
|
||||
(ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
|
||||
(define (record-type-field-names rtd)
|
||||
(ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
|
||||
(define (record-field-mutable? rtd k)
|
||||
(ensure-rtd rtd)
|
||||
(let ((vt (struct-ref rtd rtd-index-field-vtable)))
|
||||
(eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout))
|
||||
(+ (* 2 (+ k 2)) 1))
|
||||
#\w)))
|
||||
)
|
||||
|
|
@ -49,62 +49,78 @@
|
|||
|
||||
vector->list)
|
||||
(ice-9 receive)
|
||||
(only (srfi :1) fold-right split-at take))
|
||||
(only (srfi :1) fold split-at take))
|
||||
|
||||
(define (record-rtd record) (struct-ref record 1))
|
||||
(define (record-type-name rtd) (struct-ref rtd 0))
|
||||
(define (record-type-parent rtd) (struct-ref rtd 2))
|
||||
(define (record-type-uid rtd) (struct-ref rtd 1))
|
||||
(define (record-type-generative? rtd) (not (record-type-uid rtd)))
|
||||
(define (record-type-sealed? rtd) (struct-ref rtd 3))
|
||||
(define (record-type-opaque? rtd) (struct-ref rtd 4))
|
||||
(define (record-type-field-names rtd) (struct-ref rtd 6))
|
||||
(define (record-internal? obj)
|
||||
(and (struct? obj)
|
||||
(let* ((vtable (struct-vtable obj))
|
||||
(layout (symbol->string
|
||||
(struct-ref vtable vtable-index-layout))))
|
||||
(and (>= (string-length layout) 4)
|
||||
(let ((rtd (struct-ref obj record-index-rtd)))
|
||||
(and (record-type-descriptor? rtd)))))))
|
||||
|
||||
(define record-index-parent 0)
|
||||
(define record-index-rtd 1)
|
||||
|
||||
(define rtd-index-name 0)
|
||||
(define rtd-index-uid 1)
|
||||
(define rtd-index-parent 2)
|
||||
(define rtd-index-sealed? 3)
|
||||
(define rtd-index-opaque? 4)
|
||||
(define rtd-index-predicate 5)
|
||||
(define rtd-index-field-names 6)
|
||||
(define rtd-index-field-vtable 7)
|
||||
(define rtd-index-field-binder 8)
|
||||
|
||||
(define rctd-index-rtd 0)
|
||||
(define rctd-index-parent 1)
|
||||
(define rctd-index-protocol 2)
|
||||
|
||||
(define record-type-vtable
|
||||
(make-vtable "prprprprprprprprpr"
|
||||
(lambda (obj port)
|
||||
(display "#<r6rs:record-type-vtable>" port))))
|
||||
(simple-format port "#<r6rs:record-type:~A>"
|
||||
(struct-ref obj rtd-index-name)))))
|
||||
|
||||
(define record-constructor-vtable
|
||||
(make-vtable "prprpr"
|
||||
(lambda (obj port)
|
||||
(display "#<r6rs:record-constructor-vtable>" port))))
|
||||
(simple-format port "#<r6rs:record-constructor:~A>"
|
||||
(struct-ref (struct-ref obj rctd-index-rtd)
|
||||
rtd-index-name)))))
|
||||
|
||||
(define uid-table (make-hash-table))
|
||||
|
||||
(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
|
||||
(define fields-vtable
|
||||
(make-vtable (fold-right (lambda (x p)
|
||||
(string-append p (case (car x)
|
||||
((immutable) "pr")
|
||||
((mutable) "pw"))))
|
||||
"prpr" (vector->list fields))
|
||||
(make-vtable (fold (lambda (x p)
|
||||
(string-append p (case (car x)
|
||||
((immutable) "pr")
|
||||
((mutable) "pw"))))
|
||||
"prpr" (vector->list fields))
|
||||
(lambda (obj port)
|
||||
(simple-format
|
||||
port "#<r6rs:record-field-layout-vtable:~A>" name))))
|
||||
(define field-names (map cadr (vector->list fields)))
|
||||
(simple-format port "#<r6rs:record:~A>" name))))
|
||||
(define field-names (list->vector (map cadr (vector->list fields))))
|
||||
(define late-rtd #f)
|
||||
(define (private-record-predicate obj)
|
||||
(and (struct? obj)
|
||||
(let* ((vtable (struct-vtable obj))
|
||||
(layout (symbol->string
|
||||
(struct-ref vtable vtable-index-layout))))
|
||||
(and (>= (string-length layout) 3)
|
||||
(let ((rtd (struct-ref obj 1)))
|
||||
(and (record-type-descriptor? rtd)
|
||||
(or (eq? (struct-ref rtd 7) fields-vtable)
|
||||
(and=> (struct-ref obj 0)
|
||||
private-record-predicate))))))))
|
||||
(and (record-internal? obj)
|
||||
(let ((rtd (struct-ref obj record-index-rtd)))
|
||||
(or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
|
||||
(and=> (struct-ref obj record-index-parent)
|
||||
private-record-predicate)))))
|
||||
|
||||
(define (field-binder parent-struct . args)
|
||||
(apply make-struct (append (list fields-vtable 0
|
||||
parent-struct
|
||||
late-rtd)
|
||||
args)))
|
||||
(if (and parent (record-type-sealed? parent))
|
||||
(if (and parent (struct-ref parent rtd-index-sealed?))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
|
||||
(let ((matching-rtd (and uid (hashq-ref uid-table uid))))
|
||||
(let ((matching-rtd (and uid (hashq-ref uid-table uid)))
|
||||
(opaque? (or opaque? (and parent (struct-ref
|
||||
parent rtd-index-opaque?)))))
|
||||
(if matching-rtd
|
||||
(if (equal? (list name
|
||||
parent
|
||||
|
|
@ -112,12 +128,13 @@
|
|||
opaque?
|
||||
field-names
|
||||
(struct-ref fields-vtable vtable-index-layout))
|
||||
(list (record-type-name matching-rtd)
|
||||
(record-type-parent matching-rtd)
|
||||
(record-type-sealed? matching-rtd)
|
||||
(record-type-opaque? matching-rtd)
|
||||
(record-type-field-names matching-rtd)
|
||||
(struct-ref (struct-ref matching-rtd 7)
|
||||
(list (struct-ref matching-rtd rtd-index-name)
|
||||
(struct-ref matching-rtd rtd-index-parent)
|
||||
(struct-ref matching-rtd rtd-index-sealed?)
|
||||
(struct-ref matching-rtd rtd-index-opaque?)
|
||||
(struct-ref matching-rtd rtd-index-field-names)
|
||||
(struct-ref (struct-ref matching-rtd
|
||||
rtd-index-field-vtable)
|
||||
vtable-index-layout)))
|
||||
matching-rtd
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
|
|
@ -144,7 +161,7 @@
|
|||
(define (make-record-constructor-descriptor rtd
|
||||
parent-constructor-descriptor
|
||||
protocol)
|
||||
(define rtd-arity (length (struct-ref rtd 6)))
|
||||
(define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
|
||||
(define (default-inherited-protocol n)
|
||||
(lambda args
|
||||
(receive
|
||||
|
|
@ -154,7 +171,7 @@
|
|||
(apply p p-args)))))
|
||||
(define (default-protocol p) p)
|
||||
|
||||
(let* ((prtd (struct-ref rtd 1))
|
||||
(let* ((prtd (struct-ref rtd rtd-index-parent))
|
||||
(pcd (or parent-constructor-descriptor
|
||||
(and=> prtd (lambda (d) (make-record-constructor-descriptor
|
||||
prtd #f #f)))))
|
||||
|
|
@ -164,35 +181,40 @@
|
|||
(make-struct record-constructor-vtable 0 rtd pcd prot)))
|
||||
|
||||
(define (record-constructor rctd)
|
||||
(let* ((rtd (struct-ref rctd 0))
|
||||
(parent-rctd (struct-ref rctd 1))
|
||||
(protocol (struct-ref rctd 2)))
|
||||
(let* ((rtd (struct-ref rctd rctd-index-rtd))
|
||||
(parent-rctd (struct-ref rctd rctd-index-parent))
|
||||
(protocol (struct-ref rctd rctd-index-protocol)))
|
||||
(protocol
|
||||
(if parent-rctd
|
||||
(let ((parent-record-constructor (record-constructor parent-rctd))
|
||||
(parent-rtd (struct-ref parent-rctd 0)))
|
||||
(parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
|
||||
(lambda args
|
||||
(let ((struct (apply parent-record-constructor args)))
|
||||
(lambda args
|
||||
(apply (struct-ref rtd 8)
|
||||
(apply (struct-ref rtd rtd-index-field-binder)
|
||||
(cons struct args))))))
|
||||
(lambda args (apply (struct-ref rtd 8) (cons #f args)))))))
|
||||
(lambda args (apply (struct-ref rtd rtd-index-field-binder)
|
||||
(cons #f args)))))))
|
||||
|
||||
(define (record-predicate rtd) (struct-ref rtd 5))
|
||||
(define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
|
||||
|
||||
(define (record-accessor rtd k)
|
||||
(define (record-accessor-inner obj)
|
||||
(and obj
|
||||
(or (and (eq? (struct-ref obj 1) rtd) (struct-ref obj (+ k 2)))
|
||||
(record-accessor-inner (struct-ref obj 0)))))
|
||||
(if (not (record-internal? obj))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(if (eq? (struct-ref obj record-index-rtd) rtd)
|
||||
(struct-ref obj (+ k 2))
|
||||
(record-accessor-inner (struct-ref obj record-index-parent))))
|
||||
(lambda (obj) (record-accessor-inner obj)))
|
||||
|
||||
(define (record-mutator rtd k)
|
||||
(define (record-mutator-inner obj val)
|
||||
(and obj
|
||||
(or (and (eq? (struct-ref obj 1) rtd) (struct-set! obj (+ k 2) val))
|
||||
(record-mutator-inner (struct-ref obj 0) val))))
|
||||
(let* ((rtd-vtable (struct-ref rtd 7))
|
||||
(or (and (eq? (struct-ref obj record-index-rtd) rtd)
|
||||
(struct-set! obj (+ k 2) val))
|
||||
(record-mutator-inner (struct-ref obj record-index-parent)
|
||||
val))))
|
||||
(let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
|
||||
(field-layout (symbol->string
|
||||
(struct-ref rtd-vtable vtable-index-layout))))
|
||||
(if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
|
||||
|
|
|
|||
|
|
@ -79,6 +79,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/r6rs-arithmetic-bitwise.test \
|
||||
tests/r6rs-control.test \
|
||||
tests/r6rs-ports.test \
|
||||
tests/r6rs-records-inspection.test \
|
||||
tests/r6rs-records-procedural.test \
|
||||
tests/rnrs-libraries.test \
|
||||
tests/ramap.test \
|
||||
|
|
|
|||
148
test-suite/tests/r6rs-records-inspection.test
Normal file
148
test-suite/tests/r6rs-records-inspection.test
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
|
||||
|
||||
;; 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 inspection) :version (6))
|
||||
:use-module ((rnrs records procedural) :version (6))
|
||||
:use-module (test-suite lib))
|
||||
|
||||
(with-test-prefix "record?"
|
||||
(pass-if "record? recognizes non-opaque records"
|
||||
(let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#()))
|
||||
(make-rec (record-constructor
|
||||
(make-record-constructor-descriptor rec #f #f))))
|
||||
(record? (make-rec))))
|
||||
|
||||
(pass-if "record? doesn't recognize opaque records"
|
||||
(let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#()))
|
||||
(make-rec (record-constructor
|
||||
(make-record-constructor-descriptor rec #f #f))))
|
||||
(not (record? (make-rec)))))
|
||||
|
||||
(pass-if "record? doesn't recognize non-records" (not (record? 'foo))))
|
||||
|
||||
(with-test-prefix "record-rtd"
|
||||
(pass-if "simple"
|
||||
(let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#()))
|
||||
(make-rec (record-constructor
|
||||
(make-record-constructor-descriptor rtd #f #f))))
|
||||
(eq? (record-rtd (make-rec)) rtd)))
|
||||
|
||||
(pass-if "&assertion on opaque record"
|
||||
(let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#()))
|
||||
(make-rec (record-constructor
|
||||
(make-record-constructor-descriptor rtd #f #f)))
|
||||
(success #f))
|
||||
(call/cc
|
||||
(lambda (continuation)
|
||||
(with-exception-handler
|
||||
(lambda (condition)
|
||||
(set! success (assertion-violation? condition))
|
||||
(continuation))
|
||||
(lambda () (record-rtd (make-rec))))))
|
||||
success)))
|
||||
|
||||
(with-test-prefix "record-type-name"
|
||||
(pass-if "simple"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(eq? (record-type-name rtd) 'foo))))
|
||||
|
||||
(with-test-prefix "record-type-parent"
|
||||
(pass-if "eq? to parent"
|
||||
(let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#()))
|
||||
(rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#())))
|
||||
(eq? (record-type-parent rtd) rtd-parent)))
|
||||
|
||||
(pass-if "#f when parent not present"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(not (record-type-parent rtd)))))
|
||||
|
||||
(with-test-prefix "record-type-uid"
|
||||
(pass-if "eq? to uid"
|
||||
(let* ((uid (gensym))
|
||||
(rtd (make-record-type-descriptor uid #f uid #f #f '#())))
|
||||
(eq? (record-type-uid rtd) uid)))
|
||||
|
||||
(pass-if "#f when uid not present"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(not (record-type-uid rtd)))))
|
||||
|
||||
(with-test-prefix "record-type-generative?"
|
||||
(pass-if "#t when uid is not #f"
|
||||
(let* ((uid (gensym))
|
||||
(rtd (make-record-type-descriptor uid #f uid #f #f '#())))
|
||||
(record-type-generative? rtd)))
|
||||
|
||||
(pass-if "#f when uid is #f"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(not (record-type-generative? rtd)))))
|
||||
|
||||
(with-test-prefix "record-type-sealed?"
|
||||
(pass-if "#t when sealed? is #t"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#())))
|
||||
(record-type-sealed? rtd)))
|
||||
|
||||
(pass-if "#f when sealed? is #f"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(not (record-type-sealed? rtd)))))
|
||||
|
||||
(with-test-prefix "record-type-opaque?"
|
||||
(pass-if "#t when opaque? is #t"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#())))
|
||||
(record-type-opaque? rtd)))
|
||||
|
||||
(pass-if "#f when opaque? is #f"
|
||||
(let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
|
||||
(not (record-type-opaque? rtd))))
|
||||
|
||||
(pass-if "#t when parent is opaque"
|
||||
(let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
|
||||
(rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#())))
|
||||
(record-type-opaque? rtd))))
|
||||
|
||||
(with-test-prefix "record-type-field-names"
|
||||
(pass-if "simple"
|
||||
(let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
|
||||
'#((immutable foo)
|
||||
(mutable bar)))))
|
||||
(equal? (record-type-field-names rtd) '#(foo bar))))
|
||||
|
||||
(pass-if "parent fields not included"
|
||||
(let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
|
||||
'#((mutable foo))))
|
||||
(rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
|
||||
'#((immutable bar)))))
|
||||
(equal? (record-type-field-names rtd) '#(bar))))
|
||||
|
||||
(pass-if "subtype fields not included"
|
||||
(let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
|
||||
'#((mutable foo))))
|
||||
(rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
|
||||
'#((immutable bar)))))
|
||||
(equal? (record-type-field-names parent-rtd) '#(foo)))))
|
||||
|
||||
(with-test-prefix "record-field-mutable?"
|
||||
(pass-if "simple"
|
||||
(let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
|
||||
'#((mutable foo)
|
||||
(immutable bar)))))
|
||||
(and (record-field-mutable? rtd 0)
|
||||
(not (record-field-mutable? rtd 1))))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue