void
gdbscm_memory_error (const char *subr, const char *msg, SCM args)
{
SCM exception = gdbscm_make_memory_error (subr, msg, args);
gdbscm_throw (exception);
}
void
gdbscm_misc_error (const char *subr, int arg_pos, SCM bad_value,
const char *error)
{
SCM exception = gdbscm_make_misc_error (subr, arg_pos, bad_value, error);
gdbscm_throw (exception);
}
static SCM
vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
{
struct gdbarch *gdbarch = get_current_arch ();
const struct language_defn *language = current_language;
struct value *arg1;
SCM result = SCM_BOOL_F;
struct value *res_val = NULL;
SCM except_scm;
struct cleanup *cleanups;
cleanups = make_cleanup_value_free_to_mark (value_mark ());
arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
&except_scm, gdbarch, language);
if (arg1 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
TRY
{
switch (opcode)
{
case VALSCM_NOT:
/* Alas gdb and guile use the opposite meaning for "logical not". */
{
struct type *type = language_bool_type (language, gdbarch);
res_val
= value_from_longest (type, (LONGEST) value_logical_not (arg1));
}
break;
case VALSCM_NEG:
res_val = value_neg (arg1);
break;
case VALSCM_NOP:
/* Seemingly a no-op, but if X was a Scheme value it is now
a <gdb:value> object. */
res_val = arg1;
break;
case VALSCM_ABS:
if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
res_val = value_neg (arg1);
else
res_val = arg1;
break;
case VALSCM_LOGNOT:
res_val = value_complement (arg1);
break;
default:
gdb_assert_not_reached ("unsupported operation");
}
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
}
void
gdbscm_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
const char *object)
{
SCM exception
= gdbscm_make_invalid_object_error (subr, arg_pos, bad_value, object);
gdbscm_throw (exception);
}
static SCM
frscm_scm_from_frame_unsafe (struct frame_info *frame,
struct inferior *inferior)
{
SCM f_scm = frscm_scm_from_frame (frame, inferior);
if (gdbscm_is_exception (f_scm))
gdbscm_throw (f_scm);
return f_scm;
}
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 SCM
gdbscm_lazy_string_to_value (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
struct value *value = NULL;
volatile struct gdb_exception except;
if (ls_smob->address == 0)
{
gdbscm_throw (gdbscm_make_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_("cannot create a value from NULL")));
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
value = value_at_lazy (ls_smob->type, ls_smob->address);
}
void
gdbscm_throw_gdb_exception (struct gdb_exception exception)
{
gdbscm_throw (gdbscm_scm_from_gdb_exception (exception));
}
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 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");
}
}
CATCH (except, RETURN_MASK_ALL)
{
SCM excp = gdbscm_scm_from_gdb_exception (except);
gdbscm_throw (excp);
}
