Adding support for bi-directional ports, and making (chibi net) use them for sockets.

Also modifying FFI to automatically make input ports non-blocking,
and fixing R7RS incompatibility where closing an already closed
port signalled an error.

eval.c

@@ -1,5 +1,5 @@
 /*  eval.c -- evaluator library implementation                */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include "chibi/eval.h"
@@ -1050,8 +1050,6 @@ sexp sexp_open_binary_output_file (sexp ctx, sexp self, sexp_sint_t n, sexp path
 
 sexp sexp_close_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
   sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
-  if (! sexp_port_openp(port))
-    return sexp_user_exception(ctx, self, "port already closed", port);
   return sexp_finalize_port(ctx, self, n, port);
 }
 
@@ -1964,6 +1962,9 @@ static const char* sexp_initial_features[] = {
 #if SEXP_USE_DL
   "dynamic-loading",
 #endif
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+  "bidir-ports",
+#endif
 #if SEXP_USE_STRING_STREAMS
   "string-streams",
 #endif

include/chibi/features.h

@@ -1,5 +1,5 @@
 /*  features.h -- general feature configuration               */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 /* uncomment this to disable most features */
@@ -510,6 +510,10 @@
 #define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
 #endif
 
+#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
+#define SEXP_USE_BIDIRECTIONAL_PORTS ! SEXP_USE_NO_FEATURES
+#endif
+
 #ifndef SEXP_USE_2010_EPOCH
 #define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
 #endif

include/chibi/sexp.h

@@ -1,5 +1,5 @@
 /*  sexp.h -- header for sexp library                         */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_H
@@ -315,7 +315,7 @@ struct sexp_struct {
     struct {
       FILE *stream;
       char *buf;
-      char openp, binaryp, no_closep, sourcep, blockedp, fold_casep;
+      char openp, bidirp, binaryp, no_closep, sourcep, blockedp, fold_casep;
       sexp_uint_t offset, line, flags;
       size_t size;
       sexp name;
@@ -604,7 +604,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_bytesp(x)      (sexp_check_tag(x, SEXP_BYTES))
 #define sexp_vectorp(x)     (sexp_check_tag(x, SEXP_VECTOR))
 #define sexp_iportp(x)      (sexp_check_tag(x, SEXP_IPORT))
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+#define sexp_oportp(x)      (sexp_check_tag(x, SEXP_OPORT) || (sexp_check_tag(x, SEXP_IPORT) && sexp_port_bidirp(x)))
+#else
 #define sexp_oportp(x)      (sexp_check_tag(x, SEXP_OPORT))
+#endif
 #if SEXP_USE_BIGNUMS
 #define sexp_bignump(x)     (sexp_check_tag(x, SEXP_BIGNUM))
 #else
@@ -651,7 +655,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_idp(x) \
   (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
 
-#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x))
+#define sexp_portp(x) (sexp_check_tag(x, SEXP_IPORT) || sexp_check_tag(x, SEXP_OPORT))
 
 #if SEXP_USE_STRING_STREAMS
 #define sexp_stream_portp(x) 1
@@ -842,6 +846,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_port_name(p)       (sexp_pred_field(p, port, sexp_portp, name))
 #define sexp_port_line(p)       (sexp_pred_field(p, port, sexp_portp, line))
 #define sexp_port_openp(p)      (sexp_pred_field(p, port, sexp_portp, openp))
+#define sexp_port_bidirp(p)     (sexp_pred_field(p, port, sexp_portp, bidirp))
 #define sexp_port_binaryp(p)    (sexp_pred_field(p, port, sexp_portp, binaryp))
 #define sexp_port_no_closep(p)  (sexp_pred_field(p, port, sexp_portp, no_closep))
 #define sexp_port_sourcep(p)    (sexp_pred_field(p, port, sexp_portp, sourcep))
@@ -1248,6 +1253,7 @@ SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name);
 SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name);
 SEXP_API sexp sexp_make_non_null_input_port (sexp ctx, FILE* in, sexp name);
 SEXP_API sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name);
+SEXP_API sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name);
 SEXP_API sexp sexp_port_binaryp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
 SEXP_API sexp sexp_port_openp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
 #if SEXP_USE_FOLD_CASE_SYMS

lib/chibi/filesystem.sld

@@ -6,6 +6,7 @@
 
 (define-library (chibi filesystem)
   (export open-input-file-descriptor open-output-file-descriptor
+          open-input-output-file-descriptor
           duplicate-file-descriptor duplicate-file-descriptor-to
           close-file-descriptor renumber-file-descriptor
           delete-file link-file symbolic-link-file rename-file

lib/chibi/filesystem.stub

@@ -1,5 +1,5 @@
 ;; filesystem.stub -- filesystem bindings
-;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 (c-system-include "sys/types.h")
@@ -75,6 +75,11 @@
 (define-c output-port (open-output-file-descriptor "fdopen")
   (int (value "w" string)))
 
+;;> Creates a new bidirectional port from the file descriptor @var{int}.
+
+(define-c input-output-port (open-input-output-file-descriptor "fdopen")
+  (int (value "r+" string)))
+
 ;;> Unlinks the file named @var{string} from the filesystem.
 ;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
 

lib/chibi/net.scm

@@ -1,4 +1,4 @@
-;; Copyright (c) 2010-2011 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;> @subsubsubsection{@scheme{(get-address-info host service [addrinfo])}}
@@ -42,8 +42,13 @@
                 (cond-expand
                  (threads (set-file-descriptor-flags! sock open/non-block))
                  (else #f))
-                (list (open-input-file-descriptor sock)
+                (cond-expand
-                      (open-output-file-descriptor sock)))))))))
+                 (bidir-ports
+                  (let ((port (open-input-output-file-descriptor sock)))
+                    (list port port)))
+                 (else
+                  (list (open-input-file-descriptor sock)
+                        (open-output-file-descriptor sock)))))))))))
 
 ;;> Convenience wrapper around @scheme{open-net-io}, opens
 ;;> the connection then calls @var{proc} with two arguments,
@@ -56,8 +61,9 @@
   (let ((io (open-net-io host service)))
     (if (not (pair? io))
         (error "couldn't find address" host service)
-        (let ((res (proc (car io) (car (cdr io)))))
+        (let ((res (proc (car io) (cadr io))))
           (close-input-port (car io))
+          (close-output-port (cadr io))
           res))))
 
 ;;> @subsubsubsection{@scheme{(make-listener-socket addrinfo [max-conn])}}

sexp.c

@@ -1,5 +1,5 @@
 /*  sexp.c -- standalone sexp library implementation          */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include "chibi/sexp.h"
@@ -1390,6 +1390,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
   sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS;
   sexp_port_buf(p) = NULL;
   sexp_port_openp(p) = 1;
+  sexp_port_bidirp(p) = 0;
   sexp_port_binaryp(p) = 1;
   sexp_port_no_closep(p) = 0;
   sexp_port_sourcep(p) = 0;
@@ -1418,6 +1419,18 @@ sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name) {
   return sexp_make_output_port(ctx, out, name);
 }
 
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name) {
+  sexp res;
+  if (!io) return sexp_user_exception(ctx, SEXP_FALSE, "null input-output-port", name);
+  res = sexp_make_input_port(ctx, io, name);
+  if (sexp_portp(res)) sexp_port_bidirp(res) = 1;
+  return res;
+}
+#else
+#define sexp_make_non_null_input_output_port sexp_make_non_null_input_port
+#endif
+
 sexp sexp_port_binaryp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
   return sexp_make_boolean(sexp_port_binaryp(port));

tools/chibi-ffi

@@ -149,7 +149,7 @@
            (eq? 'char (type-base type)))))
 
 (define (port-type? type)
-  (memq type '(port input-port output-port)))
+  (memq type '(port input-port output-port input-output-port)))
 
 (define (error-type? type)
   (memq type '(errno non-null-string non-null-pointer)))
@@ -400,6 +400,7 @@
      ((eq? base 'port) "sexp_portp")
      ((eq? base 'input-port) "sexp_iportp")
      ((eq? base 'output-port) "sexp_oportp")
+     ((eq? base 'input-output-port) "sexp_ioportp")
      (else #f))))
 
 (define (type-name type)
@@ -424,6 +425,7 @@
      ((eq? base 'port) "SEXP_IPORT")
      ((eq? base 'input-port) "SEXP_IPORT")
      ((eq? base 'output-port) "SEXP_OPORT")
+     ((eq? base 'input-output-port) "SEXP_IPORT")
      ((void-pointer-type? type) "SEXP_CPOINTER")
      ((assq base *types*)
       ;; (string-append "sexp_type_tag(" (type-id-name base) ")")
@@ -495,6 +497,8 @@
       (cat "sexp_make_non_null_input_port(ctx, " val ", SEXP_FALSE)"))
      ((eq? 'output-port base)
       (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)"))
+     ((eq? 'input-output-port base)
+      (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
      (else
       (let ((ctype (assq base *types*))
             (void*? (void-pointer-type? type)))
@@ -895,7 +899,17 @@
       (else #f)))
     (cat ";\n")
     (if (type-array ret-type)
-        (write-result ret-type))))
+        (write-result ret-type)
+        (write-result-adjustment ret-type))))
+
+(define (write-result-adjustment result)
+  (cond
+   ((memq (type-base result) '(input-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"
+           "    fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK);\n"
+           "#endif\n")))))
 
 (define (write-result result)
   (let ((res (string-append "res" (type-index-string result)))
@@ -934,7 +948,8 @@
       (c->scheme-converter
        result
        (string-append "tmp" (type-index-string result)))
-      (cat ";\n")))))
+      (cat ";\n")))
+    (write-result-adjustment result)))
 
 (define (write-results func)
   (let ((error-res? (error-type? (type-base (func-ret-type func))))
@@ -998,7 +1013,7 @@
          (if (number? len)
              (cat "  if (len" i " != " len ")\n"
                   "    free(tmp" i ");\n"))))
-      ((eq? (type-base a) 'input-port)
+      ((memq (type-base a) '(input-port input-output-port))
        (cat "  sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n"))
       ((and (type-result? a) (not (basic-type? a))
             (not (assq (type-base a) *types*))