summaryrefslogtreecommitdiff
path: root/module/rnrs/records
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-10 01:36:15 -0500
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:02 -0400
commit55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1 (patch)
treeb1ad3d9c98c0c2237afe95856e24c3772e94350d /module/rnrs/records
parent8b58ea453916338a60b8e8cc8d785c82a801b4ae (diff)
downloadguile-55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1.tar.gz
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.
Diffstat (limited to 'module/rnrs/records')
-rw-r--r--module/rnrs/records/6/inspection.scm83
-rw-r--r--module/rnrs/records/6/procedural.scm126
2 files changed, 157 insertions, 52 deletions
diff --git a/module/rnrs/records/6/inspection.scm b/module/rnrs/records/6/inspection.scm
new file mode 100644
index 000000000..ee9f1f097
--- /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 01c94de83..a14842e1c 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))