output ports now non-blocking by default as well

eval.c

@@ -1039,6 +1039,9 @@ sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
   } while (!out && sexp_out_of_file_descriptors() && !count++);
   if (!out)
     return sexp_user_exception(ctx, self, "couldn't open output file", path);
+#if SEXP_USE_GREEN_THREADS
+  fcntl(fileno(out), F_SETFL, O_NONBLOCK);
+#endif
   return sexp_make_output_port(ctx, out, path);
 }
 

include/chibi/sexp.h

@@ -1297,7 +1297,7 @@ SEXP_API void sexp_init(void);
 SEXP_API sexp sexp_string_index_to_offset (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp index);
 SEXP_API sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
 SEXP_API void sexp_utf8_encode_char (unsigned char* p, int len, int c);
-SEXP_API void sexp_write_utf8_char (sexp ctx, int c, sexp out);
+SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out);
 #endif
 
 #if SEXP_USE_GREEN_THREADS
@@ -1474,7 +1474,7 @@ enum sexp_opcode_names {
   SEXP_OP_CHAR_UPCASE,
   SEXP_OP_CHAR_DOWNCASE,
   SEXP_OP_WRITE_CHAR,
-  SEXP_OP_NEWLINE,
+  SEXP_OP_WRITE_STRING,
   SEXP_OP_READ_CHAR,
   SEXP_OP_PEEK_CHAR,
   SEXP_OP_YIELD,

lib/chibi/disasm.c

@@ -34,7 +34,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   if (sexp_procedurep(bc)) {
     bc = sexp_procedure_code(bc);
   } else if (sexp_opcodep(bc)) {
-    sexp_display(ctx, sexp_opcode_name(bc), out);
+    sexp_write(ctx, sexp_opcode_name(bc), out);
     sexp_write_string(ctx, " is a primitive\n", out);
     return SEXP_VOID;
   } else if (! sexp_bytecodep(bc)) {
@@ -138,7 +138,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   case SEXP_OP_FCALL4:
     sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
     sexp_write_char(ctx, ' ', out);
-    sexp_display(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
+    sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
     ip += sizeof(sexp);
     break;
   case SEXP_OP_SLOT_REF:

lib/chibi/heap-stats.c

@@ -41,7 +41,7 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
   } else {
   print_name:
     sexp_write_string(ctx, "#<", out);
-    sexp_display(ctx, sexp_object_type_name(ctx, x), out);
+    sexp_write(ctx, sexp_object_type_name(ctx, x), out);
     sexp_write_string(ctx, ">", out);
   }
 }

lib/chibi/io.sld

@@ -1,6 +1,6 @@
 
 (define-library (chibi io)
-  (export read-string read-string! write-string read-line write-line
+  (export read-string read-string! read-line write-line
           port-fold port-fold-right port-map
           port->list port->string-list port->sexp-list port->string
           file-position set-file-position! seek/set seek/cur seek/end

lib/chibi/io/io.stub

@@ -10,8 +10,7 @@
   (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-const int (seek/set "SEEK_SET"))
 (define-c-const int (seek/cur "SEEK_CUR"))

lib/chibi/io/port.c

@@ -302,7 +302,8 @@ sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {
   sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
   if (!sexp_port_binaryp(out))
     return sexp_xtype_exception(ctx, self, "not a binary port", out);
-  sexp_write_char(ctx, sexp_unbox_fixnum(u8), out);
+  if (sexp_write_char(ctx, sexp_unbox_fixnum(u8), out) == EOF)
+    return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
   return SEXP_VOID;
 }
 

lib/init-7.scm

@@ -479,6 +479,15 @@
 
 ;; I/O utils
 
+(define (display x . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (cond ((char? x) (write-char x out))
+          ((string? x) (write-string x #t out))
+          (else (write x out)))))
+
+(define (newline . o)
+  (write-char #\newline (if (pair? o) (car o) (current-output-port))))
+
 (define (port? x) (or (input-port? x) (output-port? x)))
 
 (define textual-port? port?)

main.c

@@ -255,6 +255,10 @@ static sexp sexp_load_standard_params (sexp ctx, sexp e) {
 #if SEXP_USE_GREEN_THREADS
   p  = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
   if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1);
+  p  = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
+  if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1);
+  p  = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
+  if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1);
 #endif
   res = sexp_make_env(ctx);
   sexp_env_parent(res) = e;

opcodes.c

@@ -117,19 +117,17 @@ _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL),
 #if SEXP_USE_NATIVE_X86
 _FN2OPTP(SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), "write-char", (sexp)"current-output-port", sexp_write_char_op),
-_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "newline", (sexp)"current-output-port", sexp_newline_op),
 _FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "read-char", (sexp)"current-input-port", sexp_read_char_op),
 _FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "peek-char", (sexp)"current-input-port", sexp_peek_char_op),
 _FN5(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "five", 0, sexp_five),
 #else
 _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL),
-_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"current-output-port", NULL),
+_OP(SEXP_OPC_IO, SEXP_OP_WRITE_STRING, 2, 3, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_OPORT), 0, "write-string", (sexp)"current-output-port", NULL),
 _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL),
 _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL),
 #endif
 _FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"current-input-port", sexp_read_op),
 _FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-output-port", sexp_write_op),
-_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"current-output-port", sexp_display_op),
 _FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"current-output-port", sexp_flush_output_op),
 _FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op),
 _FN3(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?/bounded", 0, sexp_equalp_bound),

opt/opcode_names.h

@@ -17,6 +17,6 @@ static const char* reverse_opcode_names[] =
    "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER",
    "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
    "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
-   "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR",
+   "WRITE-CHAR", "WRITE-STRING", "READ-CHAR", "PEEK-CHAR",
    "YIELD", "FORCE", "RET", "DONE",
   };

sexp.c

@@ -563,7 +563,7 @@ sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp
         }
       } else if (sexp_opcodep(sexp_exception_procedure(exn))) {
         sexp_write_string(ctx, " in ", out);
-        sexp_display(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
+        sexp_write(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
       }
     }
     ls = sexp_exception_source(exn);
@@ -1467,6 +1467,54 @@ sexp sexp_set_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in, sexp
 }
 #endif
 
+#if SEXP_USE_GREEN_THREADS
+int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) {
+  sexp f;
+  int c;
+  if (sexp_port_stream(in) && sexp_port_fileno(in) >= 0) {
+    if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS)
+      sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL);
+    if (sexp_port_flags(in) & O_NONBLOCK) {
+      if (!forcep
+          && (((c = sexp_read_char(ctx, in)) == EOF)
+              && sexp_port_stream(in)
+              && ferror(sexp_port_stream(in)) && (errno == EAGAIN))) {
+        clearerr(sexp_port_stream(in));
+        f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+        if (sexp_opcodep(f)) {
+          ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, in);
+          return 1;
+        }
+      }
+      if (!forcep) sexp_push_char(ctx, c, in);
+      sexp_port_blockedp(in) = 1;
+      fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK);
+    }
+  }
+  return 0;
+}
+
+int sexp_maybe_block_output_port (sexp ctx, sexp out) {
+  if (sexp_port_stream(out) && sexp_port_fileno(out) >= 0) {
+    if (sexp_port_flags(out) == SEXP_PORT_UNKNOWN_FLAGS)
+      sexp_port_flags(out) = fcntl(sexp_port_fileno(out), F_GETFL);
+    if (sexp_port_flags(out) & O_NONBLOCK) {
+      sexp_port_blockedp(out) = 1;
+      fcntl(sexp_port_fileno(out), F_SETFL, sexp_port_flags(out) & ~O_NONBLOCK);
+      return 1;
+    }
+  }
+  return 0;
+}
+
+void sexp_maybe_unblock_port (sexp ctx, sexp port) {
+  if (sexp_port_blockedp(port)) {
+    sexp_port_blockedp(port) = 0;
+    fcntl(sexp_port_fileno(port), F_SETFL, sexp_port_flags(port));
+  }
+}
+#endif
+
 #define NUMBUF_LEN 32
 
 static struct {const char* name; char ch;} sexp_char_names[] = {
@@ -1568,7 +1616,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
       break;
     case SEXP_TYPE:
       sexp_write_string(ctx, "#<type ", out);
-      sexp_display(ctx, sexp_type_name(obj), out);
+      sexp_write(ctx, sexp_type_name(obj), out);
       sexp_write_string(ctx, ">", out);
       break;
     case SEXP_STRING:
@@ -1635,7 +1683,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
 #endif
     case SEXP_OPCODE:
       sexp_write_string(ctx, "#<opcode ", out);
-      sexp_display(ctx, sexp_opcode_name(obj), out);
+      sexp_write(ctx, sexp_opcode_name(obj), out);
       sexp_write_char(ctx, '>', out);
       break;
 #if SEXP_USE_BYTEVECTOR_LITERALS
@@ -1665,7 +1713,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
         } else {
 #endif
           sexp_write_string(ctx, "#<", out);
-          sexp_display(ctx, sexp_type_name(x), out);
+          sexp_write(ctx, sexp_type_name(x), out);
           sexp_write_char(ctx, '>', out);
 #if SEXP_USE_TYPE_PRINTERS
         }
@@ -1755,36 +1803,27 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
 }
 
 sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) {
+  sexp res;
   sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
-  return sexp_write_one(ctx, obj, out);
+  sexp_maybe_block_output_port(ctx, out);
-}
+  res = sexp_write_one(ctx, obj, out);
-
+  sexp_maybe_unblock_port(ctx, out);
-#if SEXP_USE_UTF8_STRINGS
-void sexp_write_utf8_char (sexp ctx, int c, sexp out) {
-  unsigned char buf[8];
-  int len = sexp_utf8_char_byte_count(c);
-  sexp_utf8_encode_char(buf, len, c);
-  buf[len] = 0;
-  sexp_write_string(ctx, (char*)buf, out);
-}
-#endif
-
-sexp sexp_display_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) {
-  sexp res=SEXP_VOID;
-  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
-  if (sexp_stringp(obj))
-    sexp_write_string(ctx, sexp_string_data(obj), out);
-  else if (sexp_charp(obj))
-#if SEXP_USE_UTF8_STRINGS
-    sexp_write_utf8_char(ctx, sexp_unbox_character(obj), out);
-#else
-    sexp_write_char(ctx, sexp_unbox_character(obj), out);
-#endif
-  else
-    res = sexp_write_one(ctx, obj, out);
   return res;
 }
 
+#if SEXP_USE_UTF8_STRINGS
+int sexp_write_utf8_char (sexp ctx, int c, sexp out) {
+  unsigned char buf[8];
+  int len = sexp_utf8_char_byte_count(c), i;
+  sexp_utf8_encode_char(buf, len, c);
+  buf[len] = 0;
+  i = sexp_write_char(ctx, buf[0], out);
+  if (i == EOF) return EOF;
+  sexp_write_string(ctx, (char*)buf+1, out);
+  return len;
+}
+#endif
+
 sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
   sexp_flush(ctx, out);
   return SEXP_VOID;
@@ -2166,41 +2205,6 @@ static int sexp_decode_utf8_char(const unsigned char* s) {
 }
 #endif
 
-#if SEXP_USE_GREEN_THREADS
-int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) {
-  sexp f;
-  int c;
-  if (sexp_port_stream(in) && sexp_port_fileno(in) >= 0) {
-    if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS)
-      sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL);
-    if (sexp_port_flags(in) & O_NONBLOCK) {
-      if (!forcep
-          && (((c = sexp_read_char(ctx, in)) == EOF)
-              && sexp_port_stream(in)
-              && ferror(sexp_port_stream(in)) && (errno == EAGAIN))) {
-        clearerr(sexp_port_stream(in));
-        f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
-        if (sexp_opcodep(f)) {
-          ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, in);
-          return 1;
-        }
-      }
-      if (!forcep) sexp_push_char(ctx, c, in);
-      sexp_port_blockedp(in) = 1;
-      fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK);
-    }
-  }
-  return 0;
-}
-
-void sexp_maybe_unblock_port (sexp ctx, sexp in) {
-  if (sexp_port_blockedp(in)) {
-    sexp_port_blockedp(in) = 0;
-    fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in));
-  }
-}
-#endif
-
 sexp sexp_read_raw (sexp ctx, sexp in) {
   char *str;
   int c1, c2, line;

tools/chibi-ffi

@@ -1020,7 +1020,7 @@
 
 (define (write-result-adjustment result)
   (cond
-   ((memq (type-base result) '(input-port input-output-port))
+   ((memq (type-base result) '(input-port output-port input-output-port))
     (let ((res (string-append "res" (type-index-string result))))
       (cat "#ifdef SEXP_USE_GREEN_THREADS\n"
            "  if (sexp_portp(" res "))\n"

vm.c

@@ -1761,18 +1761,67 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     sexp_context_top(ctx) = top;
 #if SEXP_USE_UTF8_STRINGS
     if (sexp_unbox_character(_ARG1) >= 0x80)
-      sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
+      i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
     else
 #endif
-    sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
+    i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
-    top-=2;
+    if (i == EOF) {
-    break;
+#if SEXP_USE_GREEN_THREADS
-  case SEXP_OP_NEWLINE:
+      if (sexp_port_stream(_ARG2) && ferror(sexp_port_stream(_ARG2))
-    if (! sexp_oportp(_ARG1))
+          && (errno == EAGAIN)
-      sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1));
+          && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
-    sexp_context_top(ctx) = top;
+        clearerr(sexp_port_stream(_ARG2));
-    sexp_newline(ctx, _ARG1);
+        sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2);
+        fuel = 0;
+        ip--;      /* try again */
+        goto loop;
+      } else
+#endif
+      sexp_raise("failed to write char to port", _ARG2);
+    }
     top--;
+    _ARG1 = SEXP_VOID;
+    break;
+  case SEXP_OP_WRITE_STRING:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("write-string: not a string", sexp_list1(ctx, _ARG1));
+    if (! sexp_fixnump(_ARG2)) {
+      if (_ARG2 == SEXP_TRUE)
+        _ARG2 = sexp_make_fixnum(sexp_string_length(_ARG1));
+      else
+        sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
+    }
+    if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_string_length(_ARG1))
+      sexp_raise("write-string: not a valid string count", sexp_list2(ctx, _ARG1, _ARG2));
+    if (! sexp_oportp(_ARG3))
+      sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
+    sexp_context_top(ctx) = top;
+    if (sexp_port_stream(_ARG3)) {
+      i = fwrite(sexp_string_data(_ARG1), 1, sexp_unbox_fixnum(_ARG2), sexp_port_stream(_ARG3));
+#if SEXP_USE_GREEN_THREADS
+      if ((i < sexp_unbox_fixnum(_ARG2)) && ferror(sexp_port_stream(_ARG3))
+          && (errno == EAGAIN)
+          && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
+        clearerr(sexp_port_stream(_ARG3));
+        sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3);
+        fuel = 0;
+        if (i > 0) {
+          /* modify stack in-place so we continue where we left off next time */
+          _ARG1 = sexp_substring(ctx, _ARG1, SEXP_ZERO, sexp_make_fixnum(i));
+          _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i);
+        }
+        ip--;      /* try again */
+        goto loop;
+      }
+#endif
+    } else {  /* not a stream-backed string */
+      if (sexp_string_length(_ARG1) != sexp_unbox_fixnum(_ARG2))
+        _ARG1 = sexp_substring(ctx, _ARG1, SEXP_ZERO, _ARG2);
+      sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG3);
+    }
+    i = _ARG2;
+    top-=2;
+    _ARG1 = sexp_make_fixnum(i);
     break;
   case SEXP_OP_READ_CHAR:
     if (! sexp_iportp(_ARG1))