+2018-07-18 Pedro Alves <palves@redhat.com>
+
+ * guile/guile-internal.h: Add comment about mixing GDB and Scheme
+ exceptions.
+ (GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS): Delete.
+ (gdbscm_wrap): New.
+ * guile/scm-frame.c (gdbscm_frame_read_register): Use xfree
+ directly instead of a cleanup.
+ * guile/scm-math.c (vlscm_unop_gdbthrow): New, factored out from ...
+ (vlscm_unop): ... this. Reimplement using gdbscm_wrap.
+ (vlscm_binop_gdbthrow): New, factored out from ...
+ (vlscm_binop): ... this. Reimplement using gdbscm_wrap.
+ (vlscm_rich_compare): Use gdbscm_wrap.
+ * guile/scm-symbol.c (gdbscm_lookup_symbol): Use xfree directly
+ instead of a cleanup.
+ (gdbscm_lookup_global_symbol): Use xfree directly instead of a
+ cleanup.
+ * guile/scm-type.c (gdbscm_type_field, gdbscm_type_has_field_p):
+ Use xfree directly instead of a cleanup.
+ * guile/scm-value.c (gdbscm_make_value, gdbscm_make_lazy_value):
+ Adjust to use gdbscm_wrap and scoped_value_mark.
+ (gdbscm_value_optimized_out_p): Adjust to use gdbscm_wrap.
+ (gdbscm_value_address, gdbscm_value_dereference)
+ (gdbscm_value_referenced_value): Adjust to use gdbscm_wrap and
+ scoped_value_mark.
+ (gdbscm_value_dynamic_type): Use scoped_value_mark.
+ (vlscm_do_cast, gdbscm_value_field): Adjust to use gdbscm_wrap and
+ scoped_value_mark.
+ (gdbscm_value_subscript, gdbscm_value_call): Adjust to use
+ gdbscm_wrap and scoped_value_mark.
+ (gdbscm_value_to_string): Use xfree directly instead of a
+ cleanup. Move 'buffer' unique_ptr to TRY scope.
+ (gdbscm_value_to_lazy_string): Use xfree directly instead of a
+ cleanup. Move 'buffer' unique_ptr to TRY scope. Use
+ scoped_value_mark.
+ (gdbscm_value_fetch_lazy_x): Use gdbscm_wrap.
+ (gdbscm_parse_and_eval): Adjust to use gdbscm_wrap and
+ scoped_value_mark.
+ (gdbscm_history_ref, gdbscm_history_append_x): Adjust to use
+ gdbscm_wrap.
+
2018-07-18 Tom de Vries <tdevries@suse.de>
* findvar.c (default_read_var_value): Also resolve dynamic type for
extern void gdbscm_initialize_types (void);
extern void gdbscm_initialize_values (void);
\f
-/* Use these after a TRY_CATCH to throw the appropriate Scheme exception
- if a GDB error occurred. */
+
+/* A complication with the Guile code is that we have two types of
+ exceptions to consider. GDB/C++ exceptions, and Guile/SJLJ
+ exceptions. Code that is facing the Guile interpreter must not
+ throw GDB exceptions, instead Scheme exceptions must be thrown.
+ Also, because Guile exceptions are SJLJ based, Guile-facing code
+ must not use local objects with dtors, unless wrapped in a scope
+ with a TRY/CATCH, because the dtors won't otherwise be run when a
+ Guile exceptions is thrown. */
+
+/* Use this after a TRY/CATCH to throw the appropriate Scheme
+ exception if a GDB error occurred. */
#define GDBSCM_HANDLE_GDB_EXCEPTION(exception) \
do { \
} \
} while (0)
-/* If cleanups are establish outside the TRY_CATCH block, use this version. */
-
-#define GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS(exception, cleanups) \
- do { \
- if (exception.reason < 0) \
- { \
- do_cleanups (cleanups); \
- gdbscm_throw_gdb_exception (exception); \
- /*NOTREACHED */ \
- } \
- } while (0)
+/* Use this to wrap a callable to throw the appropriate Scheme
+ exception if the callable throws a GDB error. ARGS are forwarded
+ to FUNC. Returns the result of FUNC, unless FUNC returns a Scheme
+ exception, in which case that exception is thrown. Note that while
+ the callable is free to use objects of types with destructors,
+ because GDB errors are C++ exceptions, the caller of gdbscm_wrap
+ must not use such objects, because their destructors would not be
+ called when a Scheme exception is thrown. */
+
+template<typename Function, typename... Args>
+SCM
+gdbscm_wrap (Function &&func, Args... args)
+{
+ SCM result = SCM_BOOL_F;
+
+ TRY
+ {
+ result = func (std::forward<Args> (args)...);
+ }
+ CATCH (except, RETURN_MASK_ALL)
+ {
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ }
+ END_CATCH
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
#endif /* GDB_GUILE_INTERNAL_H */
char *register_str;
struct value *value = NULL;
struct frame_info *frame = NULL;
- struct cleanup *cleanup;
frame_smob *f_smob;
f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "s",
register_scm, ®ister_str);
- cleanup = make_cleanup (xfree, register_str);
+
+ struct gdb_exception except = exception_none;
TRY
{
value = value_of_register (regnum, frame);
}
}
- CATCH (except, RETURN_MASK_ALL)
+ CATCH (ex, RETURN_MASK_ALL)
{
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ except = ex;
}
END_CATCH
- do_cleanups (cleanup);
+ xfree (register_str);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (frame == NULL)
{
#define STRIP_REFERENCE(TYPE) \
((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE))
-/* Returns a value object which is the result of applying the operation
- specified by OPCODE to the given argument.
- If there's an error a Scheme exception is thrown. */
+/* Helper for vlscm_unop. Contains all the code that may throw a GDB
+ exception. */
static SCM
-vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
+vlscm_unop_gdbthrow (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 ());
+ scoped_value_mark free_values;
- arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
- &except_scm, gdbarch, language);
+ SCM except_scm;
+ value *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);
- }
+ return 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)
+ struct value *res_val = NULL;
+
+ switch (opcode)
{
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ 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");
}
- END_CATCH
gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
+ return vlscm_scm_from_value (res_val);
+}
- return result;
+static SCM
+vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
+{
+ return gdbscm_wrap (vlscm_unop_gdbthrow, opcode, x, func_name);
}
-/* Returns a value object which is the result of applying the operation
- specified by OPCODE to the given arguments.
- If there's an error a Scheme exception is thrown. */
+/* Helper for vlscm_binop. Contains all the code that may throw a GDB
+ exception. */
static SCM
-vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
- const char *func_name)
+vlscm_binop_gdbthrow (enum valscm_binary_opcode opcode, SCM x, SCM y,
+ const char *func_name)
{
struct gdbarch *gdbarch = get_current_arch ();
const struct language_defn *language = current_language;
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 ());
+ scoped_value_mark free_values;
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);
- }
+ return except_scm;
+
arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
&except_scm, gdbarch, language);
if (arg2 == NULL)
- {
- do_cleanups (cleanups);
- gdbscm_throw (except_scm);
- }
+ return except_scm;
- TRY
+ switch (opcode)
{
- switch (opcode)
- {
- case VALSCM_ADD:
- {
- struct type *ltype = value_type (arg1);
- struct type *rtype = value_type (arg2);
-
- ltype = check_typedef (ltype);
- ltype = STRIP_REFERENCE (ltype);
- rtype = check_typedef (rtype);
- rtype = STRIP_REFERENCE (rtype);
-
- if (TYPE_CODE (ltype) == TYPE_CODE_PTR
- && is_integral_type (rtype))
- res_val = value_ptradd (arg1, value_as_long (arg2));
- else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
- && is_integral_type (ltype))
- res_val = value_ptradd (arg2, value_as_long (arg1));
- else
- res_val = value_binop (arg1, arg2, BINOP_ADD);
- }
- break;
- case VALSCM_SUB:
+ case VALSCM_ADD:
+ {
+ struct type *ltype = value_type (arg1);
+ struct type *rtype = value_type (arg2);
+
+ ltype = check_typedef (ltype);
+ ltype = STRIP_REFERENCE (ltype);
+ rtype = check_typedef (rtype);
+ rtype = STRIP_REFERENCE (rtype);
+
+ if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && is_integral_type (rtype))
+ res_val = value_ptradd (arg1, value_as_long (arg2));
+ else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
+ && is_integral_type (ltype))
+ res_val = value_ptradd (arg2, value_as_long (arg1));
+ else
+ res_val = value_binop (arg1, arg2, BINOP_ADD);
+ }
+ break;
+ case VALSCM_SUB:
+ {
+ struct type *ltype = value_type (arg1);
+ struct type *rtype = value_type (arg2);
+
+ ltype = check_typedef (ltype);
+ ltype = STRIP_REFERENCE (ltype);
+ rtype = check_typedef (rtype);
+ rtype = STRIP_REFERENCE (rtype);
+
+ if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && TYPE_CODE (rtype) == TYPE_CODE_PTR)
{
- struct type *ltype = value_type (arg1);
- struct type *rtype = value_type (arg2);
-
- ltype = check_typedef (ltype);
- ltype = STRIP_REFERENCE (ltype);
- rtype = check_typedef (rtype);
- rtype = STRIP_REFERENCE (rtype);
-
- if (TYPE_CODE (ltype) == TYPE_CODE_PTR
- && TYPE_CODE (rtype) == TYPE_CODE_PTR)
- {
- /* A ptrdiff_t for the target would be preferable here. */
- res_val
- = value_from_longest (builtin_type (gdbarch)->builtin_long,
- value_ptrdiff (arg1, arg2));
- }
- else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
- && is_integral_type (rtype))
- res_val = value_ptradd (arg1, - value_as_long (arg2));
- else
- res_val = value_binop (arg1, arg2, BINOP_SUB);
+ /* A ptrdiff_t for the target would be preferable here. */
+ res_val
+ = value_from_longest (builtin_type (gdbarch)->builtin_long,
+ value_ptrdiff (arg1, arg2));
}
- break;
- case VALSCM_MUL:
- res_val = value_binop (arg1, arg2, BINOP_MUL);
- break;
- case VALSCM_DIV:
- res_val = value_binop (arg1, arg2, BINOP_DIV);
- break;
- case VALSCM_REM:
- res_val = value_binop (arg1, arg2, BINOP_REM);
- break;
- case VALSCM_MOD:
- res_val = value_binop (arg1, arg2, BINOP_MOD);
- break;
- case VALSCM_POW:
- res_val = value_binop (arg1, arg2, BINOP_EXP);
- break;
- case VALSCM_LSH:
- res_val = value_binop (arg1, arg2, BINOP_LSH);
- break;
- case VALSCM_RSH:
- res_val = value_binop (arg1, arg2, BINOP_RSH);
- break;
- case VALSCM_MIN:
- res_val = value_binop (arg1, arg2, BINOP_MIN);
- break;
- case VALSCM_MAX:
- res_val = value_binop (arg1, arg2, BINOP_MAX);
- break;
- case VALSCM_BITAND:
- res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
- break;
- case VALSCM_BITOR:
- res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
- break;
- case VALSCM_BITXOR:
- res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
- break;
- default:
- gdb_assert_not_reached ("unsupported operation");
- }
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && is_integral_type (rtype))
+ res_val = value_ptradd (arg1, - value_as_long (arg2));
+ else
+ res_val = value_binop (arg1, arg2, BINOP_SUB);
+ }
+ break;
+ case VALSCM_MUL:
+ res_val = value_binop (arg1, arg2, BINOP_MUL);
+ break;
+ case VALSCM_DIV:
+ res_val = value_binop (arg1, arg2, BINOP_DIV);
+ break;
+ case VALSCM_REM:
+ res_val = value_binop (arg1, arg2, BINOP_REM);
+ break;
+ case VALSCM_MOD:
+ res_val = value_binop (arg1, arg2, BINOP_MOD);
+ break;
+ case VALSCM_POW:
+ res_val = value_binop (arg1, arg2, BINOP_EXP);
+ break;
+ case VALSCM_LSH:
+ res_val = value_binop (arg1, arg2, BINOP_LSH);
+ break;
+ case VALSCM_RSH:
+ res_val = value_binop (arg1, arg2, BINOP_RSH);
+ break;
+ case VALSCM_MIN:
+ res_val = value_binop (arg1, arg2, BINOP_MIN);
+ break;
+ case VALSCM_MAX:
+ res_val = value_binop (arg1, arg2, BINOP_MAX);
+ break;
+ case VALSCM_BITAND:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
+ break;
+ case VALSCM_BITOR:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
+ break;
+ case VALSCM_BITXOR:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
+ break;
+ default:
+ gdb_assert_not_reached ("unsupported operation");
}
- END_CATCH
gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
+ return vlscm_scm_from_value (res_val);
+}
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
+/* Returns a value object which is the result of applying the operation
+ specified by OPCODE to the given arguments.
+ If there's an error a Scheme exception is thrown. */
- return result;
+static SCM
+vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
+ const char *func_name)
+{
+ return gdbscm_wrap (vlscm_binop_gdbthrow, opcode, x, y, func_name);
}
/* (value-add x y) -> <gdb:value> */
static SCM
vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
{
- struct gdbarch *gdbarch = get_current_arch ();
- const struct language_defn *language = current_language;
- struct value *v1, *v2;
- int result = 0;
- SCM except_scm;
- struct cleanup *cleanups;
- struct gdb_exception except = exception_none;
+ return gdbscm_wrap ([=]
+ {
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ SCM except_scm;
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
+ scoped_value_mark free_values;
- v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
- &except_scm, gdbarch, language);
- if (v1 == NULL)
- {
- do_cleanups (cleanups);
- gdbscm_throw (except_scm);
- }
- v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
- &except_scm, gdbarch, language);
- if (v2 == NULL)
- {
- do_cleanups (cleanups);
- gdbscm_throw (except_scm);
- }
+ value *v1
+ = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
+ &except_scm, gdbarch, language);
+ if (v1 == NULL)
+ return except_scm;
- TRY
- {
+ value *v2
+ = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
+ &except_scm, gdbarch, language);
+ if (v2 == NULL)
+ return except_scm;
+
+ int result;
switch (op)
{
case BINOP_LESS:
break;
default:
gdb_assert_not_reached ("invalid <gdb:value> comparison");
- }
- }
- CATCH (ex, RETURN_MASK_ALL)
- {
- except = ex;
- }
- END_CATCH
-
- do_cleanups (cleanups);
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- return scm_from_bool (result);
+ }
+ return scm_from_bool (result);
+ });
}
/* (value=? x y) -> boolean
int block_arg_pos = -1, domain_arg_pos = -1;
struct field_of_this_result is_a_field_of_this;
struct symbol *symbol = NULL;
- struct cleanup *cleanups;
- struct gdb_exception except = exception_none;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#Oi",
name_scm, &name, rest,
&block_arg_pos, &block_scm,
&domain_arg_pos, &domain);
- cleanups = make_cleanup (xfree, name);
-
if (block_arg_pos >= 0)
{
SCM except_scm;
&except_scm);
if (block == NULL)
{
- do_cleanups (cleanups);
+ xfree (name);
gdbscm_throw (except_scm);
}
}
}
CATCH (except, RETURN_MASK_ALL)
{
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ xfree (name);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
}
+ struct gdb_exception except = exception_none;
TRY
{
symbol = lookup_symbol (name, block, (domain_enum) domain,
}
END_CATCH
- do_cleanups (cleanups);
+ xfree (name);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (symbol == NULL)
int domain_arg_pos = -1;
int domain = VAR_DOMAIN;
struct symbol *symbol = NULL;
- struct cleanup *cleanups;
struct gdb_exception except = exception_none;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#i",
name_scm, &name, rest,
&domain_arg_pos, &domain);
- cleanups = make_cleanup (xfree, name);
-
TRY
{
symbol = lookup_global_symbol (name, NULL, (domain_enum) domain).symbol;
}
END_CATCH
- do_cleanups (cleanups);
+ xfree (name);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (symbol == NULL)
struct type *type = t_smob->type;
char *field;
int i;
- struct cleanup *cleanups;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
_(not_composite_error));
field = gdbscm_scm_to_c_string (field_scm);
- cleanups = make_cleanup (xfree, field);
for (i = 0; i < TYPE_NFIELDS (type); i++)
{
if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
{
- do_cleanups (cleanups);
- return tyscm_make_field_smob (self, i);
+ xfree (field);
+ return tyscm_make_field_smob (self, i);
}
}
- do_cleanups (cleanups);
+ xfree (field);
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, field_scm,
_("Unknown field"));
struct type *type = t_smob->type;
char *field;
int i;
- struct cleanup *cleanups;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
_(not_composite_error));
field = gdbscm_scm_to_c_string (field_scm);
- cleanups = make_cleanup (xfree, field);
for (i = 0; i < TYPE_NFIELDS (type); i++)
{
if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
{
- do_cleanups (cleanups);
- return SCM_BOOL_T;
+ xfree (field);
+ return SCM_BOOL_T;
}
}
- do_cleanups (cleanups);
+ xfree (field);
return SCM_BOOL_F;
}
static SCM
gdbscm_make_value (SCM x, SCM rest)
{
- struct gdbarch *gdbarch = get_current_arch ();
- const struct language_defn *language = current_language;
const SCM keywords[] = { type_keyword, SCM_BOOL_F };
+
int type_arg_pos = -1;
SCM type_scm = SCM_UNDEFINED;
- SCM except_scm, result;
- type_smob *t_smob;
- struct type *type = NULL;
- struct value *value;
- struct cleanup *cleanups;
-
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
&type_arg_pos, &type_scm);
+ struct type *type = NULL;
if (type_arg_pos > 0)
{
- t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
- FUNC_NAME);
+ type_smob *t_smob = tyscm_get_type_smob_arg_unsafe (type_scm,
+ type_arg_pos,
+ FUNC_NAME);
type = tyscm_type_smob_type (t_smob);
}
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
+ return gdbscm_wrap ([=]
+ {
+ scoped_value_mark free_values;
- value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
+ SCM except_scm;
+ struct value *value
+ = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
type_arg_pos, type_scm, type,
&except_scm,
- gdbarch, language);
- if (value == NULL)
- {
- do_cleanups (cleanups);
- gdbscm_throw (except_scm);
- }
+ get_current_arch (),
+ current_language);
+ if (value == NULL)
+ return except_scm;
- result = vlscm_scm_from_value (value);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
- return result;
+ return vlscm_scm_from_value (value);
+ });
}
/* (make-lazy-value <gdb:type> address) -> <gdb:value> */
static SCM
gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
{
- type_smob *t_smob;
- struct type *type;
- ULONGEST address;
- struct value *value = NULL;
- SCM result;
- struct cleanup *cleanups;
-
- t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
- type = tyscm_type_smob_type (t_smob);
+ type_smob *t_smob = tyscm_get_type_smob_arg_unsafe (type_scm,
+ SCM_ARG1, FUNC_NAME);
+ struct type *type = tyscm_type_smob_type (t_smob);
+ ULONGEST address;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
address_scm, &address);
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
-
- /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
- and future-proofing we do. */
- TRY
- {
- value = value_from_contents_and_address (type, NULL, address);
- }
- CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
-
- result = vlscm_scm_from_value (value);
+ scoped_value_mark free_values;
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
- return result;
+ struct value *value = value_from_contents_and_address (type, NULL,
+ address);
+ return vlscm_scm_from_value (value);
+ });
}
/* (value-optimized-out? <gdb:value>) -> boolean */
{
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct value *value = v_smob->value;
- int opt = 0;
- TRY
- {
- opt = value_optimized_out (value);
- }
- CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
- }
- END_CATCH
-
- return scm_from_bool (opt);
+ return scm_from_bool (value_optimized_out (v_smob->value));
+ });
}
/* (value-address <gdb:value>) -> integer
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
- if (SCM_UNBNDP (v_smob->address))
+ return gdbscm_wrap ([=]
{
- struct cleanup *cleanup
- = make_cleanup_value_free_to_mark (value_mark ());
- SCM address = SCM_BOOL_F;
-
- TRY
+ if (SCM_UNBNDP (v_smob->address))
{
- address = vlscm_scm_from_value (value_addr (value));
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- }
- END_CATCH
+ scoped_value_mark free_values;
- do_cleanups (cleanup);
+ SCM address = SCM_BOOL_F;
- if (gdbscm_is_exception (address))
- gdbscm_throw (address);
+ TRY
+ {
+ address = vlscm_scm_from_value (value_addr (value));
+ }
+ CATCH (except, RETURN_MASK_ALL)
+ {
+ }
+ END_CATCH
- v_smob->address = address;
- }
+ if (gdbscm_is_exception (address))
+ return address;
+
+ v_smob->address = address;
+ }
- return v_smob->address;
+ return v_smob->address;
+ });
}
/* (value-dereference <gdb:value>) -> <gdb:value>
{
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct value *value = v_smob->value;
- SCM result;
- struct value *res_val = NULL;
- struct cleanup *cleanups;
-
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
- TRY
+ return gdbscm_wrap ([=]
{
- res_val = value_ind (value);
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
+ scoped_value_mark free_values;
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ struct value *res_val = value_ind (v_smob->value);
+ return vlscm_scm_from_value (res_val);
+ });
}
/* (value-referenced-value <gdb:value>) -> <gdb:value>
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
- SCM result;
- struct value *res_val = NULL;
- struct cleanup *cleanups;
-
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
- TRY
+ return gdbscm_wrap ([=]
{
+ scoped_value_mark free_values;
+
+ struct value *res_val;
+
switch (TYPE_CODE (check_typedef (value_type (value))))
{
case TYPE_CODE_PTR:
error (_("Trying to get the referenced value from a value which is"
" neither a pointer nor a reference"));
}
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
-
- result = vlscm_scm_from_value (res_val);
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ return vlscm_scm_from_value (res_val);
+ });
}
/* (value-type <gdb:value>) -> <gdb:type> */
TRY
{
- struct cleanup *cleanup
- = make_cleanup_value_free_to_mark (value_mark ());
+ scoped_value_mark free_values;
type = value_type (value);
type = check_typedef (type);
/* Re-use object's static type. */
type = NULL;
}
-
- do_cleanups (cleanup);
}
CATCH (except, RETURN_MASK_ALL)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
struct type *type = tyscm_type_smob_type (t_smob);
- SCM result;
- struct value *res_val = NULL;
- struct cleanup *cleanups;
-
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
- TRY
+ return gdbscm_wrap ([=]
{
+ scoped_value_mark free_values;
+
+ struct value *res_val;
if (op == UNOP_DYNAMIC_CAST)
res_val = value_dynamic_cast (type, value);
else if (op == UNOP_REINTERPRET_CAST)
gdb_assert (op == UNOP_CAST);
res_val = value_cast (type, value);
}
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
-
- gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ return vlscm_scm_from_value (res_val);
+ });
}
/* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
{
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct value *value = v_smob->value;
- char *field = NULL;
- struct value *res_val = NULL;
- SCM result;
- struct cleanup *cleanups;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
+ return gdbscm_wrap ([=]
+ {
+ scoped_value_mark free_values;
- field = gdbscm_scm_to_c_string (field_scm);
- make_cleanup (xfree, field);
+ char *field = gdbscm_scm_to_c_string (field_scm);
- TRY
- {
- struct value *tmp = value;
+ struct cleanup *cleanups = make_cleanup (xfree, field);
- res_val = value_struct_elt (&tmp, NULL, field, NULL,
- "struct/class/union");
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
+ struct value *tmp = v_smob->value;
- gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
+ struct value *res_val = value_struct_elt (&tmp, NULL, field, NULL,
+ "struct/class/union");
- do_cleanups (cleanups);
+ SCM result = vlscm_scm_from_value (res_val);
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
+ do_cleanups (cleanups);
- return result;
+ return result;
+ });
}
/* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
- struct value *index = NULL;
- struct value *res_val = NULL;
struct type *type = value_type (value);
- struct gdbarch *gdbarch;
- SCM result, except_scm;
- struct cleanup *cleanups;
-
- /* The sequencing here, as everywhere else, is important.
- We can't have existing cleanups when a Scheme exception is thrown. */
SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
- gdbarch = get_type_arch (type);
-
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
- index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
- &except_scm,
- gdbarch, current_language);
- if (index == NULL)
+ return gdbscm_wrap ([=]
{
- do_cleanups (cleanups);
- gdbscm_throw (except_scm);
- }
+ scoped_value_mark free_values;
- TRY
- {
- struct value *tmp = value;
+ SCM except_scm;
+ struct value *index
+ = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
+ &except_scm,
+ get_type_arch (type),
+ current_language);
+ if (index == NULL)
+ return except_scm;
/* Assume we are attempting an array access, and let the value code
throw an exception if the index has an invalid type.
Check the value's type is something that can be accessed via
a subscript. */
- tmp = coerce_ref (tmp);
- type = check_typedef (value_type (tmp));
- if (TYPE_CODE (type) != TYPE_CODE_ARRAY
- && TYPE_CODE (type) != TYPE_CODE_PTR)
+ struct value *tmp = coerce_ref (value);
+ struct type *tmp_type = check_typedef (value_type (tmp));
+ if (TYPE_CODE (tmp_type) != TYPE_CODE_ARRAY
+ && TYPE_CODE (tmp_type) != TYPE_CODE_PTR)
error (_("Cannot subscript requested type"));
- res_val = value_subscript (tmp, value_as_long (index));
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
-
- gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ struct value *res_val = value_subscript (tmp, value_as_long (index));
+ return vlscm_scm_from_value (res_val);
+ });
}
/* (value-call <gdb:value> arg-list) -> <gdb:value>
gdb_assert (gdbscm_is_true (scm_null_p (args)));
}
- TRY
+ return gdbscm_wrap ([=]
{
- struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
- struct value *return_value;
+ scoped_value_mark free_values;
- return_value = call_function_by_hand (function, NULL, args_count, vargs);
- result = vlscm_scm_from_value (return_value);
- do_cleanups (cleanup);
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
- }
- END_CATCH
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ value *return_value = call_function_by_hand (function, NULL,
+ args_count, vargs);
+ return vlscm_scm_from_value (return_value);
+ });
}
/* (value->bytevector <gdb:value>) -> bytevector */
int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
char *encoding = NULL;
SCM errors = SCM_BOOL_F;
+ gdb_byte *buffer_contents;
int length = -1;
- gdb::unique_xmalloc_ptr<gdb_byte> buffer;
const char *la_encoding = NULL;
struct type *char_type = NULL;
SCM result;
- struct cleanup *cleanups;
/* The sequencing here, as everywhere else, is important.
We can't have existing cleanups when a Scheme exception is thrown. */
&errors_arg_pos, &errors,
&length_arg_pos, &length);
- cleanups = make_cleanup (xfree, encoding);
-
if (errors_arg_pos > 0
&& errors != SCM_BOOL_F
&& !scm_is_eq (errors, error_symbol)
= gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
_("invalid error kind"));
- do_cleanups (cleanups);
+ xfree (encoding);
gdbscm_throw (excp);
}
if (errors == SCM_BOOL_F)
TRY
{
+ gdb::unique_xmalloc_ptr<gdb_byte> buffer;
LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
+ buffer_contents = buffer.release ();
}
CATCH (except, RETURN_MASK_ALL)
{
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ xfree (encoding);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
- /* If errors is "error" scm_from_stringn may throw a Scheme exception.
+ /* If errors is "error", scm_from_stringn may throw a Scheme exception.
Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
- discard_cleanups (cleanups);
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
gdbscm_dynwind_xfree (encoding);
- gdb_byte *buffer_contents = buffer.release ();
gdbscm_dynwind_xfree (buffer_contents);
result = scm_from_stringn ((const char *) buffer_contents,
char *encoding = NULL;
int length = -1;
SCM result = SCM_BOOL_F; /* -Wall */
- struct cleanup *cleanups;
struct gdb_exception except = exception_none;
/* The sequencing here, as everywhere else, is important.
_("invalid length"));
}
- cleanups = make_cleanup (xfree, encoding);
-
TRY
{
- struct cleanup *inner_cleanup
- = make_cleanup_value_free_to_mark (value_mark ());
+ scoped_value_mark free_values;
+
struct type *type, *realtype;
CORE_ADDR addr;
}
result = lsscm_make_lazy_string (addr, length, encoding, type);
-
- do_cleanups (inner_cleanup);
}
CATCH (ex, RETURN_MASK_ALL)
{
}
END_CATCH
- do_cleanups (cleanups);
+ xfree (encoding);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (gdbscm_is_exception (result))
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
- TRY
+ return gdbscm_wrap ([=]
{
if (value_lazy (value))
value_fetch_lazy (value);
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
- }
- END_CATCH
-
- return SCM_UNSPECIFIED;
+ return SCM_UNSPECIFIED;
+ });
}
/* (value-print <gdb:value>) -> string */
gdbscm_parse_and_eval (SCM expr_scm)
{
char *expr_str;
- struct value *res_val = NULL;
- SCM result;
- struct cleanup *cleanups;
-
- /* The sequencing here, as everywhere else, is important.
- We can't have existing cleanups when a Scheme exception is thrown. */
-
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
expr_scm, &expr_str);
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
- make_cleanup (xfree, expr_str);
-
- TRY
- {
- res_val = parse_and_eval (expr_str);
- }
- CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
- }
- END_CATCH
-
- gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ scoped_value_mark free_values;
+ return vlscm_scm_from_value (parse_and_eval (expr_str));
+ });
}
/* (history-ref integer) -> <gdb:value>
gdbscm_history_ref (SCM index)
{
int i;
- struct value *res_val = NULL; /* Initialize to appease gcc warning. */
-
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
- TRY
+ return gdbscm_wrap ([=]
{
- res_val = access_value_history (i);
- }
- CATCH (except, RETURN_MASK_ALL)
- {
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
- }
- END_CATCH
-
- return vlscm_scm_from_value (res_val);
+ return vlscm_scm_from_value (access_value_history (i));
+ });
}
/* (history-append! <gdb:value>) -> index
static SCM
gdbscm_history_append_x (SCM value)
{
- int res_index = -1;
- struct value *v;
- value_smob *v_smob;
-
- v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
- v = v_smob->value;
-
- TRY
- {
- res_index = record_latest_value (v);
- }
- CATCH (except, RETURN_MASK_ALL)
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
+ return gdbscm_wrap ([=]
{
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
- }
- END_CATCH
-
- return scm_from_int (res_index);
+ return scm_from_int (record_latest_value (v_smob->value));
+ });
}
\f
/* Initialize the Scheme value code. */
projects / binutils-gdb.git / commitdiff