.

original commit: e51933fa60bad870baba2f215ffc1b60652574e6

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)

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])

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")))
+
+	   
+