summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-data.texi28
-rw-r--r--module/ice-9/boot-9.scm69
-rw-r--r--test-suite/tests/records.test52
3 files changed, 108 insertions, 41 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 5b9c5654e..9b6cd88d4 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8630,7 +8630,8 @@ Note that @code{record?} may be true of any Scheme value; there is no
promise that records are disjoint with other Scheme types.
@end deffn
-@deffn {Scheme Procedure} make-record-type type-name field-names [print]
+@deffn {Scheme Procedure} make-record-type type-name field-names [print] @
+ [#:final?=@code{#t}] [parent=@code{#f}]
Create and return a new @dfn{record-type descriptor}.
@var{type-name} is a string naming the type. Currently it's only used
@@ -8646,19 +8647,24 @@ The optional @var{print} argument is a function used by
@code{display}, @code{write}, etc, for printing a record of the new
type. It's called as @code{(@var{print} record port)} and should look
at @var{record} and write to @var{port}.
+
+Pass the @code{#:parent} keyword to derive a record type from a
+supertype. A derived record type has the fields from its parent type,
+followed by fields declared in the @code{make-record-type} call. Record
+predicates and field accessors for instance of a parent type will also
+work on any instance of a subtype.
+
+@cindex final record types
+@cindex record types, final
+Allowing record subtyping has a small amount of overhead. To avoid this
+overhead, declare the record type as @dfn{final} by passing
+@code{#:final? #t}. Record types in Guile are final by default.
@end deffn
-@deffn {Scheme Procedure} record-constructor rtd [field-names]
+@deffn {Scheme Procedure} record-constructor rtd
Return a procedure for constructing new members of the type represented
-by @var{rtd}. The returned procedure accepts exactly as many arguments
-as there are symbols in the given list, @var{field-names}; these are
-used, in order, as the initial values of those fields in a new record,
-which is returned by the constructor procedure. The values of any
-fields not named in that list are unspecified. The @var{field-names}
-argument defaults to the list of field names in the call to
-@code{make-record-type} that created the type represented by @var{rtd};
-if the @var{field-names} argument is provided, it is an error if it
-contains any duplicates or any symbols not in the default list.
+by @var{rtd}. The result will be a procedure accepting exactly as many
+arguments as there are fields in the record type.
@end deffn
@deffn {Scheme Procedure} record-predicate rtd
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 24cecb02d..023838133 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1285,6 +1285,8 @@ VALUE."
(define parents
(cond
((record-type? parent)
+ (when (memq 'final (record-type-flags parent))
+ (error "parent type is final"))
(let* ((parent-parents (record-type-parents parent))
(parent-nparents (vector-length parent-parents))
(parents (make-vector (1+ parent-nparents))))
@@ -1362,36 +1364,37 @@ VALUE."
(and (< pos (vector-length parents))
(eq? (vector-ref parents pos) rtd))))))))))
-(define (%record-type-error rtd obj) ;; private helper
- (or (eq? rtd (record-type-descriptor obj))
- (scm-error 'wrong-type-arg "%record-type-check"
- "Wrong type record (want `~S'): ~S"
- (list (record-type-name rtd) obj)
- #f)))
-
(define (record-accessor rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
+ (let ((type-name (record-type-name rtd))
+ (pos (or (list-index (record-type-fields rtd) field-name)
+ (error 'no-such-field field-name)))
+ (pred (record-predicate rtd)))
(lambda (obj)
- (if (eq? (struct-vtable obj) rtd)
- (struct-ref obj pos)
- (%record-type-error rtd obj)))))
+ (unless (pred obj)
+ (scm-error 'wrong-type-arg "record-accessor"
+ "Wrong type argument (want `~S'): ~S"
+ (list type-name obj)
+ #f))
+ (struct-ref obj pos))))
(define (record-modifier rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
+ (let ((type-name (record-type-name rtd))
+ (pos (or (list-index (record-type-fields rtd) field-name)
+ (error 'no-such-field field-name)))
+ (pred (record-predicate rtd)))
(lambda (obj val)
- (if (eq? (struct-vtable obj) rtd)
- (struct-set! obj pos val)
- (%record-type-error rtd obj)))))
+ (unless (pred obj)
+ (scm-error 'wrong-type-arg "record-modifier"
+ "Wrong type argument (want `~S'): ~S"
+ (list type-name obj)
+ #f))
+ (struct-set! obj pos val))))
(define (record? obj)
(and (struct? obj) (record-type? (struct-vtable obj))))
(define (record-type-descriptor obj)
- (if (struct? obj)
+ (if (record? obj)
(struct-vtable obj)
(error 'not-a-record obj)))
@@ -1938,20 +1941,30 @@ name extensions listed in %load-extensions."
fragments))))
(define (getter rtd type-name field slot)
- #`(define #,(make-id rtd type-name '- field)
+ (define id (make-id rtd type-name '- field))
+ #`(define #,id
(let ((rtd #,rtd))
(lambda (#,type-name)
- (if (eq? (struct-vtable #,type-name) rtd)
- (struct-ref #,type-name #,slot)
- (%record-type-error rtd #,type-name))))))
+ (unless (eq? (struct-vtable #,type-name) rtd)
+ (scm-error 'wrong-type-arg
+ #,(symbol->string (syntax->datum id))
+ "Wrong type argument (want `~S'): ~S"
+ (list '#,type-name #,type-name)
+ #f))
+ (struct-ref #,type-name #,slot)))))
(define (setter rtd type-name field slot)
- #`(define #,(make-id rtd 'set- type-name '- field '!)
+ (define id (make-id rtd 'set- type-name '- field '!))
+ #`(define #,id
(let ((rtd #,rtd))
(lambda (#,type-name val)
- (if (eq? (struct-vtable #,type-name) rtd)
- (struct-set! #,type-name #,slot val)
- (%record-type-error rtd #,type-name))))))
+ (unless (eq? (struct-vtable #,type-name) rtd)
+ (scm-error 'wrong-type-arg
+ #,(symbol->string (syntax->datum id))
+ "Wrong type argument (want `~S'): ~S"
+ (list '#,type-name #,type-name)
+ #f))
+ (struct-set! #,type-name #,slot val)))))
(define (accessors rtd type-name fields n exp)
(syntax-case fields ()
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index c2ea06ed7..625a3db2e 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -1,6 +1,6 @@
;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2019 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
@@ -87,4 +87,52 @@
(with-locale "en_US.utf8"
(string-prefix? "#<fŏŏ"
(with-output-to-string
- (lambda () (display (make-fŏŏ 1 2)))))))))
+ (lambda () (display (make-fŏŏ 1 2))))))))
+
+ (with-test-prefix "subtyping"
+ (let ()
+ (define a (make-record-type 'a '(s t)))
+ (define b (make-record-type 'b '(u v) #:final? #f))
+ (define c (make-record-type 'c '(w x) #:parent b))
+
+ (pass-if "default final: a"
+ (and (memq 'final (record-type-flags a)) #t))
+ (pass-if "default final: b"
+ (not (memq 'final (record-type-flags b))))
+ (pass-if "default final: c"
+ (and (memq 'final (record-type-flags c)) #t))
+
+ (pass-if-exception "subtyping final: a" '(misc-error . "final")
+ (make-record-type 'd '(y x) #:parent a))
+ (pass-if-exception "subtyping final: c" '(misc-error . "final")
+ (make-record-type 'd '(y x) #:parent c))
+
+ (pass-if-equal "fields of subtype" '(u v w x)
+ (record-type-fields c))
+
+ (pass-if "final predicate: a? a"
+ ((record-predicate a) ((record-constructor a) 1 2)))
+ (pass-if "final predicate: a? b"
+ (not ((record-predicate a) ((record-constructor b) 1 2))))
+
+ (pass-if "non-final predicate: b? a"
+ (not ((record-predicate b) ((record-constructor a) 1 2))))
+ (pass-if "non-final predicate: b? b"
+ ((record-predicate b) ((record-constructor b) 1 2)))
+ (pass-if "non-final predicate: b? c"
+ ((record-predicate b) ((record-constructor c) 1 2 3 4)))
+
+ (pass-if "final predicate: c? a"
+ (not ((record-predicate c) ((record-constructor a) 1 2))))
+ (pass-if "final predicate: c? b"
+ (not ((record-predicate c) ((record-constructor b) 1 2))))
+ (pass-if "final predicate: c? c"
+ ((record-predicate c) ((record-constructor c) 1 2 3 4)))
+
+ (pass-if-equal "b accessor on b" 1
+ ((record-accessor b 'u) ((record-constructor b) 1 2)))
+ (pass-if-equal "b accessor on c" 1
+ ((record-accessor b 'u) ((record-constructor c) 1 2 3 4)))
+
+ (pass-if-equal "c accessor on c" 3
+ ((record-accessor c 'w) ((record-constructor c) 1 2 3 4))))))