static sexp check_exception (sexp ctx, sexp res) {
sexp_gc_var4(err, advise, sym, tmp);
if (res && sexp_exceptionp(res)) {
sexp_gc_preserve4(ctx, err, advise, sym, tmp);
tmp = res;
err = sexp_current_error_port(ctx);
if (! sexp_oportp(err))
err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_print_exception(ctx, res, err);
sexp_stack_trace(ctx, err);
#if SEXP_USE_MAIN_ERROR_ADVISE
if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV))) {
advise = sexp_eval_string(ctx, sexp_advice_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
if (sexp_vectorp(advise)) {
advise = sexp_vector_ref(advise, SEXP_ONE);
if (sexp_envp(advise)) {
sym = sexp_intern(ctx, "repl-advise-exception", -1);
advise = sexp_env_ref(ctx, advise, sym, SEXP_FALSE);
if (sexp_procedurep(advise))
sexp_apply(ctx, advise, tmp=sexp_list2(ctx, res, err));
}
}
}
#endif
sexp_gc_release4(ctx);
exit_failure();
}
return res;
}
sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) {
sexp ls1, ls2;
if (sexp_not(condvar)) {
/* normal unlock - always succeeds, just need to unblock threads */
if (sexp_truep(sexp_mutex_lockp(mutex))) {
sexp_mutex_lockp(mutex) = SEXP_FALSE;
sexp_mutex_thread(mutex) = ctx;
/* search for threads blocked on this mutex */
for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == mutex) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2))
= sexp_context_timeoutp(sexp_car(ls2)) = 0;
break;
}
}
return SEXP_TRUE;
} else {
/* wait on condition var */
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = condvar;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
}
sexp sexp_mutex_unlock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp condvar, sexp timeout) {
sexp ls1, ls2;
/* first unlock and unblock threads */
if (sexp_truep(sexp_mutex_lockp(mutex))) {
sexp_mutex_lockp(mutex) = SEXP_FALSE;
sexp_mutex_thread(mutex) = ctx;
/* search for threads blocked on this mutex */
for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == mutex) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2))
= sexp_context_timeoutp(sexp_car(ls2)) = 0;
break;
}
}
if (sexp_truep(condvar)) {
/* wait on condition var if specified */
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = condvar;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
return SEXP_TRUE;
}
/* return true if this fd was already being polled */
static sexp sexp_insert_pollfd (sexp ctx, int fd, int events) {
int i;
struct pollfd *pfd;
sexp pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS);
if (! (pollfds && sexp_pollfdsp(ctx, pollfds))) {
sexp_global(ctx, SEXP_G_THREADS_POLL_FDS) = pollfds = sexp_make_pollfds(ctx);
}
for (i=0; i<sexp_pollfds_num_fds(pollfds); ++i) {
if (sexp_pollfds_fds(pollfds)[i].fd == fd) {
sexp_pollfds_fds(pollfds)[i].events |= events;
return SEXP_TRUE;
}
}
if (sexp_pollfds_num_fds(pollfds) == sexp_pollfds_max_fds(pollfds)) {
sexp_pollfds_max_fds(pollfds) = i*2;
pfd = sexp_pollfds_fds(pollfds);
sexp_pollfds_fds(pollfds) = malloc(i*2*sizeof(struct pollfd));
if (sexp_pollfds_fds(pollfds))
memcpy(sexp_pollfds_fds(pollfds), pfd, i*2*sizeof(struct pollfd));
free(pfd);
}
pfd = &(sexp_pollfds_fds(pollfds)[sexp_pollfds_num_fds(pollfds)++]);
pfd->fd = fd;
pfd->events = events;
return SEXP_FALSE;
}
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 pid_t sexp_fork_and_kill_threads (sexp ctx) {
pid_t res = fork();
#if SEXP_USE_GREEN_THREADS
if (res == 0) { /* child */
sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = SEXP_NULL;
}
#endif
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;
}
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 int sexp_delete_list (sexp ctx, int global, sexp x) {
sexp ls1=NULL, ls2=sexp_global(ctx, global);
for ( ; sexp_pairp(ls2) && sexp_car(ls2) != x; ls1=ls2, ls2=sexp_cdr(ls2))
;
if (sexp_pairp(ls2)) {
if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
else sexp_global(ctx, global) = sexp_cdr(ls2);
return 1;
} else {
return 0;
}
}
static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) {
#if SEXP_USE_FLONUMS
double d;
#endif
sexp ls1=SEXP_NULL, ls2;
sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread);
ls2 = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
if (sexp_realp(timeout))
gettimeofday(&sexp_context_timeval(thread), NULL);
if (sexp_fixnump(timeout)) {
sexp_context_timeval(thread).tv_sec += sexp_unbox_fixnum(timeout);
#if SEXP_USE_FLONUMS
} else if (sexp_flonump(timeout)) {
d = sexp_flonum_value(timeout);
sexp_context_timeval(thread).tv_sec += trunc(d);
sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000;
if (sexp_context_timeval(thread).tv_usec > 1000000) {
sexp_context_timeval(thread).tv_sec += 1;
sexp_context_timeval(thread).tv_usec -= 1000000;
}
#endif
#if SEXP_USE_RATIOS
} else if (sexp_ratiop(timeout)) {
d = sexp_ratio_to_double(timeout);
sexp_context_timeval(thread).tv_sec += trunc(d);
sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000;
if (sexp_context_timeval(thread).tv_usec > 1000000) {
sexp_context_timeval(thread).tv_sec += 1;
sexp_context_timeval(thread).tv_usec -= 1000000;
}
#endif
} else if (sexp_contextp(timeout)) {
sexp_context_timeval(thread).tv_sec = sexp_context_timeval(timeout).tv_sec;
sexp_context_timeval(thread).tv_usec = sexp_context_timeval(timeout).tv_usec;
} else {
sexp_context_timeval(thread).tv_sec = 0;
sexp_context_timeval(thread).tv_usec = 0;
}
if (sexp_realp(timeout) || sexp_contextp(timeout))
while (sexp_pairp(ls2)
&& sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread)))
ls1=ls2, ls2=sexp_cdr(ls2);
else
while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec)
ls1=ls2, ls2=sexp_cdr(ls2);
if (ls1 == SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2);
else
sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2);
}
sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
sexp ls;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = SEXP_NULL;
#if SEXP_USE_GREEN_THREADS
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
#endif
if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) {
sexp_gc_var3(e, p, res);
sexp_gc_preserve3(ctx, e, p, res);
e = sexp_load_standard_env(ctx, env, k);
if (sexp_exceptionp(e)) return e;
sexp_load_standard_ports(ctx, e, stdin, stdout, stderr, 0);
#if SEXP_USE_GREEN_THREADS
p = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1);
#endif
res = sexp_make_env(ctx);
sexp_env_parent(res) = e;
sexp_set_parameter(ctx, res, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), res);
sexp_gc_release3(ctx);
return res;
}
static sexp sexp_load_standard_params (sexp ctx, sexp e, int nonblocking) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
sexp_load_standard_ports(ctx, e, stdin, stdout, stderr, 0);
if (nonblocking) {
sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)));
sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)));
sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)));
}
res = sexp_make_env(ctx);
sexp_env_parent(res) = e;
sexp_context_env(ctx) = res;
sexp_set_parameter(ctx, sexp_meta_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), res);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
if (!(sexp_version_compatible(ctx, version, sexp_version)
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
return sexp_global(ctx, SEXP_G_ABI_ERROR);
sexp_define_foreign(ctx, env, "increment-cdr!", 1, sexp_increment_cdr);
return SEXP_VOID;
}
static sexp sexp_make_pollfds (sexp ctx) {
sexp res = sexp_alloc_tagged(ctx, sexp_sizeof_pollfds, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID)));
sexp_pollfds_fds(res) = malloc(SEXP_INIT_POLLFDS_MAX_FDS * sizeof(struct pollfd));
sexp_pollfds_num_fds(res) = 0;
sexp_pollfds_max_fds(res) = SEXP_INIT_POLLFDS_MAX_FDS;
return res;
}
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;
}
sexp sexp_condition_variable_signal (sexp ctx, sexp self, sexp_sint_t n, sexp condvar) {
sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == condvar) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0;
return SEXP_TRUE;
}
return SEXP_FALSE;
}
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 void repl (sexp ctx, sexp env) {
sexp_gc_var6(obj, tmp, res, in, out, err);
sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err);
sexp_context_tracep(ctx) = 1;
in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
if (in == NULL || out == NULL) {
fprintf(stderr, "Standard I/O ports not found, aborting. Maybe a bad -x language?\n");
exit_failure();
}
if (err == NULL) err = out;
sexp_port_sourcep(in) = 1;
while (1) {
sexp_write_string(ctx, "> ", out);
sexp_flush(ctx, out);
sexp_maybe_block_port(ctx, in, 1);
obj = sexp_read(ctx, in);
sexp_maybe_unblock_port(ctx, in);
if (obj == SEXP_EOF)
break;
if (sexp_exceptionp(obj)) {
sexp_print_exception(ctx, obj, err);
} else {
sexp_context_top(ctx) = 0;
if (!(sexp_idp(obj)||sexp_pairp(obj)||sexp_nullp(obj)))
obj = sexp_make_lit(ctx, obj);
tmp = sexp_env_bindings(env);
res = sexp_eval(ctx, obj, env);
#if SEXP_USE_WARN_UNDEFS
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, res);
#endif
if (res && sexp_exceptionp(res)) {
sexp_print_exception(ctx, res, err);
if (res != sexp_global(ctx, SEXP_G_OOS_ERROR))
sexp_stack_trace(ctx, err);
} else if (res != SEXP_VOID) {
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
}
}
sexp_gc_release6(ctx);
}
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
if (!(sexp_version_compatible(ctx, version, sexp_version)
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
return sexp_global(ctx, SEXP_G_ABI_ERROR);
sexp_define_foreign(ctx, env, "current-clock-second", 0, sexp_current_clock_second);
#if SEXP_USE_NTP_GETTIME
determine_ntp_resolution();
sexp_define_foreign(ctx, env, "current-ntp-clock-values", 0, sexp_current_ntp_clock_values);
#endif
return SEXP_VOID;
}
static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
sexp_gc_var2(ls, res);
sexp_gc_preserve2(ctx, ls, res);
res = x;
ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_apply1(ctx, sexp_cdar(ls), res);
sexp_free_vars(ctx, res, SEXP_NULL);
sexp_gc_release2(ctx);
return res;
}
sexp sexp_mutex_state (sexp ctx, sexp self, sexp_sint_t n, sexp mutex) {
if (!sexp_mutexp(ctx, mutex))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_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);
}
}
static void do_init_context (sexp* ctx, sexp* env, sexp_uint_t heap_size,
sexp_uint_t heap_max_size, sexp_sint_t fold_case) {
*ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size, heap_max_size);
if (! *ctx) {
fprintf(stderr, "chibi-scheme: out of memory\n");
exit_failure();
}
#if SEXP_USE_FOLD_CASE_SYMS
sexp_global(*ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(fold_case);
#endif
*env = sexp_context_env(*ctx);
}
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);
}
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;
}
static void repl (sexp ctx, sexp env) {
sexp in, out, err;
sexp_gc_var3(obj, tmp, res);
sexp_gc_preserve3(ctx, obj, tmp, res);
sexp_context_tracep(ctx) = 1;
in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
sexp_port_sourcep(in) = 1;
while (1) {
sexp_write_string(ctx, "> ", out);
sexp_flush(ctx, out);
sexp_maybe_block_port(ctx, in, 1);
obj = sexp_read(ctx, in);
sexp_maybe_unblock_port(ctx, in);
if (obj == SEXP_EOF)
break;
if (sexp_exceptionp(obj)) {
sexp_print_exception(ctx, obj, err);
} else {
tmp = sexp_env_bindings(env);
sexp_context_top(ctx) = 0;
res = sexp_eval(ctx, obj, env);
if (sexp_exceptionp(res)) {
sexp_print_exception(ctx, res, err);
sexp_stack_trace(ctx, err);
} else {
#if SEXP_USE_WARN_UNDEFS
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp);
#endif
if (res != SEXP_VOID) {
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
}
}
}
sexp_gc_release3(ctx);
}
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 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 sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) {
int res;
sexp oldaction;
if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0
&& sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM))
return sexp_xtype_exception(ctx, self, "not a valid signal number", signum);
if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
|| sexp_booleanp(newaction)))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction);
if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)))
sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE);
oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
res = sigaction(sexp_unbox_fixnum(signum),
(sexp_booleanp(newaction) ?
(sexp_truep(newaction) ? &call_sigdefault : &call_sigignore)
: &call_sigaction),
NULL);
if (res)
return sexp_user_exception(ctx, self, "couldn't set signal", signum);
sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction);
sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx;
return oldaction;
}
static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k, int bootp, int nonblocking) {
sexp_gc_var1(e);
sexp_gc_preserve1(ctx, e);
e = sexp_load_standard_env(ctx, env, k);
if (!sexp_exceptionp(e)) {
#if SEXP_USE_MODULES
if (!bootp)
e = sexp_eval_string(ctx, sexp_default_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
if (!sexp_exceptionp(e))
sexp_add_import_binding(ctx, e);
#endif
if (!sexp_exceptionp(e))
e = sexp_load_standard_params(ctx, e, nonblocking);
}
sexp_gc_release1(ctx);
return e;
}
