(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
(define (make-record-type type-name fields . opt)
- (let ((printer-fn (and (pair? opt) (car opt))))
- (let ((struct (make-struct record-type-vtable 0
- (make-struct-layout
- (apply string-append
- (map (lambda (f) "pw") fields)))
- (or printer-fn
- (lambda (s p)
- (display "#<" p)
- (display type-name p)
- (let loop ((fields fields)
- (off 0))
- (cond
- ((not (null? fields))
- (display " " p)
- (display (car fields) p)
- (display ": " p)
- (display (struct-ref s off) p)
- (loop (cdr fields) (+ 1 off)))))
- (display ">" p)))
- type-name
- (copy-tree 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! struct (if (symbol? type-name)
- type-name
- (string->symbol type-name)))
- struct)))
+ (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)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p))
+
+ (let ((struct (make-struct record-type-vtable 0
+ (make-struct-layout
+ (apply string-append
+ (map (lambda (f) "pw") fields)))
+ (or (and (pair? opt) (car opt))
+ default-record-printer)
+ type-name
+ (copy-tree 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! struct (if (symbol? type-name)
+ type-name
+ (string->symbol type-name)))
+ struct))
(define (record-type-name obj)
(if (record-type? obj)
;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-records)
+ #:use-module (ice-9 format)
#:use-module (test-suite lib))
-;; ascii names and symbols
-(define rtd-foo (make-record-type "foo" '(x y)))
+;; ascii names and symbols, custom printer
+(define rtd-foo (make-record-type "foo" '(x y)
+ (lambda (s p)
+ (display "#<it is a foo>" p))))
(define make-foo (record-constructor rtd-foo))
(define foo? (record-predicate rtd-foo))
(define get-foo-x (record-accessor rtd-foo 'x))
(define set-foo-x! (record-modifier rtd-foo 'x))
(define set-foo-y! (record-modifier rtd-foo 'y))
-;; non-Latin-1 names and symbols
+;; non-Latin-1 names and symbols, default printer
(define rtd-fŏŏ (make-record-type "fŏŏ" '(x ȳ)))
(define make-fŏŏ (record-constructor rtd-fŏŏ))
(define fŏŏ? (record-predicate rtd-fŏŏ))
(string=? "foo" (record-type-name rtd-foo)))
(pass-if "fŏŏ"
- (string=? "fŏŏ" (record-type-name rtd-fŏŏ)))))
+ (string=? "fŏŏ" (record-type-name rtd-fŏŏ))))
+
+ (with-test-prefix "printer"
+
+ (pass-if "foo"
+ (string=? "#<it is a foo>"
+ (with-output-to-string
+ (lambda () (display (make-foo 1 2))))))
+
+ (pass-if "fŏŏ"
+ (with-locale "en_US.utf8"
+ (string-prefix? "#<fŏŏ"
+ (with-output-to-string
+ (lambda () (display (make-fŏŏ 1 2)))))))))