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

improve consistency of printers and prop:custom-write

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2020-01-14 16:50:32 -07:00
parent 738d2b7a81
commit 712494312a
5 changed files with 373 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/racket-doc/scribblings/reference/custom-write.scrbl
View File

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

151
pkgs/racket-test-core/tests/racket/print.rktl
View File

@ -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 "#<mine: " port)
(if mode
(write val port)
(display val port))
(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) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#t #t))
(expect (displayln y) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#f #f))
(printf "Wrapped list 'always\n")
(define z (mine/always x))
(expect (println z) "'#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(1 1))
(expect (writeln z) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#t #t))
(expect (displayln z) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\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) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#t #t))
(expect (displayln y/c) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\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) "'#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(1 1))
(expect (writeln z/c) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#t #t))
(expect (displayln z/c) "#<mine: (#&CONTENT #(struct:my-struct (1 a)))>\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 '#&#0# (my-struct '(1 a))))\n")
(check-saw-mode '(0 0) '(0 0 0))
(expect (writeln y) "#<mine: #0=(#&#0# #(struct:my-struct (1 a)))>\n")
(check-saw-mode '(#t #t) '(#t #t #t))
(expect (displayln y) "#<mine: #0=(#&#0# #(struct:my-struct (1 a)))>\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) "#<mine: (#&CONTENT)>\n")
(check-saw-mode '(#t #t))
(expect (displayln yq) "#<mine: (#&CONTENT)>\n")
(check-saw-mode '(#f #f))
(printf "Wrapped quotable list 'maybe\n")
(define yqm (mine/maybe '(#&CONTENT)))
(expect (println yqm) "'#<mine: (#&CONTENT)>\n")
(check-saw-mode '(0 1)) ; guess unquoted, discovered to be quoted
(expect (writeln yqm) "#<mine: (#&CONTENT)>\n")
(check-saw-mode '(#t #t))
(expect (displayln yqm) "#<mine: (#&CONTENT)>\n")
(check-saw-mode '(#f #f))
(void))
(show println writeln displayln)
(show pretty-print pretty-write pretty-display))
(report-errs)

322
racket/collects/racket/pretty.rkt
View File

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

5
racket/src/io/print/graph.rkt
View File

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

113
racket/src/racket/src/print.c
View File

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