diff --git a/TODO b/TODO
index 93f7c837..3e01c1f5 100644
--- a/TODO
+++ b/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
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 369e3b65..491e70a9 100644
--- a/include/chibi/sexp.h
+++ b/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))
diff --git a/lib/chibi/io.module b/lib/chibi/io.module
index f9d531f3..ec765c04 100644
--- a/lib/chibi/io.module
+++ b/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"))
diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm
index a6e0f8d2..97de1cc6 100644
--- a/lib/chibi/io/io.scm
+++ b/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)))))
diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub
index 685e1832..208d0a18 100644
--- a/lib/chibi/io/io.stub
+++ b/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))
diff --git a/sexp.c b/sexp.c
index b6eab627..5e313b12 100644
--- a/sexp.c
+++ b/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);