[Guile-commits] 07/10: put-char in Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit d8067213dc3728a37c3c60d15aa0f1113d2e8daa
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 1 23:48:08 2016 +0200

    put-char in Scheme
    
    * libguile/ports.c (scm_port_encode_char): New function.
    * module/ice-9/ports.scm (port-encode-char): Export port-encode-char to
      the internals module.
    * module/ice-9/sports.scm (put-char): New function.
      (port-bindings): Add put-char and put-string.
---
 libguile/ports.c                   |   19 +++++++++++++++++++
 module/ice-9/ports.scm             |    2 ++
 module/ice-9/suspendable-ports.scm |   17 ++++++++++++++---
 3 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/libguile/ports.c b/libguile/ports.c
index a464aaf..2694dcf 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -3238,6 +3238,25 @@ SCM_DEFINE (scm_port_encode_chars, "port-encode-chars", 
5, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM scm_port_encode_char (SCM, SCM, SCM);
+SCM_DEFINE (scm_port_encode_char, "port-encode-char", 3, 0, 0,
+            (SCM port, SCM buf, SCM ch),
+            "")
+#define FUNC_NAME s_scm_port_encode_char
+{
+  scm_t_uint32 codepoint;
+
+  SCM_VALIDATE_OPOUTPORT (1, port);
+  SCM_VALIDATE_VECTOR (2, buf);
+  SCM_VALIDATE_CHAR (3, ch);
+
+  codepoint = SCM_CHAR (ch);
+  encode_utf32_chars (port, buf, &codepoint, 1);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 void
 scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *chars, size_t len)
 {
diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm
index 43a029b..8eee229 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -187,6 +187,7 @@ interpret its input and output."
             specialize-port-encoding!
             port-random-access?
             port-decode-char
+            port-encode-char
             port-encode-chars
             port-read-buffering
             port-poll
@@ -235,6 +236,7 @@ interpret its input and output."
                        %port-encoding
                        specialize-port-encoding!
                        port-decode-char
+                       port-encode-char
                        port-encode-chars
                        port-random-access?
                        port-read-buffering
diff --git a/module/ice-9/suspendable-ports.scm 
b/module/ice-9/suspendable-ports.scm
index d4468be..6d3d405 100644
--- a/module/ice-9/suspendable-ports.scm
+++ b/module/ice-9/suspendable-ports.scm
@@ -660,15 +660,26 @@
                (port-line-buffered? port))
       (flush-output port))))
 
+(define* (put-char port char)
+  (let ((aux (port-auxiliary-write-buffer port)))
+    (set-port-buffer-cur! aux 0)
+    (port-clear-stream-start-for-bom-write port aux)
+    (port-encode-char port aux char)
+    (let ((end (port-buffer-end aux)))
+      (set-port-buffer-end! aux 0)
+      (put-bytevector port (port-buffer-bytevector aux) 0 end))
+    (when (and (eqv? char #\newline) (port-line-buffered? port))
+      (flush-output port))))
+
 (define saved-port-bindings #f)
 (define port-bindings
-  '(((guile) read-char peek-char force-output close-port)
+  '(((guile)
+     read-char peek-char force-output close-port)
     ((ice-9 binary-ports)
      get-u8 lookahead-u8 get-bytevector-n
      put-u8 put-bytevector)
     ((ice-9 textual-ports)
-     ;; FIXME: put-char
-     put-string)
+     put-char put-string)
     ((ice-9 rdelim) %read-line read-line read-delimited)))
 (define (install-suspendable-ports!)
   (unless saved-port-bindings