88 lines
2.5 KiB
Scheme
88 lines
2.5 KiB
Scheme
|
|
;; A few simple port functions are needed in pretty.ss, which is
|
|
;; used by contract.ss, which is used by port.ss --- so we
|
|
;; break the cycle with this module.
|
|
|
|
(module port mzscheme
|
|
(require "../etc.ss")
|
|
(provide open-output-nowhere
|
|
relocate-output-port
|
|
transplant-output-port
|
|
transplant-to-relocate)
|
|
|
|
(define open-output-nowhere
|
|
(opt-lambda ([name 'nowhere] [specials-ok? #t])
|
|
(make-output-port
|
|
name
|
|
always-evt
|
|
(lambda (s start end non-block? breakable?) (- end start))
|
|
void
|
|
(and specials-ok?
|
|
(lambda (special non-block? breakable?) #t))
|
|
(lambda (s start end) (wrap-evt
|
|
always-evt
|
|
(lambda (x)
|
|
(- end start))))
|
|
(and specials-ok?
|
|
(lambda (special)
|
|
(wrap-evt always-evt (lambda (x) #t)))))))
|
|
|
|
(define (transplant-to-relocate transplant p line col pos close?)
|
|
(let-values ([(init-l init-c init-p) (port-next-location p)])
|
|
(transplant
|
|
p
|
|
(lambda ()
|
|
(let-values ([(l c p) (port-next-location p)])
|
|
(values (and l init-l (+ l (- init-l) line))
|
|
(and c init-c (if (equal? l init-l)
|
|
(+ c (- init-c) col)
|
|
c))
|
|
(and p init-p (+ p (- init-p) pos)))))
|
|
pos
|
|
close?)))
|
|
|
|
(define relocate-output-port
|
|
(opt-lambda (p line col pos [close? #t])
|
|
(transplant-to-relocate
|
|
transplant-output-port
|
|
p line col pos close?)))
|
|
|
|
(define transplant-output-port
|
|
(opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
|
|
(make-output-port
|
|
(object-name p)
|
|
p
|
|
(lambda (s start end nonblock? breakable?)
|
|
(let ([v ((if nonblock?
|
|
write-bytes-avail*
|
|
(if breakable?
|
|
write-bytes-avail/enable-break
|
|
write-bytes-avail))
|
|
s p start end)])
|
|
(if (and (zero? v) (not (= start end)))
|
|
(wrap-evt p (lambda (x) #f))
|
|
v)))
|
|
(lambda ()
|
|
(when close?
|
|
(close-output-port p)))
|
|
(and (port-writes-special? p)
|
|
(lambda (special nonblock? breakable?)
|
|
((if nonblock?
|
|
write-special-avail*
|
|
(if breakable?
|
|
(lambda (spec p)
|
|
(parameterize-break #t
|
|
(write-special spec p)))
|
|
write-special))
|
|
special p)))
|
|
(and (port-writes-atomic? p)
|
|
(lambda (s start end)
|
|
(write-bytes-avail-evt s p start end)))
|
|
(and (port-writes-atomic? p)
|
|
(port-writes-special? p)
|
|
(lambda (spec)
|
|
(write-special-evt spec p)))
|
|
location-proc
|
|
count-lines!-proc
|
|
pos))))
|