add printable<%>

svn: r11705

collects/scheme/private/class-internal.ss

@@ -30,7 +30,7 @@
              class?
              mixin
              interface interface?
-             object% object? externalizable<%>
+             object% object? externalizable<%> printable<%>
              object=?
              new make-object instantiate
              send send/apply send* class-field-accessor class-field-mutator with-method
@@ -2041,6 +2041,13 @@
 						   ;; Map object property to class:
 						   (append
 						    (list (cons prop:object c))
+                                                    (if (interface-extension? i printable<%>)
+                                                        (list (cons prop:custom-write
+                                                                    (lambda (obj port write?)
+                                                                      (if write?
+                                                                          (send obj custom-write port)
+                                                                          (send obj custom-display port)))))
+                                                        null)
 						    (if deserialize-id
 							(list
 							 (cons prop:serializable
@@ -3694,6 +3701,9 @@
   (define externalizable<%>
     (_interface () externalize internalize))
 
+  (define printable<%>
+    (_interface () custom-write custom-display))
+
   ;; Providing traced versions:
   (provide class-traced
            class*-traced
@@ -3735,7 +3745,7 @@
            class?
            mixin
 	   (rename-out [_interface interface]) interface?
-	   object% object? object=? externalizable<%>
+	   object% object? object=? externalizable<%> printable<%>
            new make-object instantiate
            get-field field-bound? field-names
 	   send send/apply send* class-field-accessor class-field-mutator with-method

collects/scribblings/reference/class.scrbl

@@ -1539,6 +1539,25 @@ The @scheme[externalizable<%>] interface includes only the
 @scheme[externalize] and @scheme[internalize] methods. See
 @scheme[define-serializable-class*] for more information.}
 
+@; ------------------------------------------------------------------------
+
+@section[#:tag "objectprinting"]{Object Printing}
+
+To customize the way that a class instance is printed by @scheme[write]
+or @scheme[display], implement the @scheme[printable<%>] interface.
+
+@defthing[printable<%> interface?]{
+
+The @scheme[printable<%>] interface includes only the
+@scheme[custom-write] and @scheme[custom-print] methods. Each accepts
+a single argument, which is the destination port to @scheme[write] or
+@scheme[display] the object.
+
+Calls to the @scheme[custom-write] or @scheme[custom-display] are like
+calls to a procedure attached to a structure type through the
+@scheme[prop:custom-write] property. In particular, recursive printing
+can trigger an escape from the call. See @scheme[prop:custom-write]
+for more information.}
 
 @; ------------------------------------------------------------------------
 

collects/scribblings/reference/eval-model.scrbl

@@ -651,9 +651,9 @@ escape-continuation aborts can cross continuation barriers.
 @section[#:tag "thread-model"]{Threads}
 
 Scheme supports multiple, pre-emptive @deftech{threads} of
-evaluation. In terms of the evaluation model, this means that each
+evaluation. Threads are created explicitly by functions such as @scheme[thread]. 
-step in evaluation actually consists of multiple concurrent
+In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent
-expressions, rather than a single expression. The expressions all
+expressions, up to one per thread, rather than a single expression. The expressions all
 share the same objects and top-level variables, so that they can
 communicate through shared state. Most evaluation steps involve a
 single step in a single expression, but certain synchronization

collects/tests/mzscheme/object.ss

@@ -1375,6 +1375,44 @@
 (let ([c% (class object% (define foo (lambda () 10)) (define/public (get) foo) (super-new))])
   (test 'foo object-name (send (new c%) get)))
 
+;; ----------------------------------------
+;; Implementing printable<%>
+
+(let ()
+  (define (check w-cycle? d-cycle?)
+    (define c% (class* object% (printable<%>) 
+                 (define/public (custom-write p)
+                   (if w-cycle?
+                       (write this p)
+                       (display "hi" p)))
+                 (define/public (custom-display p) 
+                   (if d-cycle?
+                       (display this p)
+                       (display "HI" p)))
+                 (super-new)))
+
+    (let ([p (open-output-bytes)])
+      (write (new c%) p)
+      (test (if w-cycle? #"#0=#0#" #"hi")
+            get-output-bytes p))
+    (let ([p (open-output-bytes)])
+      (display (new c%) p)
+      (test (if d-cycle? #"#0=#0#" #"HI")
+            get-output-bytes p))
+
+    (let ([p (open-output-bytes)])
+      (write (new (class c%
+                    (define/override (custom-write p)
+                      (write 777 p))
+                    (super-new)))
+             p)
+      (test #"777" get-output-bytes p)))
+
+  (check #f #f)
+  (check #t #f)
+  (check #f #t)
+  (check #t #t))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/mzscheme/src/port.c

@@ -30,6 +30,7 @@
    ports. */
 
 #include "schpriv.h"
+#include "schmach.h"
 #ifdef UNISTD_INCLUDE
 # include <unistd.h>
 #endif
@@ -6635,17 +6636,57 @@ scheme_make_null_output_port(int can_write_special)
 /*                         redirect output ports                          */
 /*========================================================================*/
 
+static Scheme_Object *redirect_write_bytes_k(void);
+
 static long
 redirect_write_bytes(Scheme_Output_Port *op,
 		     const char *str, long d, long len,
 		     int rarely_block, int enable_break)
 {
+  /* arbitrary nesting means we can overflow the stack */
+#ifdef DO_STACK_CHECK
+# include "mzstkchk.h"
+  {
+    Scheme_Thread *p = scheme_current_thread;
+    Scheme_Object *n;
+
+    p->ku.k.p1 = (void *)op;
+    p->ku.k.p2 = (void *)str;
+    p->ku.k.i1 = d;
+    p->ku.k.i2 = len;
+    p->ku.k.i3 = rarely_block;
+    p->ku.k.i4 = enable_break;
+
+    n = scheme_handle_stack_overflow(redirect_write_bytes_k);
+    return SCHEME_INT_VAL(n);
+  }
+#endif
+
   return scheme_put_byte_string("redirect-output",
 				(Scheme_Object *)op->port_data,
 				str, d, len,
 				rarely_block);
 }
 
+static Scheme_Object *redirect_write_bytes_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1;
+  const char *str = (const char *)p->ku.k.p2;
+  long d = p->ku.k.i1;
+  long len = p->ku.k.i2;
+  int rarely_block = p->ku.k.i3;
+  int enable_break = p->ku.k.i4;
+  long n;
+
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+
+  n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break);
+
+  return scheme_make_integer(n);
+}
+
 static void
 redirect_close_out (Scheme_Output_Port *port)
 {

src/mzscheme/src/print.c

@@ -112,7 +112,7 @@ static char *print_to_string(Scheme_Object *obj, long * volatile len, int write,
 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
                                 Scheme_Marshal_Tables *mt,
 				PrintParams *pp, int notdisplay);
-static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp);
+static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp);
 
 
 #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1)
@@ -394,7 +394,7 @@ scheme_internal_print(Scheme_Object *obj, Scheme_Object *port)
 }
 
 #ifdef DO_STACK_CHECK
-static int check_cycles(Scheme_Object *, Scheme_Hash_Table *ht, PrintParams *);
+static int check_cycles(Scheme_Object *, int, Scheme_Hash_Table *ht, PrintParams *);
 
 static Scheme_Object *check_cycle_k(void)
 {
@@ -407,12 +407,12 @@ static Scheme_Object *check_cycle_k(void)
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
 
-  return check_cycles(o, ht, pp)
+  return check_cycles(o, p->ku.k.i1, ht, pp)
     ? scheme_true : scheme_false;
 }
 #endif
 
-static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *pp)
+static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, PrintParams *pp)
 {
   Scheme_Type t;
 
@@ -424,6 +424,7 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
       scheme_current_thread->ku.k.p1 = (void *)obj;
       scheme_current_thread->ku.k.p2 = (void *)ht;
       scheme_current_thread->ku.k.p3 = (void *)pp;
+      scheme_current_thread->ku.k.i1 = for_write;
       return SCHEME_TRUEP(scheme_handle_stack_overflow(check_cycle_k));
     }
   }
@@ -451,27 +452,27 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     return 0;
 
   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
-    if (check_cycles(SCHEME_CAR(obj), ht, pp))
+    if (check_cycles(SCHEME_CAR(obj), for_write, ht, pp))
       return 1;
-    if (check_cycles(SCHEME_CDR(obj), ht, pp))
+    if (check_cycles(SCHEME_CDR(obj), for_write, ht, pp))
       return 1;
   } else if (SCHEME_BOXP(obj)) {
     /* got here => printable */
-    if (check_cycles(SCHEME_BOX_VAL(obj), ht, pp))
+    if (check_cycles(SCHEME_BOX_VAL(obj), for_write, ht, pp))
       return 1;
   } else if (SCHEME_VECTORP(obj)) {
     int i, len;
 
     len = SCHEME_VEC_SIZE(obj);
     for (i = 0; i < len; i++) {
-      if (check_cycles(SCHEME_VEC_ELS(obj)[i], ht, pp)) {
+      if (check_cycles(SCHEME_VEC_ELS(obj)[i], for_write, ht, pp)) {
 	return 1;
       }
     }
   } else if (SAME_TYPE(t, scheme_structure_type)
 	     || SAME_TYPE(t, scheme_proc_struct_type)) {
     if (scheme_is_writable_struct(obj)) {
-      if (check_cycles(writable_struct_subs(obj, pp), ht, pp))
+      if (check_cycles(writable_struct_subs(obj, for_write, pp), for_write, ht, pp))
 	return 1;
     } else {
       /* got here => printable */
@@ -479,7 +480,7 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
 
       while (i--) {
 	if (scheme_inspector_sees_part(obj, pp->inspector, i)) {
-	  if (check_cycles(((Scheme_Structure *)obj)->slots[i], ht, pp)) {
+	  if (check_cycles(((Scheme_Structure *)obj)->slots[i], for_write, ht, pp)) {
 	    return 1;
 	  }
 	}
@@ -497,9 +498,9 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     for (i = t->size; i--; ) {
       if (vals[i]) {
 	val = vals[i];
-	if (check_cycles(keys[i], ht, pp))
+	if (check_cycles(keys[i], for_write, ht, pp))
 	  return 1;
-	if (check_cycles(val, ht, pp))
+	if (check_cycles(val, for_write, ht, pp))
 	  return 1;
       }
     }
@@ -512,9 +513,9 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     i = scheme_hash_tree_next(t, -1);
     while (i != -1) {
       scheme_hash_tree_index(t, i, &key, &val);
-      if (check_cycles(key, ht, pp))
+      if (check_cycles(key, for_write, ht, pp))
         return 1;
-      if (check_cycles(val, ht, pp))
+      if (check_cycles(val, for_write, ht, pp))
         return 1;
       i = scheme_hash_tree_next(t, i);
     }
@@ -614,7 +615,7 @@ END_XFORM_SKIP;
 #endif
 
 #ifdef DO_STACK_CHECK
-static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
+static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
 
 static Scheme_Object *setup_graph_k(void)
 {
@@ -623,19 +624,20 @@ static Scheme_Object *setup_graph_k(void)
   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p2;
   int *counter = (int *)p->ku.k.p3;
   PrintParams *pp = (PrintParams *)p->ku.k.p4;
+  int for_write = p->ku.k.i1;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
   p->ku.k.p4 = NULL;
 
-  setup_graph_table(o, ht, counter, pp);
+  setup_graph_table(o, for_write, ht, counter, pp);
 
   return scheme_false;
 }
 #endif
 
-static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
+static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht,
 			      int *counter, PrintParams *pp)
 {
   if (HAS_SUBSTRUCT(obj, ssQUICKp)) {
@@ -651,6 +653,7 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
 	scheme_current_thread->ku.k.p2 = (void *)ht;
 	scheme_current_thread->ku.k.p3 = (void *)counter;
 	scheme_current_thread->ku.k.p4 = (void *)pp;
+        scheme_current_thread->ku.k.i1 = for_write;
 	scheme_handle_stack_overflow(setup_graph_k);
 	return;
       }
@@ -674,29 +677,29 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
   SCHEME_USE_FUEL(1);
 
   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
-    setup_graph_table(SCHEME_CAR(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_CAR(obj), for_write, ht, counter, pp);
-    setup_graph_table(SCHEME_CDR(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_CDR(obj), for_write, ht, counter, pp);
   } else if ((!pp || pp->print_box) && SCHEME_BOXP(obj)) {
-    setup_graph_table(SCHEME_BOX_VAL(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_BOX_VAL(obj), for_write, ht, counter, pp);
   } else if (SCHEME_VECTORP(obj)) {
     int i, len;
 
     len = SCHEME_VEC_SIZE(obj);
     for (i = 0; i < len; i++) {
-      setup_graph_table(SCHEME_VEC_ELS(obj)[i], ht, counter, pp);
+      setup_graph_table(SCHEME_VEC_ELS(obj)[i], for_write, ht, counter, pp);
     }
   } else if (pp && SCHEME_STRUCTP(obj)) { /* got here => printable */
     if (scheme_is_writable_struct(obj)) {
       if (pp->print_unreadable) {
-	obj = writable_struct_subs(obj, pp);
+	obj = writable_struct_subs(obj, for_write, pp);
-	setup_graph_table(obj, ht, counter, pp);
+	setup_graph_table(obj, for_write, ht, counter, pp);
       }
     } else {
       int i = SCHEME_STRUCT_NUM_SLOTS(obj);
 
       while (i--) {
 	if (scheme_inspector_sees_part(obj, pp->inspector, i))
-	  setup_graph_table(((Scheme_Structure *)obj)->slots[i], ht, counter, pp);
+	  setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp);
       }
     }
   } else if (pp && SCHEME_HASHTP(obj)) { /* got here => printable */
@@ -710,8 +713,8 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
     for (i = t->size; i--; ) {
       if (vals[i]) {
 	val = vals[i];
-	setup_graph_table(keys[i], ht, counter, pp);
+	setup_graph_table(keys[i], for_write, ht, counter, pp);
-	setup_graph_table(val, ht, counter, pp);
+	setup_graph_table(val, for_write, ht, counter, pp);
       }
     }
   } else if (SCHEME_HASHTRP(obj)) {
@@ -723,8 +726,8 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
     i = scheme_hash_tree_next(t, -1);
     while (i != -1) {
       scheme_hash_tree_index(t, i, &key, &val);
-      setup_graph_table(key, ht, counter, pp);
+      setup_graph_table(key, for_write, ht, counter, pp);
-      setup_graph_table(val, ht, counter, pp);
+      setup_graph_table(val, for_write, ht, counter, pp);
       i = scheme_hash_tree_next(t, i);
     }
   }
@@ -732,7 +735,7 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
 
 #define CACHE_HT_SIZE_LIMIT 32
 
-Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print)
+static Scheme_Hash_Table *setup_datum_graph(Scheme_Object *o, int for_write, void *for_print)
 {
   Scheme_Hash_Table *ht;
   int counter = 1;
@@ -743,7 +746,7 @@ Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print)
   } else
     ht = scheme_make_hash_table(SCHEME_hash_ptr);
 
-  setup_graph_table(o, ht, &counter, (PrintParams *)for_print);
+  setup_graph_table(o, for_write, ht, &counter, (PrintParams *)for_print);
 
   if (counter > 1)
     return ht;
@@ -847,12 +850,12 @@ print_to_string(Scheme_Object *obj,
     cycles = check_cycles_fast(obj, (PrintParams *)&params, &fast_checker_counter);
     if (cycles == -1) {
       ht = scheme_make_hash_table(SCHEME_hash_ptr);
-      cycles = check_cycles(obj, ht, (PrintParams *)&params);
+      cycles = check_cycles(obj, write, ht, (PrintParams *)&params);
     }
   }
 
   if (cycles)
-    ht = scheme_setup_datum_graph(obj, (PrintParams *)&params);
+    ht = setup_datum_graph(obj, write, (PrintParams *)&params);
   else
     ht = NULL;
 
@@ -2488,7 +2491,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
       pp->print_box = 1;
       
       q_ht = scheme_make_hash_table(SCHEME_hash_ptr);
-      setup_graph_table(v, q_ht, &counter, pp);
+      setup_graph_table(v, notdisplay, q_ht, &counter, pp);
 
       if (compact)
 	print_compact(pp, CPT_QUOTE);
@@ -3251,7 +3254,7 @@ static Scheme_Object *accum_write(void *_b, int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
-static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp)
+static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp)
 {
   Scheme_Object *v, *o, *a[3], *b, *accum_proc;
   Scheme_Output_Port *op;
@@ -3275,7 +3278,7 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp)
 
   a[0] = s;
   a[1] = o;
-  a[2] = scheme_false;
+  a[2] = (for_write ? scheme_true : scheme_false);
 
   scheme_apply_multi(v, 3, a);
 

src/mzscheme/src/schpriv.h

@@ -804,7 +804,6 @@ int scheme_stx_proper_list_length(Scheme_Object *list);
 Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx);
 
 Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj);
-Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print);
 
 Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *stx);