From 24b43e367bcc46584eb3fbef06af07d1d8da254d Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sat, 17 Dec 2011 15:55:10 +0900
Subject: [PATCH] Providing scheme versions of some I/O functions when string
 streams aren't used.

---
 eval.c               |  3 +++
 lib/chibi/io/io.scm  | 43 +++++++++++++++++++++++++++++++++++++++++++
 lib/chibi/io/io.stub | 18 ++++++++++--------
 3 files changed, 56 insertions(+), 8 deletions(-)

diff --git a/eval.c b/eval.c
index e6fb1434..54b96c41 100644
--- a/eval.c
+++ b/eval.c
@@ -1954,6 +1954,9 @@ static const char* sexp_initial_features[] = {
 #if SEXP_USE_DL
   "dynamic-loading",
 #endif
+#if SEXP_USE_STRING_STREAMS
+  "string-streams",
+#endif
 #if SEXP_USE_MODULES
   "modules",
 #endif
diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm
index ddb5f083..775d6180 100644
--- a/lib/chibi/io/io.scm
+++ b/lib/chibi/io/io.scm
@@ -28,6 +28,17 @@
     (display str out)
     (newline out)))
 
+;;> @subsubsubsection{(write-string str n [out])}
+
+;;> Writes the first @var{n} bytes of @var{str} to output port
+;;> @var{out}.
+
+(cond-expand
+ ((not string-streams)
+  (define (write-string str n . o)
+    (let ((out (if (pair? o) (car o) (current-output-port))))
+      (display (substring str 0 n out))))))
+
 ;;> @subsubsubsection{(read-line [in [n]])}
 
 ;;> Read a line from the input port @var{in}, defaulting to
@@ -35,6 +46,21 @@
 ;;> a string not including the newline.  Reads at most @var{n}
 ;;> characters, defaulting to 8192.
 
+(cond-expand
+ ((not string-streams)
+  (define (%read-line n in)
+    (let ((out (open-output-string)))
+      (let lp ()
+        (let ((ch (read-char in)))
+          (cond
+           ((eof-object? ch)
+            (get-output-string out))
+           (else
+            (write-char ch out)
+            (if (eqv? ch #\newline)
+                (get-output-string out)
+                (lp))))))))))
+
 (define (read-line . o)
   (let ((in (if (pair? o) (car o) (current-input-port)))
         (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
@@ -58,6 +84,15 @@
 ;;> than @var{n} characters if the end of file is reached,
 ;;> or the eof-object if no characters are available.
 
+(cond-expand
+ ((not string-streams)
+  (define (%read-string n in)
+    (let ((out (open-output-string)))
+      (do ((i 0 (+ i 1))
+           (ch (read-char in) (read-char in)))
+          ((or (= i n) (eof-object? ch)) (get-output-string out))
+        (write-char ch out))))))
+
 (define (read-string n . o)
   (if (zero? n)
       ""
@@ -80,6 +115,14 @@
 ;;> An error is signalled if the length of @var{str} is smaller
 ;;> than @var{n}.
 
+(cond-expand
+ ((not string-streams)
+  (define (%read-string! str n in)
+    (do ((i 0 (+ i 1))
+         (ch (read-char in) (read-char in)))
+        ((or (= i n) (eof-object? ch)) i)
+      (string-set! str i ch)))))
+
 (define (read-string! str n . o)
   (if (>= n (string-length str))
       (error "string to small to read chars" str n))
diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub
index 307dd0b3..629d02c0 100644
--- a/lib/chibi/io/io.stub
+++ b/lib/chibi/io/io.stub
@@ -1,15 +1,17 @@
 
-(define-c non-null-string (%read-line "fgets")
-  ((result (array char arg1)) int (default (current-input-port) input-port)))
+(cond-expand
+ (string-streams
+  (define-c non-null-string (%read-line "fgets")
+    ((result (array char arg1)) int (default (current-input-port) input-port)))
 
-(define-c size_t (%read-string "fread")
-  ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
+  (define-c size_t (%read-string "fread")
+    ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
 
-(define-c size_t (%read-string! "fread")
-  (string (value 1 size_t) size_t (default (current-input-port) input-port)))
+  (define-c size_t (%read-string! "fread")
+    (string (value 1 size_t) size_t (default (current-input-port) input-port)))
 
-(define-c size_t (write-string "fwrite")
-  (string (value 1 size_t) size_t (default (current-output-port) output-port)))
+  (define-c size_t (write-string "fwrite")
+    (string (value 1 size_t) size_t (default (current-output-port) output-port)))))
 
 (define-c-const int (seek/set "SEEK_SET"))
 (define-c-const int (seek/cur "SEEK_CUR"))