diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index f18fc02cd7..a17f0b9d47 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -997,10 +997,11 @@ profile todo: (super-new))) (define test-covered-style-delta (make-object style-delta%)) - (send test-covered-style-delta set-delta-foreground "forest green") - (define test-not-covered-style-delta (make-object style-delta%)) - (send test-not-covered-style-delta set-delta-foreground "firebrick") + + ;; test colors chosen to try to be color-blindness friendly + (send test-covered-style-delta set-delta-foreground "forest green") + (send test-not-covered-style-delta set-delta-foreground "maroon") (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color)) diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index dbe054e00b..acb0f40b1d 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -256,9 +256,9 @@ (define interface-widgets (list ok username passwd assignment retrieve?)) (define (disable-interface) - (for ([x interface-widgets]) (send x enable #f))) + (for ([x (in-list interface-widgets)]) (send x enable #f))) (define (enable-interface) - (for ([x interface-widgets]) (send x enable #t) )) + (for ([x (in-list interface-widgets)]) (send x enable #t) )) (define (done-interface) (send cancel set-label "Close") (send cancel focus)) @@ -309,7 +309,7 @@ (handin-disconnect h) (error 'handin "there are no active assignments")) (set! connection h) - (for ([assign l]) (send assignment append assign)) + (for ([assign (in-list l)]) (send assignment append assign)) (send assignment enable #t) (set! ok-can-enable? #t) (activate-ok) @@ -575,8 +575,8 @@ "Password Error" (format "The \"~a\" and \"~a\" passwords are not the same." l1 l2)) (k (void)))) - (for ([t (if new? add-user-fields change-user-fields)] - [f (or user-fields '())]) + (for ([t (in-list (if new? add-user-fields change-user-fields))] + [f (in-list (or user-fields '()))]) (check-length t 100 f k)) (send tabs enable #f) (parameterize ([current-custodian comm-cust]) @@ -716,7 +716,7 @@ [stream (make-object editor-stream-out% base)]) (write-editor-version stream base) (write-editor-global-header stream) - (for ([ed editors]) (send ed write-to-file stream)) + (for ([ed (in-list editors)]) (send ed write-to-file stream)) (write-editor-global-footer stream) (send base get-bytes))) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index 680c138e36..545416698d 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -19,7 +19,7 @@ (error (apply format fmt args))) (define (write+flush port . xs) - (for ([x xs]) (write x port) (newline port)) + (for ([x (in-list xs)]) (write x port) (newline port)) (flush-output port)) (define (close-handin-ports h) diff --git a/collects/handin-client/handin-multi.ss b/collects/handin-client/handin-multi.ss index 8425077ade..ca198a6d06 100644 --- a/collects/handin-client/handin-multi.ss +++ b/collects/handin-client/handin-multi.ss @@ -27,7 +27,7 @@ (let/ec return (parameterize ([current-output-port (open-output-bytes)]) (printf "~a\n" magic) - (for ([file files]) + (for ([file (in-list files)]) (let ([size (and (file-exists? file) (file-size file))]) (unless size (return #f)) (let ([buf (with-input-from-file file @@ -71,7 +71,7 @@ (string? (car x)) (bytes? (cadr x)))) files)) (error* "Error in retrieved content: bad format")) - (for ([file files]) + (for ([file (in-list files)]) (let ([file (car file)] [buf (cadr file)]) (when (write? file) (with-output-to-file file diff --git a/collects/handin-client/updater.ss b/collects/handin-client/updater.ss index bb226ed1ce..05d34dade4 100644 --- a/collects/handin-client/updater.ss +++ b/collects/handin-client/updater.ss @@ -17,7 +17,7 @@ (define (update!) (let* ([in (file->inport package-filename)] [outf (make-temporary-file "tmp~a.plt")] - [out (open-output-file outf 'binary 'truncate)]) + [out (open-output-file outf #:mode 'binary #:exists 'truncate)]) (dynamic-wind void (lambda () (copy-port in out)) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 01abf7ab88..b9337a2b05 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -191,7 +191,7 @@ ;; This code will hack textualization of text boxes (define (insert-to-editor editor . xs) - (for ([x xs]) + (for ([x (in-list xs)]) (send editor insert (if (string? x) x (make-object editor-snip% x))))) ;; support for "text-box%" @@ -282,7 +282,7 @@ '(ok-cancel caution))))) (error* "Aborting..."))) ;; This will create copies of the original files - ;; (for ([file files]) + ;; (for ([file (in-list files)]) ;; (with-output-to-file (car file) ;; (lambda () (display (cadr file)) (flush-output)))) (let* ([pfx-len (string-length markup-prefix)] @@ -298,7 +298,7 @@ (display ===) (newline)) (parameterize ([current-output-port (open-output-bytes)]) - (for ([file files]) + (for ([file (in-list files)]) (sep (car file)) (parameterize ([current-input-port (open-input-bytes (cadr file))] [current-processed-file (car file)]) @@ -389,7 +389,7 @@ [user-post (id 'user-post)] [(body ...) (syntax-case #'(body ...) () [() #'(void)] [_ #'(body ...)])]) - (for ([x keyvals]) + (for ([x (in-list keyvals)]) (unless (memq (car x) got) (raise-syntax-error #f "unknown keyword" stx (cadr x)))) #'(begin @@ -470,7 +470,7 @@ (set-run-status "creating text file") (with-output-to-file text-file #:exists 'truncate (lambda () - (for ([user users]) + (for ([user (in-list users)]) (prefix-line (user-substs user student-line))) (for-each prefix-line/substs extra-lines) (for-each prefix-line/substs diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index 260ef0a1ea..8c58415ff1 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -24,7 +24,7 @@ (error (apply format fmt args))) (define (write+flush port . xs) - (for ([x xs]) (write x port) (newline port)) + (for ([x (in-list xs)]) (write x port) (newline port)) (flush-output port)) (define-struct alist (name [l #:mutable])) @@ -87,7 +87,7 @@ ;; SUCCESS, or things that are newer in the main submission ;; directory are kept (but subdirs in SUCCESS will are copied as ;; is)) - (for ([f (directory-list dir)]) + (for ([f (in-list (directory-list dir))]) (define dir/f (build-path dir f)) (cond [(not (or (file-exists? f) (directory-exists? f))) ;; f is in dir but not in the working directory @@ -116,10 +116,10 @@ (define (cleanup-all-submissions) (log-line "Cleaning up all submission directories") - (for ([pset (get-conf 'all-dirs)] + (for ([pset (in-list (get-conf 'all-dirs))] #:when (directory-exists? pset)) ; just in case (parameterize ([current-directory pset]) - (for ([sub (directory-list)] + (for ([sub (in-list (directory-list))] #:when (directory-exists? sub)) ; filter non-dirs (cleanup-submission sub))))) @@ -370,7 +370,7 @@ (error* "the username \"checker.ss\" is reserved")) (when (get-user-data username) (error* "username already exists: `~a'" username)) - (for ([str extra-fields] + (for ([str (in-list extra-fields)] [info (get-conf 'extra-fields)]) (check-field str (cadr info) (car info) (caddr info))) (wait-for-lock "+newuser+") @@ -397,8 +397,8 @@ (error* "changing information not allowed: ~a" username)) (when (equal? new-data old-data) (error* "no fields changed: ~a" username)) - (for ([str (cdr new-data)] - [info (get-conf 'extra-fields)]) + (for ([str (in-list (cdr new-data))] + [info (in-list (get-conf 'extra-fields))]) (check-field str (cadr info) (car info) (caddr info))) (log-line "change info for ~a ~s -> ~s" username old-data new-data) (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss index 2246c88fb2..3f6176fe38 100644 --- a/collects/handin-server/private/logger.ss +++ b/collects/handin-server/private/logger.ss @@ -74,5 +74,6 @@ (current-error-port (make-logger-port (and (get-conf 'log-output) (current-output-port)) - (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] + (cond [(get-conf 'log-file) + => (lambda (f) (open-output-file f #:exists 'append))] [else #f])))) 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);