72e0248351
Building GDB in C++ mode on Fedora 20, the gdb/guile/ code shows ~280
errors like:
src/gdb/guile/guile.c:515:1: error: invalid conversion from ‘scm_unused_struct* (*)(SCM, SCM) {aka scm_unused_struct* (*)(scm_unused_struct*, scm_unused_struct*)}’ to ‘scm_t_subr {aka void*}’ [-fpermissive]
This commit fixes them all.
gdb/ChangeLog:
2015-09-07 Pedro Alves <palves@redhat.com>
* guile/guile-internal.h (as_a_scm_t_subr): New.
* guile/guile.c (misc_guile_functions): Use it.
* guile/scm-arch.c (arch_functions): Use it.
* guile/scm-block.c (block_functions, gdbscm_initialize_blocks):
Use it.
* guile/scm-breakpoint.c (breakpoint_functions): Use it.
* guile/scm-cmd.c (command_functions): Use it.
* guile/scm-disasm.c (disasm_functions): Use it.
* guile/scm-exception.c (exception_functions)
(private_exception_functions): Use it.
* guile/scm-frame.c (frame_functions)
* guile/scm-gsmob.c (gsmob_functions): Use it.
* guile/scm-iterator.c (iterator_functions): Use it.
* guile/scm-lazy-string.c (lazy_string_functions): Use it.
* guile/scm-math.c (math_functions): Use it.
* guile/scm-objfile.c (objfile_functions): Use it.
* guile/scm-param.c (parameter_functions): Use it.
* guile/scm-ports.c (port_functions, private_port_functions): Use
it.
* guile/scm-pretty-print.c (pretty_printer_functions): Use it.
* guile/scm-progspace.c (pspace_functions): Use it.
* guile/scm-string.c (string_functions): Use it.
* guile/scm-symbol.c (symbol_functions): Use it.
* guile/scm-symtab.c (symtab_functions): Use it.
* guile/scm-type.c (type_functions, gdbscm_initialize_types): Use
it.
* guile/scm-value.c (value_functions): Use it.
1011 lines
25 KiB
C
1011 lines
25 KiB
C
/* GDB/Scheme support for math operations on values.
|
||
|
||
Copyright (C) 2008-2015 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 "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;
|
||
|
||
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
|
||
{
|
||
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)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
|
||
}
|
||
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 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;
|
||
|
||
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
|
||
{
|
||
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:
|
||
{
|
||
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);
|
||
}
|
||
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);
|
||
}
|
||
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 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;
|
||
struct gdb_exception except = exception_none;
|
||
|
||
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
|
||
{
|
||
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");
|
||
}
|
||
}
|
||
CATCH (ex, RETURN_MASK_ALL)
|
||
{
|
||
except = ex;
|
||
}
|
||
END_CATCH
|
||
|
||
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;
|
||
|
||
if (type == NULL)
|
||
{
|
||
gdb_assert (type_arg_pos == -1);
|
||
gdb_assert (SCM_UNBNDP (type_scm));
|
||
}
|
||
|
||
*except_scmp = SCM_BOOL_F;
|
||
|
||
TRY
|
||
{
|
||
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;
|
||
}
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
except_scm = gdbscm_scm_from_gdb_exception (except);
|
||
}
|
||
END_CATCH
|
||
|
||
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, as_a_scm_t_subr (gdbscm_value_add),
|
||
"\
|
||
Return a + b." },
|
||
|
||
{ "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub),
|
||
"\
|
||
Return a - b." },
|
||
|
||
{ "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul),
|
||
"\
|
||
Return a * b." },
|
||
|
||
{ "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div),
|
||
"\
|
||
Return a / b." },
|
||
|
||
{ "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem),
|
||
"\
|
||
Return a % b." },
|
||
|
||
{ "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, as_a_scm_t_subr (gdbscm_value_pow),
|
||
"\
|
||
Return pow (x, y)." },
|
||
|
||
{ "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not),
|
||
"\
|
||
Return !a." },
|
||
|
||
{ "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg),
|
||
"\
|
||
Return -a." },
|
||
|
||
{ "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos),
|
||
"\
|
||
Return a." },
|
||
|
||
{ "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs),
|
||
"\
|
||
Return abs (a)." },
|
||
|
||
{ "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh),
|
||
"\
|
||
Return a << b." },
|
||
|
||
{ "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh),
|
||
"\
|
||
Return a >> b." },
|
||
|
||
{ "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min),
|
||
"\
|
||
Return min (a, b)." },
|
||
|
||
{ "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max),
|
||
"\
|
||
Return max (a, b)." },
|
||
|
||
{ "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot),
|
||
"\
|
||
Return ~a." },
|
||
|
||
{ "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand),
|
||
"\
|
||
Return a & b." },
|
||
|
||
{ "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior),
|
||
"\
|
||
Return a | b." },
|
||
|
||
{ "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor),
|
||
"\
|
||
Return a ^ b." },
|
||
|
||
{ "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p),
|
||
"\
|
||
Return a == b." },
|
||
|
||
{ "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p),
|
||
"\
|
||
Return a < b." },
|
||
|
||
{ "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p),
|
||
"\
|
||
Return a <= b." },
|
||
|
||
{ "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p),
|
||
"\
|
||
Return a > b." },
|
||
|
||
{ "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p),
|
||
"\
|
||
Return a >= b." },
|
||
|
||
END_FUNCTIONS
|
||
};
|
||
|
||
void
|
||
gdbscm_initialize_math (void)
|
||
{
|
||
gdbscm_define_functions (math_functions, 1);
|
||
}
|