From a97d20ed501214f8e4edf9dd7baa9b6ea225e261 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 22 Nov 2007 15:16:38 -0500
Subject: [PATCH] Added put-string.

---
 scheme/ikarus.io-primitives.ss | 54 ++++++++++++++++++++++++++++++++--
 scheme/last-revision           |  2 +-
 scheme/makefile.ss             |  2 +-
 scheme/todo-r6rs.ss            |  4 +--
 4 files changed, 56 insertions(+), 6 deletions(-)

diff --git a/scheme/ikarus.io-primitives.ss b/scheme/ikarus.io-primitives.ss
index 4f02b95..e8619be 100644
--- a/scheme/ikarus.io-primitives.ss
+++ b/scheme/ikarus.io-primitives.ss
@@ -16,7 +16,7 @@
 
 (library (ikarus io-primitives)
   (export read-char unread-char peek-char write-char write-byte
-          put-u8 put-char get-char get-u8
+          put-u8 put-char put-string get-char get-u8
           newline port-name input-port-name output-port-name
           close-input-port reset-input-port! 
           flush-output-port close-output-port get-line)
@@ -25,7 +25,7 @@
     (ikarus system $fx)
     (ikarus system $ports)
     (except (ikarus) read-char unread-char peek-char write-char write-byte 
-            put-u8 put-char get-char get-u8
+            put-u8 put-char put-string get-char get-u8
             newline port-name input-port-name output-port-name
             close-input-port reset-input-port!  flush-output-port
             close-output-port get-line))
@@ -195,5 +195,55 @@
         (get-it p)
         (error 'get-line "not an input port" p)))
   
+  (module (put-string)
+    (import (ikarus system $strings)
+            (ikarus system $fx))
+    (define ($put-string p s i j)
+      (unless ($fx= i j) 
+        ($write-char ($string-ref s i) p)
+        ($put-string p s ($fx+ i 1) j))) 
+    (define put-string
+      (case-lambda
+        [(p s) 
+         (unless (output-port? p) 
+           (error 'put-string "not an output port" p))
+         (unless (string? s) 
+           (error 'put-string "not a string" s))
+         ($put-string p s 0 (string-length s))]
+        [(p s i) 
+         (unless (output-port? p) 
+           (error 'put-string "not an output port" p))
+         (unless (string? s) 
+           (error 'put-string "not a string" s))
+         (let ([len ($string-length s)])
+           (unless (fixnum? i) 
+             (error 'put-string "starting index is not a fixnum" i))
+           (when (or ($fx< i 0) ($fx> i len))
+             (error 'put-string 
+               (format "starting index is out of range 0..~a" len)
+               i))
+           ($put-string p s i len))]
+        [(p s i c) 
+         (unless (output-port? p) 
+           (error 'put-string "not an output port" p))
+         (unless (string? s) 
+           (error 'put-string "not a string" s))
+         (let ([len ($string-length s)])
+           (unless (fixnum? i) 
+             (error 'put-string "starting index is not a fixnum" i))
+           (when (or ($fx< i 0) ($fx> i len))
+             (error 'put-string 
+               (format "starting index is out of range 0..~a" len)
+               i))
+           (unless (fixnum? c) 
+             (error 'put-string "count is not a fixnum" c))
+           (let ([j (+ i c)])
+             (when (or ($fx< c 0) (> j len))
+               (error 'put-string 
+                 (format "count is out of range 0..~a" (- len i))
+                 c))
+             ($put-string p s i j)))])))
+ 
+
   )
 
diff --git a/scheme/last-revision b/scheme/last-revision
index 9707e87..af6316f 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1108
+1109
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 4f58d8b..107fa13 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1138,7 +1138,7 @@
     [put-bytevector                              r ip]
     [put-char                                    i r ip]
     [put-datum                                   i r ip]
-    [put-string                                  r ip]
+    [put-string                                  i r ip]
     [put-u8                                      i r ip]
     [set-port-position!                          r ip]
     [standard-error-port                         i r ip]
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index 03406fe..4168f16 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -568,7 +568,7 @@
     [get-bytevector-n!                          S ip]
     [get-bytevector-some                        S ip]
     [get-char                                   C ip]
-    [get-datum                                  S ip]
+    [get-datum                                  C ip]
     [get-line                                   C ip]
     [get-string-all                             S ip]
     [get-string-n                               S ip]
@@ -643,7 +643,7 @@
     [put-bytevector                             S ip]
     [put-char                                   C ip]
     [put-datum                                  C ip]
-    [put-string                                 S ip]
+    [put-string                                 C ip]
     [put-u8                                     C ip]
     [set-port-position!                         S ip]
     [standard-error-port                        S ip]