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 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); }
static sexp sexp_duplicate_file_descriptor_to_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { int err; sexp res; if (! (sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_type_exception(ctx, self, SEXP_FILENO, arg0); if (! (sexp_filenop(arg1) || sexp_fixnump(arg1))) return sexp_type_exception(ctx, self, SEXP_FILENO, arg1); err = dup2((sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)), (sexp_filenop(arg1) ? sexp_fileno_fd(arg1) : sexp_unbox_fixnum(arg1))); if (err) { res = SEXP_FALSE; } else { res = SEXP_TRUE; } return res; }
static sexp sexp_get_file_descriptor_status_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { sexp res; if (! (sexp_portp(arg0) || sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_xtype_exception(ctx, self, "not a port or file descriptor",arg0); res = sexp_make_integer(ctx, fcntl((sexp_portp(arg0) ? sexp_port_fileno(arg0) : sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)), F_GETFL)); return 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_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_is_a_tty_p_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { sexp res; if (! (sexp_portp(arg0) || sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_xtype_exception(ctx, self, "not a port or file descriptor",arg0); res = sexp_make_boolean(isatty((sexp_portp(arg0) ? sexp_port_fileno(arg0) : sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)))); return res; }
static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) { sexp res; int p = sexp_unbox_fixnum(k); if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); else if (! sexp_fixnump(k)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) p = sexp_opcode_num_args(op); switch (p) { case 0: res = sexp_opcode_arg1_type(op); break; case 1: res = sexp_opcode_arg2_type(op); break; default: res = sexp_opcode_arg3_type(op); if (res && sexp_vectorp(res)) { if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); else res = sexp_type_by_index(ctx, SEXP_OBJECT); } break; } return sexp_translate_opcode_type(ctx, res); }
static sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp seed) { if (! sexp_random_source_p(rs)) return sexp_type_exception(ctx, self, rs_type_id, rs); if (! sexp_fixnump(seed)) return sexp_type_exception(ctx, self, rs_type_id, seed); sexp_seed_random(sexp_unbox_fixnum(seed), rs); return SEXP_VOID; }
static sexp sexp_file_truncate_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { sexp res; if (! (sexp_portp(arg0) || sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_xtype_exception(ctx, self, "not a port or file descriptor",arg0); if (! sexp_exact_integerp(arg1)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); res = sexp_make_integer(ctx, ftruncate((sexp_portp(arg0) ? sexp_port_fileno(arg0) : sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)), sexp_uint_value(arg1))); return res; }
static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp res; if (!op) return sexp_type_by_index(ctx, SEXP_OBJECT); if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); if (sexp_opcode_code(op) == SEXP_OP_RAISE) return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); res = sexp_opcode_return_type(op); if (sexp_fixnump(res)) res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); return sexp_translate_opcode_type(ctx, res); }
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); }
static sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) { if (! sexp_random_source_p(rs)) return sexp_type_exception(ctx, self, rs_type_id, rs); else if (sexp_fixnump(state)) *sexp_random_data(rs) = sexp_unbox_fixnum(state); #if SEXP_USE_BIGNUMS else if (sexp_bignump(state)) *sexp_random_data(rs) = sexp_bignum_data(state)[0]*sexp_bignum_sign(state); #endif else return sexp_type_exception(ctx, self, SEXP_FIXNUM, state); return SEXP_VOID; }
static double sexp_to_double (sexp x) { if (sexp_flonump(x)) return sexp_flonum_value(x); else if (sexp_fixnump(x)) return sexp_fixnum_to_double(x); else if (sexp_bignump(x)) return sexp_bignum_to_double(x); #if SEXP_USE_RATIOS else if (sexp_ratiop(x)) return sexp_ratio_to_double(x); #endif else return 0.0; }
static sexp sexp_set_file_descriptor_flags_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg2) { int err; sexp res; if (! (sexp_portp(arg0) || sexp_filenop(arg0) || sexp_fixnump(arg0))) return sexp_xtype_exception(ctx, self, "not a port or file descriptor",arg0); if (! sexp_exact_integerp(arg2)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); err = fcntl((sexp_portp(arg0) ? sexp_port_fileno(arg0) : sexp_filenop(arg0) ? sexp_fileno_fd(arg0) : sexp_unbox_fixnum(arg0)), F_SETFD, sexp_sint_value(arg2)); if (err) { res = SEXP_FALSE; } else { res = SEXP_TRUE; } return res; }
static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { sexp_gc_var2(res, tmp); res = type; if (! res) { res = sexp_type_by_index(ctx, SEXP_OBJECT); } if (sexp_fixnump(res)) { res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); } else if (sexp_nullp(res)) { /* opcode list types */ sexp_gc_preserve2(ctx, res, tmp); tmp = sexp_intern(ctx, "or", -1); res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); res = sexp_cons(ctx, tmp, res); sexp_gc_release2(ctx); } return res; }
/* interface anyway */ static sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) { sexp_uint_t tmp; sexp_sint_t c; #if SEXP_USE_BIGNUMS sexp_sint_t len, offset, bit_shift, j; sexp_gc_var1(res); #else sexp res; #endif if (! sexp_fixnump(count)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, count); c = sexp_unbox_fixnum(count); if (c == 0) return i; if (sexp_fixnump(i)) { if (c < 0) { res = sexp_make_fixnum(sexp_unbox_fixnum(i) >> -c); } else {
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_to_complex (sexp ctx, sexp x) { #if SEXP_USE_RATIOS sexp_gc_var1(tmp); #endif if (sexp_flonump(x) || sexp_fixnump(x) || sexp_bignump(x)) { return sexp_make_complex(ctx, x, SEXP_ZERO); #if SEXP_USE_RATIOS } else if (sexp_ratiop(x)) { sexp_gc_preserve1(ctx, tmp); tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x)); sexp_gc_release1(ctx); return tmp; #endif } else { return x; } }
/* block the current thread on the specified port */ static sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd) { int fd; /* register the fd */ if (sexp_portp(portorfd)) fd = sexp_port_fileno(portorfd); else if (sexp_filenop(portorfd)) fd = sexp_fileno_fd(portorfd); else if (sexp_fixnump(portorfd)) fd = sexp_unbox_fixnum(portorfd); else return sexp_type_exception(ctx, self, SEXP_IPORT, portorfd); if (fd >= 0) sexp_insert_pollfd(ctx, fd, sexp_oportp(portorfd) ? POLLOUT : POLLIN); /* pause the current thread */ sexp_context_waitp(ctx) = 1; sexp_context_event(ctx) = portorfd; sexp_insert_timed(ctx, ctx, SEXP_FALSE); return SEXP_VOID; }
static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) { if (sexp_pointerp(x)) return sexp_object_type(ctx, x); else if (sexp_fixnump(x)) return sexp_type_by_index(ctx, SEXP_FIXNUM); else if (sexp_booleanp(x)) return sexp_type_by_index(ctx, SEXP_BOOLEAN); else if (sexp_charp(x)) return sexp_type_by_index(ctx, SEXP_CHAR); #if SEXP_USE_HUFF_SYMS else if (sexp_symbolp(x)) return sexp_type_by_index(ctx, SEXP_SYMBOL); #endif #if SEXP_USE_IMMEDIATE_FLONUMS else if (sexp_flonump(x)) return sexp_type_by_index(ctx, SEXP_FLONUM); #endif else return sexp_type_by_index(ctx, SEXP_OBJECT); }
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; } }
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; }
sexp sexp_peek_u8 (sexp ctx, sexp self, sexp in) { sexp res = sexp_read_u8(ctx, self, in); if (sexp_fixnump(res)) sexp_push_char(ctx, sexp_unbox_fixnum(res), in); return res; }
static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) { if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); }
sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) { int i, k; struct timeval tval; struct pollfd *pfds; useconds_t usecs = 0; sexp res, ls1, ls2, evt, runner, paused, front, pollfds; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); /* check signals */ if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); if (! sexp_contextp(runner)) { /* ensure the runner exists */ if (sexp_envp(runner)) { tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0); if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; sexp_thread_start(ctx, self, 1, runner); if (!sexp_pairp(front)) front = sexp_global(ctx, SEXP_G_THREADS_FRONT); } } } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ sexp_context_waitp(runner) = 0; sexp_thread_start(ctx, self, 1, runner); } } /* check blocked fds */ pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS); if (sexp_pollfdsp(ctx, pollfds) && sexp_pollfds_num_fds(pollfds) > 0) { pfds = sexp_pollfds_fds(pollfds); k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), 0); for (i=sexp_pollfds_num_fds(pollfds)-1; i>=0 && k>0; --i) { if (pfds[i].revents > 0) { /* free all threads blocked on this fd */ k--; /* maybe unblock the current thread */ evt = sexp_context_event(ctx); if ((sexp_portp(evt) && (sexp_port_fileno(evt) == pfds[i].fd)) || (sexp_fixnump(evt) && (sexp_unbox_fixnum(evt) == pfds[i].fd))) { sexp_context_waitp(ctx) = 0; sexp_context_timeoutp(ctx) = 0; sexp_context_event(ctx) = SEXP_FALSE; } /* maybe unblock paused threads */ for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { /* TODO: distinguish input and output on the same fd? */ evt = sexp_context_event(sexp_car(ls2)); if ((sexp_portp(evt) && sexp_port_fileno(evt) == pfds[i].fd) || (sexp_fixnump(evt) && sexp_unbox_fixnum(evt) == pfds[i].fd)) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; sexp_context_event(sexp_car(ls2)) = SEXP_FALSE; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (sexp_car(ls2) != ctx) { if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; } ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } if (i < (sexp_pollfds_num_fds(pollfds) - 1)) { pfds[i] = pfds[sexp_pollfds_num_fds(pollfds) - 1]; } sexp_pollfds_num_fds(pollfds) -= 1; } } } /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { if (sexp_context_event(sexp_car(ls2)) == ctx) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } } /* check timeouts */ if (sexp_pairp(paused)) { if (gettimeofday(&tval, NULL) == 0) { ls1 = SEXP_NULL; ls2 = paused; while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { sexp_context_timeoutp(sexp_car(ls2)) = 1; sexp_context_waitp(sexp_car(ls2)) = 0; ls1 = ls2; ls2 = sexp_cdr(ls2); } if (sexp_pairp(ls1)) { sexp_cdr(ls1) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; } } } /* dequeue next thread */ if (sexp_pairp(front)) { res = sexp_car(front); if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { /* orig ctx is either terminated or paused */ sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); if (! sexp_pairp(sexp_cdr(front))) sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; if (sexp_context_refuel(ctx) > 0 && sexp_not(sexp_memq(ctx, ctx, paused))) sexp_insert_timed(ctx, ctx, SEXP_FALSE); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); } else { /* swap with front of queue */ sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; /* rotate front of queue to back */ sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; } } else { /* no threads to dequeue */ res = ctx; /* prefer a thread we can wait on instead of spinning */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=paused; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { evt = sexp_context_event(sexp_car(ls1)); if (sexp_fixnump(evt) || sexp_portp(evt)) { res = sexp_car(ls1); break; } } } } if (sexp_context_waitp(res)) { /* the only thread available was waiting */ if (sexp_pairp(paused) && sexp_context_before(sexp_car(paused), sexp_context_timeval(res))) { tmp = res; res = sexp_car(paused); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(paused); if (sexp_not(sexp_memq(ctx, tmp, paused))) sexp_insert_timed(ctx, tmp, tmp); } else { sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, res); } paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); usecs = 0; if ((sexp_context_timeval(res).tv_sec == 0) && (sexp_context_timeval(res).tv_usec == 0)) { /* no timeout, wait for default 10ms */ usecs = 10*1000; } else { /* wait until the next timeout */ gettimeofday(&tval, NULL); if (tval.tv_sec <= sexp_context_timeval(res).tv_sec) { usecs = (sexp_context_timeval(res).tv_sec - tval.tv_sec) * 1000000; if (tval.tv_usec < sexp_context_timeval(res).tv_usec || usecs > 0) usecs += sexp_context_timeval(res).tv_usec - tval.tv_usec; } } /* take a nap to avoid busy looping */ usleep(usecs); sexp_context_waitp(res) = 0; sexp_context_timeoutp(res) = 1; } sexp_gc_release1(ctx); return res; }