sexp sexp_string_count (sexp ctx, sexp self, sexp ch, sexp str, sexp start, sexp end) {
const unsigned char *s, *e;
sexp_sint_t c, count = 0;
#if SEXP_USE_UTF8_STRINGS
sexp_sint_t i;
#endif
sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_size(str));
else sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
c = sexp_unbox_character(ch);
#if SEXP_USE_UTF8_STRINGS
if (c < 128) {
#endif
s = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(start);
e = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(end);
if (e > (unsigned char*)sexp_string_data(str) + sexp_string_size(str))
return sexp_user_exception(ctx, self, "string-count: end index out of range", end);
/* fast case for ASCII chars */
while (s < e) if (*s++ == c) count++;
#if SEXP_USE_UTF8_STRINGS
} else {
/* decode utf8 chars */
s = (unsigned char*)sexp_string_data(str);
for (i = sexp_unbox_fixnum(start); i < sexp_unbox_fixnum(end);
i += sexp_utf8_initial_byte_count(s[i]))
if (sexp_string_utf8_ref(ctx, str, sexp_make_fixnum(i)) == ch) count++;
}
#endif
return sexp_make_fixnum(count);
}
static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
if (from < 0 || from > to)
return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
if (start < 0 || start > sexp_string_size(src))
return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
if (end < start || end > sexp_string_size(src))
return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
pfrom = (unsigned char*)sexp_string_data(dst) + from;
pto = (unsigned char*)sexp_string_data(dst) + to;
pstart = (unsigned char*)sexp_string_data(src) + start;
pend = (unsigned char*)sexp_string_data(src) + end;
for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
*pfrom = *pstart;
/* adjust for incomplete trailing chars */
prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
for (p = prev; p < pfrom; ++p)
*p = '\0';
pstart -= pfrom - prev;
}
return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
}
static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
const char *res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
res = strstr(sexp_string_data(x), sexp_string_data(y));
return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
}
static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
sexp_gc_var1(tmp);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
sexp_gc_preserve1(ctx, tmp);
sexp_env_push(ctx, env, tmp, name, value);
sexp_gc_release1(ctx);
return SEXP_VOID;
}
static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
sexp x = (sexp)sexp_unbox_fixnum(i);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
if (sexp_pointerp(x))
return dflt;
return x;
}
sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) {
sexp_context_waitp(ctx) = 1;
if (timeout != SEXP_TRUE) {
sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout);
sexp_insert_timed(ctx, ctx, timeout);
}
return SEXP_FALSE;
}
sexp sexp_thread_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp timeout) {
sexp_context_waitp(ctx) = 1;
if (timeout != SEXP_TRUE) {
sexp_assert_type(ctx, sexp_realp, SEXP_NUMBER, timeout);
sexp_context_event(ctx) = SEXP_FALSE;
sexp_insert_timed(ctx, ctx, timeout);
}
return SEXP_FALSE;
}
static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
int err;
if (x == SEXP_FALSE) {
err = errno;
} else {
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
err = sexp_unbox_fixnum(x);
}
return sexp_c_string(ctx, strerror(err), -1);
}
static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id) {
sexp cell;
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
cell = sexp_env_cell(env, id, 0);
while ((! cell) && sexp_synclop(id)) {
env = sexp_synclo_env(id);
id = sexp_synclo_expr(id);
}
return cell ? cell : SEXP_FALSE;
}
static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp data;
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
data = sexp_opcode_data(op);
if (!data) return SEXP_VOID;
return sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
&& 0 <= sexp_unbox_fixnum(data)
&& sexp_unbox_fixnum(data) <= sexp_context_num_types(ctx) ?
sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
}
sexp sexp_open_input_bytevector (sexp ctx, sexp self, sexp vec) {
sexp_gc_var2(str, res);
sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
sexp_gc_preserve2(ctx, str, res);
str = sexp_bytes_to_string(ctx, vec);
res = sexp_open_input_string(ctx, str);
sexp_port_binaryp(res) = 1;
sexp_gc_release2(ctx);
return res;
}
sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) {
sexp_assert_type(ctx, sexp_mutexp, sexp_mutex_id, mutex);
if (sexp_truep(sexp_mutex_lockp(mutex))) {
if (sexp_contextp(sexp_mutex_thread(mutex)))
return sexp_mutex_thread(mutex);
else
return sexp_intern(ctx, "not-owned", -1);
} else {
return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1);
}
}
sexp sexp_thread_join (sexp ctx, sexp self, sexp_sint_t n, sexp thread, sexp timeout) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ {
return SEXP_TRUE;
}
sexp_context_timeoutp(ctx) = 0;
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = thread;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
sexp sexp_get_output_bytevector (sexp ctx, sexp self, sexp port) {
sexp_gc_var1(res);
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
if (!sexp_port_binaryp(port))
return sexp_xtype_exception(ctx, self, "not a binary port", port);
sexp_gc_preserve1(ctx, res);
res = sexp_get_output_string(ctx, port);
res = sexp_string_to_bytes(ctx, res);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_thread_start (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
sexp cell;
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
cell = sexp_cons(ctx, thread, SEXP_NULL);
if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell;
sexp_global(ctx, SEXP_G_THREADS_BACK) = cell;
} else { /* init queue */
sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell;
}
return thread;
}
sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) {
sexp res, *stack;
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
sexp_context_proc(res) = thunk;
sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
stack = sexp_stack_data(sexp_context_stack(res));
stack[0] = stack[1] = stack[3] = SEXP_ZERO;
stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
sexp_context_top(res) = 4;
sexp_context_last_fp(res) = 0;
return res;
}
/* block the current thread on the specified port */
static sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
int fd;
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
/* register the fd */
fd = sexp_port_fileno(port);
if (fd >= 0)
sexp_insert_pollfd(ctx, fd, sexp_iportp(port) ? POLLIN : POLLOUT);
/* pause the current thread */
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = port;
sexp_insert_timed(ctx, ctx, SEXP_FALSE);
return SEXP_VOID;
}
sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, u8);
if (sexp_unbox_fixnum(u8) < 0 || sexp_unbox_fixnum(u8) > 255)
return sexp_xtype_exception(ctx, self, "not a u8 value", u8);
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
if (!sexp_port_binaryp(out))
return sexp_xtype_exception(ctx, self, "not a binary port", out);
#if SEXP_USE_GREEN_THREADS
errno = 0;
#endif
if (sexp_write_char(ctx, sexp_unbox_fixnum(u8), out) == EOF) {
if (sexp_port_stream(out))
clearerr(sexp_port_stream(out));
#if SEXP_USE_GREEN_THREADS
if (errno == EAGAIN) {
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), out);
return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
}
#endif
}
return SEXP_VOID;
}
static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
sexp cell;
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
cell = sexp_env_cell(ctx, env, id, 0);
if (! cell) {
if (sexp_synclop(id)) {
env = sexp_synclo_env(id);
id = sexp_synclo_expr(id);
}
cell = sexp_env_cell(ctx, env, id, 0);
if (!cell && createp)
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
}
return cell ? cell : SEXP_FALSE;
}
sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name) {
sexp *stack;
sexp_gc_var1(res);
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
sexp_gc_preserve1(ctx, res);
res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
sexp_context_name(res) = name;
sexp_context_proc(res) = thunk;
sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
stack = sexp_stack_data(sexp_context_stack(res));
stack[0] = stack[1] = stack[3] = SEXP_ZERO;
stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
sexp_context_top(res) = 4;
sexp_context_last_fp(res) = 0;
sexp_context_dk(res) = sexp_list1(ctx, SEXP_FALSE);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_read_u8 (sexp ctx, sexp self, sexp in) {
int c;
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
if (!sexp_port_binaryp(in))
return sexp_xtype_exception(ctx, self, "not a binary port", in);
#if SEXP_USE_GREEN_THREADS
errno = 0;
#endif
c = sexp_read_char(ctx, in);
#if SEXP_USE_GREEN_THREADS
if ((c == EOF)
&& (errno == EAGAIN)) {
if (sexp_port_stream(in))
clearerr(sexp_port_stream(in));
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), in);
return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
}
#endif
if (c == '\n') sexp_port_line(in)++;
return (c==EOF) ? SEXP_EOF : sexp_make_fixnum(c);
}
/* TODO: add validation */
sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec) {
sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
return sexp_bytes_to_string(ctx, vec);
}
sexp sexp_string_to_utf8 (sexp ctx, sexp self, sexp str) {
sexp res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
res = sexp_c_string(ctx, sexp_string_data(str), sexp_string_size(str));
return sexp_string_to_bytes(ctx, res);
}
static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
: sexp_make_fixnum(sexp_type_field_eq_len_base(t));
}
sexp sexp_thread_end_result (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
return sexp_context_result(thread) ? sexp_context_result(thread) : SEXP_VOID;
}
sexp sexp_thread_specific_set (sexp ctx, sexp self, sexp_sint_t n, sexp thread, sexp val) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
sexp_context_specific(thread) = val;
return SEXP_VOID;
}
sexp sexp_thread_specific (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
return sexp_context_specific(thread);
}
static sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) {
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum);
return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
}
sexp sexp_thread_exceptionp (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
return sexp_make_boolean(sexp_context_errorp(thread));
}
static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
}
