X-Git-Url: http://git.efficios.com/?a=blobdiff_plain;f=gdb%2Fguile%2Fscm-math.c;h=35ad4aa6035fd25a766bea6733705d7b8967b79b;hb=228c8f4be0c428369ec6b68e25696863d1e62ed7;hp=80e16736156d3dd55656f59c2f0ac5a719ed3480;hpb=ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461;p=deliverable%2Fbinutils-gdb.git diff --git a/gdb/guile/scm-math.c b/gdb/guile/scm-math.c index 80e1673615..35ad4aa603 100644 --- a/gdb/guile/scm-math.c +++ b/gdb/guile/scm-math.c @@ -1,6 +1,6 @@ /* 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. @@ -24,10 +24,7 @@ #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" @@ -70,212 +67,195 @@ enum valscm_binary_opcode #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 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 + 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) -> */ @@ -436,33 +416,27 @@ gdbscm_value_logxor (SCM x, SCM y) 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: @@ -486,12 +460,9 @@ vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name) break; default: gdb_assert_not_reached ("invalid comparison"); - } - } - do_cleanups (cleanups); - GDBSCM_HANDLE_GDB_EXCEPTION (except); - - return scm_from_bool (result); + } + return scm_from_bool (result); + }); } /* (value=? x y) -> boolean @@ -588,7 +559,7 @@ vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj, } } 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, @@ -668,7 +639,7 @@ vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM 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")); @@ -743,7 +714,6 @@ vlscm_convert_typed_value_from_scheme (const char *func_name, { struct value *value = NULL; SCM except_scm = SCM_BOOL_F; - volatile struct gdb_exception except; if (type == NULL) { @@ -753,7 +723,7 @@ vlscm_convert_typed_value_from_scheme (const char *func_name, *except_scmp = SCM_BOOL_F; - TRY_CATCH (except, RETURN_MASK_ALL) + try { if (vlscm_is_value (obj)) { @@ -806,9 +776,7 @@ vlscm_convert_typed_value_from_scheme (const char *func_name, } else if (scm_is_string (obj)) { - char *s; size_t len; - struct cleanup *cleanup; if (type != NULL) { @@ -820,19 +788,15 @@ vlscm_convert_typed_value_from_scheme (const char *func_name, else { /* TODO: Provide option to specify conversion strategy. */ - s = gdbscm_scm_to_string (obj, &len, + gdb::unique_xmalloc_ptr 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; } @@ -860,8 +824,10 @@ vlscm_convert_typed_value_from_scheme (const char *func_name, 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)) { @@ -892,99 +858,99 @@ vlscm_convert_value_from_scheme (const char *func_name, 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_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." },