static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) { size_t freed; sexp_uint_t sizes[512]; sexp_sint_t i; sexp_heap h = sexp_context_heap(ctx); sexp_free_list q; sexp_gc_var2(res, tmp); /* run gc once to remove unused variables */ sexp_gc(ctx, &freed); /* initialize stats */ for (i=0; i<512; i++) sizes[i]=0; /* loop over each free block */ for ( ; h; h=h->next) for (q=h->free_list; q; q=q->next) sizes[sexp_heap_chunks(q->size) > 511 ? 511 : sexp_heap_chunks(q->size)]++; /* build and return results */ sexp_gc_preserve2(ctx, res, tmp); res = SEXP_NULL; for (i=511; i>=0; i--) if (sizes[i]) { tmp = sexp_cons(ctx, sexp_make_fixnum(i), sexp_make_fixnum(sizes[i])); res = sexp_cons(ctx, tmp, res); } sexp_gc_release2(ctx); return res; }
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); }
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { sexp t; sexp_gc_var1(name); if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) return SEXP_ABI_ERROR; #if SEXP_USE_GREEN_THREADS sexp_gc_preserve1(ctx, name); sexp_global(ctx, SEXP_G_THREADS_MUTEX_ID) = sexp_lookup_named_type(ctx, env, "Mutex"); name = sexp_c_string(ctx, "pollfds", -1); t = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL, (sexp_proc2)sexp_free_pollfds); if (sexp_typep(t)) { sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID) = sexp_make_fixnum(sexp_type_tag(t)); } sexp_define_type_predicate_by_tag(ctx, env, "thread?", SEXP_CONTEXT); sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); sexp_define_foreign(ctx, env, "%thread-end-result", 1, sexp_thread_end_result); sexp_define_foreign(ctx, env, "%thread-exception?", 1, sexp_thread_exceptionp); sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_BLOCKER) = sexp_make_foreign(ctx, "blocker", 1, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE); /* remember the env to lookup the runner later */ sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; sexp_gc_release1(ctx); #endif /* SEXP_USE_GREEN_THREADS */ return SEXP_VOID; }
static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) { int allsigs, restsigs, signum; if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { return SEXP_FALSE; } else { allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); restsigs = allsigs & (allsigs-1); sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); signum = sexp_log2_of_pow2(allsigs-restsigs); return sexp_make_fixnum(signum); } }
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_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { sexp res; #if SEXP_USE_BIGNUMS sexp_sint_t len, i; #endif if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); #if SEXP_USE_BIGNUMS else if (sexp_bignump(y)) res = sexp_bit_and(ctx, self, n, y, x); #endif else res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); } else if (sexp_bignump(y)) { if (sexp_bignum_length(x) < sexp_bignum_length(y)) res = sexp_copy_bignum(ctx, NULL, x, 0); else res = sexp_copy_bignum(ctx, NULL, y, 0); for (i=0, len=sexp_bignum_length(res); i<len; i++) sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i]; } else { res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); }
static sexp sexp_rs_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp bound) { sexp res; int32_t m; #if SEXP_USE_BIGNUMS int32_t hi, mod, len, i, *data; #endif if (! sexp_random_source_p(rs)) res = sexp_type_exception(ctx, self, rs_type_id, rs); if (sexp_fixnump(bound)) { sexp_call_random(rs, m); res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(bound)) { hi = sexp_bignum_hi(bound); len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); res = sexp_make_bignum(ctx, hi); data = (int32_t*) sexp_bignum_data(res); for (i=0; i<len-1; i++) { sexp_call_random(rs, m); data[i] = m; } sexp_call_random(rs, m); mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t); if (mod) data[i] = m % mod; #endif } else { res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); } return res; }
static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp t; if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) return SEXP_ZERO; t = sexp_object_type(ctx, x); return sexp_make_fixnum(sexp_type_size_of_object(t, x)); }
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_duplicate_file_descriptor_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { sexp res; if (! (sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_type_exception(ctx, self, SEXP_FILENO, arg0); res = sexp_make_fileno(ctx, sexp_make_fixnum(dup((sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)))), SEXP_FALSE); return res; }
static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { #ifdef PLAN9 return SEXP_FALSE; #else return sexp_make_fixnum(errno); #endif }
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_heap_walk (sexp ctx, int depth, int printp) { size_t freed; sexp_uint_t stats[256], hi_type=0, i; sexp_heap h = sexp_context_heap(ctx); sexp p, out=SEXP_FALSE; sexp_free_list q, r; char *end; sexp_gc_var3(res, tmp, name); if (printp) out = sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE)); /* run gc once to remove unused variables */ sexp_gc(ctx, &freed); /* initialize stats */ for (i=0; i<256; i++) stats[i]=0; /* loop over each heap chunk */ for ( ; h; h=h->next) { p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); q = h->free_list; end = (char*)h->data + h->size; while (((char*)p) < end) { /* find the preceding and succeeding free list pointers */ for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) ; if ((char*)r == (char*)p) { /* this is a free block, skip */ p = (sexp) (((char*)p) + r->size); continue; } /* otherwise maybe print, then increment the stat and continue */ if (sexp_oportp(out)) { sexp_print_simple(ctx, p, out, depth); sexp_write_char(ctx, '\n', out); } stats[sexp_pointer_tag(p)]++; if (sexp_pointer_tag(p) > hi_type) hi_type = sexp_pointer_tag(p); p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); } } /* build and return results */ sexp_gc_preserve3(ctx, res, tmp, name); res = SEXP_NULL; for (i=hi_type; i>0; i--) if (stats[i]) { name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i)); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); res = sexp_cons(ctx, tmp, res); } sexp_gc_release3(ctx); return res; }
static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_uint_t cindex, char* get, char *set) { sexp type, index; sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); type = sexp_make_fixnum(ctype); index = sexp_make_fixnum(cindex); if (get) { op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); } if (set) { op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); } sexp_gc_release2(ctx); }
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 void sexp_define_type_predicate_by_tag (sexp ctx, sexp env, char *cname, sexp_uint_t type) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, cname, -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); sexp_gc_release2(ctx); }
sexp sexp_bignum_normalize (sexp a) { sexp_uint_t *data; if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) return a; data = sexp_bignum_data(a); if ((data[0] > SEXP_MAX_FIXNUM) && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) return a; return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); }
sexp sexp_wait (sexp ctx, sexp self, sexp_sint_t n) { /* just return (pid msg) */ Waitmsg *wmsg; sexp res; sexp_gc_var(msg, s_msg); sexp_gc_preserve(ctx, msg, s_msg); wmsg = wait(); msg = sexp_c_string(ctx, wmsg->msg, -1); res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); sexp_gc_release(ctx, msg, s_msg); return res; }
static sexp sexp_open_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { sexp res; if (! sexp_stringp(arg0)) return sexp_type_exception(ctx, self, SEXP_STRING, arg0); if (! sexp_exact_integerp(arg1)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); if (! sexp_exact_integerp(arg2)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); res = sexp_make_fileno(ctx, sexp_make_fixnum(open(sexp_string_data(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_FALSE); return res; }
sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { sexp res; if (x <= SEXP_MAX_FIXNUM) { res = sexp_make_fixnum(x); } else { res = sexp_make_bignum(ctx, 1); sexp_bignum_sign(res) = 1; sexp_bignum_data(res)[0] = x; } return res; }
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { sexp_gc_var2(name, op); if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) return SEXP_ABI_ERROR; sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx, NULL, 0); name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx, NULL, 0, default_random_source); 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; } }
sexp sexp_init_library(sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi){ sexp_gc_var3(name, tmp, op); sexp args; /* check ABI */ if(!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) { return SEXP_ABI_ERROR; } sexp_gc_preserve3(ctx, name, tmp, op); op = sexp_define_foreign(ctx, env, "yuniffi_nccc_call", 7, sexp_yuniffi_nccc_call_bridge); if(sexp_opcodep(op)){ sexp_opcode_return_type(op) = SEXP_VOID; /* 1: func */ sexp_opcode_arg2_type(op) = SEXP_VOID; /* 2: in */ /* 3: in_off */ sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM); /* N: [1:in_len, 2:out, 3:out_off, 4:out_len] */ sexp_opcode_argn_type(op) = sexp_make_vector(ctx, SEXP_FOUR, sexp_make_fixnum(SEXP_OBJECT)); args = sexp_opcode_argn_type(op); sexp_vector_set(args, SEXP_ZERO, sexp_make_fixnum(SEXP_FIXNUM)); sexp_vector_set(args, SEXP_TWO, sexp_make_fixnum(SEXP_FIXNUM)); sexp_vector_set(args, SEXP_THREE, sexp_make_fixnum(SEXP_FIXNUM)); }else{ /* FIXME: abort() here? */ } op = sexp_define_foreign(ctx, env, "yuniffi_nccc_proc_register", 1, sexp_yuniffi_nccc_proc_register); if(sexp_opcodep(op)){ sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); /* 1: proc */ sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_PROCEDURE); } op = sexp_define_foreign(ctx, env, "yuniffi_nccc_proc_release", 1, sexp_yuniffi_nccc_proc_release); if(sexp_opcodep(op)){ sexp_opcode_return_type(op) = SEXP_VOID; /* 1: proc */ sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); } sexp_gc_release3(ctx); return SEXP_VOID; }
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx sexp_api_pass(NULL, 0)); name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx sexp_api_pass(NULL, 0), default_random_source); sexp_gc_release2(ctx); return SEXP_VOID; }
static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { sexp ctx; #if ! SEXP_USE_GREEN_THREADS sexp sigctx, handler; sexp_gc_var1(args); #endif ctx = sexp_signal_contexts[signum]; if (ctx) { #if SEXP_USE_GREEN_THREADS sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum((1UL<<signum) | sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS))); #else handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), sexp_make_fixnum(signum)); if (sexp_applicablep(handler)) { sigctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve1(sigctx, args); args = sexp_cons(sigctx, sexp_make_fixnum(signum), SEXP_NULL); sexp_apply(sigctx, handler, args); sexp_gc_release1(sigctx); } #endif } }
static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_seek(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); args = sexp_make_integer(ctx, *position); args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); res = sexp_apply(ctx, sexp_cookie_seek(vec), args); if (sexp_fixnump(res)) *position = sexp_unbox_fixnum(res); sexp_gc_release2(ctx); return sexp_fixnump(res); }
sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { sexp res; if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { res = sexp_make_fixnum(x); } else { res = sexp_make_bignum(ctx, 1); if (x < 0) { sexp_bignum_sign(res) = -1; sexp_bignum_data(res)[0] = -x; } else { sexp_bignum_sign(res) = 1; sexp_bignum_data(res)[0] = x; } } return res; }
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp t; sexp_gc_var1(name); sexp_gc_preserve1(ctx, name); sexp_mutex_id = sexp_lookup_type(ctx, env, "mutex"); sexp_condvar_id = sexp_lookup_type(ctx, env, "condition-variable"); name = sexp_c_string(ctx, "pollfds", -1); t = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)sexp_free_pollfds); if (sexp_typep(t)) sexp_pollfds_id = sexp_type_tag(t); sexp_define_type_predicate_by_tag(ctx, env, "thread?", SEXP_CONTEXT); sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_BLOCKER) = sexp_make_foreign(ctx, "blocker", 1, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE); /* remember the env to lookup the runner later */ sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; sexp_gc_release1(ctx); return SEXP_VOID; }
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; }
static sexp sexp_open_pipe_stub (sexp ctx, sexp self, sexp_sint_t n) { int i, err; int tmp0[2]; sexp res; sexp_gc_var1(res0); sexp_gc_preserve1(ctx, res0); err = pipe(tmp0); if (err) { res = SEXP_FALSE; } else { res0 = SEXP_NULL; for (i=2-1; i>=0; i--) { sexp_push(ctx, res0, SEXP_VOID); sexp_car(res0) = sexp_make_fileno(ctx, sexp_make_fixnum(tmp0[i]), SEXP_FALSE); } res = res0; } sexp_gc_release1(ctx); return res; }