* boot-9.scm (struct-layout, %struct-printer-tag, struct-printer,

make-struct-printer, set-struct-printer-in-vtable!): New bindings
to support printing of structures.
(record-type-vtable, make-record-type): Add slot to hold printing
function and initialize it with something appropriate.  Removed
commented out printing code.
(record-type-name, record-type-fields): Adjusted slot offsets.
(%print-module): Reduce argument list to "mod" and "port".

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 49d6fa5..03bd5ef 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -299,10 +299,88 @@
     (and rem (pair? (cdr rem)) (cadr rem))))
 
 \f
+
+;;; Printing structs
+
+;; The printing of structures can be customized by setting the builtin
+;; variable *struct-printer* to a procedure.  A second dispatching
+;; step is implemented here to allow for struct-type specific printing
+;; procedures.
+;;
+;; A particular type of structures is characterized by its vtable.  In
+;; addition to some internal fields, such a vtable can contain
+;; arbitrary user-defined fields.  We use the first of these fields to
+;; hold the specific printing procedure.  To avoid breaking code that
+;; already uses this first extra-field for some other purposes, we use
+;; a unique tag to decide whether it really contains a structure
+;; printer or not.
+;;
+;; XXX - Printing structures is probably fundamental enough that we
+;; can simply hardcode the vtable slot convention and expect everyone
+;; to obey it.
+;;
+;; A structure-type specific printer follows the same calling
+;; convention as the builtin *struct-printer*.
+
+;; A shorthand for one already hardcoded vtable convention
+
+(define (struct-layout s)
+  (struct-ref (struct-vtable s) 0))
+
+;; This is our new convention for storing printing procedures
+
+(define %struct-printer-tag (cons '%struct-printer-tag #f))
+
+(define (struct-printer s)
+  (and (>= (string-length (struct-layout s))
+          (* 2 struct-vtable-offset))
+       (let ((p (struct-ref (struct-vtable s) struct-vtable-offset)))
+        (and (eq? (car p) %struct-printer-tag)
+             (cdr p)))))
+
+(define (make-struct-printer printer)
+  (cons %struct-printer-tag printer))
+
+;; Note: While the printer is extracted from a structure itself, it
+;; has to be set in the vtable of the structure.
+
+(define (set-struct-printer-in-vtable! vtable printer)
+  (struct-set! vtable struct-vtable-offset (make-struct-printer printer)))
+
+;; The dispatcher
+
+(set! *struct-printer* (lambda (s p)
+                        (let ((printer (struct-printer s)))
+                          (and printer
+                               (printer s p)))))
+
+\f
 ;;; {Records}
 ;;;
 
-(define record-type-vtable (make-vtable-vtable "prpr" 0))
+;; Printing records: by default, records are printed as
+;;
+;;   #<type-name field1: val1 field2: val2 ...>
+;;
+;; You can change that by giving a custom printing function to
+;; MAKE-RECORD-TYPE (after the list of field symbols).  This function
+;; will be called like
+;;
+;;   (<printer> object port)
+;;
+;; It should print OBJECT to PORT.
+
+;; 0: printer, 1: type-name, 2: fields
+(define record-type-vtable 
+  (make-vtable-vtable "prprpr" 0
+                     (make-struct-printer
+                      (lambda (s p)
+                        (cond ((eq? s record-type-vtable)
+                               (display "#<record-type-vtable>" p))
+                              (else
+                               (display "#<record-type " p)
+                               (display (record-type-name s) p)
+                               (display ">" p)))))))
 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
@@ -313,25 +391,33 @@
                               (make-struct-layout
                                (apply symbol-append
                                       (map (lambda (f) "pw") fields)))
+                              (make-struct-printer
+                               (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))))
-      ;; !!! leaks printer functions
-      ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it
-      ;; possible to print records nicely.
-      ;(if printer-fn
-;        (extend-print-style! default-print-style
-;                             (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
-;                             printer-fn))
       struct)))
 
 (define (record-type-name obj)
   (if (record-type? obj)
-      (struct-ref obj struct-vtable-offset)
+      (struct-ref obj (+ 1 struct-vtable-offset))
       (error 'not-a-record-type obj)))
 
 (define (record-type-fields obj)
   (if (record-type? obj)
-      (struct-ref obj (+ 1 struct-vtable-offset))
+      (struct-ref obj (+ 2 struct-vtable-offset))
       (error 'not-a-record-type obj)))
 
 (define (record-constructor rtd . opt)
@@ -1078,8 +1164,12 @@
 \f
 ;;; {Printing Modules}
 ;; This is how modules are printed.  You can re-define it.
-;;
-(define (%print-module mod port depth length style table)
+;; (Redefining is actually more complicated than simply redefining
+;; %print-module because that would only change the binding and not
+;; the value stored in the vtable that determines how record are
+;; printed. Sigh.)
+
+(define (%print-module mod port)  ; unused args: depth length style table)
   (display "#<" port)
   (display (or (module-kind mod) "module") port)
   (let ((name (module-name mod)))