Adding custom port support for non-string-stream builds.

String-streams are now disabled by default.

eval.c

@@ -1058,7 +1058,17 @@ 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 res = SEXP_VOID;
   sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
+  /* we can't run arbitrary scheme code in the finalizer, so we need */
+  /* to flush and run the closer here */
+  if (sexp_port_customp(port)) {
+    if (sexp_oportp(port)) res = sexp_flush_output(ctx, port);
+    if (sexp_exceptionp(res)) return res;
+    if (sexp_applicablep(sexp_port_closer(port)))
+      res = sexp_apply1(ctx, sexp_port_closer(port), port);
+    if (sexp_exceptionp(res)) return res;
+  }
   return sexp_finalize_port(ctx, self, n, port);
 }
 

include/chibi/features.h

@@ -179,10 +179,10 @@
 /*   Making them immutable allows for packed UTF-8 strings. */
 /* #define SEXP_USE_MUTABLE_STRINGS 0 */
 
-/* uncomment this to disable string ports */
+/* uncomment this to base string ports on C streams */
-/*   If disabled some basic functionality such as number->string */
+/*   This historic option enables string and custom ports backed */
-/*   will not be available by default. */
+/*   by FILE* objects using memstreams and funopen/fopencookie. */
-/* #define SEXP_USE_STRING_STREAMS 0 */
+/* #define SEXP_USE_STRING_STREAMS 1 */
 
 /* uncomment this to disable automatic closing of ports */
 /*   If enabled, the underlying FILE* for file ports will be */
@@ -525,11 +525,7 @@
 #endif
 
 #ifndef SEXP_USE_STRING_STREAMS
-#ifdef _WIN32
 #define SEXP_USE_STRING_STREAMS 0
-#else
-#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES
-#endif
 #endif
 
 #ifndef SEXP_USE_AUTOCLOSE_PORTS
@@ -544,6 +540,10 @@
 #define SEXP_USE_BIDIRECTIONAL_PORTS ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_PORT_BUFFER_SIZE
+#define SEXP_PORT_BUFFER_SIZE 4096
+#endif
+
 #ifndef SEXP_USE_2010_EPOCH
 #define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
 #endif

include/chibi/sexp.h

@@ -681,6 +681,15 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_stream_portp(x) (sexp_port_stream(x) != NULL)
 #endif
 
+#define sexp_port_customp(x) (sexp_vectorp(sexp_port_cookie(x)) && sexp_vector_length(sexp_port_cookie(x)) == 6)
+
+/* only valid on custom ports */
+#define sexp_port_buffer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_ONE))
+#define sexp_port_reader(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_TWO))
+#define sexp_port_writer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_THREE))
+#define sexp_port_seeker(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_FOUR))
+#define sexp_port_closer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_FIVE))
+
 /***************************** constructors ****************************/
 
 #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)

lib/chibi/io.sld

@@ -5,7 +5,8 @@
           port->list port->string-list port->sexp-list port->string
           file-position set-file-position! seek/set seek/cur seek/end
           make-custom-input-port make-custom-output-port
-          make-null-output-port make-broadcast-port make-concatenated-port
+          make-null-output-port make-null-input-port
+          make-broadcast-port make-concatenated-port
           make-generated-input-port make-filtered-output-port
           make-filtered-input-port string-count
           open-input-bytevector open-output-bytevector get-output-bytevector

lib/chibi/io/io.scm

@@ -1,5 +1,5 @@
 ;; io.scm -- various input/output utilities
-;; 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
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -37,7 +37,7 @@
  ((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))))))
+      (display (substring str 0 n) out)))))
 
 ;;> @subsubsubsection{(read-line [in [n]])}
 
@@ -90,7 +90,7 @@
     (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))
+          ((or (= i n) (eof-object? ch)) (list i (get-output-string out)))
         (write-char ch out))))))
 
 (define (read-string n . o)
@@ -183,28 +183,32 @@
     (%make-custom-output-port write seek close)))
 
 (define (make-null-output-port)
-  (make-custom-output-port (lambda (str n) 0)))
+  (make-custom-output-port (lambda (str start end) 0)))
 
 (define (make-broadcast-port . ports)
   (make-custom-output-port
-   (lambda (str n)
+   (lambda (str start end)
+     (let ((str (if (zero? start) str (substring str start)))
+           (n (- end start)))
        (for-each (lambda (p) (write-string str n p)) ports)
-     n)))
+       n))))
 
 (define (make-filtered-output-port filter out)
   (make-custom-output-port
-   (lambda (str n)
+   (lambda (str start end)
      (let* ((len (string-length str))
-            (s1 (if (= n len) str (substring str 0 n)))
+            (s1 (if (and (zero? start) (= end len)) str (substring str start end)))
             (s2 (filter s1)))
        (if (string? s2)
            (write-string s2 (string-length s2) out))))))
 
 (define (make-concatenated-port . ports)
   (make-custom-input-port
-   (lambda (str n)
+   (lambda (str start end)
      (if (null? ports)
          0
+         (let ((str (if (zero? start) str (substring str start)))
+               (n (- end start)))
            (let lp ((i (read-string! str n (car ports))))
              (cond
               ((>= i n)
@@ -219,29 +223,33 @@
                         (len (if (string? s) (string-length s) 0)))
                    (if (and (string? str) (> len 0))
                        (string-copy! str i s 0 len))
-                 (lp (+ i len))))))))))))
+                   (lp (+ i len)))))))))))))
+
+(define (make-null-input-port)
+  (make-concatenated-port))
 
 (define (make-generated-input-port generator)
   (let ((buf "")
         (len 0)
         (offset 0))
     (make-custom-input-port
-     (lambda (str n)
+     (lambda (str start end)
+       (let ((n (- end start)))
          (cond
           ((>= (- len offset) n)
-         (string-copy! str 0 buf offset (+ offset n))
+           (string-copy! str start buf offset (+ offset n))
            (set! offset (+ offset n))
            n)
           (else
-         (string-copy! str 0 buf offset len)
+           (string-copy! str start buf offset len)
-         (let lp ((i (- len offset)))
+           (let lp ((i (+ start (- len offset))))
              (set! buf (generator))
              (cond
               ((not (string? buf))
                (set! buf "")
                (set! len 0)
                (set! offset 0)
-             (- n i))
+               (- i start))
               (else
                (set! len (string-length buf))
                (set! offset 0)
@@ -252,7 +260,7 @@
                  n)
                 (else
                  (string-copy! str i buf offset len)
-               (lp (+ i (- len offset))))))))))))))
+                 (lp (+ i (- len offset)))))))))))))))
 
 (define (make-filtered-input-port filter in)
   (make-generated-input-port

lib/chibi/io/io.stub

@@ -9,7 +9,6 @@
 
   (define-c size_t (%read-string! "fread")
     (string (value 1 size_t) size_t (default (current-input-port) input-port)))
-
   ))
 
 (define-c-const int (seek/set "SEEK_SET"))

lib/chibi/io/port.c

@@ -2,7 +2,6 @@
 #include <stdio.h>
 #include <chibi/eval.h>
 
-#define SEXP_PORT_BUFFER_SIZE 1024
 #define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
 
 #define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
@@ -62,7 +61,8 @@ static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size)
   sexp_gc_preserve2(ctx, ctx2, args);
   if (size > sexp_string_length(sexp_cookie_buffer(vec)))
     sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
-  args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
   res = sexp_apply(ctx, sexp_cookie_read(vec), args);
   sexp_gc_release2(ctx);
   if (sexp_fixnump(res)) {
@@ -88,7 +88,8 @@ static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size
   if (size > sexp_string_length(sexp_cookie_buffer(vec)))
     sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
   memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size);
-  args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
   res = sexp_apply(ctx, sexp_cookie_write(vec), args);
   sexp_gc_release2(ctx);
   return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1);
@@ -189,21 +190,47 @@ static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode,
 static sexp sexp_make_custom_port (sexp ctx, sexp self,
                                    char *mode, sexp read, sexp write,
                                    sexp seek, sexp close) {
-  return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL);
+  sexp vec;
+  sexp_gc_var2(res, str);
+  sexp_gc_preserve2(ctx, res, str);
+  str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
+  if (sexp_exceptionp(str)) return str;
+  res = sexp_make_input_string_port(ctx, str);
+  if (sexp_exceptionp(res)) return res;
+  if (mode && mode[0] == 'w') {
+    sexp_pointer_tag(res) = SEXP_OPORT;
+    sexp_port_cookie(res) = str;
+  } else {
+    sexp_port_offset(res) = 0;
+    sexp_port_size(res) = 0;
+  }
+  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
+  if (sexp_exceptionp(vec)) return vec;
+  sexp_vector_set(vec, SEXP_ZERO, SEXP_FALSE);
+  sexp_vector_set(vec, SEXP_ONE, sexp_port_cookie(res));
+  sexp_vector_set(vec, SEXP_TWO, read);
+  sexp_vector_set(vec, SEXP_THREE, write);
+  sexp_vector_set(vec, SEXP_FOUR, seek);
+  sexp_vector_set(vec, SEXP_FIVE, close);
+  sexp_port_cookie(res) = vec;
+  sexp_gc_release2(ctx);
+  return res;
 }
 
 #endif
 
-static sexp sexp_make_custom_input_port (sexp ctx, sexp self,
+sexp sexp_make_custom_input_port (sexp ctx, sexp self,
                                   sexp read, sexp seek, sexp close) {
   return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close);
 }
 
-static sexp sexp_make_custom_output_port (sexp ctx, sexp self,
+sexp sexp_make_custom_output_port (sexp ctx, sexp self,
                                    sexp write, sexp seek, sexp close) {
   sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
+#if SEXP_USE_STRING_STREAMS
   if (!sexp_exceptionp(res))
     sexp_pointer_tag(res) = SEXP_OPORT;
+#endif
   return res;
 }
 

sexp.c

@@ -124,7 +124,11 @@ sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
 #if !SEXP_USE_STRING_STREAMS
               || (sexp_iportp(port) && sexp_truep(sexp_port_cookie(port)))
 #endif
-              ))
+              )
+#if SEXP_USE_STRING_STREAMS
+          && !sexp_port_customp(port)
+#endif
+          )
 	free(sexp_port_buf(port));
     }
 #ifndef PLAN9
@@ -1354,9 +1358,8 @@ sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp
 
 #else  /* ! SEXP_USE_STRING_STREAMS */
 
-#define SEXP_PORT_BUFFER_SIZE 4096
-
 int sexp_buffered_read_char (sexp ctx, sexp p) {
+  sexp_gc_var1(tmp);
   int res = 0;
   if (sexp_port_offset(p) < sexp_port_size(p)) {
     return sexp_port_buf(p)[sexp_port_offset(p)++];
@@ -1376,6 +1379,21 @@ int sexp_buffered_read_char (sexp ctx, sexp p) {
       res = ((sexp_port_offset(p) < sexp_port_size(p))
              ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF);
     }
+  } else if (sexp_port_customp(p)) {
+    sexp_gc_preserve1(ctx, tmp);
+    tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE));
+    tmp = sexp_cons(ctx, sexp_port_buffer(p), tmp);
+    tmp = sexp_apply(ctx, sexp_port_reader(p), tmp);
+    if (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) {
+      sexp_port_offset(p) = 0;
+      sexp_port_size(p) = sexp_unbox_fixnum(tmp);
+      res = ((sexp_port_offset(p) < sexp_port_size(p))
+             ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF);
+    } else {
+      res = EOF;
+      sexp_port_size(p) = 0;
+    }
+    sexp_gc_release1(ctx);
   } else {
     res = EOF;
   }
@@ -1434,8 +1452,14 @@ int sexp_buffered_flush (sexp ctx, sexp p) {
       sexp_port_offset(p) = 0;
       res = 0;
     }
-  } else if (sexp_port_offset(p) > 0) { /* string port */
+  } else if (sexp_port_offset(p) > 0) {
     sexp_gc_preserve1(ctx, tmp);
+    if (sexp_port_customp(p)) {   /* custom port */
+      tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(sexp_port_offset(p)));
+      tmp = sexp_cons(ctx, sexp_port_buffer(p), tmp);
+      tmp = sexp_apply(ctx, sexp_port_writer(p), tmp);
+      res = (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) ? 0 : -1;
+    } else {                      /* string port */
       tmp = sexp_c_string(ctx, sexp_port_buf(p), off);
       if (tmp && sexp_stringp(tmp)) {
         sexp_push(ctx, sexp_port_cookie(p), tmp);
@@ -1444,6 +1468,7 @@ int sexp_buffered_flush (sexp ctx, sexp p) {
       } else {
         res = -1;
       }
+    }
     sexp_gc_release1(ctx);
   }
   return res;

tests/io-tests.scm

@@ -23,12 +23,6 @@
   (call-with-input-string "abc\ndef"
     (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
 
-;; Custom ports are only supported with string streams (i.e. either
-;; GNU fopencookie or BSD funopen).
-
-(cond-expand
- (string-streams
-
 (test "null-output-port" #t
   (let ((out (make-null-output-port)))
     (write 1 out)
@@ -36,7 +30,7 @@
     #t))
 
 (test "null-input-port" #t
-    (let ((in (make-concatenated-port)))
+  (let ((in (make-null-input-port)))
     (let ((res (eof-object? (read-char in))))
       (close-input-port in)
       res)))
@@ -57,6 +51,6 @@
     (lambda (out)
       (let ((out (make-filtered-output-port string-upcase out)))
         (display "abc" out)
-          (close-output-port out)))))))
+        (close-output-port out)))))
 
 (test-end)