From: Marius Vollmer <mvo@zagadka.de>
Date: Wed, 4 Jun 1997 22:39:09 +0000 (+0000)
Subject: * boot-9.scm (struct-layout, %struct-printer-tag, struct-printer,
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/fa7e92746642ed139eaad0250d3c2a953bcd32dc

* 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 49d6fa596..03bd5ef9f 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -299,10 +299,88 @@
     (and rem (pair? (cdr rem)) (cadr rem))))
 
 
+
+;;; 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)))))
+
+
 ;;; {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 @@
 
 ;;; {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)))