(define string-ref++
  (foreign-lambda*
   char
   ((scheme-pointer buf) ((c-pointer integer) i))
   "char *p=(char *)buf; return(p[(*i)++]);"))

(define make-internal-pipe
  (let ([make-input-port make-input-port]
	[make-output-port make-output-port]
	[make-mutex make-mutex]
	[make-queue make-queue]
	[make-condition-variable make-condition-variable]
	[string-length string-length]
	[string-ref string-ref]
	[string-append string-append])
    (lambda args
      (define name (or (and (pair? args) (car args))
		       'internal-pipe))
      (let-location
       ((off integer 0))
       (let ((mutex (make-mutex name))
	     (condition (make-condition-variable name))
	     (queue (make-queue))
	     (buf #f))
	 (define (eof?) (eq? #!eof buf))
	 (define (buf-empty?) (or (not buf) (fx>= off (string-length buf))))
	 (define (read-input!)
	   (mutex-lock! mutex)
	   (if (buf-empty?)
	       (if (queue-empty? queue)
		   (begin
		     (mutex-unlock! mutex condition)
		     (read-input!))
		   (begin
		     (set! buf #f)
		     (set! buf (queue-remove! queue))
		     (set! off 0)
		     (mutex-unlock! mutex)))
	       (mutex-unlock! mutex)))
	 (define (read!)
	   (if (eof?) buf
	       (if (buf-empty?)
		   (begin (read-input!) (read!))
		   (string-ref++ buf (location off)))))
	 (define (ready?)
	   (and (not (eof?))
		(or (not (buf-empty?))
		    (not (queue-empty? queue)))))
	 (define (read-string p n dest start)
	   (let loop ((n n) (m 0) (start start))
	     (cond ((eq? n 0) m)
		   ((eof?) m)
		   ((buf-empty?) (read-input!) (loop n m start))
		   (else
		    (let* ((rest (fx- (string-length buf) off))
			   (n2 (if (fx< n rest) n rest)))
		      (##core#inline "C_substring_copy" buf dest off (fx+ off n2) start)
		      (set! off (fx+ off n2))
		      (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ) ) ))
	 (define (read-line p limit)
	   (let loop ((str #f))
	     (cond ((eof?) (or str ""))
		   ((buf-empty?) (read-input!) (loop str))
		   (else
		    (##sys#scan-buffer-line
		     buf 
		     (string-length buf)
		     off
		     (lambda (pos2 next)
		       (let ((dest (##sys#make-string (fx- pos2 off))))
			 (##core#inline "C_substring_copy" buf dest off pos2 0)
			 (set! off next)
			 (cond ((eq? pos2 next) ; no line-terminator encountered
				(read-input!)
				(loop (if str (##sys#string-append str dest) dest)) )
			       (else
				(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
				(if str (##sys#string-append str dest) dest)) ) ) ) ) ) ) ) )
	 (define (close) (set! buf #!eof))
	 (define (write! s)
	   (if (or (and (string? s) (fx> (string-length s) 0))
		   (eof-object? s))
	       (begin
		 (mutex-lock! mutex)
		 (queue-add! queue s)
		 (condition-variable-signal! condition)
		 (mutex-unlock! mutex) )))
	 (values
	  (make-input-port read! ready? close #f read-string read-line)
	  (make-output-port write! (lambda () (write! #!eof)))))))))