static sexpr get (sexpr arguments, struct machine_state *st)
{
sexpr e = car (arguments), r;
if (!environmentp (e))
{
e = lx_make_environment (sx_end_of_list);
}
r = include (cdr (arguments),
(struct machine_state *)
lx_make_state (sx_end_of_list, e, sx_end_of_list,
sx_end_of_list));
if (nexp (r))
{
e = lx_environment_bind (e, sym_error, sym_file_not_found);
return include (cons (str_error_file_not_found_xhtml,
sx_end_of_list),
(struct machine_state *)
lx_make_state (sx_end_of_list, e, sx_end_of_list,
sx_end_of_list));
}
return r;
}
inline Environment * check_environment(Value value)
{
if (environmentp(value))
return the_environment(value);
signal_type_error(value, S_environment);
// Not reached.
return NULL;
}
sexpr lx_environment_alist (sexpr env)
{
if (environmentp (env))
{
struct environment *tenv = (struct environment *)env;
return tenv->environment;
}
return sx_end_of_list;
}
sexpr lx_environment_bind (sexpr env, sexpr key, sexpr value)
{
sexpr r = sx_end_of_list;
if (environmentp (env))
{
struct environment *t = (struct environment *)env;
r = cons (cons(key, value), t->environment);
}
return lx_make_environment (r);
}
sexpr lx_environment_join (sexpr a, sexpr b)
{
sexpr r = sx_end_of_list;
if (environmentp (a) && environmentp (b))
{
struct environment *ta = (struct environment *)a;
struct environment *tb = (struct environment *)b;
sexpr c = tb->environment;
while (consp (c))
{
sexpr d = car (c);
sexpr da = car (d);
ta = (struct environment *)lx_environment_unbind ((sexpr)ta, da);
ta = (struct environment *)lx_environment_bind ((sexpr)ta, da, cdr (d));
c = cdr (c);
}
return (sexpr)ta;
}
return lx_make_environment (r);
}
sexpr lx_environment_lookup (sexpr env, sexpr key)
{
if (environmentp (env))
{
struct environment *t = (struct environment *)env;
sexpr sx = t->environment;
while (consp (sx))
{
sexpr sxt = car (sx);
if (truep (equalp (car (sxt), key)))
{
return cdr (sxt);
}
sx = cdr (sx);
}
}
return sx_nonexistent;
}
sexpr lx_environment_unbind (sexpr env, sexpr key)
{
sexpr r = sx_end_of_list;
if (environmentp (env))
{
struct environment *t = (struct environment *)env;
sexpr sx = t->environment;
while (consp (sx))
{
sexpr sxt = car (sx);
if (falsep (equalp (car (sxt), key)))
{
r = cons (sxt, r);
}
sx = cdr (sx);
}
}
return lx_make_environment (r);
}
static sexpr action_dispatch
(sexpr arguments, struct machine_state *state)
{
if (eolp (state->stack))
{
state->stack = cons(lx_foreign_mu (sym_action_dispatch,
action_dispatch),
state->stack);
state->stack = cons (car (state->code), state->stack);
state->code = cdr (state->code);
state->stack = cons (car (state->code), state->stack);
state->code = cdr (state->code);
return sx_nonexistent;
}
else
{
sexpr meta = car (arguments), code, env;
arguments = cdr (arguments);
code = car (arguments);
env = car (cdr (arguments));
state->stack = sx_end_of_list;
state->code = cons (cons (sym_action_wrap, cons (meta, code)),
sx_end_of_list);
if (environmentp (env))
{
state->environment = lx_environment_join (state->environment, env);
}
return sx_unquote;
}
}
inline Environment * the_environment(Value value)
{
assert(environmentp(value));
return reinterpret_cast<Environment *>(value - LOWTAG_TYPED_OBJECT);
}
static sexpr pong (sexpr arguments, struct machine_state *st)
{
sexpr e = car (arguments), r, tf, v, ex, bn, on;
if (!environmentp (e))
{
e = lx_make_environment (sx_end_of_list);
r = arguments;
}
else
{
r = cdr (arguments);
}
on = lx_environment_lookup (e, sym_original_name);
ex = lx_environment_lookup (e, sym_extension);
bn = lx_environment_lookup (e, sym_base_name);
if (!nexp (on) && (nexp (ex) || nexp (bn)))
{
const char *ts = sx_string (on);
char *tmp;
int len = 0, i = 0;
while (ts[len] != (char)0)
{
if (ts[len] == '.') i = len;
len++;
}
if (i > 0)
{
len = i;
tmp = aalloc (len + 1);
for (i = 0; i < len; i++)
{
tmp[i] = ts[i];
}
tmp[i] = 0;
i++;
bn = make_string (tmp);
ex = make_string (ts + i);
afree (i, tmp);
if (!nexp (bn))
{
lx_environment_unbind (e, sym_base_name);
}
if (!nexp (ex))
{
lx_environment_unbind (e, sym_extension);
}
e = lx_environment_bind (e, sym_base_name, bn);
e = lx_environment_bind (e, sym_extension, ex);
}
else
{
e = lx_environment_bind (e, sym_base_name, on);
}
}
tf = lx_environment_lookup (e, sym_format);
if (nexp (tf))
{
tf = lx_environment_lookup (mime_map, ex);
if (nexp (tf))
{
tf = lx_environment_lookup (e, sym_accept);
if (!nexp (tf))
{
tf = get_acceptable_type (tf);
}
else
{
tf = default_type;
}
v = lx_environment_lookup (e, sym_Vary);
if (!nexp (v))
{
e = lx_environment_unbind (e, sym_Vary);
e = lx_environment_bind
(e, sym_Vary,
sx_join (v, str_cAccept, sx_end_of_list));
}
else
{
e = lx_environment_bind
(e, sym_Vary, str_Accept);
}
}
e = lx_environment_bind (e, sym_format, tf);
}
return sx_list2 (e, r);
}
