From eb8680e0e5602178cee43b2473428476aea3ab9f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 16 May 2004 03:51:14 +0000 Subject: [PATCH] . original commit: ef5bb50667aeded71aa2b9c9978e5be88a23248d --- collects/mzlib/port.ss | 94 ++++++++++++++++++++++------ collects/tests/mzscheme/threadlib.ss | 40 +----------- 2 files changed, 76 insertions(+), 58 deletions(-) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index 0635601..5074e79 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -73,16 +73,22 @@ (copy b) rd))])) + ;; Not kill-safe. + ;; Works only when read proc never returns an event. (define (make-input-port/read-to-peek name read fast-peek close) (define lock-semaphore (make-semaphore 1)) (define-values (peeked-r peeked-w) (make-pipe)) (define peeked-end 0) (define special-peeked null) (define special-peeked-tail #f) + (define progress-requested? #f) (define (try-again) (convert-evt (semaphore-peek-evt lock-semaphore) (lambda (x) 0))) + (define (make-progress) + (write-byte 0 peeked-w) + (read-byte peeked-r)) (define (read-it s) (call-with-semaphore lock-semaphore @@ -95,7 +101,9 @@ ;; If nothing is saved from a peeking read, ;; dispatch to `read', otherwise (cond - [(null? special-peeked) (read s)] + [(null? special-peeked) + (when progress-requested? (make-progress)) + (read s)] [else (if (bytes? (car special-peeked)) (let ([b (car special-peeked)]) (set! peeked-end (+ (file-position peeked-r) (bytes-length b))) @@ -106,22 +114,26 @@ (read-bytes-avail!* s peeked-r)) (begin0 (car special-peeked) + (make-progress) (set! special-peeked (cdr special-peeked)) (when (null? special-peeked) (set! special-peeked-tail #f))))]))) - (define (peek-it s skip) + (define (peek-it s skip unless-evt) (call-with-semaphore lock-semaphore (lambda () - (do-peek-it s skip)) + (do-peek-it s skip unless-evt)) try-again)) - (define (do-peek-it s skip) - (let ([v (peek-bytes-avail!* s skip peeked-r)]) + (define (do-peek-it s skip unless-evt) + (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) (if (zero? v) ;; The peek may have failed because peeked-r is empty, - ;; or because the skip is far. Handle nicely the common - ;; case where there are no specials. + ;; because unless-evt is ready, or because the skip is + ;; far. Handle nicely the common case where there are no + ;; specials. (cond + [(and unless-evt (sync/timeout 0 unless-evt)) + 0] [(null? special-peeked) ;; Empty special queue, so read through the original proc (let ([r (read s)]) @@ -131,7 +143,7 @@ (set! peeked-end (+ r peeked-end)) (write-bytes s peeked-w 0 r) ;; Now try again - (peek-bytes-avail!* s skip peeked-r)] + (peek-bytes-avail!* s skip #f peeked-r)] [else (set! special-peeked (cons r null)) (set! special-peeked-tail special-peeked) @@ -169,10 +181,10 @@ [(eof-object? (car l)) ;; No peeking past an EOF eof] - [(pair? (car l)) - (if (skip . < . (caar l)) + [(procedure? (car l)) + (if (skip . < . 1) (car l) - (loop (- skip (caar l)) (cdr l)))] + (loop (sub1 skip) (cdr l)))] [(bytes? (car l)) (let ([len (bytes-length (car l))]) (if (skip . < . len) @@ -182,6 +194,48 @@ n) (loop (- skip len) (cdr l))))])))]) v))) + (define (commit-it amt unless-evt dont-evt) + (call-with-semaphore + lock-semaphore + (lambda () + (do-commit-it amt unless-evt dont-evt)))) + (define (do-commit-it amt unless-evt dont-evt) + (if (sync/timeout 0 unless-evt) + #f + (let* ([pos (file-position peeked-r)] + [avail (- peeked-end pos)] + [p-commit (min avail amt)]) + (let loop ([amt (- amt p-commit)] + [l special-peeked]) + (cond + [(amt . <= . 0) + ;; Enough has been peeked... + (unless (zero? p-commit) + (peek-byte peeked-r (sub1 amt)) + (port-commit-peeked amt peeked-r)) + (set! special-peeked l) + (when (null? special-peeked) + (set! special-peeked-tail #f)) + #t] + [(null? l) + ;; Requested commit was larger than previous peeks + #f] + [(bytes? (car l)) + (let ([bl (bytes-length (car l))]) + (if (bl . > . amt) + ;; Split the string + (let ([next (cons + (subbytes (car l) amt) + (cdr l))]) + (set-car! l (subbytes (car l) 0 amt)) + (set-cdr! l next) + (when (eq? l special-peeked-tail) + (set! special-peeked-tail next)) + (loop 0 (cdr l))) + ;; Consume this string... + (loop (- amt bl) (cdr l))))] + [else + (loop (sub1 amt) (cdr l))]))))) (make-input-port name ;; Read @@ -191,10 +245,12 @@ (lambda (s skip) (fast-peek s skip peek-it)) peek-it) - close)) - - - + close + (lambda () + (set! progress-requested? #t) + (port-progress-evt peeked-r)) + commit-it)) + (define input-port-append (opt-lambda (close-orig? . ports) @@ -214,12 +270,12 @@ (set! ports (cdr ports)) 0] [else n])))) - (lambda (str skip) + (lambda (str skip unless-evt) ;; Peeking is more difficult, due to skips. (let loop ([ports ports][skip skip]) (if (null? ports) eof - (let ([n (peek-bytes-avail!* str skip (car ports))]) + (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) (cond [(eq? n 0) ;; Not ready, yet. @@ -281,7 +337,7 @@ (if (zero? upto) skip (let* ([half (quotient upto 2)] - [n (peek-bytes-avail!* str (+ skip half) p)]) + [n (peek-bytes-avail!* str (+ skip half) #f p)]) (if (eq? n 1) (loop (- upto half 1) (+ skip half 1)) (loop half skip))))))) @@ -304,7 +360,7 @@ (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) (if (zero? count) eof - (let ([n (peek-bytes-avail!* str skip port 0 count)]) + (let ([n (peek-bytes-avail!* str skip #f port 0 count)]) (if (eq? n 0) port n))))) diff --git a/collects/tests/mzscheme/threadlib.ss b/collects/tests/mzscheme/threadlib.ss index b1182c2..fee6412 100644 --- a/collects/tests/mzscheme/threadlib.ss +++ b/collects/tests/mzscheme/threadlib.ss @@ -5,42 +5,4 @@ (require (lib "thread.ss")) -;; input-port-append tests -(let* ([do-test - ;; ls is a list of strings for ports - ;; n, m, q are positive - ;; n and n+m < total length - ;; n+m+q can be greater than total length - (lambda (ls n m q) - (let* ([p (apply input-port-append #f (map open-input-string ls))] - [s (apply string-append ls)] - [l (string-length s)]) - (test (substring s 0 n) peek-string n 0 p) - (test (substring s n (min l (+ n m q))) peek-string (+ m q) n p) - (test (substring s (+ n m) (min l (+ n m q))) peek-string q (+ n m) p) - - (test (substring s 0 n) read-string n p) - - (test (substring s n (+ n m)) peek-string m 0 p) - (test (substring s (+ n m) (min l (+ n m q))) peek-string q m p) - - (test (substring s n (+ n m)) read-string m p) - - (test (substring s (+ n m) (min l (+ n m q))) peek-string q 0 p)))] - [do-tests - (lambda (ls) - (let ([l (apply + (map string-length ls))]) - (let loop ([n 1]) - (unless (= n (- l 2)) - (let loop ([m 1]) - (unless (= (+ m n) (- l 1)) - (do-test ls n m 1) - (do-test ls n m (- l n m)) - (do-test ls n m (+ (- l n m) 2)) - (loop (add1 m)))) - (loop (add1 n))))))]) - (do-tests '("apple" "banana")) - (do-tests '("ax" "b" "cz"))) - - - \ No newline at end of file +;; FIXME: Add tests!!