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

.

Browse Source 
original commit: da0210c7bbdd78c09b11695e40b528d36882c6b8
This commit is contained in:
Matthew Flatt 2005-05-06 15:26:41 +00:00
parent be205971e3
commit 6d327e00cb
1 changed files with 333 additions and 304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/mzlib/port.ss
View File

@ -141,7 +141,12 @@
;; Not kill-safe. ;; Not kill-safe.
;; If the `read' proc returns an event, the event must produce ;; If the `read' proc returns an event, the event must produce
;; 0 always ;; 0 always
(define (make-input-port/read-to-peek name read fast-peek close) (define make-input-port/read-to-peek
(opt-lambda (name read fast-peek close
[location-proc #f]
[count-lines!-proc void]
[init-position 1]
[buffer-mode-proc #f])
(define lock-semaphore (make-semaphore 1)) (define lock-semaphore (make-semaphore 1))
(define commit-semaphore (make-semaphore 1)) (define commit-semaphore (make-semaphore 1))
(define-values (peeked-r peeked-w) (make-pipe)) (define-values (peeked-r peeked-w) (make-pipe))
@ -437,7 +442,11 @@
(lambda () (lambda ()
(set! progress-requested? #t) (set! progress-requested? #t)
(port-progress-evt peeked-r)) (port-progress-evt peeked-r))
commit-it)) commit-it
location-proc
count-lines!-proc
init-position
buffer-mode-proc)))
(define peeking-input-port (define peeking-input-port
(opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) (opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
@ -1173,7 +1182,9 @@
[buf-start 0] [buf-start 0]
[buf-end 0] [buf-end 0]
[buf-eof? #f] [buf-eof? #f]
[buf-eof-result #f]) [buf-eof-result #f]
[buffer-mode (or (file-stream-buffer-mode port)
'none)])
;; Main reader entry: ;; Main reader entry:
(define (read-it s) (define (read-it s)
(cond (cond
@ -1210,8 +1221,11 @@
(set! buf-end (- buf-end buf-start)) (set! buf-end (- buf-end buf-start))
(set! buf-start 0)) (set! buf-start 0))
(let* ([amt (bytes-length s)] (let* ([amt (bytes-length s)]
[c (read-bytes-avail!* buf port buf-end (min (bytes-length buf) [c (read-bytes-avail!* buf port buf-end
(+ buf-end amt)))]) (if (eq? buffer-mode 'block)
(bytes-length buf)
(min (bytes-length buf)
(+ buf-end amt))))])
(cond (cond
[(or (eof-object? c) [(or (eof-object? c)
(procedure? c)) (procedure? c))
@ -1271,23 +1285,25 @@
(lambda () (lambda ()
(when close? (when close?
(close-input-port port)) (close-input-port port))
(bytes-close-converter c)))))) (bytes-close-converter c))
#f void 1
(case-lambda
[() buffer-mode]
[(mode) (set! buffer-mode mode)])))))
;; -------------------------------------------------- ;; --------------------------------------------------
(define reencode-output-port (define reencode-output-port
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)])
[buffer-mode (if (and (output-port? port)
(file-stream-port? port))
(file-stream-buffer-mode port)
'block)])
(let ([c (bytes-open-converter "UTF-8" encoding)] (let ([c (bytes-open-converter "UTF-8" encoding)]
[ready-bytes (make-bytes 1024)] [ready-bytes (make-bytes 1024)]
[ready-start 0] [ready-start 0]
[ready-end 0] [ready-end 0]
[out-bytes (make-bytes 1024)] [out-bytes (make-bytes 1024)]
[out-start 0] [out-start 0]
[out-end 0]) [out-end 0]
[buffer-mode (or (file-stream-buffer-mode port)
'block)])
;; The main writing entry point: ;; The main writing entry point:
(define (write-it s start end no-buffer&block? enable-break?) (define (write-it s start end no-buffer&block? enable-break?)
@ -1497,4 +1513,17 @@
(when close? (when close?
(close-output-port port)) (close-output-port port))
(bytes-close-converter c)) (bytes-close-converter c))
write-special-it))))) write-special-it
#f #f
#f void
1
(case-lambda
[() buffer-mode]
[(mode) (let ([old buffer-mode])
(set! buffer-mode mode)
(when (or (and (eq? old 'block)
(memq mode '(none line)))
(and (eq? old 'line)
(memq mode '(none))))
;; Flush output
(write-it #"" 0 0 #f #f)))]))))))