adding extended io utils, including custom ports, with high-level

custom port constructors such as concatenated and filtered ports.

TODO

@@ -60,7 +60,8 @@
    - State "DONE"       [2009-07-07 Tue 14:42]
 ** TODO unicode
 ** TODO threads
-** TODO virtual ports
+** DONE virtual ports
+   - State "DONE"       [2010-01-02 Sat 20:12]
 ** DONE dynamic-wind
    - State "DONE"       [2009-12-26 Sat 01:51]
    Adapted a version from Scheme48.
@@ -114,7 +115,8 @@
     - State "DONE"       [2009-12-26 Sat 01:50]
 *** DONE time interface
     - State "DONE"       [2009-12-26 Sat 01:50]
-*** TODO host system interface
+*** DONE host system interface
+    - State "DONE"       [2010-01-02 Sat 20:12]
 ** DONE pathname library
    - State "DONE"       [2009-12-16 Wed 18:58]
 ** DONE uri library

include/chibi/sexp.h

@@ -460,6 +460,10 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define SEXP_THREE   sexp_make_fixnum(3)
 #define SEXP_FOUR    sexp_make_fixnum(4)
 #define SEXP_FIVE    sexp_make_fixnum(5)
+#define SEXP_SIX     sexp_make_fixnum(6)
+#define SEXP_SEVEN   sexp_make_fixnum(7)
+#define SEXP_EIGHT   sexp_make_fixnum(8)
+#define SEXP_NINE    sexp_make_fixnum(9)
 
 #define sexp_make_character(n)  ((sexp) ((((sexp_sint_t)(n))<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
 #define sexp_unbox_character(n) ((int) (((sexp_sint_t)(n))>>SEXP_EXTENDED_BITS))

lib/chibi/io.module

@@ -2,7 +2,12 @@
 (define-module (chibi io)
   (export read-string read-string! write-string read-line write-line
           port-fold port-fold-right port-map
-          port->list port->string-list port->sexp-list port->string)
+          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-generated-input-port make-filtered-output-port
+          make-filtered-input-port)
   (import-immutable (scheme))
   (include-shared "io/io")
   (include "io/io.scm"))

lib/chibi/io/io.scm

@@ -1,8 +1,22 @@
+;; io.scm -- various input/output utilities
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
 
 (define eof
   (call-with-input-string " "
     (lambda (in) (read-char in) (read-char in))))
 
+(define (string-copy! dst start src from to)
+  (do ((i from (+ i 1)) (j start (+ j 1)))
+      ((>= i to))
+    (string-set! dst j (string-ref src i))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reading and writing
+
 (define (write-line str . o)
   (let ((out (if (pair? o) (car o) (current-output-port))))
     (display str out)
@@ -21,6 +35,9 @@
           eof
           (cadr res)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; higher order port operations
+
 (define (port-fold kons knil . o)
   (let ((read (if (pair? o) (car o) read))
         (in (if (and (pair? o) (pair? (cdr o)))
@@ -53,3 +70,94 @@
 
 (define (port->string in)
   (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; custom port utilities
+
+(define (make-custom-input-port read . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-input-port read seek close)))
+
+(define (make-custom-output-port write . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-output-port write seek close)))
+
+(define (make-null-output-port)
+  (make-custom-output-port (lambda (str n) 0)))
+
+(define (make-broadcast-port . ports)
+  (make-custom-output-port
+   (lambda (str n)
+     (for-each (lambda (p) (write-string str n p)) ports)
+     n)))
+
+(define (make-filtered-output-port filter out)
+  (make-custom-output-port
+   (lambda (str n)
+     (let* ((len (string-length str))
+            (s1 (if (= n len) str (substring str 0 n)))
+            (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)
+     (if (null? ports)
+         0
+         (let lp ((i (read-string! str n (car ports))))
+           (cond
+            ((>= i n)
+             i)
+            (else
+             (set! ports (cdr ports))
+             (cond
+              ((null? ports)
+               i)
+              (else
+               (let* ((s (read-string (- n i) (car ports)))
+                      (len (if (string? s) (string-length s) 0)))
+                 (if (and (string? str) (> len 0))
+                     (string-copy! str i s 0 len))
+                 (lp (+ i len))))))))))))
+
+(define (make-generated-input-port generator)
+  (let ((buf "")
+        (len 0)
+        (offset 0))
+    (make-custom-input-port
+     (lambda (str n)
+       (cond
+        ((>= (- len offset) n)
+         (string-copy! str 0 buf offset (+ offset n))
+         (set! offset (+ offset n))
+         n)
+        (else
+         (string-copy! str 0 buf offset len)
+         (let lp ((i (- len offset)))
+           (set! buf (generator))
+           (cond
+            ((not (string? buf))
+             (set! buf "")
+             (set! len 0)
+             (set! offset 0)
+             (- n i))
+            (else
+             (set! len (string-length buf))
+             (set! offset 0)
+             (cond
+              ((>= (- len offset) (- n i))
+               (string-copy! str i buf offset (+ offset (- n i)))
+               (set! offset (+ offset (- n i)))
+               n)
+              (else
+               (string-copy! str i buf offset len)
+               (lp (+ i (- len offset))))))))))))))
+
+(define (make-filtered-input-port filter in)
+  (make-generated-input-port
+   (lambda ()
+     (let ((res (read-string 1024 in)))
+       (if (string? res) (filter res) res)))))

lib/chibi/io/io.stub

@@ -6,8 +6,22 @@
   ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port)))
 
 (define-c size_t (read-string! "fread")
-  (string size_t (value 1 size_t) (default (current-input-port) input-port)))
+  (string (value 1 size_t) size_t (default (current-input-port) input-port)))
 
 (define-c size_t (write-string "fwrite")
-  (string size_t (value 1 size_t) (default (current-output-port) output-port)))
+  (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"))
+(define-c-const int (seek/end "SEEK_END"))
+
+(define-c long (file-position "ftell") (port))
+(define-c long (set-file-position! "fseek") (port long int))
+
+(c-include "port.c")
+
+(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port")
+  ((value ctx sexp) sexp sexp sexp))
+
+(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port")
+  ((value ctx sexp) sexp sexp sexp))

sexp.c

@@ -291,7 +291,9 @@ sexp sexp_make_context (sexp ctx, sexp_uint_t size) {
 #if ! SEXP_USE_GLOBAL_HEAP
 void sexp_destroy_context (sexp ctx) {
   sexp_heap heap;
+  size_t sum_freed;
   if (sexp_context_heap(ctx)) {
+    sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */
     heap = sexp_context_heap(ctx);
     sexp_context_heap(ctx) = NULL;
     free(heap);