static sexp sexp_make_custom_port (sexp ctx, sexp self,
char *mode, sexp read, sexp write,
sexp seek, sexp close) {
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_open_input_string(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;
}
sexp sexp_seek (sexp ctx, sexp self, sexp x, off_t offset, int whence) {
off_t res;
if (! (sexp_portp(x) || sexp_filenop(x)))
return sexp_type_exception(ctx, self, SEXP_IPORT, x);
if (sexp_filenop(x))
return sexp_make_integer(ctx, lseek(sexp_fileno_fd(x), offset, whence));
if (sexp_filenop(sexp_port_fd(x))) {
res = lseek(sexp_fileno_fd(sexp_port_fd(x)), offset, whence);
if (res >= 0 && !(whence == SEEK_CUR && offset == 0))
sexp_port_offset(x) = 0;
return sexp_make_integer(ctx, res);
}
if (sexp_stream_portp(x))
return sexp_make_integer(ctx, fseek(sexp_port_stream(x), offset, whence));
return sexp_xtype_exception(ctx, self, "not a seekable port", x);
}
