mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

srfi-9 record compatibility with boot-9 records

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-08-17 10:47:04 +02:00
parent 42f9581238
commit 8761623524
1 changed files with 22 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

32
module/srfi/srfi-9.scm
View file

@ -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)))