diff options
Diffstat (limited to 'gdb/guile/scm-math.c')
| -rw-r--r-- | gdb/guile/scm-math.c | 374 |
1 files changed, 169 insertions, 205 deletions
diff --git a/gdb/guile/scm-math.c b/gdb/guile/scm-math.c index 5507dd7..74d5075 100644 --- a/gdb/guile/scm-math.c +++ b/gdb/guile/scm-math.c @@ -67,88 +67,77 @@ 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; - 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; @@ -156,129 +145,119 @@ vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y, 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> */ @@ -439,33 +418,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; - 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: @@ -489,18 +462,9 @@ vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name) 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 |