/* GDB/Scheme support for math operations on values.
- Copyright (C) 2008-2014 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 "doublest.h" /* Needed by dfp.h. */
-#include "expression.h" /* Needed by dfp.h. */
-#include "dfp.h"
-#include "gdb_assert.h"
+#include "target-float.h"
#include "symtab.h" /* Needed by language.h. */
#include "language.h"
#include "valprint.h"
#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;
- volatile struct gdb_exception except;
- 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;
+
+ struct value *res_val = NULL;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ switch (opcode)
{
- 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");
- }
+ 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");
}
- 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 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;
struct value *arg1, *arg2;
- SCM result = SCM_BOOL_F;
struct value *res_val = NULL;
SCM except_scm;
- struct cleanup *cleanups;
- volatile struct gdb_exception except;
- 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_CATCH (except, RETURN_MASK_ALL)
+ switch (opcode)
{
- switch (opcode)
- {
- case VALSCM_ADD:
- {
- struct type *ltype = value_type (arg1);
- struct type *rtype = value_type (arg2);
-
- CHECK_TYPEDEF (ltype);
- ltype = STRIP_REFERENCE (ltype);
- 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);
-
- CHECK_TYPEDEF (ltype);
- ltype = STRIP_REFERENCE (ltype);
- 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");
- }
+ 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");
}
- GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
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;
- volatile struct gdb_exception except;
+ 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_CATCH (except, RETURN_MASK_ALL)
- {
+ 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");
- }
- }
- do_cleanups (cleanups);
- GDBSCM_HANDLE_GDB_EXCEPTION (except);
-
- return scm_from_bool (result);
+ }
+ return scm_from_bool (result);
+ });
}
/* (value=? x y) -> boolean
}
}
else if (TYPE_CODE (type) == TYPE_CODE_FLT)
- return value_from_double (type, scm_to_double (obj));
+ return value_from_host_double (type, scm_to_double (obj));
else
{
*except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
gdbscm_scm_to_ulongest (obj));
}
else if (scm_is_real (obj))
- return value_from_double (bt->builtin_double, scm_to_double (obj));
+ return value_from_host_double (bt->builtin_double, scm_to_double (obj));
*except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
_("value not a number representable on the target"));
{
struct value *value = NULL;
SCM except_scm = SCM_BOOL_F;
- volatile struct gdb_exception except;
if (type == NULL)
{
*except_scmp = SCM_BOOL_F;
- TRY_CATCH (except, RETURN_MASK_ALL)
+ try
{
if (vlscm_is_value (obj))
{
}
else if (scm_is_string (obj))
{
- char *s;
size_t len;
- struct cleanup *cleanup;
if (type != NULL)
{
else
{
/* TODO: Provide option to specify conversion strategy. */
- s = gdbscm_scm_to_string (obj, &len,
+ gdb::unique_xmalloc_ptr<char> s
+ = gdbscm_scm_to_string (obj, &len,
target_charset (gdbarch),
0 /*non-strict*/,
&except_scm);
if (s != NULL)
- {
- cleanup = make_cleanup (xfree, s);
- value
- = value_cstring (s, len,
- language_string_char_type (language,
- gdbarch));
- do_cleanups (cleanup);
- }
+ value = value_cstring (s.get (), len,
+ language_string_char_type (language,
+ gdbarch));
else
value = NULL;
}
value = NULL;
}
}
- if (except.reason < 0)
- except_scm = gdbscm_scm_from_gdb_exception (except);
+ catch (const gdb_exception &except)
+ {
+ except_scm = gdbscm_scm_from_gdb_exception (unpack (except));
+ }
if (gdbscm_is_true (except_scm))
{
static const scheme_function math_functions[] =
{
- { "value-add", 2, 0, 0, gdbscm_value_add,
+ { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add),
"\
Return a + b." },
- { "value-sub", 2, 0, 0, gdbscm_value_sub,
+ { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub),
"\
Return a - b." },
- { "value-mul", 2, 0, 0, gdbscm_value_mul,
+ { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul),
"\
Return a * b." },
- { "value-div", 2, 0, 0, gdbscm_value_div,
+ { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div),
"\
Return a / b." },
- { "value-rem", 2, 0, 0, gdbscm_value_rem,
+ { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem),
"\
Return a % b." },
- { "value-mod", 2, 0, 0, gdbscm_value_mod,
+ { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod),
"\
Return a mod b. See Knuth 1.2.4." },
- { "value-pow", 2, 0, 0, gdbscm_value_pow,
+ { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow),
"\
Return pow (x, y)." },
- { "value-not", 1, 0, 0, gdbscm_value_not,
+ { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not),
"\
Return !a." },
- { "value-neg", 1, 0, 0, gdbscm_value_neg,
+ { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg),
"\
Return -a." },
- { "value-pos", 1, 0, 0, gdbscm_value_pos,
+ { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos),
"\
Return a." },
- { "value-abs", 1, 0, 0, gdbscm_value_abs,
+ { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs),
"\
Return abs (a)." },
- { "value-lsh", 2, 0, 0, gdbscm_value_lsh,
+ { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh),
"\
Return a << b." },
- { "value-rsh", 2, 0, 0, gdbscm_value_rsh,
+ { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh),
"\
Return a >> b." },
- { "value-min", 2, 0, 0, gdbscm_value_min,
+ { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min),
"\
Return min (a, b)." },
- { "value-max", 2, 0, 0, gdbscm_value_max,
+ { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max),
"\
Return max (a, b)." },
- { "value-lognot", 1, 0, 0, gdbscm_value_lognot,
+ { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot),
"\
Return ~a." },
- { "value-logand", 2, 0, 0, gdbscm_value_logand,
+ { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand),
"\
Return a & b." },
- { "value-logior", 2, 0, 0, gdbscm_value_logior,
+ { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior),
"\
Return a | b." },
- { "value-logxor", 2, 0, 0, gdbscm_value_logxor,
+ { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor),
"\
Return a ^ b." },
- { "value=?", 2, 0, 0, gdbscm_value_eq_p,
+ { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p),
"\
Return a == b." },
- { "value<?", 2, 0, 0, gdbscm_value_lt_p,
+ { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p),
"\
Return a < b." },
- { "value<=?", 2, 0, 0, gdbscm_value_le_p,
+ { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p),
"\
Return a <= b." },
- { "value>?", 2, 0, 0, gdbscm_value_gt_p,
+ { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p),
"\
Return a > b." },
- { "value>=?", 2, 0, 0, gdbscm_value_ge_p,
+ { "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p),
"\
Return a >= b." },
projects / deliverable / binutils-gdb.git / blobdiff