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; }
static sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { sexp res; sexp_gc_var1(state); sexp_gc_preserve1(ctx, state); state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF); res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id); if (sexp_exceptionp(res)) return res; sexp_random_state(res) = state; sexp_random_init(res, 1); sexp_gc_release1(ctx); return res; }
static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) #endif { sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; sexp_gc_var2(ctx2, args); ctx = sexp_cookie_ctx(vec); ctx2 = sexp_last_context(ctx, (sexp*)&cookie); 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)); memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); res = sexp_apply(ctx, sexp_cookie_write(vec), args); sexp_gc_release2(ctx); return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); }
static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, sexp read, sexp write, sexp seek, sexp close) { FILE *in; sexp res; sexp_gc_var1(vec); if (sexp_truep(read) && ! sexp_procedurep(read)) return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); if (sexp_truep(write) && ! sexp_procedurep(write)) return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); if (sexp_truep(seek) && ! sexp_procedurep(seek)) return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); if (sexp_truep(close) && ! sexp_procedurep(close)) return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); sexp_gc_preserve1(ctx, vec); vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); sexp_cookie_ctx_set(vec, ctx); sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID)); sexp_cookie_read_set(vec, read); sexp_cookie_write_set(vec, write); sexp_cookie_seek_set(vec, seek); sexp_cookie_close_set(vec, close); #if SEXP_BSD in = funopen(vec, (sexp_procedurep(read) ? sexp_cookie_reader : NULL), (sexp_procedurep(write) ? sexp_cookie_writer : NULL), NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); #else in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); #endif if (! in) { res = sexp_user_exception(ctx, self, "couldn't make custom port", read); } else { res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = vec; /* for gc preserving */ } if (mode && mode[0] == 'w') sexp_pointer_tag(res) = SEXP_OPORT; sexp_gc_release1(ctx); return res; }
sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { int i, str_len, lg_base = log2i(base); char *data; sexp_gc_var2(b, str); sexp_gc_preserve2(ctx, b, str); b = sexp_copy_bignum(ctx, NULL, a, 0); sexp_bignum_sign(b) = 1; i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) / lg_base + 1; str = sexp_make_string(ctx, sexp_make_fixnum(str_len), sexp_make_character(' ')); data = sexp_string_data(str); while (! sexp_bignum_zerop(b)) data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); if (i == str_len) data[--i] = '0'; else if (sexp_bignum_sign(a) == -1) data[--i] = '-'; sexp_write_string(ctx, data + i, out); sexp_gc_release2(ctx); return SEXP_VOID; }
static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size) #endif { sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_read(vec))) return -1; sexp_gc_var2(ctx2, args); ctx = sexp_cookie_ctx(vec); ctx2 = sexp_last_context(ctx, (sexp*)&cookie); sexp_gc_preserve2(ctx, ctx2, args); if (size > sexp_string_size(sexp_cookie_buffer(vec))) sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID)); 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)) { memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); return sexp_unbox_fixnum(res); } else { return -1; } }