mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Change record type "flags" field to "properties"

Browse source 
* module/ice-9/boot-9.scm (record-type-properties): Rename from
  record-type-flags.
  (record-type-final?): New accessor.
  (make-record-type):
  (define-record-type):
* test-suite/tests/records.test ("records"): Adapt.
This commit is contained in:
Andy Wingo 2019-10-27 20:03:51 +01:00
parent 04615d3c20
commit 958aa8b313
2 changed files with 11 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/ice-9/boot-9.scm
View file

@ -1220,11 +1220,14 @@ VALUE."
(error 'not-a-record-type rtd)) (error 'not-a-record-type rtd))
(struct-ref rtd (+ 2 vtable-offset-user))) (struct-ref rtd (+ 2 vtable-offset-user)))
(define (record-type-flags rtd) (define (record-type-properties rtd)
(unless (record-type? rtd) (unless (record-type? rtd)
(error 'not-a-record-type rtd)) (error 'not-a-record-type rtd))
(struct-ref rtd (+ 3 vtable-offset-user))) (struct-ref rtd (+ 3 vtable-offset-user)))
(define (record-type-final? rtd)
(assq-ref (record-type-properties rtd) 'final?))
(define (record-type-parents rtd) (define (record-type-parents rtd)
(unless (record-type? rtd) (unless (record-type? rtd)
(error 'not-a-record-type rtd)) (error 'not-a-record-type rtd))
@ -1285,7 +1288,7 @@ VALUE."
(define parents (define parents
(cond (cond
((record-type? parent) ((record-type? parent)
(when (memq 'final (record-type-flags parent)) (when (record-type-final? parent)
(error "parent type is final")) (error "parent type is final"))
(let* ((parent-parents (record-type-parents parent)) (let* ((parent-parents (record-type-parents parent))
(parent-nparents (vector-length parent-parents)) (parent-nparents (vector-length parent-parents))
@ -1345,7 +1348,7 @@ VALUE."
name-sym name-sym
computed-fields computed-fields
#f ; Constructor initialized below. #f ; Constructor initialized below.
(if final? '(final) '()) (if final? '((final? . #t)) '())
parents)) parents))
(struct-set! rtd (+ vtable-offset-user 2) (struct-set! rtd (+ vtable-offset-user 2)
@ -1379,7 +1382,7 @@ VALUE."
(define (record-predicate rtd) (define (record-predicate rtd)
(unless (record-type? rtd) (unless (record-type? rtd)
(error 'not-a-record-type rtd)) (error 'not-a-record-type rtd))
(if (memq 'final (record-type-flags rtd)) (if (record-type-final? rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))
(let ((pos (vector-length (record-type-parents rtd)))) (let ((pos (vector-length (record-type-parents rtd))))
;; Extensible record types form a forest of DAGs, with each ;; Extensible record types form a forest of DAGs, with each
@ -2066,7 +2069,7 @@ name extensions listed in %load-extensions."
'#,type-name '#,type-name
'#,(field-list fields) '#,(field-list fields)
#f ; constructor; set later #f ; constructor; set later
'() ; flags '() ; properties
#())) ; parents #())) ; parents
(set-struct-vtable-name! #,rtd '#,type-name))))) (set-struct-vtable-name! #,rtd '#,type-name)))))

9
test-suite/tests/records.test
View file

@ -95,12 +95,9 @@
(define b (make-record-type 'b '(u v) #:final? #f)) (define b (make-record-type 'b '(u v) #:final? #f))
(define c (make-record-type 'c '(w x) #:parent b)) (define c (make-record-type 'c '(w x) #:parent b))
(pass-if "default final: a" (pass-if (record-type-final? a))
(and (memq 'final (record-type-flags a)) #t)) (pass-if (not (record-type-final? b)))
(pass-if "default final: b" (pass-if (record-type-final? c))
(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") (pass-if-exception "subtyping final: a" '(misc-error . "final")
(make-record-type 'd '(y x) #:parent a)) (make-record-type 'd '(y x) #:parent a))