diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-22 15:05:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-22 16:22:48 +0200 |
commit | f060f1a4e69a21c6a95410f3cea0b7f957c3e2c0 (patch) | |
tree | 747835fe4a7beb875f85badd669efb5edd0e0740 | |
parent | 4bec125e634d88afabdc3cac16566144ccbf6d5f (diff) | |
download | guile-f060f1a4e69a21c6a95410f3cea0b7f957c3e2c0.tar.gz |
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.
-rw-r--r-- | doc/ref/api-data.texi | 28 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 69 | ||||
-rw-r--r-- | test-suite/tests/records.test | 52 |
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)))))) |