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