mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +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) (identifier? x)
#'proc-name)))))))))) #'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 (define-syntax define-record-type
(lambda (x) (lambda (x)
(define (field-identifiers field-specs) (define (field-identifiers field-specs)
@ -177,16 +191,14 @@
(indices (field-indices (map syntax->datum fields)))) (indices (field-indices (map syntax->datum fields))))
#`(begin #`(begin
(define type-name (define type-name
(make-vtable #,layout (let ((rtd (make-struct/no-tail
(lambda (obj port) record-type-vtable
(format port "#<~A" 'type-name) '#,(datum->syntax #'here (make-struct-layout layout))
#,@(map (lambda (field) default-record-printer
(let* ((f (syntax->datum field)) 'type-name
(i (assoc-ref indices f))) '#,fields)))
#`(format port " ~A: ~S" '#,field (set-struct-vtable-name! rtd 'type-name)
(struct-ref obj #,i)))) rtd))
fields)
(format port ">"))))
(define-inlinable (predicate-name obj) (define-inlinable (predicate-name obj)
(and (struct? obj) (and (struct? obj)
(eq? (struct-vtable obj) type-name))) (eq? (struct-vtable obj) type-name)))