.

original commit: 9ac7d7d43715ed6314d9ce17fe0d91fe73b6d518

collects/mzlib/port.ss

@@ -2,13 +2,17 @@
 (module port mzscheme
   (require (lib "etc.ss")
 	   (lib "contract.ss")
-	   (lib "list.ss"))
+	   (lib "list.ss")
+	   "private/port.ss")
 
   (provide open-output-nowhere
 	   make-pipe-with-specials
 	   make-input-port/read-to-peek
 	   peeking-input-port
 	   relocate-input-port
+	   transplant-input-port
+	   relocate-output-port
+	   transplant-output-port
 	   merge-input
 	   copy-port
 	   input-port-append
@@ -73,22 +77,6 @@
 
   ;; ----------------------------------------
 
-  (define open-output-nowhere
-    (opt-lambda ([name 'nowhere])
-      (make-output-port 
-       name
-       always-evt
-       (lambda (s start end non-block? breakable?) (- end start))
-       void
-       (lambda (special non-block? breakable?) #t)
-       (lambda (s start end) (wrap-evt
-			      always-evt
-			      (lambda (x)
-				(- end start))))
-       (lambda (special) (wrap-evt always-evt (lambda (x) #t))))))
-
-  ;; ----------------------------------------
-
   (define (copy-port src dest . dests)
     (unless (input-port? src)
       (raise-type-error 'copy-port "input-port" src))
@@ -468,8 +456,13 @@
        void)))
 
   (define relocate-input-port
-    (lambda (p line col pos)
+    (opt-lambda (p line col pos [close? #t])
-      (let-values ([(init-l init-c init-p) (port-next-location p)])
+      (transplant-to-relocate
+       transplant-input-port
+       p line col pos close?)))
+
+  (define transplant-input-port
+    (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
       (make-input-port
        (object-name p)
        (lambda (s) (let ([v (read-bytes-avail!* s p)])
@@ -486,22 +479,17 @@
 		    never-evt))
 	       v)))
        (lambda ()
-	   (close-input-port p))
+	 (when close?
+	   (close-input-port p)))
        (and (port-provides-progress-evts? p)
 	    (lambda ()
 	      (port-progress-evt p)))
        (and (port-provides-progress-evts? p)
 	    (lambda (n evt target-evt)
 	      (port-commit-peeked n evt target-evt p)))
-	 (lambda ()
+       location-proc
-	   (let-values ([(l c p) (port-next-location p)])
+       count-lines!-proc
-	     (values (and l (+ l (- init-l) line))
+       pos)))
-		     (and c (if (equal? l init-l)
-				(+ c (- init-c) col)
-				c))
-		     (and p (+ p (- init-p) pos)))))
-	 void
-	 pos))))
 
   ;; Not kill-safe.
   (define make-pipe-with-specials