static SCM
gdbscm_string_to_argv (SCM string_scm)
{
char *string;
char **c_argv;
int i;
SCM result = SCM_EOL;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
string_scm, &string);
if (string == NULL || *string == '\0')
{
xfree (string);
return SCM_EOL;
}
c_argv = gdb_buildargv (string);
for (i = 0; c_argv[i] != NULL; ++i)
result = scm_cons (gdbscm_scm_from_c_string (c_argv[i]), result);
freeargv (c_argv);
xfree (string);
return scm_reverse_x (result, SCM_EOL);
}
static SCM
gdbscm_execute_gdb_command (SCM command_scm, SCM rest)
{
int from_tty_arg_pos = -1, to_string_arg_pos = -1;
int from_tty = 0, to_string = 0;
volatile struct gdb_exception except;
const SCM keywords[] = { from_tty_keyword, to_string_keyword, SCM_BOOL_F };
char *command;
char *result = NULL;
struct cleanup *cleanups;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#tt",
command_scm, &command, rest,
&from_tty_arg_pos, &from_tty,
&to_string_arg_pos, &to_string);
/* Note: The contents of "command" may get modified while it is
executed. */
cleanups = make_cleanup (xfree, command);
TRY_CATCH (except, RETURN_MASK_ALL)
{
struct cleanup *inner_cleanups;
inner_cleanups = make_cleanup_restore_integer (&interpreter_async);
interpreter_async = 0;
prevent_dont_repeat ();
if (to_string)
result = execute_command_to_string (command, from_tty);
else
{
execute_command (command, from_tty);
result = NULL;
}
/* Do any commands attached to breakpoint we stopped at. */
bpstat_do_actions ();
do_cleanups (inner_cleanups);
}
do_cleanups (cleanups);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (result)
{
SCM r = gdbscm_scm_from_c_string (result);
xfree (result);
return r;
}
return SCM_UNSPECIFIED;
}
static SCM
gdbscm_open_memory (SCM rest)
{
const SCM keywords[] = {
mode_keyword, start_keyword, size_keyword, SCM_BOOL_F
};
char *mode = NULL;
CORE_ADDR start = 0;
CORE_ADDR end;
int mode_arg_pos = -1, start_arg_pos = -1, size_arg_pos = -1;
ULONGEST size;
SCM port;
long mode_bits;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "#sUU", rest,
&mode_arg_pos, &mode,
&start_arg_pos, &start,
&size_arg_pos, &size);
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
if (mode == NULL)
mode = xstrdup ("r");
scm_dynwind_free (mode);
if (size_arg_pos > 0)
{
/* For now be strict about start+size overflowing. If it becomes
a nuisance we can relax things later. */
if (start + size < start)
{
gdbscm_out_of_range_error (FUNC_NAME, 0,
scm_list_2 (gdbscm_scm_from_ulongest (start),
gdbscm_scm_from_ulongest (size)),
_("start+size overflows"));
}
end = start + size;
}
else
end = ~(CORE_ADDR) 0;
mode_bits = ioscm_parse_mode_bits (FUNC_NAME, mode);
port = ioscm_open_port (memory_port_desc, mode_bits);
ioscm_init_memory_port (port, start, end);
scm_dynwind_end ();
/* TODO: Set the file name as "memory-start-end"? */
return port;
}
static SCM
gdbscm_find_pc_line (SCM pc_scm)
{
ULONGEST pc_ull;
struct symtab_and_line sal;
volatile struct gdb_exception except;
init_sal (&sal); /* -Wall */
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc_ull);
TRY_CATCH (except, RETURN_MASK_ALL)
{
CORE_ADDR pc = (CORE_ADDR) pc_ull;
sal = find_pc_line (pc, 0);
}
static SCM
gdbscm_find_pc_line (SCM pc_scm)
{
ULONGEST pc_ull;
struct symtab_and_line sal;
init_sal (&sal); /* -Wall */
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc_ull);
TRY
{
CORE_ADDR pc = (CORE_ADDR) pc_ull;
sal = find_pc_line (pc, 0);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
static SCM
gdbscm_string_to_argv (SCM string_scm)
{
char *string;
SCM result = SCM_EOL;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
string_scm, &string);
if (string == NULL || *string == '\0')
{
xfree (string);
return SCM_EOL;
}
gdb_argv c_argv (string);
for (char *arg : c_argv)
result = scm_cons (gdbscm_scm_from_c_string (arg), result);
xfree (string);
return scm_reverse_x (result, SCM_EOL);
}
static SCM
gdbscm_make_breakpoint (SCM location_scm, SCM rest)
{
const SCM keywords[] = {
type_keyword, wp_class_keyword, internal_keyword, SCM_BOOL_F
};
char *s;
char *location;
int type_arg_pos = -1, access_type_arg_pos = -1, internal_arg_pos = -1;
enum bptype type = bp_breakpoint;
enum target_hw_bp_type access_type = hw_write;
int internal = 0;
SCM result;
breakpoint_smob *bp_smob;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iit",
location_scm, &location, rest,
&type_arg_pos, &type,
&access_type_arg_pos, &access_type,
&internal_arg_pos, &internal);
result = bpscm_make_breakpoint_smob ();
bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (result);
s = location;
location = gdbscm_gc_xstrdup (s);
xfree (s);
switch (type)
{
case bp_breakpoint:
if (access_type_arg_pos > 0)
{
gdbscm_misc_error (FUNC_NAME, access_type_arg_pos,
scm_from_int (access_type),
_("access type with breakpoint is not allowed"));
}
break;
case bp_watchpoint:
switch (access_type)
{
case hw_write:
case hw_access:
case hw_read:
break;
default:
gdbscm_out_of_range_error (FUNC_NAME, access_type_arg_pos,
scm_from_int (access_type),
_("invalid watchpoint class"));
}
break;
default:
gdbscm_out_of_range_error (FUNC_NAME, access_type_arg_pos,
scm_from_int (type),
_("invalid breakpoint type"));
}
bp_smob->is_scheme_bkpt = 1;
bp_smob->spec.location = location;
bp_smob->spec.type = type;
bp_smob->spec.access_type = access_type;
bp_smob->spec.is_internal = internal;
return result;
}
static SCM
gdbscm_make_parameter (SCM name_scm, SCM rest)
{
const SCM keywords[] = {
command_class_keyword, parameter_type_keyword, enum_list_keyword,
set_func_keyword, show_func_keyword,
doc_keyword, set_doc_keyword, show_doc_keyword,
initial_value_keyword, SCM_BOOL_F
};
int cmd_class_arg_pos = -1, param_type_arg_pos = -1;
int enum_list_arg_pos = -1, set_func_arg_pos = -1, show_func_arg_pos = -1;
int doc_arg_pos = -1, set_doc_arg_pos = -1, show_doc_arg_pos = -1;
int initial_value_arg_pos = -1;
char *s;
char *name;
int cmd_class = no_class;
int param_type = var_boolean; /* ARI: var_boolean */
SCM enum_list_scm = SCM_BOOL_F;
SCM set_func = SCM_BOOL_F, show_func = SCM_BOOL_F;
char *doc = NULL, *set_doc = NULL, *show_doc = NULL;
SCM initial_value_scm = SCM_BOOL_F;
const char * const *enum_list = NULL;
SCM p_scm;
param_smob *p_smob;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iiOOOsssO",
name_scm, &name, rest,
&cmd_class_arg_pos, &cmd_class,
¶m_type_arg_pos, ¶m_type,
&enum_list_arg_pos, &enum_list_scm,
&set_func_arg_pos, &set_func,
&show_func_arg_pos, &show_func,
&doc_arg_pos, &doc,
&set_doc_arg_pos, &set_doc,
&show_doc_arg_pos, &show_doc,
&initial_value_arg_pos, &initial_value_scm);
/* If doc is NULL, leave it NULL. See add_setshow_cmd_full. */
if (set_doc == NULL)
set_doc = get_doc_string ();
if (show_doc == NULL)
show_doc = get_doc_string ();
s = name;
name = gdbscm_canonicalize_command_name (s, 0);
xfree (s);
if (doc != NULL)
{
s = doc;
doc = gdbscm_gc_xstrdup (s);
xfree (s);
}
s = set_doc;
set_doc = gdbscm_gc_xstrdup (s);
xfree (s);
s = show_doc;
show_doc = gdbscm_gc_xstrdup (s);
xfree (s);
if (!gdbscm_valid_command_class_p (cmd_class))
{
gdbscm_out_of_range_error (FUNC_NAME, cmd_class_arg_pos,
scm_from_int (cmd_class),
_("invalid command class argument"));
}
if (!pascm_valid_parameter_type_p (param_type))
{
gdbscm_out_of_range_error (FUNC_NAME, param_type_arg_pos,
scm_from_int (param_type),
_("invalid parameter type argument"));
}
if (enum_list_arg_pos > 0 && param_type != var_enum)
{
gdbscm_misc_error (FUNC_NAME, enum_list_arg_pos, enum_list_scm,
_("#:enum-values can only be provided with PARAM_ENUM"));
}
if (enum_list_arg_pos < 0 && param_type == var_enum)
{
gdbscm_misc_error (FUNC_NAME, GDBSCM_ARG_NONE, SCM_BOOL_F,
_("PARAM_ENUM requires an enum-values argument"));
}
if (set_func_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_procedure (set_func), set_func,
set_func_arg_pos, FUNC_NAME, _("procedure"));
}
if (show_func_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_procedure (show_func), show_func,
show_func_arg_pos, FUNC_NAME, _("procedure"));
}
if (param_type == var_enum)
{
/* Note: enum_list lives in GC space, so we don't have to worry about
freeing it if we later throw an exception. */
enum_list = compute_enum_list (enum_list_scm, enum_list_arg_pos,
FUNC_NAME);
}
/* If initial-value is a function, we need the parameter object constructed
to pass it to the function. A typical thing the function may want to do
is add an object-property to it to record the last known good value. */
p_scm = pascm_make_param_smob ();
p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
/* These are all stored in GC space so that we don't have to worry about
freeing them if we throw an exception. */
p_smob->name = name;
p_smob->cmd_class = (enum command_class) cmd_class;
p_smob->type = (enum var_types) param_type;
p_smob->doc = doc;
p_smob->set_doc = set_doc;
p_smob->show_doc = show_doc;
p_smob->enumeration = enum_list;
p_smob->set_func = set_func;
p_smob->show_func = show_func;
if (initial_value_arg_pos > 0)
{
if (gdbscm_is_procedure (initial_value_scm))
{
initial_value_scm = gdbscm_safe_call_1 (initial_value_scm,
p_smob->containing_scm, NULL);
if (gdbscm_is_exception (initial_value_scm))
gdbscm_throw (initial_value_scm);
}
pascm_set_param_value_x (p_smob->type, &p_smob->value, enum_list,
initial_value_scm,
initial_value_arg_pos, FUNC_NAME);
}
return p_scm;
}
static SCM
gdbscm_arch_disassemble (SCM self, SCM start_scm, SCM rest)
{
arch_smob *a_smob
= arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct gdbarch *gdbarch = arscm_get_gdbarch (a_smob);
const SCM keywords[] = {
port_keyword, offset_keyword, size_keyword, count_keyword, SCM_BOOL_F
};
int port_arg_pos = -1, offset_arg_pos = -1;
int size_arg_pos = -1, count_arg_pos = -1;
SCM port = SCM_BOOL_F;
ULONGEST offset = 0;
unsigned int count = 1;
unsigned int size;
ULONGEST start_arg;
CORE_ADDR start, end;
CORE_ADDR pc;
unsigned int i;
int using_port;
SCM result;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "U#OUuu",
start_scm, &start_arg, rest,
&port_arg_pos, &port,
&offset_arg_pos, &offset,
&size_arg_pos, &size,
&count_arg_pos, &count);
/* START is first stored in a ULONGEST because we don't have a format char
for CORE_ADDR, and it's not really worth it to have one yet. */
start = start_arg;
if (port_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_false (port)
|| gdbscm_is_true (scm_input_port_p (port)),
port, port_arg_pos, FUNC_NAME, _("input port"));
}
using_port = gdbscm_is_true (port);
if (offset_arg_pos > 0
&& (port_arg_pos < 0
|| gdbscm_is_false (port)))
{
gdbscm_out_of_range_error (FUNC_NAME, offset_arg_pos,
gdbscm_scm_from_ulongest (offset),
_("offset provided but port is missing"));
}
if (size_arg_pos > 0)
{
if (size == 0)
return SCM_EOL;
/* For now be strict about start+size overflowing. If it becomes
a nuisance we can relax things later. */
if (start + size < start)
{
gdbscm_out_of_range_error (FUNC_NAME, 0,
scm_list_2 (gdbscm_scm_from_ulongest (start),
gdbscm_scm_from_ulongest (size)),
_("start+size overflows"));
}
end = start + size - 1;
}
else
end = ~(CORE_ADDR) 0;
if (count == 0)
return SCM_EOL;
result = SCM_EOL;
for (pc = start, i = 0; pc <= end && i < count; )
{
int insn_len = 0;
struct ui_file *memfile = mem_fileopen ();
struct cleanup *cleanups = make_cleanup_ui_file_delete (memfile);
TRY
{
if (using_port)
{
insn_len = gdbscm_print_insn_from_port (gdbarch, port, offset,
pc, memfile, NULL);
}
else
insn_len = gdb_print_insn (gdbarch, pc, memfile, NULL);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
}
END_CATCH
std::string as = ui_file_as_string (memfile);
result = scm_cons (dascm_make_insn (pc, as.c_str (), insn_len),
result);
pc += insn_len;
i++;
do_cleanups (cleanups);
}
