diff options
Diffstat (limited to 'gdb/guile/scm-math.c')
| -rw-r--r-- | gdb/guile/scm-math.c | 998 |
1 files changed, 998 insertions, 0 deletions
diff --git a/gdb/guile/scm-math.c b/gdb/guile/scm-math.c new file mode 100644 index 0000000..80e1673 --- /dev/null +++ b/gdb/guile/scm-math.c @@ -0,0 +1,998 @@ +/* GDB/Scheme support for math operations on values. + + Copyright (C) 2008-2014 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. */ + +/* See README file in this directory for implementation notes, coding + conventions, et.al. */ + +#include "defs.h" +#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 "symtab.h" /* Needed by language.h. */ +#include "language.h" +#include "valprint.h" +#include "value.h" +#include "guile-internal.h" + +/* Note: Use target types here to remain consistent with the values system in + GDB (which uses target arithmetic). */ + +enum valscm_unary_opcode +{ + VALSCM_NOT, + VALSCM_NEG, + VALSCM_NOP, + VALSCM_ABS, + /* Note: This is Scheme's "logical not", not GDB's. + GDB calls this UNOP_COMPLEMENT. */ + VALSCM_LOGNOT +}; + +enum valscm_binary_opcode +{ + VALSCM_ADD, + VALSCM_SUB, + VALSCM_MUL, + VALSCM_DIV, + VALSCM_REM, + VALSCM_MOD, + VALSCM_POW, + VALSCM_LSH, + VALSCM_RSH, + VALSCM_MIN, + VALSCM_MAX, + VALSCM_BITAND, + VALSCM_BITOR, + VALSCM_BITXOR +}; + +/* If TYPE is a reference, return the target; otherwise return TYPE. */ +#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. */ + +static SCM +vlscm_unop (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 ()); + + 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); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + 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"); + } + } + 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; +} + +/* 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. */ + +static SCM +vlscm_binop (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 ()); + + 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); + } + 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); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + 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: + { + 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); + } + 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); + + if (gdbscm_is_exception (result)) + gdbscm_throw (result); + + return result; +} + +/* (value-add x y) -> <gdb:value> */ + +static SCM +gdbscm_value_add (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME); +} + +/* (value-sub x y) -> <gdb:value> */ + +static SCM +gdbscm_value_sub (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME); +} + +/* (value-mul x y) -> <gdb:value> */ + +static SCM +gdbscm_value_mul (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME); +} + +/* (value-div x y) -> <gdb:value> */ + +static SCM +gdbscm_value_div (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME); +} + +/* (value-rem x y) -> <gdb:value> */ + +static SCM +gdbscm_value_rem (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME); +} + +/* (value-mod x y) -> <gdb:value> */ + +static SCM +gdbscm_value_mod (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME); +} + +/* (value-pow x y) -> <gdb:value> */ + +static SCM +gdbscm_value_pow (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME); +} + +/* (value-neg x) -> <gdb:value> */ + +static SCM +gdbscm_value_neg (SCM x) +{ + return vlscm_unop (VALSCM_NEG, x, FUNC_NAME); +} + +/* (value-pos x) -> <gdb:value> */ + +static SCM +gdbscm_value_pos (SCM x) +{ + return vlscm_unop (VALSCM_NOP, x, FUNC_NAME); +} + +/* (value-abs x) -> <gdb:value> */ + +static SCM +gdbscm_value_abs (SCM x) +{ + return vlscm_unop (VALSCM_ABS, x, FUNC_NAME); +} + +/* (value-lsh x y) -> <gdb:value> */ + +static SCM +gdbscm_value_lsh (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME); +} + +/* (value-rsh x y) -> <gdb:value> */ + +static SCM +gdbscm_value_rsh (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME); +} + +/* (value-min x y) -> <gdb:value> */ + +static SCM +gdbscm_value_min (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME); +} + +/* (value-max x y) -> <gdb:value> */ + +static SCM +gdbscm_value_max (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME); +} + +/* (value-not x) -> <gdb:value> */ + +static SCM +gdbscm_value_not (SCM x) +{ + return vlscm_unop (VALSCM_NOT, x, FUNC_NAME); +} + +/* (value-lognot x) -> <gdb:value> */ + +static SCM +gdbscm_value_lognot (SCM x) +{ + return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME); +} + +/* (value-logand x y) -> <gdb:value> */ + +static SCM +gdbscm_value_logand (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME); +} + +/* (value-logior x y) -> <gdb:value> */ + +static SCM +gdbscm_value_logior (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME); +} + +/* (value-logxor x y) -> <gdb:value> */ + +static SCM +gdbscm_value_logxor (SCM x, SCM y) +{ + return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME); +} + +/* Utility to perform all value comparisons. + If there's an error a Scheme exception is thrown. */ + +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; + + cleanups = make_cleanup_value_free_to_mark (value_mark ()); + + 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); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + switch (op) + { + case BINOP_LESS: + result = value_less (v1, v2); + break; + case BINOP_LEQ: + result = (value_less (v1, v2) + || value_equal (v1, v2)); + break; + case BINOP_EQUAL: + result = value_equal (v1, v2); + break; + case BINOP_NOTEQUAL: + gdb_assert_not_reached ("not-equal not implemented"); + case BINOP_GTR: + result = value_less (v2, v1); + break; + case BINOP_GEQ: + result = (value_less (v2, v1) + || value_equal (v1, v2)); + break; + default: + gdb_assert_not_reached ("invalid <gdb:value> comparison"); + } + } + do_cleanups (cleanups); + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return scm_from_bool (result); +} + +/* (value=? x y) -> boolean + There is no "not-equal?" function (value!= ?) on purpose. + We're following string=?, etc. as our Guide here. */ + +static SCM +gdbscm_value_eq_p (SCM x, SCM y) +{ + return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME); +} + +/* (value<? x y) -> boolean */ + +static SCM +gdbscm_value_lt_p (SCM x, SCM y) +{ + return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME); +} + +/* (value<=? x y) -> boolean */ + +static SCM +gdbscm_value_le_p (SCM x, SCM y) +{ + return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME); +} + +/* (value>? x y) -> boolean */ + +static SCM +gdbscm_value_gt_p (SCM x, SCM y) +{ + return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME); +} + +/* (value>=? x y) -> boolean */ + +static SCM +gdbscm_value_ge_p (SCM x, SCM y) +{ + return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME); +} + +/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. + Convert OBJ, a Scheme number, to a <gdb:value> object. + OBJ_ARG_POS is its position in the argument list, used in exception text. + + TYPE is the result type. TYPE_ARG_POS is its position in + the argument list, used in exception text. + TYPE_SCM is Scheme object wrapping TYPE, used in exception text. + + If the number isn't representable, e.g. it's too big, a <gdb:exception> + object is stored in *EXCEPT_SCMP and NULL is returned. + The conversion may throw a gdb error, e.g., if TYPE is invalid. */ + +static struct value * +vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj, + int type_arg_pos, SCM type_scm, struct type *type, + struct gdbarch *gdbarch, SCM *except_scmp) +{ + if (is_integral_type (type) + || TYPE_CODE (type) == TYPE_CODE_PTR) + { + if (TYPE_UNSIGNED (type)) + { + ULONGEST max; + + get_unsigned_type_max (type, &max); + if (!scm_is_unsigned_integer (obj, 0, max)) + { + *except_scmp + = gdbscm_make_out_of_range_error (func_name, + obj_arg_pos, obj, + _("value out of range for type")); + return NULL; + } + return value_from_longest (type, gdbscm_scm_to_ulongest (obj)); + } + else + { + LONGEST min, max; + + get_signed_type_minmax (type, &min, &max); + if (!scm_is_signed_integer (obj, min, max)) + { + *except_scmp + = gdbscm_make_out_of_range_error (func_name, + obj_arg_pos, obj, + _("value out of range for type")); + return NULL; + } + return value_from_longest (type, gdbscm_scm_to_longest (obj)); + } + } + else if (TYPE_CODE (type) == TYPE_CODE_FLT) + return value_from_double (type, scm_to_double (obj)); + else + { + *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj, + NULL); + return NULL; + } +} + +/* Return non-zero if OBJ, an integer, fits in TYPE. */ + +static int +vlscm_integer_fits_p (SCM obj, struct type *type) +{ + if (TYPE_UNSIGNED (type)) + { + ULONGEST max; + + /* If scm_is_unsigned_integer can't work with this type, just punt. */ + if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax)) + return 0; + get_unsigned_type_max (type, &max); + return scm_is_unsigned_integer (obj, 0, max); + } + else + { + LONGEST min, max; + + /* If scm_is_signed_integer can't work with this type, just punt. */ + if (TYPE_LENGTH (type) > sizeof (scm_t_intmax)) + return 0; + get_signed_type_minmax (type, &min, &max); + return scm_is_signed_integer (obj, min, max); + } +} + +/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. + Convert OBJ, a Scheme number, to a <gdb:value> object. + OBJ_ARG_POS is its position in the argument list, used in exception text. + + If OBJ is an integer, then the smallest int that will hold the value in + the following progression is chosen: + int, unsigned int, long, unsigned long, long long, unsigned long long. + Otherwise, if OBJ is a real number, then it is converted to a double. + Otherwise an exception is thrown. + + If the number isn't representable, e.g. it's too big, a <gdb:exception> + object is stored in *EXCEPT_SCMP and NULL is returned. */ + +static struct value * +vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj, + struct gdbarch *gdbarch, SCM *except_scmp) +{ + const struct builtin_type *bt = builtin_type (gdbarch); + + /* One thing to keep in mind here is that we are interested in the + target's representation of OBJ, not the host's. */ + + if (scm_is_exact (obj) && scm_is_integer (obj)) + { + if (vlscm_integer_fits_p (obj, bt->builtin_int)) + return value_from_longest (bt->builtin_int, + gdbscm_scm_to_longest (obj)); + if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int)) + return value_from_longest (bt->builtin_unsigned_int, + gdbscm_scm_to_ulongest (obj)); + if (vlscm_integer_fits_p (obj, bt->builtin_long)) + return value_from_longest (bt->builtin_long, + gdbscm_scm_to_longest (obj)); + if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long)) + return value_from_longest (bt->builtin_unsigned_long, + gdbscm_scm_to_ulongest (obj)); + if (vlscm_integer_fits_p (obj, bt->builtin_long_long)) + return value_from_longest (bt->builtin_long_long, + gdbscm_scm_to_longest (obj)); + if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long)) + return value_from_longest (bt->builtin_unsigned_long_long, + gdbscm_scm_to_ulongest (obj)); + } + else if (scm_is_real (obj)) + return value_from_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")); + return NULL; +} + +/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. + Convert BV, a Scheme bytevector, to a <gdb:value> object. + + TYPE, if non-NULL, is the result type. Otherwise, a vector of type + uint8_t is used. + TYPE_SCM is Scheme object wrapping TYPE, used in exception text, + or #f if TYPE is NULL. + + If the bytevector isn't the same size as the type, then a <gdb:exception> + object is stored in *EXCEPT_SCMP, and NULL is returned. */ + +static struct value * +vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm, + int arg_pos, const char *func_name, + SCM *except_scmp, struct gdbarch *gdbarch) +{ + LONGEST length = SCM_BYTEVECTOR_LENGTH (bv); + struct value *value; + + if (type == NULL) + { + type = builtin_type (gdbarch)->builtin_uint8; + type = lookup_array_range_type (type, 0, length); + make_vector_type (type); + } + type = check_typedef (type); + if (TYPE_LENGTH (type) != length) + { + *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos, + type_scm, + _("size of type does not match size of bytevector")); + return NULL; + } + + value = value_from_contents (type, + (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv)); + return value; +} + +/* Convert OBJ, a Scheme value, to a <gdb:value> object. + OBJ_ARG_POS is its position in the argument list, used in exception text. + + TYPE, if non-NULL, is the result type which must be compatible with + the value being converted. + If TYPE is NULL then a suitable default type is chosen. + TYPE_SCM is Scheme object wrapping TYPE, used in exception text, + or SCM_UNDEFINED if TYPE is NULL. + TYPE_ARG_POS is its position in the argument list, used in exception text, + or -1 if TYPE is NULL. + + OBJ may also be a <gdb:value> object, in which case a copy is returned + and TYPE must be NULL. + + If the value cannot be converted, NULL is returned and a gdb:exception + object is stored in *EXCEPT_SCMP. + Otherwise the new value is returned, added to the all_values chain. */ + +struct value * +vlscm_convert_typed_value_from_scheme (const char *func_name, + int obj_arg_pos, SCM obj, + int type_arg_pos, SCM type_scm, + struct type *type, + SCM *except_scmp, + struct gdbarch *gdbarch, + const struct language_defn *language) +{ + struct value *value = NULL; + SCM except_scm = SCM_BOOL_F; + volatile struct gdb_exception except; + + if (type == NULL) + { + gdb_assert (type_arg_pos == -1); + gdb_assert (SCM_UNBNDP (type_scm)); + } + + *except_scmp = SCM_BOOL_F; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + if (vlscm_is_value (obj)) + { + if (type != NULL) + { + except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, + type_scm, + _("No type allowed")); + value = NULL; + } + else + value = value_copy (vlscm_scm_to_value (obj)); + } + else if (gdbscm_is_true (scm_bytevector_p (obj))) + { + value = vlscm_convert_bytevector (obj, type, type_scm, + obj_arg_pos, func_name, + &except_scm, gdbarch); + } + else if (gdbscm_is_bool (obj)) + { + if (type != NULL + && !is_integral_type (type)) + { + except_scm = gdbscm_make_type_error (func_name, type_arg_pos, + type_scm, NULL); + } + else + { + value = value_from_longest (type + ? type + : language_bool_type (language, + gdbarch), + gdbscm_is_true (obj)); + } + } + else if (scm_is_number (obj)) + { + if (type != NULL) + { + value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj, + type_arg_pos, type_scm, type, + gdbarch, &except_scm); + } + else + { + value = vlscm_convert_number (func_name, obj_arg_pos, obj, + gdbarch, &except_scm); + } + } + else if (scm_is_string (obj)) + { + char *s; + size_t len; + struct cleanup *cleanup; + + if (type != NULL) + { + except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, + type_scm, + _("No type allowed")); + value = NULL; + } + else + { + /* TODO: Provide option to specify conversion strategy. */ + 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); + } + else + value = NULL; + } + } + else if (lsscm_is_lazy_string (obj)) + { + if (type != NULL) + { + except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, + type_scm, + _("No type allowed")); + value = NULL; + } + else + { + value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos, + func_name, + &except_scm); + } + } + else /* OBJ isn't anything we support. */ + { + except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj, + NULL); + value = NULL; + } + } + if (except.reason < 0) + except_scm = gdbscm_scm_from_gdb_exception (except); + + if (gdbscm_is_true (except_scm)) + { + gdb_assert (value == NULL); + *except_scmp = except_scm; + } + + return value; +} + +/* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there + is no supplied type. See vlscm_convert_typed_value_from_scheme for + details. */ + +struct value * +vlscm_convert_value_from_scheme (const char *func_name, + int obj_arg_pos, SCM obj, + SCM *except_scmp, struct gdbarch *gdbarch, + const struct language_defn *language) +{ + return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj, + -1, SCM_UNDEFINED, NULL, + except_scmp, + gdbarch, language); +} + +/* Initialize value math support. */ + +static const scheme_function math_functions[] = +{ + { "value-add", 2, 0, 0, gdbscm_value_add, + "\ +Return a + b." }, + + { "value-sub", 2, 0, 0, gdbscm_value_sub, + "\ +Return a - b." }, + + { "value-mul", 2, 0, 0, gdbscm_value_mul, + "\ +Return a * b." }, + + { "value-div", 2, 0, 0, gdbscm_value_div, + "\ +Return a / b." }, + + { "value-rem", 2, 0, 0, gdbscm_value_rem, + "\ +Return a % b." }, + + { "value-mod", 2, 0, 0, gdbscm_value_mod, + "\ +Return a mod b. See Knuth 1.2.4." }, + + { "value-pow", 2, 0, 0, gdbscm_value_pow, + "\ +Return pow (x, y)." }, + + { "value-not", 1, 0, 0, gdbscm_value_not, + "\ +Return !a." }, + + { "value-neg", 1, 0, 0, gdbscm_value_neg, + "\ +Return -a." }, + + { "value-pos", 1, 0, 0, gdbscm_value_pos, + "\ +Return a." }, + + { "value-abs", 1, 0, 0, gdbscm_value_abs, + "\ +Return abs (a)." }, + + { "value-lsh", 2, 0, 0, gdbscm_value_lsh, + "\ +Return a << b." }, + + { "value-rsh", 2, 0, 0, gdbscm_value_rsh, + "\ +Return a >> b." }, + + { "value-min", 2, 0, 0, gdbscm_value_min, + "\ +Return min (a, b)." }, + + { "value-max", 2, 0, 0, gdbscm_value_max, + "\ +Return max (a, b)." }, + + { "value-lognot", 1, 0, 0, gdbscm_value_lognot, + "\ +Return ~a." }, + + { "value-logand", 2, 0, 0, gdbscm_value_logand, + "\ +Return a & b." }, + + { "value-logior", 2, 0, 0, gdbscm_value_logior, + "\ +Return a | b." }, + + { "value-logxor", 2, 0, 0, gdbscm_value_logxor, + "\ +Return a ^ b." }, + + { "value=?", 2, 0, 0, gdbscm_value_eq_p, + "\ +Return a == b." }, + + { "value<?", 2, 0, 0, gdbscm_value_lt_p, + "\ +Return a < b." }, + + { "value<=?", 2, 0, 0, gdbscm_value_le_p, + "\ +Return a <= b." }, + + { "value>?", 2, 0, 0, gdbscm_value_gt_p, + "\ +Return a > b." }, + + { "value>=?", 2, 0, 0, gdbscm_value_ge_p, + "\ +Return a >= b." }, + + END_FUNCTIONS +}; + +void +gdbscm_initialize_math (void) +{ + gdbscm_define_functions (math_functions, 1); +} |