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.
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
--- /dev/null
+;;; 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
+\f
+
+(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)))
+)
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
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)))
(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
(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)))))
(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))
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 \
--- /dev/null
+;;; 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
+\f
+
+(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))))))
HCoop / bpt / guile.git / commitdiff