SCM
gdbscm_make_error (SCM key, const char *subr, const char *message,
SCM args, SCM data)
{
return gdbscm_make_error_scm
(key,
subr == NULL ? SCM_BOOL_F : scm_from_latin1_string (subr),
message == NULL ? SCM_BOOL_F : scm_from_latin1_string (message),
args, data);
}
static void scm_conv_check(void)
{
scm_init_guile();
static struct {
int version;
char const *str;
char const *num;
sa_family_t exp_family;
} tests[] = {
{ 4, "1.0.0.0", "(%d . 16777216)", AF_INET },
{ 4, "127.0.0.1", "(%d . 2130706433)", AF_INET },
{ 4, "128.10.5.255", "(%d . 2148140543)", AF_INET },
{ 6, "ff02::1", "(%d . 338963523518870617245727861364146307073)", AF_INET6 },
{ 6, "1:2:3:4::", "(%d . 5192455318486707403025865779445760)", AF_INET6 },
};
for (unsigned t = 0; t < NB_ELEMS(tests); t++) {
struct ip_addr addr;
ip_addr_ctor_from_str(&addr, tests[t].str, strlen(tests[t].str), tests[t].version);
SCM ip = scm_from_ip_addr(&addr);
SCM str = scm_simple_format(SCM_BOOL_F, scm_from_latin1_string("~a"), scm_cons(ip, SCM_EOL));
char buf[256];
size_t len = scm_to_locale_stringbuf(str, buf, sizeof(buf));
assert(len < sizeof(buf));
buf[len] = '\0';
char expected[256];
snprintf(expected, sizeof(expected), tests[t].num, tests[t].exp_family);
printf("%s -> '%s' (expected '%s')\n", tests[t].str, buf, expected);
assert(0 == strcmp(expected, buf));
}
}
/* returns a (sec . usec) pair. It throws an 'a-sync-exception guile
exception if the library has been configured for monotonic time at
configuration time but it is not in fact supported, but this is not
worth testing for by user code as it should never happen - the
library configuration macros should always give the correct
answer */
static SCM get_time(void) {
#ifdef HAVE_MONOTONIC_CLOCK
struct timespec ts;
if (clock_gettime(CLOCK_MONOTONIC, &ts) == -1) {
scm_throw(scm_from_latin1_symbol("a-sync-exception"),
scm_list_4(scm_from_latin1_string("get-time"),
scm_from_latin1_string("guile-a-sync2: ~A"),
scm_list_1(scm_from_latin1_string("monotonic time not supported "
"by underlying implementation")),
scm_from_int(errno)));
}
return scm_cons(scm_from_size_t(ts.tv_sec), scm_from_long(ts.tv_nsec/1000L));
#else
return scm_gettimeofday();
#endif
}
static SCM
scm_type_symbol_to_AnchorPointType (SCM symb, SCM who)
{
int type = INT_MIN;
if (scm_is_eq (symb, scm_symbol__mark ()))
type = at_mark;
else if (scm_is_eq (symb, scm_symbol__base ()))
type = at_basechar;
else if (scm_is_eq (symb, scm_symbol__ligature ()))
type = at_baselig;
else if (scm_is_eq (symb, scm_symbol__base_mark ()))
type = at_basemark;
else if (scm_is_eq (symb, scm_symbol__entry ()))
type = at_centry;
else if (scm_is_eq (symb, scm_symbol__exit ()))
type = at_cexit;
else
{
if (SCM_UNBNDP (who))
who = scm_from_latin1_string ("scm_type_symbol_to_AnchorPointType");
rnrs_raise_condition
(scm_list_4
(rnrs_make_assertion_violation (),
rnrs_make_who_condition (who),
rnrs_c_make_message_condition (_("unrecognized anchor point type")),
rnrs_make_irritants_condition (scm_list_1 (symb))));
}
return scm_from_int (type);
}
SCM
gdbscm_scm_from_printf (const char *format, ...)
{
va_list args;
SCM result;
va_start (args, format);
std::string string = string_vprintf (format, args);
va_end (args);
result = scm_from_latin1_string (string.c_str ());
return result;
}
SCM
gdbscm_scm_from_printf (const char *format, ...)
{
va_list args;
char *string;
SCM result;
va_start (args, format);
string = xstrvprintf (format, args);
va_end (args);
result = scm_from_latin1_string (string);
xfree (string);
return result;
}
static SCM
scm_AnchorPointType_to_type_symbol (SCM type, SCM who)
{
SCM symb = SCM_UNSPECIFIED;
const int _type = scm_to_int (type);
switch (_type)
{
case at_mark:
symb = scm_symbol__mark ();
break;
case at_basechar:
symb = scm_symbol__base ();
break;
case at_baselig:
symb = scm_symbol__ligature ();
break;
case at_basemark:
symb = scm_symbol__base_mark ();
break;
case at_centry:
symb = scm_symbol__entry ();
break;
case at_cexit:
symb = scm_symbol__exit ();
break;
default:
{
if (SCM_UNBNDP (who))
who = scm_from_latin1_string ("scm_AnchorPointType_to_type_symbol");
rnrs_raise_condition
(scm_list_4
(rnrs_make_assertion_violation (),
rnrs_make_who_condition (who),
rnrs_c_make_message_condition (_("unrecognized AnchorPointType "
"value")),
rnrs_make_irritants_condition (scm_list_1 (type))));
}
break;
}
return symb;
}
SCM
gdbscm_scm_from_c_string (const char *string)
{
return scm_from_latin1_string (string);
}
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 MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
else
return MAKMEMO_MOD_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_MOD_REF (REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
case SCM_EXPANDED_TOPLEVEL_SET:
return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
memoize (REF (exp, TOPLEVEL_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP), 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), scm_ilength (args), 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 == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
nargs,
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 or #f. */
{
SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
body = REF (exp, LAMBDA, BODY);
if (scm_is_false (body))
/* Give a body to case-lambda with no clauses. */
proc = MAKMEMO_LAMBDA
(MAKMEMO_CALL
(MAKMEMO_MOD_REF (list_of_guile,
scm_from_latin1_symbol ("throw"),
SCM_BOOL_F),
5,
scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
MAKMEMO_QUOTE (SCM_BOOL_F),
MAKMEMO_QUOTE (scm_from_latin1_string
("Wrong number of arguments")),
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
SCM_BOOL_F /* docstring */);
else
proc = memoize (body, env);
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
SCM_SETCAR (SCM_CDR (args), docstring);
}
return proc;
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env;
int nreq, nopt, ntotal;
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;
ntotal = scm_ilength (vars);
/* The vars are the gensyms, according to the divine plan. But we need
to memoize the inits within their appropriate environment,
complicating things. */
new_env = env;
for (walk = req; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars))
new_env = scm_cons (CAR (vars), new_env);
minits = SCM_EOL;
for (walk = opt; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (scm_is_true (rest))
{
new_env = scm_cons (CAR (vars), new_env);
vars = CDR (vars);
}
for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (!scm_is_null (vars))
abort ();
minits = scm_reverse_x (minits, SCM_UNDEFINED);
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 = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
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, minits,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_BOOL_F /* docstring */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, inits, new_env;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
inits = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
{
new_env = scm_cons (CAR (vars), new_env);
inits = scm_cons (memoize (CAR (exps), env), inits);
}
return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
memoize (body, new_env));
}
case SCM_EXPANDED_LETREC:
{
SCM vars, exps, body, undefs, new_env;
int i, nvars, in_order_p;
vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY);
in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
nvars = i = scm_ilength (vars);
undefs = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
}
if (in_order_p)
{
SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
body_exps);
seq = memoize (body, new_env);
for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
sets = scm_reverse_x (sets, SCM_UNDEFINED);
if (scm_is_null (sets))
return memoize (body, env);
for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
sets = CDR (sets))
set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
return MAKMEMO_LET (undefs,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
memoize (body, new_env)));
}
}
default:
abort ();
}
}
static SCM
scm_from_string_or_null (const char *s)
{
return scm_from_latin1_string ((s == NULL) ? "" : s);
}