static bool change_frame(struct luadebug_debugger *session, const char *option)
{
const int index = option ? atoi(option) : session->frame_index;
if (!lua_getstack(session->L, index, &session->frame)) {
session->user->print(session->user, RED "invalid frame index '%d'\n" CLEAR, index);
}
else {
UNUSED int env_index;
session->user->print(session->user, " #%d\t" CYAN, index);
dump_frame(session->L, &session->frame, session->user);
session->frame_index = index;
env_index = capture_env(session->L, index);
assert(env_index != -1);
lua_replace(session->L, session->env_index);
session->list_line = session->frame.currentline - LIST_DEFAULT_LINE/2;
}
return false;
}
//------------------------------------------------------------------------------
static void apply_env(const env_block_t* block)
{
env_block_t to_clear;
capture_env(&to_clear);
apply_env_impl(&to_clear, 1);
free_env(&to_clear);
apply_env_impl(block, 0);
}
//------------------------------------------------------------------------------
void prepare_env_for_inputrc()
{
// Give readline a chance to find the inputrc by modifying the
// environment slightly.
char buffer[1024];
void* env_handle;
env_block_t env_block;
capture_env(&env_block);
// HOME is where Readline will expand ~ to.
{
static const char home_eq[] = "HOME=";
int size = sizeof_array(home_eq);
strcpy(buffer, home_eq);
get_config_dir(buffer + size - 1, sizeof_array(buffer) - size);
putenv(buffer);
}
// INPUTRC is the path where looks for it's configuration file.
{
static const char inputrc_eq[] = "INPUTRC=";
int size = sizeof_array(inputrc_eq);
strcpy(buffer, inputrc_eq);
get_dll_dir(buffer + size - 1, sizeof_array(buffer) - size);
str_cat(buffer, "/clink_inputrc_base", sizeof_array(buffer));
putenv(buffer);
}
apply_env(&env_block);
free_env(&env_block);
}
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 ();
}
}
void luadebug_interactive_enter(struct lua_State *L, const char *single, const char *multi,
const char *msg)
{
char *line, *full_line = NULL;
bool multiline = false;
bool stop = false;
struct luadebug_interactive session;
{
mutex_lock(¤t_user_mutex);
session.user = current_user;
if (!session.user) {
message(HAKA_LOG_ERROR, L"interactive", L"no input/output handler");
mutex_unlock(¤t_user_mutex);
return;
}
luadebug_user_addref(session.user);
mutex_unlock(¤t_user_mutex);
}
mutex_lock(&active_session_mutex);
if (!single) single = "> ";
if (!multi) multi = ">> ";
session.user->completion = completion;
if (!session.user->start(session.user, "haka")) {
on_user_error();
luadebug_user_release(&session.user);
mutex_unlock(&active_session_mutex);
return;
}
current_session = &session;
LUA_STACK_MARK(L);
session.user->print(session.user, GREEN "entering interactive session" CLEAR ": %s\n", msg);
session.L = L;
session.env_index = capture_env(L, 1);
assert(session.env_index != -1);
session.complete.stack_env = session.env_index;
while (!stop && (line = session.user->readline(session.user, multiline ? multi : single))) {
int status = -1;
bool is_return = false;
char *current_line;
if (multiline) {
const size_t full_line_size = strlen(full_line);
assert(full_line);
full_line = realloc(full_line, full_line_size + 1 + strlen(line) + 1);
full_line[full_line_size] = ' ';
strcpy(full_line + full_line_size + 1, line);
current_line = full_line;
}
else {
session.user->addhistory(session.user, line);
current_line = line;
}
while (*current_line == ' ' || *current_line == '\t') {
++current_line;
}
is_return = (strncmp(current_line, "return ", 7) == 0) ||
(strcmp(current_line, "return") == 0);
if (!multiline && !is_return) {
char *return_line = malloc(7 + strlen(current_line) + 1);
strcpy(return_line, "return ");
strcpy(return_line+7, current_line);
status = luaL_loadbuffer(L, return_line, strlen(return_line), "stdin");
if (status) {
lua_pop(L, 1);
status = -1;
}
free(return_line);
}
if (status == -1) {
status = luaL_loadbuffer(L, current_line, strlen(current_line), "stdin");
}
multiline = false;
/* Change the chunk environment */
lua_pushvalue(L, session.env_index);
lua_setfenv(L, -2);
if (status == LUA_ERRSYNTAX) {
const char *message;
const int k = sizeof(EOF_MARKER) / sizeof(char) - 1;
size_t n;
message = lua_tolstring(L, -1, &n);
if (n > k &&
!strncmp(message + n - k, EOF_MARKER, k) &&
strlen(line) > 0) {
multiline = true;
} else {
session.user->print(session.user, RED "%s" CLEAR "\n", lua_tostring(L, -1));
}
lua_pop(L, 1);
}
else if (status == LUA_ERRMEM) {
session.user->print(session.user, RED "%s" CLEAR "\n", lua_tostring(L, -1));
lua_pop(L, 1);
}
else {
execute_print(L, session.user);
lua_pop(L, 1);
if (is_return) {
stop = true;
}
}
if (!multiline) {
free(full_line);
full_line = NULL;
}
else if (!full_line) {
full_line = strdup(line);
}
free(line);
}
free(full_line);
session.user->print(session.user, "\n");
session.user->print(session.user, GREEN "continue" CLEAR "\n");
lua_pop(L, 1);
LUA_STACK_CHECK(L, 0);
if (!session.user->stop(session.user)) {
on_user_error();
}
luadebug_user_release(&session.user);
current_session = NULL;
mutex_unlock(&active_session_mutex);
}
