suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add printable<%>

Browse Source 
svn: r11705
This commit is contained in:
Matthew Flatt 2008-09-12 22:50:09 +00:00
parent f7cd4784de
commit 72055191b4
7 changed files with 151 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/scheme/private/class-internal.ss
View File

@ -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

19
collects/scribblings/reference/class.scrbl
View File

@ -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.}
@; ------------------------------------------------------------------------

6
collects/scribblings/reference/eval-model.scrbl
View File

@ -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

38
collects/tests/mzscheme/object.ss
View File

@ -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)

41
src/mzscheme/src/port.c
View File

@ -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)
{

73
src/mzscheme/src/print.c
View File

@ -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 *)&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);

1
src/mzscheme/src/schpriv.h
View File

@ -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);