From 8a375a3cf7726dd9fdf63177f298fd8462ecdcbf Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 10 Dec 2007 10:36:10 -0500
Subject: [PATCH] Added make-custom-binary-output-port

---
 scheme/ikarus.io.ss  | 21 ++++++++++++++++++---
 scheme/last-revision |  2 +-
 scheme/makefile.ss   |  2 +-
 scheme/todo-r6rs.ss  |  4 ++--
 4 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index f644a09..a8eae65 100644
--- a/scheme/ikarus.io.ss
+++ b/scheme/ikarus.io.ss
@@ -24,6 +24,7 @@
     open-bytevector-input-port
     open-string-input-port
     make-custom-binary-input-port 
+    make-custom-binary-output-port 
     transcoded-port port-transcoder
     close-port close-input-port close-output-port
     port-eof?
@@ -67,6 +68,7 @@
       open-bytevector-input-port
       open-string-input-port
       make-custom-binary-input-port
+      make-custom-binary-output-port 
       transcoded-port port-transcoder
       close-port close-input-port close-output-port
       port-eof?
@@ -181,9 +183,9 @@
   (define r6rs-mode-tag          #x1000)
 
   (define ($make-custom-binary-input-port id 
-            read! get-position set-position! close buffer-size)
+            read! write! get-position set-position! close buffer-size)
     (let ([bv (make-bytevector buffer-size)])
-      ($make-port 0 0 bv 0 #f #f 0 id read! #f get-position
+      ($make-port 0 0 bv 0 #f #f 0 id read! write! get-position
                   set-position! close)))
 
   (define (make-custom-binary-input-port id 
@@ -196,7 +198,20 @@
       (error who "read! is not a procedure" read!))
     (unless (or (procedure? close) (not close))
       (error who "close should be either a procedure or #f" close))
-    ($make-custom-binary-input-port id read! get-position
+    ($make-custom-binary-input-port id read! #f get-position
+      set-position! close 256))
+
+  (define (make-custom-binary-output-port id 
+            write! get-position set-position! close)
+    ;;; FIXME: get-position and set-position! are ignored for now
+    (define who 'make-custom-binary-output-port)
+    (unless (string? id)
+      (error who "id is not a string" id))
+    (unless (procedure? write!)
+      (error who "read! is not a procedure" write!))
+    (unless (or (procedure? close) (not close))
+      (error who "close should be either a procedure or #f" close))
+    ($make-custom-binary-input-port id #f write! get-position
       set-position! close 256))
 
   (define (input-transcoder-attrs x)
diff --git a/scheme/last-revision b/scheme/last-revision
index f72207f..9c2de76 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1209
+1210
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index b0e4046..7cd717b 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1098,7 +1098,7 @@
     [make-bytevector                             i r bv]
     [make-custom-binary-input-port               i r ip]
     [make-custom-binary-input/output-port        r ip]
-    [make-custom-binary-output-port              r ip]
+    [make-custom-binary-output-port              i r ip]
     [make-custom-textual-input-port              r ip]
     [make-custom-textual-input/output-port       r ip]
     [make-custom-textual-output-port             r ip]
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index 94ceaf9..9136a67 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -514,6 +514,7 @@
     [buffer-mode                                C ip]
     [buffer-mode?                               C ip]
     [bytevector->string                         S ip]
+    [string->bytevector                         S ip]
     [call-with-bytevector-output-port           C ip]
     [call-with-port                             C ip]
     [call-with-string-output-port               C ip]
@@ -606,7 +607,7 @@
     [make-bytevector                            C bv]
     [make-custom-binary-input-port              C ip]
     [make-custom-binary-input/output-port       S ip]
-    [make-custom-binary-output-port             S ip]
+    [make-custom-binary-output-port             C ip]
     [make-custom-textual-input-port             S ip]
     [make-custom-textual-input/output-port      S ip]
     [make-custom-textual-output-port            S ip]
@@ -649,7 +650,6 @@
     [standard-error-port                        C ip]
     [standard-input-port                        C ip]
     [standard-output-port                       C ip]
-    [string->bytevector                         S ip]
     [textual-port?                              C ip]
     [transcoded-port                            C ip]
     [transcoder-codec                           C ip]