~ chicken-core (chicken-5) f4936490e67502fb81eacd37caaf3c92d107f6a2
commit f4936490e67502fb81eacd37caaf3c92d107f6a2
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Aug 10 04:39:18 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Aug 10 04:39:18 2010 -0400
added copy-port (suggested by Moritz Heidkamp)
diff --git a/manual/Unit ports b/manual/Unit ports
index 6a50e398..e26122eb 100644
--- a/manual/Unit ports
+++ b/manual/Unit ports
@@ -120,6 +120,18 @@ Apply {{FN}} to successive results of calling the zero argument procedure {{THUN
passing the {{ACC}} value as the second argument. The {{FN}} result becomes the new
{{ACC}} value. When {{THUNK}} returns {{#!eof}}, the last {{FN}} result is returned.
+==== copy-port
+
+<procedure>(copy-port FROM TO [READ [WRITE]])</procedure>
+
+Reads all remaining data from port {{FROM}} using the reader procedure
+{{READ}} and writes it to port {{TO}} using the writer procedure
+{{WRITE}}. {{READ}} defaults to {{read-char}} and {{WRITE} to
+{{write-char}}. Note that this procedure does not check {{FROM}} and
+{{TO}} for being ports, so the reader and writer procedures may
+perform arbitrary operations as long as they can be invoked
+as {{(READ FROM)}} and {{(WRITE X TO)}}, respectively.
+
=== Funky ports
diff --git a/ports.scm b/ports.scm
index 6847a8b7..9070fcab 100644
--- a/ports.scm
+++ b/ports.scm
@@ -33,7 +33,9 @@
(declare
- (unit ports))
+ (unit ports)
+ (hide read-and-write write-buf read-buf read-and-write-buf))
+
(include "common-declarations.scm")
@@ -59,12 +61,67 @@
(loop (cons (fn x) xs))))))))
(define (port-fold fn acc thunk)
- (let loop ([acc acc])
- (let ([x (thunk)])
+ (let loop ((acc acc))
+ (let ((x (thunk)))
(if (eof-object? x)
acc
(loop (fn x acc))) ) ) )
+(define-constant +buf-size+ 1024)
+
+(define (read-buf port writer)
+ (let ((buf (make-string +buf-size+)))
+ (let loop ()
+ (let ((n (read-string! +buf-size+ buf port)))
+ (unless (eq? n 0)
+ (writer buf n)
+ (loop))))))
+
+(define (write-buf buf n port writer)
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (writer (integer->char (##sys#byte buf n)) port)))
+
+(define (read-and-write reader writer)
+ (let loop ()
+ (let ((x (reader)))
+ (unless (eof-object? x)
+ (writer x)
+ (loop)))))
+
+(define (read-and-write-buf src dest reader)
+ (let ((buf (make-string +buf-size+)))
+ (let loop ((n 0))
+ (when (fx>= n +buf-size+)
+ (write-string buf +buf-size+ dest)
+ (set! n 0))
+ (let ((c (reader src)))
+ (cond ((eof-object? c)
+ (when (fx>= n 0)
+ (write-string buf n dest)))
+ (else
+ (##sys#setbyte buf n (char->integer c))
+ (loop (fx+ n 1))))))))
+
+(define copy-port
+ (let ((read-char read-char)
+ (write-char write-char))
+ (lambda (src dest #!optional (read read-char) (write write-char))
+ ;; does not check port args intentionally
+ (cond ((eq? read read-char)
+ (read-buf
+ src
+ (if (eq? write write-char)
+ (lambda (buf n) (write-string buf n dest))
+ (lambda (buf n) (write-buf buf n dest write)))))
+ ((eq? write write-char)
+ (read-and-write-buf src dest read))
+ (else
+ (read-and-write
+ (lambda () (read src))
+ (lambda (x) (write x dest))))))))
+
+
;;;; funky-ports
(define (make-broadcast-port . ports)
diff --git a/setup-api.scm b/setup-api.scm
index bffd48d7..94a609e4 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -45,7 +45,7 @@
setup-verbose-mode setup-install-mode deployment-mode
installation-prefix
destination-prefix
- chicken-prefix ;XXX remove at some stage from exports
+ chicken-prefix
find-library find-header
program-path remove-file*
patch abort-setup
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 4b99cf73..bc0ae7c1 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -1,4 +1,4 @@
-(require-extension srfi-1)
+(require-extension srfi-1 ports)
(define *text* #<<EOF
this is a test
@@ -33,3 +33,45 @@ EOF
"<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"
(read-line p)))
(assert (= 20 (length (read-lines (open-input-string *text*)))))
+
+
+;;; port operations
+
+(assert
+ (string=?
+ *text*
+ (with-output-to-string
+ (lambda ()
+ (copy-port (open-input-string *text*) (current-output-port))))))
+
+(assert
+ (equal?
+ '(3 2 1)
+ (let ((out '()))
+ (copy-port
+ (open-input-string "1 2 3")
+ #f
+ read
+ (lambda (x port) (set! out (cons x out))))
+ out)))
+
+(print "slow...")
+(time
+ (with-input-from-file "compiler.scm"
+ (lambda ()
+ (with-output-to-file "compiler.scm.2"
+ (lambda ()
+ (copy-port
+ (current-input-port) (current-output-port)
+ (lambda (port) (read-char port))
+ (lambda (x port) (write-char x port))))))))
+
+(print "fast...")
+(time
+ (with-input-from-file "compiler.scm"
+ (lambda ()
+ (with-output-to-file "compiler.scm.2"
+ (lambda ()
+ (copy-port (current-input-port) (current-output-port)))))))
+
+(delete-file "compiler.scm.2")
Trap