Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-07 05:06:37 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
String-streams are now disabled by default.
This commit is contained in:
Alex Shinn 2012-05-06 18:16:17 +09:00
parent 14370af921
commit ce80d45ff8
9 changed files with 180 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
eval.c
View file

@ -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);
}

16
include/chibi/features.h
View file

@ -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 */
/* If disabled some basic functionality such as number->string */
/* will not be available by default. */
/* #define SEXP_USE_STRING_STREAMS 0 */
/* uncomment this to base string ports on C streams */
/* This historic option enables string and custom ports backed */
/* by FILE* objects using memstreams and funopen/fopencookie. */
/* #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

9
include/chibi/sexp.h
View file

@ -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)

3
lib/chibi/io.sld
View file

@ -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

40
lib/chibi/io/io.scm
View file

@ -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)
(let lp ((i (- len offset)))
(string-copy! str start buf offset len)
(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

1
lib/chibi/io/io.stub
View file

@ -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"))

39
lib/chibi/io/port.c
View file

@ -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;
}

33
sexp.c
View file

@ -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;

10
tests/io-tests.scm
View file

@ -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)