From 712494312aa35e920c2feaf3e6a7c134b5f8c42a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Jan 2020 16:50:32 -0700 Subject: [PATCH] improve consistency of printers and `prop:custom-write` The pretty printer and built-in printer for traditional Racket did not consistently provide the current quoting mode while checking for unquoting and cycles. All printers, including the Racket CS printer, are improved for a structure type that has `prop:custom-print-quotable` as 'always, in which case we know that unquoting- and cycle-checking time that the components will be in quoted mode. The pretty printer also made three passes through a value to check for cycles, compute cycles, and compute unquotes, and those are now fused into a single pass like the Racket CS printer. The built-in printer for traditional Racket still makes up to two passes, but it now behaves more like other printers by recurring immediately on nested calls via `prop:custom-write` instead of accumulating them for after the `prop:custom-write` callback returns. The documentation clarifies that synthesizing new values during printing can interefere with cycle checking and unquoting, but the printers now react to that behavior more consistently. --- .../scribblings/reference/custom-write.scrbl | 26 +- pkgs/racket-test-core/tests/racket/print.rktl | 151 ++++++++ racket/collects/racket/pretty.rkt | 322 +++++++----------- racket/src/io/print/graph.rkt | 5 +- racket/src/racket/src/print.c | 113 +++--- 5 files changed, 373 insertions(+), 244 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/custom-write.scrbl b/pkgs/racket-doc/scribblings/reference/custom-write.scrbl index 96f5ecb3c6..666510b8e2 100644 --- a/pkgs/racket-doc/scribblings/reference/custom-write.scrbl +++ b/pkgs/racket-doc/scribblings/reference/custom-write.scrbl @@ -31,18 +31,23 @@ transfer the result to the target port using @racket[write-string] or the one given to the custom-write procedure, copy the given port's write handler, display handler, and print handler to the other port. -The port given to a custom-write handler is not necessarily the actual -target port. In particular, to detect cycles and sharing, the printer -invokes a custom-write procedure with a port that records recursive -prints, and does not retain any other output. +The port given to @racket[write-proc] is not necessarily the actual +target port. In particular, to detect cycles, sharing, and quoting +modes (in the case of @racket[print]), the printer invokes a +custom-write procedure with a port that records information about +recursive prints, and does not retain any other output. This +information-gathering phase needs the same objects (in the +@racket[eq?] sense) to be printed as later, so that the recorded +information can be correlated with printed values. -Recursive print operations may trigger an escape from the call to the -custom-write procedure (e.g., for pretty-printing where a tentative -print attempt overflows the line, or for printing error output of a -limited width). +Recursive print operations may trigger an escape from a call to +@racket[write-proc]. For example, printing may escape during +pretty-printing where a tentative print attempt overflows the line, or +it may escape while printing error output that is constrained to a +limited width. The following example definition of a @racket[tuple] type includes -custom-write procedures that print the tuple's list content using +a @racket[write-proc] procedure that prints the tuple's list content using angle brackets in @racket[write] and @racket[print] mode and no brackets in @racket[display] mode. Elements of the tuple are printed recursively, so that graph and cycle structure can be represented. @@ -78,7 +83,8 @@ so that graph and cycle structure can be represented. (write t)) ] -This function is often used in conjunction with @racket[make-constructor-style-printer]. +The @racket[make-constructor-style-printer] function can help in the +implementation of a @racket[write-proc], as in this example: @examples[ (eval:no-prompt (require racket/struct)) diff --git a/pkgs/racket-test-core/tests/racket/print.rktl b/pkgs/racket-test-core/tests/racket/print.rktl index 5ce95c9c0c..42b92b7d6d 100644 --- a/pkgs/racket-test-core/tests/racket/print.rktl +++ b/pkgs/racket-test-core/tests/racket/print.rktl @@ -594,5 +594,156 @@ (void)))) ;; ---------------------------------------- +;; More `prop:custom-write` and `prop:custom-print-quotable` checking. +;; Make sure the `prop:custom-write` callback gets an approrpriate +;; printing mode, even when looking for quoting modes and cycles, and +;; check behavior when the callback synthesizes a new lists. The +;; `ptest` tests above already do a lot of that, but this test covers +;; some additional corners. +;; Based on an example by Ryan Kramer. + +(let () + (struct my-struct (item) #:transparent) + + (define modes '()) + + (define (check-saw-mode . alts) + (define ms (reverse modes)) + (set! modes '()) + (test #t ms (and (member ms alts) #t))) + + (define-syntax-rule (expect e output) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o]) + e) + (test output get-output-string o))) + + (define (go port mode val) + (set! modes (cons mode modes)) + (case mode + [(#f #t 1) + (display "#" port)] + [else + (display "(mine " port) + (print val port mode) + (display ")" port)])) + + (struct mine (content) + #:property + prop:custom-write + (lambda (v port mode) + (go port mode (mine-content v)))) + + (struct mine/copy (content) + #:property + prop:custom-write + (lambda (v port mode) + (go port mode (apply list (mine/copy-content v))))) + + (struct mine/always (content) + #:property + prop:custom-print-quotable 'always + #:property + prop:custom-write + (lambda (v port mode) + (go port mode (mine/always-content v)))) + + (struct mine/maybe (content) + #:property + prop:custom-print-quotable 'maybe + #:property + prop:custom-write + (lambda (v port mode) + (go port mode (mine/maybe-content v)))) + + (struct mine/copy/always (content) + #:property + prop:custom-print-quotable 'always + #:property + prop:custom-write + (lambda (v port mode) + (go port mode (apply list (mine/copy/always-content v))))) + + (define (show println writeln displayln) + (define b (box 'CONTENT)) + (define x (list b (my-struct '(1 a)))) + + (printf "List\n") + (expect (println x) "(list '#&CONTENT (my-struct '(1 a)))\n") + (expect (writeln x) "(#&CONTENT #(struct:my-struct (1 a)))\n") + (expect (displayln x) "(#&CONTENT #(struct:my-struct (1 a)))\n") + + (printf "Wrapped list\n") + (define y (mine x)) + (expect (println y) "(mine (list '#&CONTENT (my-struct '(1 a))))\n") + (check-saw-mode '(0 0)) + (expect (writeln y) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln y) "#\n") + (check-saw-mode '(#f #f)) + + (printf "Wrapped list 'always\n") + (define z (mine/always x)) + (expect (println z) "'#\n") + (check-saw-mode '(1 1)) + (expect (writeln z) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln z) "#\n") + (check-saw-mode '(#f #f)) + + (printf "Wrapped list copied on print\n") + (define y/c (mine/copy x)) + (expect (println y/c) "(mine '(#&CONTENT #(struct:my-struct (1 a))))\n") + (check-saw-mode '(0 0)) + (expect (writeln y/c) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln y/c) "#\n") + (check-saw-mode '(#f #f)) + + (printf "Wrapped list copied on print 'always\n") + (define z/c (mine/copy/always x)) + (expect (println z/c) "'#\n") + (check-saw-mode '(1 1)) + (expect (writeln z/c) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln z/c) "#\n") + (check-saw-mode '(#f #f)) + + (printf "Wrapped cycle list\n") + (set-box! b x) + ;; The printer may need two passes to sort out cycles + (expect (println y) "(mine #0=(list '#�# (my-struct '(1 a))))\n") + (check-saw-mode '(0 0) '(0 0 0)) + (expect (writeln y) "#\n") + (check-saw-mode '(#t #t) '(#t #t #t)) + (expect (displayln y) "#\n") + (check-saw-mode '(#f #f) '(#f #f #f)) + + (printf "Wrapped quotable list\n") + (define yq (mine '(#&CONTENT))) + (expect (println yq) "(mine '(#&CONTENT))\n") + (check-saw-mode '(0 0)) + (expect (writeln yq) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln yq) "#\n") + (check-saw-mode '(#f #f)) + + (printf "Wrapped quotable list 'maybe\n") + (define yqm (mine/maybe '(#&CONTENT))) + (expect (println yqm) "'#\n") + (check-saw-mode '(0 1)) ; guess unquoted, discovered to be quoted + (expect (writeln yqm) "#\n") + (check-saw-mode '(#t #t)) + (expect (displayln yqm) "#\n") + (check-saw-mode '(#f #f)) + + (void)) + + (show println writeln displayln) + (show pretty-print pretty-write pretty-display)) (report-errs) diff --git a/racket/collects/racket/pretty.rkt b/racket/collects/racket/pretty.rkt index c45650ecaa..7476ac2c2f 100644 --- a/racket/collects/racket/pretty.rkt +++ b/racket/collects/racket/pretty.rkt @@ -427,7 +427,10 @@ (define mpair-open (if (print-mpair-curly-braces) "{" "(")) (define mpair-close (if (print-mpair-curly-braces) "}" ")")) - (define table (make-hasheq)) ; Hash table for looking for loops + (define table (make-hasheq)) ; For graph structure: object -> mark + (define found-cycle? #f) + + (define escapes-table (make-hasheq)) ; For print quoting: object -> boolean[unquoted?] (define show-inexactness? (pretty-print-show-inexactness)) (define exact-as-decimal? (pretty-print-exact-as-decimal)) @@ -462,202 +465,133 @@ (mkvector->repeatless-list flvector->repeatless-list flvector-length flvector-ref equal? flvector->list) (mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? fxvector->list) - (define (extract-sub-objects obj pport) - (let ([p (open-output-nowhere 'null (port-writes-special? pport))] - [l null]) - (let ([record (lambda (o p) (set! l (cons o l)))]) - (port-write-handler p record) - (port-display-handler p record) - (port-print-handler p record)) - (parameterize ([pretty-printing #f]) - ((custom-write-accessor obj) obj p #f)) - l)) + (define init-mode + (cond + [display? #f] + [print-as-qq? qq-depth] + [else #t])) - (define found-cycle - (or print-graph? - (let loop ([obj obj]) - (and (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) - print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash? obj) - (not (and (zero? (hash-count obj)) - (immutable? obj))) - print-hash-table?)) - (or (hash-ref table obj #f) - (begin - (hash-set! table obj #t) - (let ([cycle - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (if (= i len) - #f - (or (loop (vector-ref obj i)) - (vloop (add1 i))))))] - [(pair? obj) - (or (loop (car obj)) - (loop (cdr obj)))] - [(mpair? obj) - (or (loop (mcar obj)) - (loop (mcdr obj)))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (ormap loop - (vector->list (struct->vector obj)))] - [(hash? obj) - (for/or ([(k v) (in-hash obj)]) - (or (loop v) (loop k)))])]) - (hash-remove! table obj) - cycle))))))) - - (define __dummy__ - (when found-cycle - (let loop ([obj obj]) - (if (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) - print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash? obj) - (not (and (zero? (hash-count obj)) - (immutable? obj))) - print-hash-table?)) - ;; A little confusing: use #t for not-found - (let ([p (hash-ref table obj #t)]) - (when (not (mark? p)) - (if p - (begin - (hash-set! table obj #f) - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (unless (= i len) - (loop (vector-ref obj i)) - (vloop (add1 i)))))] - [(pair? obj) - (loop (car obj)) - (loop (cdr obj))] - [(mpair? obj) - (loop (mcar obj)) - (loop (mcdr obj))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (for-each loop - (vector->list (struct->vector obj)))] - [(hash? obj) - (hash-for-each - obj - (lambda (k v) - (loop k) - (loop v)))])) - (begin - (hash-set! table obj - (make-mark #f (box #f))))))) - (void))))) - - (define escapes-table - (let* ([table (make-hasheq)] - [local-compound (and print-as-qq? - (make-hasheq))] - [is-compound! (lambda (obj) - (hash-set! local-compound obj #t))] - [escapes! (lambda (obj) - (hash-set! table obj #t) - #t)] - [orf (lambda (a b) (or a b))]) - (when print-as-qq? - (let loop ([obj obj]) - (cond - [(hash-ref table obj #f) - ;; already decided that it escapes + ;; Recur through the value to find to check for cycles, find graph + ;; references, and determining unquoted/quoted printing modes. This + ;; loop fills in `table`, `found-cycle?`, and `escapes-table`. + (let ([start-compound! (lambda (obj) + (hash-set! table obj 'in-progress))] + [end-compound! (lambda (obj escapes?) + (when (eq? 'in-progress (hash-ref table obj #f)) + (hash-set! table obj 'done)) + escapes?)] + [escapes! (lambda (obj mode) + (and (not (boolean? mode)) + (begin + (hash-set! escapes-table obj #t) + #t)))] + [orf (lambda (a b) (or a b))]) + ;; Returns #t if `obj` needs to print as unquoted + (let loop ([obj obj] [mode init-mode]) + (cond + [(hash-ref table obj #f) + => (lambda (g) + ;; Note: counting all references as the same quoting mode + (when (eq? g 'in-progress) + (set! found-cycle? #t)) + (hash-set! table obj (make-mark #f (box #f))) + #f)] + [else + (cond + [(vector? obj) + (start-compound! obj) + (end-compound! + obj + (let ([len (vector-length obj)]) + (let vloop ([esc? #f] [i 0]) + (if (= i len) + (and esc? + (escapes! obj mode)) + (vloop (or (loop (vector-ref obj i) mode) esc?) + (add1 i))))))] + [(or (flvector? obj) + (fxvector? obj)) + ;; always unquoted: #t] - [(and local-compound - (hash-ref local-compound obj #f)) - ;; either still deciding (so assume #f) or - ;; already decided that no escape is needed - #f] - [else + [(pair? obj) + (start-compound! obj) + (end-compound! + obj + (and (orf (loop (car obj) mode) + (loop (cdr obj) mode)) + (escapes! obj mode)))] + [(mpair? obj) + (start-compound! obj) + (loop (mcar obj) mode) + (loop (mcdr obj) mode) + (end-compound! + obj + ;; always unquoted: + #t)] + [(and (box? obj) print-box?) + (start-compound! obj) + (end-compound! + obj + (and (loop (unbox obj) mode) + (escapes! obj mode)))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (start-compound! obj) + (define kind (custom-print-quotable-accessor obj 'self)) + (define escapes? (eq? kind 'never)) + (define (sub o p mode) + (define esc? (loop o mode)) + (unless (or escapes? + (not esc?) + (boolean? mode) + (eq? kind 'self) + (eq? kind 'always)) + (set! escapes? #t))) + (let ([p (open-output-nowhere 'null (port-writes-special? pport))]) + (port-write-handler p (lambda (o p) (sub o p #t))) + (port-display-handler p (lambda (o p) (sub o p #f))) + (port-print-handler p (lambda (o p [mode 0]) (sub o p mode))) + (parameterize ([pretty-printing #f]) + ((custom-write-accessor obj) obj p (if (and (eqv? mode 0) ; => unquoted + (eq? kind 'always)) + 1 ; sub parts always quoted + mode)))) + (end-compound! + obj + (and escapes? + (escapes! obj mode)))] + [(struct? obj) + (start-compound! obj) + (end-compound! + obj + (and (or (loop (struct->vector obj) mode) + (not (prefab-struct-key obj))) + (escapes! obj mode)))] + [(hash? obj) (cond - [(vector? obj) - (is-compound! obj) - (let ([len (vector-length obj)]) - (let vloop ([esc? #f][i 0]) - (if (= i len) - (and esc? - (escapes! obj)) - (vloop (or (loop (vector-ref obj i)) esc?) - (add1 i)))))] - [(flvector? obj) - (is-compound! obj) - ;; always unquoted: - #t] - [(fxvector? obj) - (is-compound! obj) - ;; always unquoted: - #t] - [(pair? obj) - (is-compound! obj) - (and (orf (loop (car obj)) - (loop (cdr obj))) - (escapes! obj))] - [(mpair? obj) - (is-compound! obj) - (loop (mcar obj)) - (loop (mcdr obj)) - ;; always unquoted: - #t] - [(and (box? obj) print-box?) - (is-compound! obj) - (and (loop (unbox obj)) - (escapes! obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (is-compound! obj) - (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) - (and (or (and (loop (extract-sub-objects obj pport)) - (not (memq kind '(self always)))) - (memq kind '(never))) - (escapes! obj)))] - [(struct? obj) - (is-compound! obj) - (and (or (loop (struct->vector obj)) - (not (prefab-struct-key obj))) - (escapes! obj))] - [(hash? obj) - (unless (and (zero? (hash-count obj)) - (immutable? obj)) - (is-compound! obj)) - (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) - (or (orf (loop v) - (loop k)) - esc?)) - (escapes! obj))] - [else #f])]))) - table)) + [(and (zero? (hash-count obj)) + (immutable? obj)) + #f] + [else + (start-compound! obj) + (end-compound! + obj + (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) + (or (orf (loop v mode) + (loop k mode)) + esc?)) + (escapes! obj mode)))])] + [else #f])])) + (when (or found-cycle? print-graph?) + ;; Remove unwanted table entries: + (for ([k (in-list (hash-keys table))]) + (when (eq? (hash-ref table k #f) 'done) + (hash-remove! table k))))) (define cycle-counter 0) - (define found (if found-cycle - table - #f)) + (define found (and (or found-cycle? print-graph?) + table)) (define dsub1 (lambda (d) (if d @@ -939,9 +873,7 @@ #f #f (lambda () (parameterize ([pretty-print-columns 'infinity]) - (let ([qd (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) + (let ([qd (let ([kind (custom-print-quotable-accessor obj 'self)]) (if (memq kind '(self never)) qd (to-quoted out qd obj)))]) @@ -1557,7 +1489,7 @@ (pr obj 0 pp-expr depth qd)) (define (to-quoted out qd obj) - (and qd + (and qd (if (zero? qd) (if (hash-ref escapes-table obj #f) qd diff --git a/racket/src/io/print/graph.rkt b/racket/src/io/print/graph.rkt index 6b251da3fe..693f1e0718 100644 --- a/racket/src/io/print/graph.rkt +++ b/racket/src/io/print/graph.rkt @@ -184,7 +184,10 @@ (set! unquoted? (or e-unquoted? unquoted?)))] [else (build-graph e mode)])))) (checking! v) - ((custom-write-accessor v) v checking-port mode) + ((custom-write-accessor v) v checking-port (if (and (eq? mode PRINT-MODE/UNQUOTED) + (eq? print-quotable 'always)) + PRINT-MODE/QUOTED + mode)) (done! v unquoted?)] [(and (struct? v) (config-get config print-struct)) diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 356858f8a8..4e1581a36e 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -127,7 +127,12 @@ static char *print_to_string(Scheme_Object *obj, intptr_t * volatile len, int wr 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, int for_write, PrintParams *pp); + +static int writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp, + int mode, Scheme_Hash_Table *ht, int *counter); + +#define SUBS_CHECK_CYCLES 1 +#define SUBS_SETUP_GRAPH 2 static Scheme_Object *srcloc_path_to_string(Scheme_Object *p); @@ -579,7 +584,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht } else if (SCHEME_CHAPERONE_STRUCTP(obj)) { if (scheme_is_writable_struct(obj)) { if (pp->print_unreadable) { - res = check_cycles(writable_struct_subs(obj, for_write, pp), for_write, ht, pp); + res = writable_struct_subs(obj, for_write, pp, SUBS_CHECK_CYCLES, ht, NULL); if (for_write >= 3) { Scheme_Object *kind; @@ -884,10 +889,8 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab } } else if (pp && SCHEME_CHAPERONE_STRUCTP(obj)) { /* got here => printable */ if (scheme_is_writable_struct(obj)) { - if (pp->print_unreadable) { - obj = writable_struct_subs(obj, for_write, pp); - setup_graph_table(obj, for_write, ht, counter, pp); - } + if (pp->print_unreadable) + (void)writable_struct_subs(obj, for_write, pp, SUBS_SETUP_GRAPH, ht, counter); } else { int i; @@ -3811,22 +3814,49 @@ void scheme_set_type_printer(Scheme_Type stype, Scheme_Type_Printer printer) /* custom writing */ /*========================================================================*/ -static Scheme_Object *accum_write(void *_b, int argc, Scheme_Object **argv) +static Scheme_Object *callback_write(void *_p, int argc, Scheme_Object **argv) { - if (SCHEME_BOX_VAL(_b)) { - Scheme_Object *v; - v = scheme_make_pair(argv[0], SCHEME_BOX_VAL(_b)); - SCHEME_BOX_VAL(_b) = v; + Scheme_Object *p = (Scheme_Object *)_p; + + if (SCHEME_PAIRP(p)) { /* will always be a pair, so this is just in case */ + Scheme_Object *v = SCHEME_CAR(p); + if (SCHEME_VECTORP(v)) { /* will always be a vector, so this is just in case */ + int cb_mode = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[0]); + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)(SCHEME_VEC_ELS(v)[1]); + int *counter = (int *)SCHEME_CAR(SCHEME_VEC_ELS(v)[2]); + PrintParams *pp = (PrintParams *)SCHEME_CDR(SCHEME_VEC_ELS(v)[2]); + int mode = SCHEME_INT_VAL(SCHEME_CDR(p)); + + if (argc > 2) + mode += SCHEME_INT_VAL(argv[2]); + + if (cb_mode == SUBS_CHECK_CYCLES) { + int res; + res = check_cycles(argv[0], mode, ht, pp); + SCHEME_VEC_ELS(v)[3] = scheme_make_integer(res | SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[3])); + } else { + setup_graph_table(argv[0], mode, ht, counter, pp); + } + } } return scheme_void; } -static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp) +/* the `mode` argument determines a callback; result is useful for `SUBS_CHECK_CYCLES` mode */ +static int writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp, + int mode, Scheme_Hash_Table *ht, int *counter) { - Scheme_Object *v, *o, *a[3], *b; - Scheme_Object *d_accum_proc, *w_accum_proc, *p_accum_proc; + Scheme_Object *v, *o, *a[3], *cb, *pr; + Scheme_Object *d_callback_proc, *w_callback_proc, *p_callback_proc; Scheme_Output_Port *op; + + if (for_write >= 3) { + Scheme_Object *kind; + kind = scheme_print_attribute_ref(s); + if (kind && !strcmp(SCHEME_SYM_VAL(kind), "always")) + for_write = 4; /* sub parts are always in quoted mode */ + } v = scheme_is_writable_struct(s); @@ -3834,37 +3864,44 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin && ((Scheme_Output_Port *)pp->print_port)->write_special_fun); op = (Scheme_Output_Port *)o; - - b = scheme_box(scheme_null); - d_accum_proc = scheme_make_closed_prim_w_arity(accum_write, - b, - "custom-display-recur-handler", - 2, 2); - w_accum_proc = scheme_make_closed_prim_w_arity(accum_write, - b, - "custom-write-recur-handler", - 2, 2); - p_accum_proc = scheme_make_closed_prim_w_arity(accum_write, - b, - "custom-print-recur-handler", - 2, 3); - op->display_handler = d_accum_proc; - op->write_handler = w_accum_proc; - op->print_handler = p_accum_proc; + cb = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(cb)[0] = scheme_make_integer(mode); + SCHEME_VEC_ELS(cb)[1] = (Scheme_Object *)ht; + pr = scheme_make_raw_pair((Scheme_Object *)counter, (Scheme_Object *)pp); /* raw pair can wrap a raw pointers */ + SCHEME_VEC_ELS(cb)[2] = pr; + SCHEME_VEC_ELS(cb)[3] = scheme_make_integer(0); /* for SUBS_CHECK_CYCLES mode */ + + d_callback_proc = scheme_make_closed_prim_w_arity(callback_write, + scheme_make_pair(cb, scheme_make_integer(0)), + "custom-display-recur-handler", + 2, 2); + w_callback_proc = scheme_make_closed_prim_w_arity(callback_write, + scheme_make_pair(cb, scheme_make_integer(1)), + "custom-write-recur-handler", + 2, 2); + p_callback_proc = scheme_make_closed_prim_w_arity(callback_write, + scheme_make_pair(cb, scheme_make_integer(3)), + "custom-print-recur-handler", + 2, 3); + + op->display_handler = d_callback_proc; + op->write_handler = w_callback_proc; + op->print_handler = p_callback_proc; a[0] = s; a[1] = o; - a[2] = (for_write ? scheme_true : scheme_false); + a[2] = (for_write + ? ((for_write >= 3) + ? scheme_make_integer(for_write-3) + : scheme_true) + : scheme_false); scheme_apply_multi(v, 3, a); - + scheme_close_output_port(o); - - v = SCHEME_BOX_VAL(b); - SCHEME_BOX_VAL(b) = NULL; - - return v; + + return SCHEME_INT_VAL(SCHEME_VEC_ELS(cb)[3]); } static void flush_from_byte_port(Scheme_Object *orig_port, PrintParams *pp)