From 72055191b4b81f6a48415c0b3c8f6b80e462606c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Sep 2008 22:50:09 +0000 Subject: [PATCH] add printable<%> svn: r11705 --- collects/scheme/private/class-internal.ss | 14 +++- collects/scribblings/reference/class.scrbl | 19 +++++ .../scribblings/reference/eval-model.scrbl | 6 +- collects/tests/mzscheme/object.ss | 38 ++++++++++ src/mzscheme/src/port.c | 41 +++++++++++ src/mzscheme/src/print.c | 73 ++++++++++--------- src/mzscheme/src/schpriv.h | 1 - 7 files changed, 151 insertions(+), 41 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 6bfec81799..a755f01c56 100644 --- a/collects/scheme/private/class-internal.ss +++ b/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 diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 219a62e709..6a99448b84 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/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.} @; ------------------------------------------------------------------------ diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 86d85425e5..b9303df996 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/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 -step in evaluation actually consists of multiple concurrent -expressions, rather than a single expression. The expressions all +evaluation. Threads are created explicitly by functions such as @scheme[thread]. +In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent +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 diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 62951775e2..e5850aaf96 100644 --- a/collects/tests/mzscheme/object.ss +++ b/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) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 89570b0799..f49a88ed02 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -30,6 +30,7 @@ ports. */ #include "schpriv.h" +#include "schmach.h" #ifdef UNISTD_INCLUDE # include #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) { diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 76ee2c2b51..f4277a4d49 100644 --- a/src/mzscheme/src/print.c +++ b/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_CDR(obj), ht, counter, pp); + setup_graph_table(SCHEME_CAR(obj), for_write, 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); - setup_graph_table(obj, ht, counter, pp); + obj = writable_struct_subs(obj, for_write, 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(val, ht, counter, pp); + setup_graph_table(keys[i], for_write, 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(val, ht, counter, pp); + setup_graph_table(key, for_write, 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 *)¶ms, &fast_checker_counter); if (cycles == -1) { ht = scheme_make_hash_table(SCHEME_hash_ptr); - cycles = check_cycles(obj, ht, (PrintParams *)¶ms); + cycles = check_cycles(obj, write, ht, (PrintParams *)¶ms); } } if (cycles) - ht = scheme_setup_datum_graph(obj, (PrintParams *)¶ms); + ht = setup_datum_graph(obj, write, (PrintParams *)¶ms); 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); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 2227b9e20c..ef28bde3ea 100644 --- a/src/mzscheme/src/schpriv.h +++ b/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);