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 the one given to the custom-write procedure, copy the given port's
write handler, display handler, and print handler to the other port. write handler, display handler, and print handler to the other port.
The port given to a custom-write handler is not necessarily the actual The port given to @racket[write-proc] is not necessarily the actual
target port. In particular, to detect cycles and sharing, the printer target port. In particular, to detect cycles, sharing, and quoting
invokes a custom-write procedure with a port that records recursive modes (in the case of @racket[print]), the printer invokes a
prints, and does not retain any other output. 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 Recursive print operations may trigger an escape from a call to
custom-write procedure (e.g., for pretty-printing where a tentative @racket[write-proc]. For example, printing may escape during
print attempt overflows the line, or for printing error output of a pretty-printing where a tentative print attempt overflows the line, or
limited width). it may escape while printing error output that is constrained to a
limited width.
The following example definition of a @racket[tuple] type includes 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 angle brackets in @racket[write] and @racket[print] mode and no brackets in
@racket[display] mode. Elements of the tuple are printed recursively, @racket[display] mode. Elements of the tuple are printed recursively,
so that graph and cycle structure can be represented. so that graph and cycle structure can be represented.
@ -78,7 +83,8 @@ so that graph and cycle structure can be represented.
(write t)) (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[ @examples[
(eval:no-prompt (require racket/struct)) (eval:no-prompt (require racket/struct))

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

@ -594,5 +594,156 @@
(void)))) (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) (report-errs)

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

@ -427,7 +427,10 @@
(define mpair-open (if (print-mpair-curly-braces) "{" "(")) (define mpair-open (if (print-mpair-curly-braces) "{" "("))
(define mpair-close (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 show-inexactness? (pretty-print-show-inexactness))
(define exact-as-decimal? (pretty-print-exact-as-decimal)) (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 flvector->repeatless-list flvector-length flvector-ref equal? flvector->list)
(mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? fxvector->list) (mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? fxvector->list)
(define (extract-sub-objects obj pport) (define init-mode
(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 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 (cond
[(vector? obj) [display? #f]
(let ([len (vector-length obj)]) [print-as-qq? qq-depth]
(let vloop ([i 0]) [else #t]))
(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__ ;; Recur through the value to find to check for cycles, find graph
(when found-cycle ;; references, and determining unquoted/quoted printing modes. This
(let loop ([obj obj]) ;; loop fills in `table`, `found-cycle?`, and `escapes-table`.
(if (or (vector? obj) (let ([start-compound! (lambda (obj)
(pair? obj) (hash-set! table obj 'in-progress))]
(mpair? obj) [end-compound! (lambda (obj escapes?)
(and (box? obj) (when (eq? 'in-progress (hash-ref table obj #f))
print-box?) (hash-set! table obj 'done))
(and (custom-write? obj) escapes?)]
(not (struct-type? obj))) [escapes! (lambda (obj mode)
(and (struct? obj) print-struct?) (and (not (boolean? mode))
(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 (begin
(hash-set! table obj #f) (hash-set! escapes-table obj #t)
(cond #t)))]
[(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))]) [orf (lambda (a b) (or a b))])
(when print-as-qq? ;; Returns #t if `obj` needs to print as unquoted
(let loop ([obj obj]) (let loop ([obj obj] [mode init-mode])
(cond (cond
[(hash-ref table obj #f) [(hash-ref table obj #f)
;; already decided that it escapes => (lambda (g)
#t] ;; Note: counting all references as the same quoting mode
[(and local-compound (when (eq? g 'in-progress)
(hash-ref local-compound obj #f)) (set! found-cycle? #t))
;; either still deciding (so assume #f) or (hash-set! table obj (make-mark #f (box #f)))
;; already decided that no escape is needed #f)]
#f]
[else [else
(cond (cond
[(vector? obj) [(vector? obj)
(is-compound! obj) (start-compound! obj)
(end-compound!
obj
(let ([len (vector-length obj)]) (let ([len (vector-length obj)])
(let vloop ([esc? #f][i 0]) (let vloop ([esc? #f] [i 0])
(if (= i len) (if (= i len)
(and esc? (and esc?
(escapes! obj)) (escapes! obj mode))
(vloop (or (loop (vector-ref obj i)) esc?) (vloop (or (loop (vector-ref obj i) mode) esc?)
(add1 i)))))] (add1 i))))))]
[(flvector? obj) [(or (flvector? obj)
(is-compound! obj) (fxvector? obj))
;; always unquoted:
#t]
[(fxvector? obj)
(is-compound! obj)
;; always unquoted: ;; always unquoted:
#t] #t]
[(pair? obj) [(pair? obj)
(is-compound! obj) (start-compound! obj)
(and (orf (loop (car obj)) (end-compound!
(loop (cdr obj))) obj
(escapes! obj))] (and (orf (loop (car obj) mode)
(loop (cdr obj) mode))
(escapes! obj mode)))]
[(mpair? obj) [(mpair? obj)
(is-compound! obj) (start-compound! obj)
(loop (mcar obj)) (loop (mcar obj) mode)
(loop (mcdr obj)) (loop (mcdr obj) mode)
(end-compound!
obj
;; always unquoted: ;; always unquoted:
#t] #t)]
[(and (box? obj) print-box?) [(and (box? obj) print-box?)
(is-compound! obj) (start-compound! obj)
(and (loop (unbox obj)) (end-compound!
(escapes! obj))] obj
(and (loop (unbox obj) mode)
(escapes! obj mode)))]
[(and (custom-write? obj) [(and (custom-write? obj)
(not (struct-type? obj))) (not (struct-type? obj)))
(is-compound! obj) (start-compound! obj)
(let ([kind (if (custom-print-quotable? obj) (define kind (custom-print-quotable-accessor obj 'self))
(custom-print-quotable-accessor obj) (define escapes? (eq? kind 'never))
'self)]) (define (sub o p mode)
(and (or (and (loop (extract-sub-objects obj pport)) (define esc? (loop o mode))
(not (memq kind '(self always)))) (unless (or escapes?
(memq kind '(never))) (not esc?)
(escapes! obj)))] (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) [(struct? obj)
(is-compound! obj) (start-compound! obj)
(and (or (loop (struct->vector obj)) (end-compound!
obj
(and (or (loop (struct->vector obj) mode)
(not (prefab-struct-key obj))) (not (prefab-struct-key obj)))
(escapes! obj))] (escapes! obj mode)))]
[(hash? obj) [(hash? obj)
(unless (and (zero? (hash-count obj)) (cond
[(and (zero? (hash-count obj))
(immutable? obj)) (immutable? obj))
(is-compound! obj)) #f]
[else
(start-compound! obj)
(end-compound!
obj
(and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)])
(or (orf (loop v) (or (orf (loop v mode)
(loop k)) (loop k mode))
esc?)) esc?))
(escapes! obj))] (escapes! obj mode)))])]
[else #f])]))) [else #f])]))
table)) (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 cycle-counter 0)
(define found (if found-cycle (define found (and (or found-cycle? print-graph?)
table table))
#f))
(define dsub1 (lambda (d) (define dsub1 (lambda (d)
(if d (if d
@ -939,9 +873,7 @@
#f #f #f #f
(lambda () (lambda ()
(parameterize ([pretty-print-columns 'infinity]) (parameterize ([pretty-print-columns 'infinity])
(let ([qd (let ([kind (if (custom-print-quotable? obj) (let ([qd (let ([kind (custom-print-quotable-accessor obj 'self)])
(custom-print-quotable-accessor obj)
'self)])
(if (memq kind '(self never)) (if (memq kind '(self never))
qd qd
(to-quoted out qd obj)))]) (to-quoted out qd obj)))])

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

@ -184,7 +184,10 @@
(set! unquoted? (or e-unquoted? unquoted?)))] (set! unquoted? (or e-unquoted? unquoted?)))]
[else (build-graph e mode)])))) [else (build-graph e mode)]))))
(checking! v) (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?)] (done! v unquoted?)]
[(and (struct? v) [(and (struct? v)
(config-get config print-struct)) (config-get config print-struct))

95
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, static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt, Scheme_Marshal_Tables *mt,
PrintParams *pp, int notdisplay); 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); 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)) { } else if (SCHEME_CHAPERONE_STRUCTP(obj)) {
if (scheme_is_writable_struct(obj)) { if (scheme_is_writable_struct(obj)) {
if (pp->print_unreadable) { 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) { if (for_write >= 3) {
Scheme_Object *kind; 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 */ } else if (pp && SCHEME_CHAPERONE_STRUCTP(obj)) { /* got here => printable */
if (scheme_is_writable_struct(obj)) { if (scheme_is_writable_struct(obj)) {
if (pp->print_unreadable) { if (pp->print_unreadable)
obj = writable_struct_subs(obj, for_write, pp); (void)writable_struct_subs(obj, for_write, pp, SUBS_SETUP_GRAPH, ht, counter);
setup_graph_table(obj, for_write, ht, counter, pp);
}
} else { } else {
int i; int i;
@ -3811,23 +3814,50 @@ void scheme_set_type_printer(Scheme_Type stype, Scheme_Type_Printer printer)
/* custom writing */ /* 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 *p = (Scheme_Object *)_p;
Scheme_Object *v;
v = scheme_make_pair(argv[0], SCHEME_BOX_VAL(_b)); if (SCHEME_PAIRP(p)) { /* will always be a pair, so this is just in case */
SCHEME_BOX_VAL(_b) = v; 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; 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 *v, *o, *a[3], *cb, *pr;
Scheme_Object *d_accum_proc, *w_accum_proc, *p_accum_proc; Scheme_Object *d_callback_proc, *w_callback_proc, *p_callback_proc;
Scheme_Output_Port *op; 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); v = scheme_is_writable_struct(s);
o = scheme_make_null_output_port(pp->print_port o = scheme_make_null_output_port(pp->print_port
@ -3835,36 +3865,43 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin
op = (Scheme_Output_Port *)o; op = (Scheme_Output_Port *)o;
b = scheme_box(scheme_null); cb = scheme_make_vector(4, NULL);
d_accum_proc = scheme_make_closed_prim_w_arity(accum_write, SCHEME_VEC_ELS(cb)[0] = scheme_make_integer(mode);
b, 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", "custom-display-recur-handler",
2, 2); 2, 2);
w_accum_proc = scheme_make_closed_prim_w_arity(accum_write, w_callback_proc = scheme_make_closed_prim_w_arity(callback_write,
b, scheme_make_pair(cb, scheme_make_integer(1)),
"custom-write-recur-handler", "custom-write-recur-handler",
2, 2); 2, 2);
p_accum_proc = scheme_make_closed_prim_w_arity(accum_write, p_callback_proc = scheme_make_closed_prim_w_arity(callback_write,
b, scheme_make_pair(cb, scheme_make_integer(3)),
"custom-print-recur-handler", "custom-print-recur-handler",
2, 3); 2, 3);
op->display_handler = d_accum_proc; op->display_handler = d_callback_proc;
op->write_handler = w_accum_proc; op->write_handler = w_callback_proc;
op->print_handler = p_accum_proc; op->print_handler = p_callback_proc;
a[0] = s; a[0] = s;
a[1] = o; 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_apply_multi(v, 3, a);
scheme_close_output_port(o); scheme_close_output_port(o);
v = SCHEME_BOX_VAL(b); return SCHEME_INT_VAL(SCHEME_VEC_ELS(cb)[3]);
SCHEME_BOX_VAL(b) = NULL;
return v;
} }
static void flush_from_byte_port(Scheme_Object *orig_port, PrintParams *pp) static void flush_from_byte_port(Scheme_Object *orig_port, PrintParams *pp)