static SCM
ioscm_with_output_to_port_worker (SCM port, SCM thunk, enum oport oport,
const char *func_name)
{
struct ui_file *port_file;
struct cleanup *cleanups;
SCM result;
SCM_ASSERT_TYPE (gdbscm_is_true (scm_output_port_p (port)), port,
SCM_ARG1, func_name, _("output port"));
SCM_ASSERT_TYPE (gdbscm_is_true (scm_thunk_p (thunk)), thunk,
SCM_ARG2, func_name, _("thunk"));
cleanups = set_batch_flag_and_make_cleanup_restore_page_info ();
make_cleanup_restore_integer (¤t_ui->async);
current_ui->async = 0;
port_file = ioscm_file_port_new (port);
make_cleanup_ui_file_delete (port_file);
scoped_restore save_file = make_scoped_restore (oport == GDB_STDERR
? &gdb_stderr : &gdb_stdout);
if (oport == GDB_STDERR)
gdb_stderr = port_file;
else
{
if (ui_out_redirect (current_uiout, port_file) < 0)
warning (_("Current output protocol does not support redirection"));
else
make_cleanup_ui_out_redirect_pop (current_uiout);
gdb_stdout = port_file;
}
result = gdbscm_safe_call_0 (thunk, NULL);
do_cleanups (cleanups);
if (gdbscm_is_exception (result))
gdbscm_throw (result);
return result;
}
static enum display_hint
ppscm_get_display_hint_enum (SCM printer)
{
SCM hint = ppscm_get_display_hint_scm (printer);
if (gdbscm_is_false (hint))
return HINT_NONE;
if (scm_is_string (hint))
{
if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
return HINT_STRING;
if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
return HINT_STRING;
if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
return HINT_STRING;
return HINT_ERROR;
}
return HINT_ERROR;
}
static SCM
gdbscm_set_pretty_printers_x (SCM printers)
{
SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
SCM_ARG1, FUNC_NAME, _("list"));
pretty_printer_list = printers;
return SCM_UNSPECIFIED;
}
static SCM
gdbscm_set_pretty_printer_enabled_x (SCM self, SCM enabled)
{
pretty_printer_smob *pp_smob
= ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
pp_smob->enabled = scm_from_bool (gdbscm_is_true (enabled));
return SCM_UNSPECIFIED;
}
static SCM
scscm_recording_unwind_handler (void *datap, SCM key, SCM args)
{
struct with_catch_data *data = datap;
/* We need to record the stack in the exception since we're about to
throw and lose the location that got the exception. We do this by
wrapping the exception + stack in a new exception. */
if (gdbscm_is_true (data->stack))
return gdbscm_make_exception_with_stack (key, args, data->stack);
return gdbscm_make_exception (key, args);
}
static SCM
ppscm_find_pretty_printer (SCM value)
{
SCM pp;
/* Look at the pretty-printer list for each objfile
in the current program-space. */
pp = ppscm_find_pretty_printer_from_objfiles (value);
/* Note: This will return if function is a <gdb:exception> object,
which is what we want. */
if (gdbscm_is_true (pp))
return pp;
/* Look at the pretty-printer list for the current program-space. */
pp = ppscm_find_pretty_printer_from_progspace (value);
/* Note: This will return if function is a <gdb:exception> object,
which is what we want. */
if (gdbscm_is_true (pp))
return pp;
/* Look at the pretty-printer list in the gdb module. */
pp = ppscm_find_pretty_printer_from_gdb (value);
return pp;
}
static int
ppscm_print_pretty_printer_smob (SCM self, SCM port, scm_print_state *pstate)
{
pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", pretty_printer_smob_name);
scm_write (pp_smob->name, port);
scm_puts (gdbscm_is_true (pp_smob->enabled) ? " enabled" : " disabled",
port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static SCM
ppscm_find_pretty_printer_from_objfiles (SCM value)
{
struct objfile *objfile;
ALL_OBJFILES (objfile)
{
objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
SCM pp = ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob),
value);
/* Note: This will return if pp is a <gdb:exception> object,
which is what we want. */
if (gdbscm_is_true (pp))
return pp;
}
return SCM_BOOL_F;
}
static SCM
extract_arg (char format_char, SCM arg, void *argp,
const char *func_name, int position)
{
switch (format_char)
{
case 's':
{
char **arg_ptr = (char **) argp;
CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position,
func_name, _("string"));
*arg_ptr = gdbscm_scm_to_c_string (arg);
break;
}
case 't':
{
int *arg_ptr = (int *) argp;
/* While in Scheme, anything non-#f is "true", we're strict. */
CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
_("boolean"));
*arg_ptr = gdbscm_is_true (arg);
break;
}
case 'i':
{
int *arg_ptr = (int *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX),
arg, position, func_name, _("int"));
*arg_ptr = scm_to_int (arg);
break;
}
case 'u':
{
int *arg_ptr = (int *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX),
arg, position, func_name, _("unsigned int"));
*arg_ptr = scm_to_uint (arg);
break;
}
case 'l':
{
long *arg_ptr = (long *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX),
arg, position, func_name, _("long"));
*arg_ptr = scm_to_long (arg);
break;
}
case 'n':
{
unsigned long *arg_ptr = (unsigned long *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX),
arg, position, func_name, _("unsigned long"));
*arg_ptr = scm_to_ulong (arg);
break;
}
case 'L':
{
LONGEST *arg_ptr = (LONGEST *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX),
arg, position, func_name, _("LONGEST"));
*arg_ptr = gdbscm_scm_to_longest (arg);
break;
}
case 'U':
{
ULONGEST *arg_ptr = (ULONGEST *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX),
arg, position, func_name, _("ULONGEST"));
*arg_ptr = gdbscm_scm_to_ulongest (arg);
break;
}
case 'O':
{
SCM *arg_ptr = (SCM *) argp;
*arg_ptr = arg;
break;
}
default:
gdb_assert_not_reached ("invalid argument format character");
}
return SCM_BOOL_F;
}
static void
pascm_set_param_value_x (enum var_types type, union pascm_variable *var,
const char * const *enumeration,
SCM value, int arg_pos, const char *func_name)
{
switch (type)
{
case var_string:
case var_string_noescape:
case var_optional_filename:
case var_filename:
SCM_ASSERT_TYPE (scm_is_string (value)
|| (type != var_filename
&& gdbscm_is_false (value)),
value, arg_pos, func_name,
_("string or #f for non-PARAM_FILENAME parameters"));
if (gdbscm_is_false (value))
{
xfree (var->stringval);
if (type == var_optional_filename)
var->stringval = xstrdup ("");
else
var->stringval = NULL;
}
else
{
char *string;
SCM exception;
string = gdbscm_scm_to_host_string (value, NULL, &exception);
if (string == NULL)
gdbscm_throw (exception);
xfree (var->stringval);
var->stringval = string;
}
break;
case var_enum:
{
int i;
char *str;
SCM exception;
SCM_ASSERT_TYPE (scm_is_string (value), value, arg_pos, func_name,
_("string"));
str = gdbscm_scm_to_host_string (value, NULL, &exception);
if (str == NULL)
gdbscm_throw (exception);
for (i = 0; enumeration[i]; ++i)
{
if (strcmp (enumeration[i], str) == 0)
break;
}
xfree (str);
if (enumeration[i] == NULL)
{
gdbscm_out_of_range_error (func_name, arg_pos, value,
_("not member of enumeration"));
}
var->cstringval = enumeration[i];
break;
}
case var_boolean:
SCM_ASSERT_TYPE (gdbscm_is_bool (value), value, arg_pos, func_name,
_("boolean"));
var->intval = gdbscm_is_true (value);
break;
case var_auto_boolean:
SCM_ASSERT_TYPE (gdbscm_is_bool (value)
|| scm_is_eq (value, auto_keyword),
value, arg_pos, func_name,
_("boolean or #:auto"));
if (scm_is_eq (value, auto_keyword))
var->autoboolval = AUTO_BOOLEAN_AUTO;
else if (gdbscm_is_true (value))
var->autoboolval = AUTO_BOOLEAN_TRUE;
else
var->autoboolval = AUTO_BOOLEAN_FALSE;
break;
case var_zinteger:
case var_uinteger:
case var_zuinteger:
case var_zuinteger_unlimited:
if (type == var_uinteger
|| type == var_zuinteger_unlimited)
{
SCM_ASSERT_TYPE (gdbscm_is_bool (value)
|| scm_is_eq (value, unlimited_keyword),
value, arg_pos, func_name,
_("integer or #:unlimited"));
if (scm_is_eq (value, unlimited_keyword))
{
if (type == var_uinteger)
var->intval = UINT_MAX;
else
var->intval = -1;
break;
}
}
else
{
SCM_ASSERT_TYPE (scm_is_integer (value), value, arg_pos, func_name,
_("integer"));
}
if (type == var_uinteger
|| type == var_zuinteger)
{
unsigned int u = scm_to_uint (value);
if (type == var_uinteger && u == 0)
u = UINT_MAX;
var->uintval = u;
}
else
{
int i = scm_to_int (value);
if (type == var_zuinteger_unlimited && i < -1)
{
gdbscm_out_of_range_error (func_name, arg_pos, value,
_("must be >= -1"));
}
var->intval = i;
}
break;
default:
gdb_assert_not_reached ("bad parameter type");
}
}
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);
}
