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

cs: fix printf and handler interaction

Browse Source 
Fixes inconsistency in the uses of handlers compared to traditional
Racket, and repairs a crash for displaying byte strings via `~a`.
This commit is contained in:
Matthew Flatt 2019-10-18 18:36:57 -06:00
parent 588778d14c
commit 3c2efafbf5
5 changed files with 66 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -117,7 +117,7 @@ escapes:
@item{@FmtMark{.}@nonterm{c} where @nonterm{c} is @litchar{a},
@litchar{A}, @litchar{s}, @litchar{S}, @litchar{v}, or @litchar{V}:
truncates @racket[display], @racket[write], or @racket[print] output
truncates default-handler @racket[display], @racket[write], or @racket[print] output
to @racket[(error-print-width)] characters, using @litchar{...} as
the last three characters if the untruncated output would be longer}

33
pkgs/racket-test-core/tests/racket/file.rktl
View File

@ -914,6 +914,39 @@
(err/rt-test (port-write-handler sp (lambda (x) 9)))
(err/rt-test (port-write-handler sp (lambda (x y z) 9)))
;; Check use of handlers by `printf`
(let ()
(define p (open-output-bytes))
(port-display-handler p (lambda (x p)
(write-bytes #"D" p)))
(port-write-handler p (lambda (x p)
(write-bytes #"W" p)))
(port-print-handler p (lambda (x p [d 0])
(write-bytes #"P" p)))
(display 'x p)
(fprintf p "~a" 'y)
(fprintf p "~.a" 'z) ; does not use handler
(write 'x p)
(fprintf p "~s" 'y)
(fprintf p "~.s" 'z) ; does not use handler
(print 'x p)
(fprintf p "~v" 'y)
(fprintf p "~.v" 'z) ; does not use handler
(test #"DDzWWzPP'z" get-output-bytes p))
;; Make sure `printf` works with wrapped ports
(let ()
(struct w (p) #:property prop:output-port (struct-field-index p))
(define o (open-output-bytes))
(define p (w o))
(fprintf p "0~a~a~s~v~.a~a~.s~.v" 1 #"1" 2 3 4 #"4" 5 6)
(test #"011234456" get-output-bytes o))
;;------------------------------------------------------------
;; peek-string and variants:

16
racket/src/io/format/printf.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base
(require "../print/main.rkt"
(submod "../print/main.rkt" internal)
"../port/string-output.rkt")
"../print/mode.rkt"
"../port/string-output.rkt"
"../port/output-port.rkt")
(provide do-printf)
@ -86,13 +88,13 @@
(write-string "\n" o)
(next i args)]
[(#\a #\A)
(do-display who (car args) o)
(display-via-handler who (car args) o)
(next i (cdr args))]
[(#\s #\S)
(do-write who (car args) o)
(write-via-handler who (car args) o)
(next i (cdr args))]
[(#\v #\V)
(do-global-print who (car args) o)
(print-via-handler who (car args) o PRINT-MODE/UNQUOTED)
(next i (cdr args))]
[(#\e #\E)
(parameterize ([print-unreadable #t])
@ -105,15 +107,15 @@
(let ([i (add1 i)])
(case (string-ref fmt i)
[(#\a #\A)
(do-display who (car args) o (error-print-width))
(do-display who (car args) (->core-output-port o) (error-print-width))
(next i (cdr args))]
[(#\s #\S)
(do-write who (car args) o (error-print-width))
(do-write who (car args) (->core-output-port o) (error-print-width))
(next i (cdr args))]
[(#\v #\V)
;; Intentionally using `do-print` instead of
;; `do-global-print`:
(do-print who (car args) o 0 (error-print-width))
(do-print who (car args) (->core-output-port o) 0 (error-print-width))
(next i (cdr args))]))]
[(#\x #\X)
(write-string (number->string (car args) 16) o)

18
racket/src/io/port/handler.rkt
View File

@ -76,8 +76,8 @@
h)))]))
(define/who (default-port-write-handler v o)
(check who output-port? o)
(do-write 'write v o))
(let ([co (->core-output-port o who)])
(do-write 'write v co)))
(define/who port-display-handler
(case-lambda
@ -95,8 +95,8 @@
h)))]))
(define/who (default-port-display-handler v o)
(check who output-port? o)
(do-display 'display v o))
(let ([co (->core-output-port o who)])
(do-display 'display v co)))
(define/who port-print-handler
(case-lambda
@ -125,11 +125,11 @@
((global-port-print-handler) v o quote-depth))
(define/who (default-global-port-print-handler v o [quote-depth 0])
(check who output-port? o)
(check who (lambda (d) (or (eq? d 0) (eq? d 1)))
#:contract "(or/c 0 1)"
quote-depth)
(do-print 'print v o quote-depth))
(let ([co (->core-output-port o who)])
(check who (lambda (d) (or (eq? d 0) (eq? d 1)))
#:contract "(or/c 0 1)"
quote-depth)
(do-print 'print v co quote-depth)))
(define/who global-port-print-handler
(make-parameter default-global-port-print-handler

15
racket/src/io/print/main.rkt
View File

@ -45,7 +45,11 @@
(all-from-out "parameter.rkt"))
(module+ internal
(provide do-display
(provide display-via-handler
write-via-handler
print-via-handler
do-display
do-write
do-print
do-global-print
@ -53,6 +57,9 @@
install-do-global-print!))
(define/who (display v [o (current-output-port)])
(display-via-handler who v o))
(define (display-via-handler who v o)
(let ([co (->core-output-port o who)])
(define display-handler (core-output-port-display-handler co))
(if display-handler
@ -74,6 +81,9 @@
(void)]))
(define/who (write v [o (current-output-port)])
(write-via-handler who v o))
(define (write-via-handler who v o)
(let ([co (->core-output-port o who)])
(define write-handler (core-output-port-write-handler co))
(if write-handler
@ -87,6 +97,9 @@
(void))
(define/who (print v [o (current-output-port)] [quote-depth PRINT-MODE/UNQUOTED])
(print-via-handler who v o quote-depth))
(define/who (print-via-handler who v o quote-depth)
(let ([co (->core-output-port o who)])
(check who print-mode? #:contract "(or/c 0 1)" quote-depth)
(define print-handler (core-output-port-print-handler co))