suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r6rs record fields should be vectors

Browse Source 
svn: r8890
This commit is contained in:
Matthew Flatt 2008-03-05 01:27:01 +00:00
parent 8e32f81c1b
commit 8d11cee42b
2 changed files with 31 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/r6rs/private/records-core.ss
View File

@ -119,34 +119,35 @@
(if (and parent
(record-type-sealed? parent))
(assertion-violation 'make-record-type-descriptor "can't extend a sealed parent type" parent))
(if (not (list? field-specs))
(assertion-violation 'make-record-type-descriptor "field specification must be a list" field-specs))
(let ((opaque? (if parent
(or (record-type-opaque? parent)
opaque?)
opaque?))
(field-specs (map parse-field-spec field-specs)))
(let ((rtd
(make-vector-type name
parent
(make-record-type-data name uid (and sealed? #t) (and opaque? #t) field-specs parent)
(append (append-field-mutable-specs parent)
(map field-spec-mutable? field-specs))
opaque?)))
(if uid
(cond
((uid->record-type-descriptor uid)
=> (lambda (old-rtd)
(if (record-type-descriptor=? rtd old-rtd)
old-rtd
(assertion-violation 'make-record-type
"mismatched nongenerative record types with identical uids"
old-rtd rtd))))
(else
(set! *nongenerative-record-types*
(cons rtd *nongenerative-record-types*))
rtd))
rtd))))
(if (not (vector? field-specs))
(assertion-violation 'make-record-type-descriptor "field specification must be a vector" field-specs))
(let ([field-specs (vector->list field-specs)])
(let ((opaque? (if parent
(or (record-type-opaque? parent)
opaque?)
opaque?))
(field-specs (map parse-field-spec field-specs)))
(let ((rtd
(make-vector-type name
parent
(make-record-type-data name uid (and sealed? #t) (and opaque? #t) field-specs parent)
(append (append-field-mutable-specs parent)
(map field-spec-mutable? field-specs))
opaque?)))
(if uid
(cond
((uid->record-type-descriptor uid)
=> (lambda (old-rtd)
(if (record-type-descriptor=? rtd old-rtd)
old-rtd
(assertion-violation 'make-record-type
"mismatched nongenerative record types with identical uids"
old-rtd rtd))))
(else
(set! *nongenerative-record-types*
(cons rtd *nongenerative-record-types*))
rtd))
rtd)))))
(define (record-type-descriptor? thing)
(and (vector-type? thing)
@ -177,7 +178,7 @@
spec))
(define (record-type-field-names rtd)
(map field-spec-name (record-type-field-specs rtd)))
(list->vector (map field-spec-name (record-type-field-specs rtd))))
(define (field-count rtd)
(let loop ((rtd rtd)

2
collects/r6rs/private/records-explicit.ss
View File

@ -196,7 +196,7 @@
(extract-nongenerative ?props)
(extract-sealed ?props)
(extract-opaque ?props)
'((?mutability ?field-name) ...)))
'#((?mutability ?field-name) ...)))
(define $constructor-descriptor
(make-record-constructor-descriptor