/* Scheme interface to values.
- Copyright (C) 2008-2015 Free Software Foundation, Inc.
+ Copyright (C) 2008-2019 Free Software Foundation, Inc.
This file is part of GDB.
#include "arch-utils.h"
#include "charset.h"
#include "cp-abi.h"
+#include "target-float.h"
#include "infcall.h"
#include "symtab.h" /* Needed by language.h. */
#include "language.h"
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
vlscm_forget_value_smob (v_smob);
- value_free (v_smob->value);
+ value_decref (v_smob->value);
return 0;
}
vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
{
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
- char *s = NULL;
struct value_print_options opts;
- volatile struct gdb_exception except;
if (pstate->writingp)
gdbscm_printf (port, "#<%s ", value_smob_name);
instead of writingp. */
opts.raw = !!pstate->writingp;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- struct ui_file *stb = mem_fileopen ();
- struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
+ string_file stb;
- common_val_print (v_smob->value, stb, 0, &opts, current_language);
- s = ui_file_xstrdup (stb, NULL);
-
- do_cleanups (old_chain);
+ common_val_print (v_smob->value, &stb, 0, &opts, current_language);
+ scm_puts (stb.c_str (), port);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- if (s != NULL)
+ catch (const gdb_exception &except)
{
- scm_puts (s, port);
- xfree (s);
+ exc = unpack (except);
}
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
if (pstate->writingp)
scm_puts (">", port);
const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
int result = 0;
- volatile struct gdb_exception except;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
result = value_equal (v1_smob->value, v2_smob->value);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
return scm_from_bool (result);
}
SCM v_scm = vlscm_make_value_smob ();
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
- v_smob->value = value;
- release_value_or_incref (value);
+ v_smob->value = release_value (value).release ();
vlscm_remember_scheme_value (v_smob);
return v_scm;
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);
- }
-
- result = vlscm_scm_from_value (value);
+ get_current_arch (),
+ current_language);
+ if (value == NULL)
+ return except_scm;
- 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;
- volatile struct gdb_exception except;
-
- 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_CATCH (except, RETURN_MASK_ALL)
- {
- value = value_from_contents_and_address (type, NULL, address);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- result = vlscm_scm_from_value (value);
-
- do_cleanups (cleanups);
+ return gdbscm_wrap ([=]
+ {
+ scoped_value_mark free_values;
- 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;
- volatile struct gdb_exception except;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- opt = value_optimized_out (value);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- 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 value *res_val = NULL;
- struct cleanup *cleanup
- = make_cleanup_value_free_to_mark (value_mark ());
- SCM address;
- volatile struct gdb_exception except;
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ if (SCM_UNBNDP (v_smob->address))
{
- res_val = value_addr (value);
- }
- if (except.reason < 0)
- address = SCM_BOOL_F;
- else
- address = vlscm_scm_from_value (res_val);
+ scoped_value_mark free_values;
- do_cleanups (cleanup);
+ SCM address = SCM_BOOL_F;
+
+ try
+ {
+ address = vlscm_scm_from_value (value_addr (value));
+ }
+ catch (const gdb_exception &except)
+ {
+ }
- if (gdbscm_is_exception (address))
- gdbscm_throw (address);
+ if (gdbscm_is_exception (address))
+ return address;
- v_smob->address = 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;
- volatile struct gdb_exception except;
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- res_val = value_ind (value);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- result = vlscm_scm_from_value (res_val);
-
- do_cleanups (cleanups);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
+ scoped_value_mark free_values;
- 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;
- volatile struct gdb_exception except;
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ 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"));
}
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- 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> */
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
struct type *type = NULL;
- volatile struct gdb_exception except;
- if (! SCM_UNBNDP (v_smob->type))
+ if (! SCM_UNBNDP (v_smob->dynamic_type))
return v_smob->dynamic_type;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- struct cleanup *cleanup
- = make_cleanup_value_free_to_mark (value_mark ());
+ scoped_value_mark free_values;
type = value_type (value);
- CHECK_TYPEDEF (type);
+ type = check_typedef (type);
if (((TYPE_CODE (type) == TYPE_CODE_PTR)
|| (TYPE_CODE (type) == TYPE_CODE_REF))
if (was_pointer)
type = lookup_pointer_type (type);
else
- type = lookup_reference_type (type);
+ type = lookup_lvalue_reference_type (type);
}
}
else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
/* Re-use object's static type. */
type = NULL;
}
-
- do_cleanups (cleanup);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
if (type == NULL)
v_smob->dynamic_type = gdbscm_value_type (self);
else
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;
- volatile struct gdb_exception except;
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ 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);
}
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- 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;
- volatile struct gdb_exception except;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
- cleanups = make_cleanup_value_free_to_mark (value_mark ());
-
- field = gdbscm_scm_to_c_string (field_scm);
- make_cleanup (xfree, field);
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- struct value *tmp = value;
-
- res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ scoped_value_mark free_values;
- gdb_assert (res_val != NULL);
- result = vlscm_scm_from_value (res_val);
+ gdb::unique_xmalloc_ptr<char> field = gdbscm_scm_to_c_string (field_scm);
- do_cleanups (cleanups);
+ struct value *tmp = v_smob->value;
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
+ struct value *res_val = value_struct_elt (&tmp, NULL, field.get (), NULL,
+ "struct/class/union");
- return result;
+ return vlscm_scm_from_value (res_val);
+ });
}
/* (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;
- volatile struct gdb_exception except;
-
- /* 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_CATCH (except, RETURN_MASK_ALL)
- {
- 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));
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- 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>
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *function = v_smob->value;
- struct value *mark = value_mark ();
struct type *ftype = NULL;
long args_count;
struct value **vargs = NULL;
- SCM result = SCM_BOOL_F;
- volatile struct gdb_exception except;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
ftype = check_typedef (value_type (function));
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
SCM_ARG1, FUNC_NAME,
_("function (value of TYPE_CODE_FUNC)"));
SCM except_scm;
long i;
- vargs = alloca (sizeof (struct value *) * args_count);
+ vargs = XALLOCAVEC (struct value *, args_count);
for (i = 0; i < args_count; i++)
{
SCM arg = scm_car (args);
gdb_assert (gdbscm_is_true (scm_null_p (args)));
}
- TRY_CATCH (except, RETURN_MASK_ALL)
+ 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, args_count, vargs);
- result = vlscm_scm_from_value (return_value);
- do_cleanups (cleanup);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- if (gdbscm_is_exception (result))
- gdbscm_throw (result);
-
- return result;
+ auto av = gdb::make_array_view (vargs, args_count);
+ value *return_value = call_function_by_hand (function, NULL, av);
+ return vlscm_scm_from_value (return_value);
+ });
}
/* (value->bytevector <gdb:value>) -> bytevector */
size_t length = 0;
const gdb_byte *contents = NULL;
SCM bv;
- volatile struct gdb_exception except;
type = value_type (value);
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- CHECK_TYPEDEF (type);
+ type = check_typedef (type);
length = TYPE_LENGTH (type);
contents = value_contents (value);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
bv = scm_c_make_bytevector (length);
memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
struct value *value = v_smob->value;
struct type *type;
LONGEST l = 0;
- volatile struct gdb_exception except;
type = value_type (value);
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- CHECK_TYPEDEF (type);
+ type = check_typedef (type);
+ }
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
_("integer-like gdb value"));
- TRY_CATCH (except, RETURN_MASK_ALL)
+ try
{
if (TYPE_CODE (type) == TYPE_CODE_PTR)
l = value_as_address (value);
else
l = value_as_long (value);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
return scm_from_bool (l != 0);
}
struct value *value = v_smob->value;
struct type *type;
LONGEST l = 0;
- volatile struct gdb_exception except;
type = value_type (value);
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- CHECK_TYPEDEF (type);
+ type = check_typedef (type);
+ }
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
_("integer-like gdb value"));
- TRY_CATCH (except, RETURN_MASK_ALL)
+ try
{
if (TYPE_CODE (type) == TYPE_CODE_PTR)
l = value_as_address (value);
else
l = value_as_long (value);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
if (TYPE_UNSIGNED (type))
return gdbscm_scm_from_ulongest (l);
else
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
struct type *type;
- DOUBLEST d = 0;
- volatile struct gdb_exception except;
+ double d = 0;
+ struct value *check = nullptr;
type = value_type (value);
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- CHECK_TYPEDEF (type);
+ type = check_typedef (type);
+ }
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
self, SCM_ARG1, FUNC_NAME, _("number"));
- TRY_CATCH (except, RETURN_MASK_ALL)
+ try
+ {
+ if (is_floating_value (value))
+ {
+ d = target_float_to_host_double (value_contents (value), type);
+ check = value_from_host_double (type, d);
+ }
+ else if (TYPE_UNSIGNED (type))
+ {
+ d = (ULONGEST) value_as_long (value);
+ check = value_from_ulongest (type, (ULONGEST) d);
+ }
+ else
+ {
+ d = value_as_long (value);
+ check = value_from_longest (type, (LONGEST) d);
+ }
+ }
+ catch (const gdb_exception &except)
{
- d = value_as_double (value);
+ exc = unpack (except);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
/* TODO: Is there a better way to check if the value fits? */
- if (d != (double) d)
+ if (!value_equal (value, check))
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_("number can't be converted to a double"));
int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
char *encoding = NULL;
SCM errors = SCM_BOOL_F;
+ /* Avoid an uninitialized warning from gcc. */
+ gdb_byte *buffer_contents = nullptr;
int length = -1;
- gdb_byte *buffer = NULL;
const char *la_encoding = NULL;
struct type *char_type = NULL;
SCM result;
- struct cleanup *cleanups;
- volatile struct gdb_exception except;
/* 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)
/* We don't assume anything about the result of scm_port_conversion_strategy.
From this point on, if errors is not 'errors, use 'substitute. */
- TRY_CATCH (except, RETURN_MASK_ALL)
+ gdbscm_gdb_exception exc {};
+ try
{
- LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
+ gdb::unique_xmalloc_ptr<gdb_byte> buffer;
+ c_get_string (value, &buffer, &length, &char_type, &la_encoding);
+ buffer_contents = buffer.release ();
}
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ catch (const gdb_exception &except)
+ {
+ xfree (encoding);
+ exc = unpack (except);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
- /* 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 (0);
+ scm_dynwind_begin ((scm_t_dynwind_flags) 0);
gdbscm_dynwind_xfree (encoding);
- gdbscm_dynwind_xfree (buffer);
+ gdbscm_dynwind_xfree (buffer_contents);
- result = scm_from_stringn ((const char *) buffer,
+ result = scm_from_stringn ((const char *) buffer_contents,
length * TYPE_LENGTH (char_type),
(encoding != NULL && *encoding != '\0'
? encoding
Return a Scheme object representing a lazy_string_object type.
A lazy string is a pointer to a string with an optional encoding and length.
If ENCODING is not given, the target's charset is used.
- If LENGTH is provided then the length parameter is set to LENGTH, otherwise
- length will be set to -1 (first null of appropriate with).
+ If LENGTH is provided then the length parameter is set to LENGTH.
+ Otherwise if the value is an array of known length then the array's length
+ is used. Otherwise the length will be set to -1 (meaning first null of
+ appropriate with).
LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
static SCM
char *encoding = NULL;
int length = -1;
SCM result = SCM_BOOL_F; /* -Wall */
- struct cleanup *cleanups;
- volatile struct gdb_exception except;
+ gdbscm_gdb_exception except {};
/* The sequencing here, as everywhere else, is important.
We can't have existing cleanups when a Scheme exception is thrown. */
&encoding_arg_pos, &encoding,
&length_arg_pos, &length);
- cleanups = make_cleanup (xfree, encoding);
+ if (length < -1)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, length_arg_pos,
+ scm_from_int (length),
+ _("invalid length"));
+ }
- TRY_CATCH (except, RETURN_MASK_ALL)
+ 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;
- if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
- value = value_ind (value);
+ type = value_type (value);
+ realtype = check_typedef (type);
- result = lsscm_make_lazy_string (value_address (value), length,
- encoding, value_type (value));
+ switch (TYPE_CODE (realtype))
+ {
+ case TYPE_CODE_ARRAY:
+ {
+ LONGEST array_length = -1;
+ LONGEST low_bound, high_bound;
+
+ /* PR 20786: There's no way to specify an array of length zero.
+ Record a length of [0,-1] which is how Ada does it. Anything
+ we do is broken, but this one possible solution. */
+ if (get_array_bounds (realtype, &low_bound, &high_bound))
+ array_length = high_bound - low_bound + 1;
+ if (length == -1)
+ length = array_length;
+ else if (array_length == -1)
+ {
+ type = lookup_array_range_type (TYPE_TARGET_TYPE (realtype),
+ 0, length - 1);
+ }
+ else if (length != array_length)
+ {
+ /* We need to create a new array type with the
+ specified length. */
+ if (length > array_length)
+ error (_("length is larger than array size"));
+ type = lookup_array_range_type (TYPE_TARGET_TYPE (type),
+ low_bound,
+ low_bound + length - 1);
+ }
+ addr = value_address (value);
+ break;
+ }
+ case TYPE_CODE_PTR:
+ /* If a length is specified we defer creating an array of the
+ specified width until we need to. */
+ addr = value_as_address (value);
+ break;
+ default:
+ /* Should flag an error here. PR 20769. */
+ addr = value_address (value);
+ break;
+ }
- do_cleanups (inner_cleanup);
+ result = lsscm_make_lazy_string (addr, length, encoding, type);
+ }
+ catch (const gdb_exception &ex)
+ {
+ except = unpack (ex);
}
- do_cleanups (cleanups);
+
+ xfree (encoding);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (gdbscm_is_exception (result))
value_smob *v_smob
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
- volatile struct gdb_exception except;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
if (value_lazy (value))
value_fetch_lazy (value);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- return SCM_UNSPECIFIED;
+ return SCM_UNSPECIFIED;
+ });
}
/* (value-print <gdb:value>) -> string */
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct value *value = v_smob->value;
struct value_print_options opts;
- char *s = NULL;
- SCM result;
- volatile struct gdb_exception except;
get_user_print_options (&opts);
opts.deref_ref = 0;
- TRY_CATCH (except, RETURN_MASK_ALL)
- {
- struct ui_file *stb = mem_fileopen ();
- struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
-
- common_val_print (value, stb, 0, &opts, current_language);
- s = ui_file_xstrdup (stb, NULL);
+ string_file stb;
- do_cleanups (old_chain);
+ gdbscm_gdb_exception exc {};
+ try
+ {
+ common_val_print (value, &stb, 0, &opts, current_language);
+ }
+ catch (const gdb_exception &except)
+ {
+ exc = unpack (except);
}
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
+ GDBSCM_HANDLE_GDB_EXCEPTION (exc);
/* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
throw an error if the encoding fails.
IWBN to use scm_take_locale_string here, but we'd have to temporarily
override the default port conversion handler because contrary to
documentation it doesn't necessarily free the input string. */
- result = scm_from_stringn (s, strlen (s), host_charset (),
- SCM_FAILED_CONVERSION_QUESTION_MARK);
- xfree (s);
-
- return result;
+ return scm_from_stringn (stb.c_str (), stb.size (), host_charset (),
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
}
\f
/* (parse-and-eval string) -> <gdb:value>
gdbscm_parse_and_eval (SCM expr_scm)
{
char *expr_str;
- struct value *res_val = NULL;
- SCM result;
- struct cleanup *cleanups;
- volatile struct gdb_exception except;
-
- /* 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_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- res_val = parse_and_eval (expr_str);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
-
- 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. */
- volatile struct gdb_exception except;
-
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
- TRY_CATCH (except, RETURN_MASK_ALL)
+ return gdbscm_wrap ([=]
{
- res_val = access_value_history (i);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- 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;
- volatile struct gdb_exception except;
-
- v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
- v = v_smob->value;
-
- TRY_CATCH (except, RETURN_MASK_ALL)
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
+ return gdbscm_wrap ([=]
{
- res_index = record_latest_value (v);
- }
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- return scm_from_int (res_index);
+ return scm_from_int (record_latest_value (v_smob->value));
+ });
}
\f
/* Initialize the Scheme value code. */
static const scheme_function value_functions[] =
{
- { "value?", 1, 0, 0, gdbscm_value_p,
+ { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p),
"\
Return #t if the object is a <gdb:value> object." },
- { "make-value", 1, 0, 1, gdbscm_make_value,
+ { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value),
"\
Create a <gdb:value> representing object.\n\
Typically this is used to convert numbers and strings to\n\
\n\
Arguments: object [#:type <gdb:type>]" },
- { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
+ { "value-optimized-out?", 1, 0, 0,
+ as_a_scm_t_subr (gdbscm_value_optimized_out_p),
"\
Return #t if the value has been optimizd out." },
- { "value-address", 1, 0, 0, gdbscm_value_address,
+ { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address),
"\
Return the address of the value." },
- { "value-type", 1, 0, 0, gdbscm_value_type,
+ { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type),
"\
Return the type of the value." },
- { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
+ { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type),
"\
Return the dynamic type of the value." },
- { "value-cast", 2, 0, 0, gdbscm_value_cast,
+ { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast),
"\
Cast the value to the supplied type.\n\
\n\
Arguments: <gdb:value> <gdb:type>" },
- { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
+ { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast),
"\
Cast the value to the supplied type, as if by the C++\n\
dynamic_cast operator.\n\
\n\
Arguments: <gdb:value> <gdb:type>" },
- { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
+ { "value-reinterpret-cast", 2, 0, 0,
+ as_a_scm_t_subr (gdbscm_value_reinterpret_cast),
"\
Cast the value to the supplied type, as if by the C++\n\
reinterpret_cast operator.\n\
\n\
Arguments: <gdb:value> <gdb:type>" },
- { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
+ { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference),
"\
Return the result of applying the C unary * operator to the value." },
- { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
+ { "value-referenced-value", 1, 0, 0,
+ as_a_scm_t_subr (gdbscm_value_referenced_value),
"\
Given a value of a reference type, return the value referenced.\n\
The difference between this function and value-dereference is that\n\
value-dereference will result in a value of type 'int' while\n\
value-referenced-value will result in a value of type 'int *'." },
- { "value-field", 2, 0, 0, gdbscm_value_field,
+ { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field),
"\
Return the specified field of the value.\n\
\n\
Arguments: <gdb:value> string" },
- { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
+ { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript),
"\
Return the value of the array at the specified index.\n\
\n\
Arguments: <gdb:value> integer" },
- { "value-call", 2, 0, 0, gdbscm_value_call,
+ { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call),
"\
Perform an inferior function call taking the value as a pointer to the\n\
function to call.\n\
\n\
Arguments: <gdb:value> arg-list" },
- { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
+ { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool),
"\
Return the Scheme boolean representing the GDB value.\n\
The value must be \"integer like\". Pointers are ok." },
- { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
+ { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer),
"\
Return the Scheme integer representing the GDB value.\n\
The value must be \"integer like\". Pointers are ok." },
- { "value->real", 1, 0, 0, gdbscm_value_to_real,
+ { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real),
"\
Return the Scheme real number representing the GDB value.\n\
The value must be a number." },
- { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
+ { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector),
"\
Return a Scheme bytevector with the raw contents of the GDB value.\n\
No transformation, endian or otherwise, is performed." },
- { "value->string", 1, 0, 1, gdbscm_value_to_string,
+ { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string),
"\
Return the Unicode string of the value's contents.\n\
If ENCODING is not given, the string is assumed to be encoded in\n\
[#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
[#:length length]" },
- { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
+ { "value->lazy-string", 1, 0, 1,
+ as_a_scm_t_subr (gdbscm_value_to_lazy_string),
"\
Return a Scheme object representing a lazily fetched Unicode string\n\
of the value's contents.\n\
\n\
Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
- { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
+ { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p),
"\
Return #t if the value is lazy (not fetched yet from the inferior).\n\
A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
is called." },
- { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
+ { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value),
"\
Create a <gdb:value> that will be lazily fetched from the target.\n\
\n\
Arguments: <gdb:type> address" },
- { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
+ { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x),
"\
Fetch the value from the inferior, if it was lazy.\n\
The result is \"unspecified\"." },
- { "value-print", 1, 0, 0, gdbscm_value_print,
+ { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print),
"\
Return the string representation (print form) of the value." },
- { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
+ { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval),
"\
Evaluates string in gdb and returns the result as a <gdb:value> object." },
- { "history-ref", 1, 0, 0, gdbscm_history_ref,
+ { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref),
"\
Return the specified value from GDB's value history." },
- { "history-append!", 1, 0, 0, gdbscm_history_append_x,
+ { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x),
"\
Append the specified value onto GDB's value history." },
projects / deliverable / binutils-gdb.git / blobdiff