mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Record accessors respect subtyping
* module/ice-9/boot-9.scm (make-record-type): Don't allow subtyping of final types. (%record-type-error): Remove helper. (record-accessor, record-modifier): Use computed record type predicate, to allow for subtyping. (define-record-type): Adapt to %record-type-error going away; these types are final so no accessor adaptation is needed. * test-suite/tests/records.test: Add tests. * doc/ref/api-data.texi (Records): Update.
This commit is contained in:
Andy Wingo
parent
4bec125e63
commit
f060f1a4e6
3 changed files with 108 additions and 41 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue