static SCM
make_env (int n, SCM init, SCM next)
{
SCM env = scm_c_make_vector (n + 1, init);
VECTOR_SET (env, 0, next);
return env;
}
static SCM
scm_i_vector2list (SCM l, long len)
{
long j;
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
}
return z;
}
SCM
thit_scm_from_vector_int(gsl_vector_int *v) {
SCM s_vector = scm_c_make_vector(v->size, SCM_BOOL_F);
int i;
for (i = 0; i < v->size; i++)
scm_vector_set_x(s_vector, scm_from_int(i),
scm_from_int(gsl_vector_int_get(v, i)));
return s_vector;
}
SCM
thit_get_missingness_pattern(SCM s_model) {
scm_assert_smob_type(thit_model_tag, s_model);
banmi_model_t *model = (banmi_model_t*)SCM_SMOB_DATA(s_model);
SCM s_rows = scm_c_make_vector(model->n_rows, SCM_BOOL_F);
int n_cols = model->n_disc + model->n_cont;
int i, j;
for (i = 0; i < model->n_rows; i++) {
SCM this_row = scm_c_make_vector(n_cols, scm_from_int(0));
int mask = 0;
for (j = 0; j < n_cols; j++) {
if ((model->mis_pat[i] | mask) > 0)
scm_vector_set_x(this_row, scm_from_int(j), scm_from_int(1));
}
scm_vector_set_x(s_rows, scm_from_int(i), this_row);
}
return s_rows;
}
SCM
thit_scm_from_banmi_data(gsl_matrix_int *disc, gsl_matrix *cont, int n_rows) {
SCM s_rows = scm_c_make_vector(n_rows, SCM_BOOL_F);
int i, j;
for (i = 0; i < n_rows; i++) {
SCM this_row = scm_c_make_vector(disc->size2 + cont->size2, SCM_BOOL_F);
for (j = 0; j < disc->size2; j++) {
scm_vector_set_x(this_row, scm_from_int(j),
scm_from_int(gsl_matrix_int_get(disc, i, j)));
}
for (j = 0; j < cont->size2; j++) {
scm_vector_set_x(this_row, scm_from_int(j + disc->size2),
scm_from_double(gsl_matrix_get(cont, i, j)));
}
scm_vector_set_x(s_rows, scm_from_int(i), this_row);
}
return s_rows;
}
static SCM
capture_flat_env (SCM lambda, SCM env)
{
int nenv;
SCM vars, link, locs;
link = CAR (env);
vars = env_link_vars (link);
nenv = scm_ilength (vars);
locs = scm_c_make_vector (nenv, SCM_BOOL_F);
for (; scm_is_pair (vars); vars = CDR (vars))
scm_c_vector_set_x (locs, --nenv, CDAR (vars));
return MAKMEMO_CAPTURE_ENV (locs, lambda);
}
static SCM
make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->min_size_index = t->size_index = i;
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
(scm_t_bits)t, 0);
}
void
scm_i_rehash (SCM table,
scm_t_hash_fn hash_fn,
void *closure,
const char* func_name)
{
SCM buckets, new_buckets;
int i;
unsigned long old_size;
unsigned long new_size;
if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
{
/* rehashing is not triggered when i <= min_size */
i = SCM_HASHTABLE (table)->size_index;
do
--i;
while (i > SCM_HASHTABLE (table)->min_size_index
&& SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
}
else
{
i = SCM_HASHTABLE (table)->size_index + 1;
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
}
SCM_HASHTABLE (table)->size_index = i;
new_size = hashtable_size[i];
if (i <= SCM_HASHTABLE (table)->min_size_index)
SCM_HASHTABLE (table)->lower = 0;
else
SCM_HASHTABLE (table)->lower = new_size / 4;
SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
buckets = SCM_HASHTABLE_VECTOR (table);
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < old_size; ++i)
{
SCM ls, cell, handle;
ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
while (scm_is_pair (ls))
{
unsigned long h;
cell = ls;
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
SCM_HASHTABLE_INCREMENT (table);
}
}
}
SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
(SCM host),
"@deffnx {Scheme Procedure} gethostbyname hostname\n"
"@deffnx {Scheme Procedure} gethostbyaddr address\n"
"Look up a host by name or address, returning a host object. The\n"
"@code{gethost} procedure will accept either a string name or an integer\n"
"address; if given no arguments, it behaves like @code{gethostent} (see\n"
"below). If a name or address is supplied but the address can not be\n"
"found, an error will be thrown to one of the keys:\n"
"@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
"@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
"Unusual conditions may result in errors thrown to the\n"
"@code{system-error} or @code{misc_error} keys.")
#define FUNC_NAME s_scm_gethost
{
SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
SCM lst = SCM_EOL;
struct hostent *entry;
struct in_addr inad;
char **argv;
int i = 0;
if (SCM_UNBNDP (host))
{
#ifdef HAVE_GETHOSTENT
entry = gethostent ();
#else
entry = NULL;
#endif
if (! entry)
{
SCM
scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
{
register long i;
long count = 0;
SCM l, fl, applicable = SCM_EOL;
SCM save = args;
SCM buffer[BUFFSIZE];
SCM const *types;
SCM *p;
SCM tmp = SCM_EOL;
scm_t_array_handle handle;
scm_c_issue_deprecation_warning
("scm_compute_applicable_methods is deprecated. Use "
"`compute-applicable-methods' from Scheme instead.");
/* Build the list of arguments types */
if (len >= BUFFSIZE)
{
tmp = scm_c_make_vector (len, SCM_UNDEFINED);
types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
/*
note that we don't have to work to reset the generation
count. TMP is a new vector anyway, and it is found
conservatively.
*/
}
else
types = p = buffer;
for ( ; !scm_is_null (args); args = SCM_CDR (args))
*p++ = scm_class_of (SCM_CAR (args));
/* Build a list of all applicable methods */
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
/* We have a dotted argument list */
|| (i >= len && scm_is_null (fl)))
{ /* both list exhausted */
applicable = scm_cons (SCM_CAR (l), applicable);
count += 1;
break;
}
if (i >= len
|| scm_is_null (fl)
|| !applicablep (types[i], SCM_CAR (fl)))
break;
}
}
if (len >= BUFFSIZE)
scm_array_handle_release (&handle);
if (count == 0)
{
if (find_method_p)
return SCM_BOOL_F;
scm_call_2 (scm_no_applicable_method, gf, save);
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
}
static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
abort ();
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, PRIMITIVE_REF, NAME))),
env);
else
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)),
memoize (REF (exp, MODULE_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, TOPLEVEL_REF, NAME))),
env);
case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
REF (exp, TOPLEVEL_SET, NAME)),
memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
REF (exp, TOPLEVEL_DEFINE, NAME)),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), args);
}
case SCM_EXPANDED_PRIMCALL:
{
SCM name, args;
int nargs;
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-ref")))
return MAKMEMO_BOX_REF (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-set!")))
return MAKMEMO_BOX_SET (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("push-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
else if (nargs == 0
&& scm_is_eq (name,
scm_from_latin1_symbol ("pop-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module
(MAKMEMO_BOX_REF
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
name)),
env),
args);
else
return MAKMEMO_CALL (MAKMEMO_BOX_REF
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
name,
SCM_BOOL_F)),
args);
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
{
SCM meta, body, proc, new_env;
meta = REF (exp, LAMBDA, META);
body = REF (exp, LAMBDA, BODY);
new_env = push_flat_link (capture_env (env));
proc = memoize (body, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
env);
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM unbound, arity, rib, new_env;
int nreq, nopt, ninits;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);
vars = REF (exp, LAMBDA_CASE, GENSYMS);
body = REF (exp, LAMBDA_CASE, BODY);
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ninits = scm_ilength (inits);
/* This relies on assignment conversion turning inits into a
sequence of CONST expressions whose values are a unique
"unbound" token. */
unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
rib = scm_vector (vars);
new_env = push_nested_link (rib, env);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = lookup_rib (CADDR (CAR (kw)), rib);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))
arity = FIXED_ARITY (nreq);
else
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_EOL /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, varsv, inits, new_env;
int i;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
new_env = push_nested_link (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
return maybe_makmemo_capture_module
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
default:
abort ();
}
}
