From c02f41a8d4abae40f72703c5c815ed0b947a855d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 6 Dec 2003 15:51:37 +0000 Subject: [PATCH] . original commit: e51933fa60bad870baba2f215ffc1b60652574e6 --- collects/mzlib/string.ss | 9 +++- collects/mzlib/thread.ss | 78 +++++++++++++++++++--------- collects/tests/mzscheme/threadlib.ss | 46 ++++++++++++++++ 3 files changed, 106 insertions(+), 27 deletions(-) create mode 100644 collects/tests/mzscheme/threadlib.ss diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss index 416e976..516feae 100644 --- a/collects/mzlib/string.ss +++ b/collects/mzlib/string.ss @@ -131,15 +131,20 @@ (regexp-replace* "&" (regexp-replace* "\\\\" s "\\\\\\\\") "\\\\&")) (define regexp-match/fail-without-reading - (opt-lambda (pattern input-port [start-k 0] [end-k #f]) + (opt-lambda (pattern input-port [start-k 0] [end-k #f] [out #f]) (unless (input-port? input-port) (raise-type-error 'regexp-match/fail-without-reading "input port" input-port)) + (unless (or (not out) (output-port? out)) + (raise-type-error 'regexp-match/fail-without-reading "output port or #f" out)) (let ([m (regexp-match-peek-positions pattern input-port start-k end-k)]) (and m ;; What happens if someone swipes our chars before we can get them? (let ([drop (caar m)]) ;; drop prefix before match: - (read-string drop input-port) + (let ([s (read-string drop input-port)]) + (when out + (display s out))) + ;; Get the matching part, and shift matching indicies (let ([s (read-string (- (cdar m) drop) input-port)]) (cons s (map (lambda (p) diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss index d023db3..0106b1c 100644 --- a/collects/mzlib/thread.ss +++ b/collects/mzlib/thread.ss @@ -12,7 +12,7 @@ merge-input copy-port - wrap-input-ports + input-port-append run-server make-limited-input-port) @@ -191,30 +191,58 @@ (loop))) (lambda () (tcp-close l)))))) - (define wrap-input-ports - (opt-lambda (ports [close-orig? #t]) - (let ([go (lambda (op) - (if (null? ports) - eof - (let ([n (op (car ports))]) - (cond - [(eq? n 0) (car ports)] - [(eof-object? n) - (when close-orig? - (close-input-port (car ports))) - (set! ports (cdr ports)) - 0] - [else n]))))]) - (make-custom-input-port - (lambda (str) - (go (lambda (p) - (read-string-avail!* str p)))) - (lambda (str skip) - (go (lambda (p) - (peek-string-avail!* str skip p)))) - (lambda () - (when close-orig? - (map close-input-port ports))))))) + (define input-port-append + (opt-lambda (close-orig? . ports) + (make-custom-input-port + (lambda (str) + ;; Reading is easy -- read from the first port, + ;; and get rid of it if the result is eof + (if (null? ports) + eof + (let ([n (read-string-avail!* str (car ports))]) + (cond + [(eq? n 0) (car ports)] + [(eof-object? n) + (when close-orig? + (close-input-port (car ports))) + (set! ports (cdr ports)) + 0] + [else n])))) + (lambda (str skip) + ;; Peeking is more difficult, due to skips. + (let loop ([ports ports][skip skip]) + (if (null? ports) + eof + (let ([n (peek-string-avail!* str skip (car ports))]) + (cond + [(eq? n 0) + ;; Not ready, yet. + (car ports)] + [(eof-object? n) + ;; Port is exhausted, or we skipped past its input. + ;; If skip is not zero, we need to figure out + ;; how many chars were skipped. + (loop (cdr ports) + (- skip (compute-avail-to-skip skip (car ports))))] + [else n]))))) + (lambda () + (when close-orig? + (map close-input-port ports)))))) + + ;; Helper for input-port-append; given a skip count + ;; and an input port, determine how many characters + ;; (up to upto) are left in the port. We figure this + ;; out using binary search. + (define (compute-avail-to-skip upto p) + (let ([str (make-string 1)]) + (let loop ([upto upto][skip 0]) + (if (zero? upto) + skip + (let* ([half (quotient upto 2)] + [n (peek-string-avail!* str (+ skip half) p)]) + (if (eq? n 1) + (loop (- upto half 1) (+ skip half 1)) + (loop half skip))))))) (define make-limited-input-port (opt-lambda (port limit [close-orig? #t]) diff --git a/collects/tests/mzscheme/threadlib.ss b/collects/tests/mzscheme/threadlib.ss new file mode 100644 index 0000000..b1182c2 --- /dev/null +++ b/collects/tests/mzscheme/threadlib.ss @@ -0,0 +1,46 @@ + +(load-relative "loadtest.ss") + +(SECTION 'thread) + +(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