This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH v1 24/36] Guile extension language: scm-math.c
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org
- Date: Tue, 24 Dec 2013 11:03:49 -0800
- Subject: [PATCH v1 24/36] Guile extension language: scm-math.c
- Authentication-results: sourceware.org; auth=none
This patch adds various math operations.
2013-12-24 Doug Evans <xdje42@gmail.com>
* guile/scm-math.c: New file.
testsuite/
* gdb.guile/scm-math.c: New file.
* gdb.guile/scm-math.exp: New file.
diff --git a/gdb/guile/scm-math.c b/gdb/guile/scm-math.c
new file mode 100644
index 0000000..a8dd594
--- /dev/null
+++ b/gdb/guile/scm-math.c
@@ -0,0 +1,1014 @@
+/* GDB/Scheme support for math operations on values.
+
+ Copyright (C) 2008-2013 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)
+ {
+ SCM scm;
+
+ scm = vlscm_scm_to_value_gsmob (obj);
+ if (vlscm_is_value (scm))
+ {
+ 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 (scm));
+ }
+ else if (gdbscm_is_exception (scm))
+ {
+ except_scm = scm;
+ value = NULL;
+ }
+ 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 select non-strict conversion? */
+ s = gdbscm_scm_to_string (obj, &len,
+ target_charset (gdbarch), 1 /*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;
+ }
+ }
+ /* Note: scm is assigned to here. */
+ else if (lsscm_is_lazy_string (scm
+ = lsscm_scm_to_lazy_string_gsmob (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 (scm, obj_arg_pos,
+ func_name,
+ &except_scm);
+ }
+ }
+ /* This catches an exception returned from the call to
+ lsscm_scm_to_lazy_string_gsmob. */
+ else if (gdbscm_is_exception (scm))
+ {
+ except_scm = scm;
+ value = NULL;
+ }
+ 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);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-math.c b/gdb/testsuite/gdb.guile/scm-math.c
new file mode 100644
index 0000000..1f1eb36
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-math.c
@@ -0,0 +1,30 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2013 Free Software Foundation, Inc.
+
+ 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/>. */
+
+enum e
+ {
+ ONE = 1,
+ TWO = 2
+ };
+
+enum e evalue = TWO;
+
+int
+main (int argc, char *argv[])
+{
+ return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/scm-math.exp b/gdb/testsuite/gdb.guile/scm-math.exp
new file mode 100644
index 0000000..0dca70b
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-math.exp
@@ -0,0 +1,301 @@
+# Copyright (C) 2008-2013 Free Software Foundation, Inc.
+
+# 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/>.
+
+# This file is part of the GDB testsuite.
+# It tests <gdb:value> math operations.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+proc test_value_numeric_ops {} {
+ global gdb_prompt
+
+ gdb_scm_test_silent_cmd "gu (define i (make-value 5))" \
+ "create first integer value"
+ gdb_scm_test_silent_cmd "gu (define j (make-value 2))" \
+ "create second integer value"
+ gdb_test "gu (print (value-add i j))" \
+ "= 7" "add two integer values"
+ gdb_test "gu (raw-print (value-add i j))" \
+ "= #<gdb:value 7>" "verify type of integer add result"
+
+ gdb_scm_test_silent_cmd "gu (define f (make-value 1.25))" \
+ "create first double value"
+ gdb_scm_test_silent_cmd "gu (define g (make-value 2.5))" \
+ "create second double value"
+ gdb_test "gu (print (value-add f g))" \
+ "= 3.75" "add two double values"
+ gdb_test "gu (raw-print (value-add f g))" \
+ "= #<gdb:value 3.75>" "verify type of double add result"
+
+ gdb_test "gu (print (value-sub i j))" \
+ "= 3" "subtract two integer values"
+ gdb_test "gu (print (value-sub f g))" \
+ "= -1.25" "subtract two double values"
+
+ gdb_test "gu (print (value-mul i j))" \
+ "= 10" "multiply two integer values"
+ gdb_test "gu (print (value-mul f g))" \
+ "= 3.125" "multiply two double values"
+
+ gdb_test "gu (print (value-div i j))" \
+ "= 2" "divide two integer values"
+ gdb_test "gu (print (value-div f g))" \
+ "= 0.5" "divide two double values"
+ gdb_test "gu (print (value-rem i j))" \
+ "= 1" "take remainder of two integer values"
+ gdb_test "gu (print (value-mod i j))" \
+ "= 1" "take modulus of two integer values"
+
+ gdb_test "gu (print (value-pow i j))" \
+ "= 25" "integer value raised to the power of another integer value"
+ gdb_test "gu (print (value-pow g j))" \
+ "= 6.25" "double value raised to the power of integer value"
+
+ gdb_test "gu (print (value-neg i))" \
+ "= -5" "negated integer value"
+ gdb_test "gu (print (value-pos i))" \
+ "= 5" "positive integer value"
+ gdb_test "gu (print (value-neg f))" \
+ "= -1.25" "negated double value"
+ gdb_test "gu (print (value-pos f))" \
+ "= 1.25" "positive double value"
+ gdb_test "gu (print (value-abs (value-sub j i)))" \
+ "= 3" "absolute of integer value"
+ gdb_test "gu (print (value-abs (value-sub f g)))" \
+ "= 1.25" "absolute of double value"
+
+ gdb_test "gu (print (value-lsh i j))" \
+ "= 20" "left shift"
+ gdb_test "gu (print (value-rsh i j))" \
+ "= 1" "right shift"
+
+ gdb_test "gu (print (value-min i j))" \
+ "= 2" "min"
+ gdb_test "gu (print (value-max i j))" \
+ "= 5" "max"
+
+ gdb_test "gu (print (value-lognot i))" \
+ "= -6" "lognot"
+ gdb_test "gu (print (value-logand i j))" \
+ "= 0" "logand i j"
+ gdb_test "gu (print (value-logand 5 1))" \
+ "= 1" "logand 5 1"
+ gdb_test "gu (print (value-logior i j))" \
+ "= 7" "logior i j"
+ gdb_test "gu (print (value-logior 5 1))" \
+ "= 5" "logior 5 1"
+ gdb_test "gu (print (value-logxor i j))" \
+ "= 7" "logxor i j"
+ gdb_test "gu (print (value-logxor 5 1))" \
+ "= 4" "logxor 5 1"
+
+ # Test <gdb:value> mixed with Guile types.
+
+ gdb_test "gu (print (value-sub i 1))" \
+ "= 4" "subtract integer value from guile integer"
+ gdb_test "gu (raw-print (value-sub i 1))" \
+ "#<gdb:value 4>" \
+ "verify type of mixed integer subtraction result"
+ gdb_test "gu (print (value-add f 1.5))" \
+ "= 2.75" "add double value with guile float"
+
+ gdb_test "gu (print (value-sub 1 i))" \
+ "= -4" "subtract guile integer from integer value"
+ gdb_test "gu (print (value-add 1.5 f))" \
+ "= 2.75" "add guile float with double value"
+
+ # Enum conversion test.
+ gdb_test "print evalue" "= TWO"
+ gdb_test "gu (print (value->integer (history-ref 0)))" "= 2"
+
+ # Test pointer arithmetic.
+
+ # First, obtain the pointers.
+ gdb_test "print (void *) 2" ".*" ""
+ gdb_test_no_output "gu (define a (history-ref 0))"
+ gdb_test "print (void *) 5" ".*" ""
+ gdb_test_no_output "gu (define b (history-ref 0))"
+
+ gdb_test "gu (print (value-add a 5))" \
+ "= 0x7( <.*>)?" "add pointer value with guile integer"
+ gdb_test "gu (print (value-sub b 2))" \
+ "= 0x3( <.*>)?" "subtract guile integer from pointer value"
+ gdb_test "gu (print (value-sub b a))" \
+ "= 3" "subtract two pointer values"
+
+ # Test some invalid operations.
+
+ gdb_test_multiple "gu (print (value-add i '()))" "catch error in guile type conversion" {
+ -re "Wrong type argument in position 2.*$gdb_prompt $" {pass "catch error in guile type conversion"}
+ -re "= .*$gdb_prompt $" {fail "catch error in guile type conversion"}
+ -re "$gdb_prompt $" {fail "catch error in guile type conversion"}
+ }
+
+ gdb_test_multiple "gu (print (value-add i \"foo\"))" "catch throw of GDB error" {
+ -re "Argument to arithmetic operation not a number or boolean.*$gdb_prompt $" {pass "catch throw of GDB error"}
+ -re "= .*$gdb_prompt $" {fail "catch throw of GDB error"}
+ -re "$gdb_prompt $" {fail "catch throw of GDB error"}
+ }
+}
+
+# Return the max signed int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_max_int { size } {
+ return [expr "(1 << ($size - 1)) - 1"]
+}
+
+# Return the min signed int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_min_int { size } {
+ return [expr "-(1 << ($size - 1))"]
+}
+
+# Return the max unsigned int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_max_uint { size } {
+ return [expr "(1 << $size) - 1"]
+}
+
+# Helper routine for test_value_numeric_ranges.
+
+proc test_make_int_value { name size } {
+ set max [get_max_int $size]
+ set min [get_min_int $size]
+ set umax [get_max_uint $size]
+ gdb_test "gu (print (value-type (make-value $max)))" \
+ "= $name" "test make-value $name $size max"
+ gdb_test "gu (print (value-type (make-value $min)))" \
+ "= $name" "test make-value $name $size min"
+ gdb_test "gu (print (value-type (make-value $umax)))" \
+ "= unsigned $name" "test make-value unsigned $name $size umax"
+}
+
+# Helper routine for test_value_numeric_ranges.
+
+proc test_make_typed_int_value { size } {
+ set name "int$size"
+ set uname "uint$size"
+ set max [get_max_int $size]
+ set min [get_min_int $size]
+ set umax [get_max_uint $size]
+ gdb_test "gu (print (make-value $max #:type (arch-${name}-type arch)))" \
+ "= $max" "test make-value $name $size max"
+ gdb_test "gu (print (make-value $min #:type (arch-${name}-type arch)))" \
+ "= $min" "test make-value $name $size min"
+ gdb_test "gu (print (make-value $umax #:type (arch-${uname}-type arch)))" \
+ "= $umax" "test make-value $uname $size umax"
+}
+
+proc test_value_numeric_ranges {} {
+ # We can't assume anything about sizeof (int), etc. on the target.
+ # Keep it simple for now, this will cover everything important for
+ # the major targets.
+ set int_size [get_integer_valueof "sizeof (int)" 0]
+ set long_size [get_integer_valueof "sizeof (long)" 0]
+ gdb_test_no_output "gu (define arch (current-arch))"
+
+ if { $int_size == 4 } {
+ test_make_int_value int 32
+ }
+ if { $long_size == 8} {
+ test_make_int_value long 64
+ }
+ gdb_test "gu (print (value-type (make-value (ash 1 64))))" \
+ "ERROR:.*value not a number representable.*" \
+ "test make-value, number too large"
+
+ foreach size { 8 16 32 } {
+ test_make_typed_int_value $size
+ }
+ if { $long_size == 8 } {
+ test_make_typed_int_value 64
+ }
+}
+
+proc test_value_boolean {} {
+ # Note: Boolean values print as 0,1 because they are printed in the
+ # current language (in this case C).
+
+ gdb_test "gu (print (make-value #t))" "= 1" "create boolean true"
+ gdb_test "gu (print (make-value #f))" "= 0" "create boolean false"
+
+ gdb_test "gu (print (value-not (make-value #t)))" \
+ "= 0" "not true"
+ gdb_test "gu (print (value-not (make-value #f)))" \
+ "= 1" "not false"
+
+ gdb_test "gu (raw-print (make-value #t))" \
+ "#<gdb:value 1>" "verify type of boolean"
+}
+
+proc test_value_compare {} {
+ gdb_test "gu (print (value<? 1 1))" \
+ "#f" "less than, equal"
+ gdb_test "gu (print (value<? 1 2))" \
+ "#t" "less than, less"
+ gdb_test "gu (print (value<? 2 1))" \
+ "#f" "less than, greater"
+
+ gdb_test "gu (print (value<=? 1 1))" \
+ "#t" "less or equal, equal"
+ gdb_test "gu (print (value<=? 1 2))" \
+ "#t" "less or equal, less"
+ gdb_test "gu (print (value<=? 2 1))" \
+ "#f" "less or equal, greater"
+
+ gdb_test "gu (print (value=? 1 1))" \
+ "#t" "equality"
+ gdb_test "gu (print (value=? 1 2))" \
+ "#f" "inequality"
+ gdb_test "gu (print (value=? (make-value 1) 1.0))" \
+ "#t" "equality of gdb:value with Guile value"
+ gdb_test "gu (print (value=? (make-value 1) 2))" \
+ "#f" "inequality of gdb:value with Guile value"
+
+ gdb_test "gu (print (value>? 1 1))" \
+ "#f" "greater than, equal"
+ gdb_test "gu (print (value>? 1 2))" \
+ "#f" "greater than, less"
+ gdb_test "gu (print (value>? 2 1))" \
+ "#t" "greater than, greater"
+
+ gdb_test "gu (print (value>=? 1 1))" \
+ "#t" "greater or equal, equal"
+ gdb_test "gu (print (value>=? 1 2))" \
+ "#f" "greater or equal, less"
+ gdb_test "gu (print (value>=? 2 1))" \
+ "#t" "greater or equal, greater"
+}
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile {debug c}]} {
+ return
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+test_value_numeric_ops
+test_value_numeric_ranges
+test_value_boolean
+test_value_compare