[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-75-g8aaf061

[Julian Graham]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8aaf061b0a57417062a8f69c4c3ddf4f5180474f

The branch, wip-r6rs-libraries has been updated
       via  8aaf061b0a57417062a8f69c4c3ddf4f5180474f (commit)
       via  3ab26d918f3a8edf680e255bcda4b16c2138b0c0 (commit)
      from  58b75e94d8964c8538116cd73cc4ef1935718778 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 8aaf061b0a57417062a8f69c4c3ddf4f5180474f
Author: Julian Graham <address@hidden>
Date:   Wed Mar 10 01:36:15 2010 -0500

    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.

commit 3ab26d918f3a8edf680e255bcda4b16c2138b0c0
Author: Julian Graham <address@hidden>
Date:   Wed Mar 10 01:26:12 2010 -0500

    Remove needless import of (rnrs io simple).
    
    * module/rnrs/6/conditions.scm: Remove (rnrs io simple (6)) from imports.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                            |    3 +-
 module/rnrs/6/conditions.scm                  |    1 -
 module/rnrs/records/6/inspection.scm          |   83 ++++++++++++++
 module/rnrs/records/6/procedural.scm          |  128 +++++++++++++---------
 test-suite/Makefile.am                        |    1 +
 test-suite/tests/r6rs-records-inspection.test |  148 +++++++++++++++++++++++++
 6 files changed, 309 insertions(+), 55 deletions(-)
 create mode 100644 module/rnrs/records/6/inspection.scm
 create mode 100644 test-suite/tests/r6rs-records-inspection.test

diff --git a/module/Makefile.am b/module/Makefile.am
index 3d1c968..a98b8e9 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index 461984f..b489999 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -83,7 +83,6 @@
          make-undefined-violation
          undefined-violation?)
   (import (rnrs base (6))
-         (rnrs io simple (6))
          (rnrs records procedural (6))
          (rnrs records syntactic (6))
          (rnrs syntax-case (6)))
diff --git a/module/rnrs/records/6/inspection.scm 
b/module/rnrs/records/6/inspection.scm
new file mode 100644
index 0000000..ee9f1f0
--- /dev/null
+++ b/module/rnrs/records/6/inspection.scm
@@ -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)))
+)
diff --git a/module/rnrs/records/6/procedural.scm 
b/module/rnrs/records/6/procedural.scm
index 01c94de..a14842e 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/module/rnrs/records/6/procedural.scm
@@ -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))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index ca48ab2..0e821bf 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -73,6 +73,7 @@ SCM_TESTS = tests/alist.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/ramap.test                    \
            tests/reader.test                   \
diff --git a/test-suite/tests/r6rs-records-inspection.test 
b/test-suite/tests/r6rs-records-inspection.test
new file mode 100644
index 0000000..717bb49
--- /dev/null
+++ b/test-suite/tests/r6rs-records-inspection.test
@@ -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))))))


hooks/post-receive
-- 
GNU Guile