sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
carry=0, i, n, *adata, *bdata, *cdata;
sexp_gc_var1(c);
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
sexp_gc_preserve1(ctx, c);
c = ((dst && sexp_bignum_hi(dst) >= alen)
? dst : sexp_copy_bignum(ctx, NULL, a, 0));
adata = sexp_bignum_data(a);
bdata = sexp_bignum_data(b);
cdata = sexp_bignum_data(c);
for (i=0; i<blen; i++) {
n = adata[i];
cdata[i] = n + bdata[i] + carry;
carry = (n > (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0);
}
for ( ; carry && (i<alen); i++) {
carry = (cdata[i] == SEXP_UINT_T_MAX-1 ? 1 : 0);
cdata[i]++;
}
if (carry) {
c = sexp_copy_bignum(ctx, NULL, c, alen+1);
sexp_bignum_data(c)[alen] = 1;
}
sexp_gc_release1(ctx);
return c;
}
static sexp sexp_current_directory_stub (sexp ctx, sexp self, sexp_sint_t n) {
char *err;
char buf0[256];
int len0;
char *tmp0;
sexp res;
sexp_gc_var1(res0);
sexp_gc_preserve1(ctx, res0);
len0 = 256;
tmp0 = buf0;
loop:
err = getcwd(tmp0, len0);
if (!err) {
if (len0 != 256)
free(tmp0);
len0 *= 2;
tmp0 = (char*) calloc(len0, sizeof(tmp0[0]));
goto loop;
} else {
res0 = sexp_c_string(ctx, tmp0, -1);
res = res0;
}
if (len0 != 256)
free(tmp0);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
sexp_gc_var1(rem);
sexp_gc_preserve1(ctx, rem);
sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */
sexp_gc_release1(ctx);
return rem;
}
sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) {
sexp res;
sexp_gc_var1(rem);
sexp_gc_preserve1(ctx, rem);
res = sexp_bignum_quot_rem(ctx, &rem, a, b);
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) {
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;
}
void sexp_resume() {
sexp_gc_var1(tmp);
sexp_gc_preserve1(sexp_resume_ctx, tmp);
tmp = sexp_list1(sexp_resume_ctx, SEXP_VOID);
if (sexp_applicablep(sexp_resume_proc)) {
sexp_resume_proc = check_exception(sexp_resume_ctx, sexp_apply(sexp_resume_ctx, sexp_resume_proc, tmp));
}
sexp_gc_release1(sexp_resume_ctx);
}
int main()
{
sexp ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
sexp_gc_var1(score);
sexp_gc_preserve1(ctx, score);
bool ret = ext::load_file(ctx, "mammon.ss");
if (!ret) {
std::cout << "Could not find configuration file `mammon.ss`."
<< std::endl;
return 1;
}
score = sexp_eval_string(ctx, "score", -1, NULL);
if (sexp_procedurep(score)) {
score::ext_score = [&ctx](const char *b, const char *t) {
return ext::call_fun_str2(ctx, "score", b, t);
};
}
const auto boards = ext::config_get_list(ctx, "boards");
if (boards.empty()) {
std::cout << "Please add a value for `boards` in your configuration "
"file.\ne.g. (define boards '(\"g\" \"a\" \"k\"))" << std::endl;
return 1;
}
const std::string dom = ext::config_get_str(ctx, "dom", "");
std::unique_ptr<chan_proc> pc;
if (dom == "4chan") {
pc = std::unique_ptr<chan_proc>(new fourchan_proc());
} else if (dom == "8chan") {
std::string url = ext::config_get_str(ctx, "url-8chan", "");
pc = std::unique_ptr<chan_proc>(new eightchan_proc(std::move(url)));
} else {
std::cout << "Please specify a value for `dom` in your configuration "
"file.\nPossible values are:" << std::endl;
std::cout
<< "\t4chan\n"
<< "\t8chan\n"
<< std::endl;
return 1;
}
for (const auto &b: boards)
pc->proc_board(b);
sexp_gc_release1(ctx);
sexp_destroy_context(ctx);
return 0;
}
sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
sexp_gc_var1(q);
sexp_gc_preserve1(ctx, q);
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
if (sexp_positivep(sexp_ratio_numerator(a)))
q = sexp_add(ctx, q, SEXP_ONE);
sexp_gc_release1(ctx);
return q;
}
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;
}
sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_to_complex(ctx, a);
res = sexp_complex_log(ctx, res);
res = sexp_mul(ctx, b, res);
res = sexp_complex_exp(ctx, res);
sexp_gc_release1(ctx);
return res;
}
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_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
sexp_gc_var1(c);
sexp_gc_preserve1(ctx, c);
c = sexp_copy_bignum(ctx, NULL, a, 0);
if (sexp_bignum_sign(c) == sexp_fx_sign(b))
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
else
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
sexp_gc_release1(ctx);
return c;
}
sexp sexp_complex_exp (sexp ctx, sexp z) {
double e2x = exp(sexp_to_double(sexp_complex_real(z))),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(res) = sexp_make_flonum(ctx, e2x*cos(y));
sexp_complex_imag(res) = sexp_make_flonum(ctx, e2x*sin(y));
sexp_gc_release1(ctx);
return res;
}
sexp sexp_complex_log (sexp ctx, sexp z) {
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(res) = sexp_make_flonum(ctx, log(sqrt(x*x + y*y)));
sexp_complex_imag(res) = sexp_make_flonum(ctx, atan2(y, x));
sexp_gc_release1(ctx);
return res;
}
sexp sexp_complex_cos (sexp ctx, sexp z) {
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(res) = sexp_make_flonum(ctx, cos(x)*cosh(y));
sexp_complex_imag(res) = sexp_make_flonum(ctx, -sin(x)*sinh(y));
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) {
sexp res;
sexp_gc_var1(state);
sexp_gc_preserve1(ctx, state);
state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF);
res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
if (sexp_exceptionp(res)) return res;
sexp_random_state(res) = state;
sexp_random_init(res, 1);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_complex_sqrt (sexp ctx, sexp z) {
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z)), r;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
r = sqrt(x*x + y*y);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2));
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_make_timeval_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) {
struct timeval* r;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_unbox_fixnum(sexp_opcode_return_type(self)));
sexp_cpointer_value(res) = calloc(1, sizeof(struct timeval));
r = (struct timeval*) sexp_cpointer_value(res);
memset(r, 0, sizeof(struct timeval));
sexp_freep(res) = 1;
r->tv_sec = sexp_unshift_epoch(sexp_uint_value(arg0));
r->tv_usec = sexp_sint_value(arg1);
sexp_gc_release1(ctx);
return res;
}
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_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_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_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;
}
static sexp sexp_time_3e_string_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
char *err;
char tmp1[64];
sexp res;
sexp_gc_var1(res1);
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
sexp_gc_preserve1(ctx, res1);
err = asctime_r((struct tm*)sexp_cpointer_value(arg0), tmp1);
if (!err) {
res = SEXP_FALSE;
} else {
res1 = sexp_c_string(ctx, tmp1, -1);
res = res1;
}
sexp_gc_release1(ctx);
return res;
}
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;
}
}
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_bignum (sexp ctx, sexp in, sexp_uint_t init,
signed char sign, sexp_uint_t base) {
int c, digit;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
sexp_bignum_sign(res) = sign;
sexp_bignum_data(res)[0] = init;
for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
digit = digit_value(c);
if ((digit < 0) || (digit >= base))
break;
res = sexp_bignum_fxmul(ctx, res, res, base, 0);
res = sexp_bignum_fxadd(ctx, res, digit);
}
if (c=='.' || c=='e' || c=='E') {
if (base != 10) {
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
} else {
if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
}
#if SEXP_USE_RATIOS
} else if (c=='/') {
res = sexp_bignum_normalize(res);
res = sexp_make_ratio(ctx, res, SEXP_ONE);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
res = sexp_ratio_normalize(ctx, res, in);
#endif
#if SEXP_USE_COMPLEX
} else if (c=='i' || c=='i' || c=='+' || c=='-') {
sexp_push_char(ctx, c, in);
res = sexp_bignum_normalize(res);
res = sexp_read_complex_tail(ctx, in, res);
#endif
} else if ((c!=EOF) && ! sexp_is_separator(c)) {
res = sexp_read_error(ctx, "invalid numeric syntax",
sexp_make_character(c), in);
} else {
sexp_push_char(ctx, c, in);
}
sexp_gc_release1(ctx);
return sexp_bignum_normalize(res);
}
static sexp sexp_make_tm_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2, sexp arg3, sexp arg4, sexp arg5, sexp arg6) {
struct tm* r;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_unbox_fixnum(sexp_opcode_return_type(self)));
sexp_cpointer_value(res) = calloc(1, sizeof(struct tm));
r = (struct tm*) sexp_cpointer_value(res);
memset(r, 0, sizeof(struct tm));
sexp_freep(res) = 1;
r->tm_sec = sexp_sint_value(arg0);
r->tm_min = sexp_sint_value(arg1);
r->tm_hour = sexp_sint_value(arg2);
r->tm_mday = sexp_sint_value(arg3);
r->tm_mon = sexp_sint_value(arg4);
r->tm_year = sexp_sint_value(arg5);
r->tm_isdst = sexp_sint_value(arg6);
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_stat_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
int err;
struct stat* tmp1;
sexp res;
sexp_gc_var1(res1);
if (! sexp_stringp(arg0))
return sexp_type_exception(ctx, self, SEXP_STRING, arg0);
sexp_gc_preserve1(ctx, res1);
tmp1 = (struct stat*) calloc(1, 1 + sizeof(tmp1[0]));
err = stat(sexp_string_data(arg0), tmp1);
if (err) {
res = SEXP_FALSE;
} else {
res1 = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_arg2_type(self)), tmp1, SEXP_FALSE, 1);
res = res1;
}
sexp_gc_release1(ctx);
return res;
}
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_seconds_3e_string_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
char *err;
char tmp1[64];
time_t tmp0;
sexp res;
sexp_gc_var1(res1);
if (! sexp_exact_integerp(arg0))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0);
sexp_gc_preserve1(ctx, res1);
tmp0 = sexp_unshift_epoch(sexp_uint_value(arg0));
err = ctime_r(&tmp0, tmp1);
if (!err) {
res = SEXP_FALSE;
} else {
res1 = sexp_c_string(ctx, tmp1, -1);
res = res1;
}
sexp_gc_release1(ctx);
return res;
}
