diff options
author | Andy Wingo <wingo@pobox.com> | 2011-08-17 10:47:04 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-08-17 10:47:04 +0200 |
commit | 8761623524d767e6e355f0de4c3be426ed3c8b09 (patch) | |
tree | c89b6a2256eb7deffa629753184842f36004bd87 /module/srfi/srfi-9.scm | |
parent | 42f9581238b011d15114bfd31606cbda10574d17 (diff) | |
download | guile-8761623524d767e6e355f0de4c3be426ed3c8b09.tar.gz |
srfi-9 record compatibility with boot-9 records
* module/srfi/srfi-9.scm (define-record-type): Instead of defining the
RTD using make-vtable, use make-struct with the record-type-vtable,
and record the type name and fields names in the vtable. This way
SRFI-9 records are compatible with boot-9 records. Also we use a
generic printer, instead of generating one anew.
Diffstat (limited to 'module/srfi/srfi-9.scm')
-rw-r--r-- | module/srfi/srfi-9.scm | 32 |
1 files changed, 22 insertions, 10 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index 6574a8da7..cb8dd0a19 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -95,6 +95,20 @@ (identifier? x) #'proc-name)))))))))) +(define (default-record-printer s p) + (display "#<" p) + (display (record-type-name (record-type-descriptor s)) p) + (let loop ((fields (record-type-fields (record-type-descriptor s))) + (off 0)) + (cond + ((not (null? fields)) + (display " " p) + (display (car fields) p) + (display ": " p) + (write (struct-ref s off) p) + (loop (cdr fields) (+ 1 off))))) + (display ">" p)) + (define-syntax define-record-type (lambda (x) (define (field-identifiers field-specs) @@ -177,16 +191,14 @@ (indices (field-indices (map syntax->datum fields)))) #`(begin (define type-name - (make-vtable #,layout - (lambda (obj port) - (format port "#<~A" 'type-name) - #,@(map (lambda (field) - (let* ((f (syntax->datum field)) - (i (assoc-ref indices f))) - #`(format port " ~A: ~S" '#,field - (struct-ref obj #,i)))) - fields) - (format port ">")))) + (let ((rtd (make-struct/no-tail + record-type-vtable + '#,(datum->syntax #'here (make-struct-layout layout)) + default-record-printer + 'type-name + '#,fields))) + (set-struct-vtable-name! rtd 'type-name) + rtd)) (define-inlinable (predicate-name obj) (and (struct? obj) (eq? (struct-vtable obj) type-name))) |