From e99ce9c03baccb5619a6086b7a81da62658043cc Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sun, 18 Nov 2007 18:48:24 -0500
Subject: [PATCH] * Added put-char, get-char, and put-u8.

---
 scheme/ikarus.io-primitives.ss | 31 +++++++++++++++++++++++++++----
 scheme/makefile.ss             |  6 +++---
 scheme/todo-r6rs.ss            |  6 +++---
 3 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/scheme/ikarus.io-primitives.ss b/scheme/ikarus.io-primitives.ss
index cb31aaa..4878028 100644
--- a/scheme/ikarus.io-primitives.ss
+++ b/scheme/ikarus.io-primitives.ss
@@ -15,16 +15,17 @@
 
 
 (library (ikarus io-primitives)
-  (export read-char unread-char peek-char write-char write-byte newline
-          port-name input-port-name output-port-name
+  (export read-char unread-char peek-char write-char write-byte
+          put-u8 put-char get-char
+          newline port-name input-port-name output-port-name
           close-input-port reset-input-port! 
           flush-output-port close-output-port get-line)
   (import 
     (ikarus system $io)
     (ikarus system $fx)
     (ikarus system $ports)
-    (except (ikarus) read-char unread-char peek-char write-char
-            write-byte
+    (except (ikarus) read-char unread-char peek-char write-char write-byte 
+            put-u8 put-char get-char
             newline port-name input-port-name output-port-name
             close-input-port reset-input-port!  flush-output-port
             close-output-port get-line))
@@ -42,6 +43,14 @@
                (error 'write-char "not an output-port" p))
            (error 'write-char "not a character" c))]))
    
+  (define put-char
+    (lambda (c p)
+      (if (char? c)
+          (if (output-port? p)
+              ($write-char c p)
+              (error 'put-char "not an output-port" p))
+          (error 'put-char "not a character" c))))
+
   (define write-byte
     (case-lambda
       [(b)
@@ -54,6 +63,14 @@
                ($write-byte b p)
                (error 'write-byte "not an output-port" p))
            (error 'write-byte "not a byte" b))]))
+
+  (define put-u8
+    (lambda (b p)
+      (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
+          (if (output-port? p)
+              ($write-byte b p)
+              (error 'put-u8 "not an output-port" p))
+          (error 'put-u8 "not a u8" b))))
   ;;;
   (define newline
     (case-lambda
@@ -85,6 +102,12 @@
           (($port-handler p) 'port-name p)
           (error 'output-port-name "not a port" p))))
 
+  (define get-char
+    (lambda (p) 
+      (if (input-port? p)
+           ($read-char p)
+           (error 'get-char "not an input-port" p))))
+
   (define read-char
     (case-lambda
       [() ($read-char (current-input-port))]
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 6fb8473..146ad9d 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1052,7 +1052,7 @@
     [get-bytevector-n                            r ip]
     [get-bytevector-n!                           r ip]
     [get-bytevector-some                         r ip]
-    [get-char                                    r ip]
+    [get-char                                    i r ip]
     [get-datum                                   r ip]
     [get-line                                    i r ip]
     [get-string-all                              r ip]
@@ -1126,10 +1126,10 @@
     [port-transcoder                             r ip]
     [port?                                       i r ip]
     [put-bytevector                              r ip]
-    [put-char                                    r ip]
+    [put-char                                    i r ip]
     [put-datum                                   r ip]
     [put-string                                  r ip]
-    [put-u8                                      r ip]
+    [put-u8                                      i r ip]
     [set-port-position!                          r ip]
     [standard-error-port                         i r ip]
     [standard-input-port                         i r ip]
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index fc9878d..18d99d6 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -567,7 +567,7 @@
     [get-bytevector-n                           S ip]
     [get-bytevector-n!                          S ip]
     [get-bytevector-some                        S ip]
-    [get-char                                   S ip]
+    [get-char                                   C ip]
     [get-datum                                  S ip]
     [get-line                                   C ip]
     [get-string-all                             S ip]
@@ -641,10 +641,10 @@
     [port-transcoder                            S ip]
     [port?                                      C ip]
     [put-bytevector                             S ip]
-    [put-char                                   S ip]
+    [put-char                                   C ip]
     [put-datum                                  S ip]
     [put-string                                 S ip]
-    [put-u8                                     S ip]
+    [put-u8                                     C ip]
     [set-port-position!                         S ip]
     [standard-error-port                        S ip]
     [standard-input-port                        S ip]