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