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 (); } }