diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-27 20:51:49 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-27 20:55:01 +0100 |
commit | 7a8e314d31ef8d40dd692bc27a93bc30c328e2b7 (patch) | |
tree | c4792f0516f132612fdca4959db6906e0efb751c /module/ice-9 | |
parent | 958aa8b313f771c281168ed56b23f2f8aebb72cc (diff) | |
download | guile-7a8e314d31ef8d40dd692bc27a93bc30c328e2b7.tar.gz |
Guile `make-record-type' supports non-generative definition
* module/ice-9/boot-9.scm (prefab-record-types): New definition.
(make-record-type): Add #:uid keyword.
* test-suite/tests/records.test ("records"): Add tests.
* doc/ref/api-data.texi (Records): Document #:uid
Diffstat (limited to 'module/ice-9')
-rw-r--r-- | module/ice-9/boot-9.scm | 67 |
1 files changed, 45 insertions, 22 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 8ea763259..3b2cdf709 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1233,8 +1233,11 @@ VALUE." (error 'not-a-record-type rtd)) (struct-ref rtd (+ 4 vtable-offset-user))) +(define prefab-record-types + (make-hash-table)) + (define* (make-record-type type-name fields #:optional printer #:key - (final? #t) parent) + (final? #t) parent uid) ;; Pre-generate constructors for nfields < 20. (define-syntax make-constructor (lambda (x) @@ -1338,27 +1341,47 @@ VALUE." (else (error "expected a symbol for record type name" type-name)))) - (define rtd - (make-struct/no-tail - record-type-vtable - (make-struct-layout - (apply string-append - (map (lambda (f) "pw") computed-fields))) - (or printer default-record-printer) - name-sym - computed-fields - #f ; Constructor initialized below. - (if final? '((final? . #t)) '()) - parents)) - - (struct-set! rtd (+ vtable-offset-user 2) - (make-constructor rtd (length computed-fields))) - - ;; Temporary solution: Associate a name to the record type descriptor - ;; so that the object system can create a wrapper class for it. - (set-struct-vtable-name! rtd name-sym) - - rtd) + (define properties + (if final? '((final? . #t)) '())) + + (cond + ((and uid (hashq-ref prefab-record-types uid)) + => (lambda (rtd) + (unless (and (equal? (record-type-name rtd) name-sym) + (equal? (record-type-fields rtd) computed-fields) + (not printer) + (equal? (record-type-properties rtd) properties) + (equal? (record-type-parents rtd) parents)) + (error "prefab record type declaration incompatible with previous" + rtd)) + rtd)) + (else + (let ((rtd (make-struct/no-tail + record-type-vtable + (make-struct-layout + (apply string-append + (map (lambda (f) "pw") computed-fields))) + (or printer default-record-printer) + name-sym + computed-fields + #f ; Constructor initialized below. + properties + parents))) + + (struct-set! rtd (+ vtable-offset-user 2) + (make-constructor rtd (length computed-fields))) + + ;; Temporary solution: Associate a name to the record type + ;; descriptor so that the object system can create a wrapper + ;; class for it. + (set-struct-vtable-name! rtd name-sym) + + (when uid + (unless (symbol? uid) + (error "UID for prefab record type should be a symbol" uid)) + (hashq-set! prefab-record-types uid rtd)) + + rtd)))) (define record-constructor (case-lambda |