mirror of
https://sourceware.org/git/binutils-gdb.git
synced 2025-03-07 13:39:43 +08:00
7022349d5c
The fact that GDB defaults to assuming that functions return int, when
it has no debug info for the function has been a recurring source of
user confusion. Recently this came up on the errno pretty printer
discussions. Shortly after, it came up again on IRC, with someone
wondering why does getenv() in GDB return a negative int:
(gdb) p getenv("PATH")
$1 = -6185
This question (with s/getenv/random-other-C-runtime-function) is a FAQ
on IRC.
The reason for the above is:
(gdb) p getenv
$2 = {<text variable, no debug info>} 0x7ffff7751d80 <getenv>
(gdb) ptype getenv
type = int ()
... which means that GDB truncated the 64-bit pointer that is actually
returned from getent to 32-bit, and then sign-extended it:
(gdb) p /x -6185
$6 = 0xffffe7d7
The workaround is to cast the function to the right type, like:
(gdb) p ((char *(*) (const char *)) getenv) ("PATH")
$3 = 0x7fffffffe7d7 "/usr/local/bin:/"...
IMO, we should do better than this.
I see the "assume-int" issue the same way I see printing bogus values
for optimized-out variables instead of "<optimized out>" -- I'd much
rather that the debugger tells me "I don't know" and tells me how to
fix it than showing me bogus misleading results, making me go around
tilting at windmills.
If GDB prints a signed integer when you're expecting a pointer or
aggregate, you at least have some sense that something is off, but
consider the case of the function actually returning a 64-bit integer.
For example, compile this without debug info:
unsigned long long
function ()
{
return 0x7fffffffffffffff;
}
Currently, with pristine GDB, you get:
(gdb) p function ()
$1 = -1 # incorrect
(gdb) p /x function ()
$2 = 0xffffffff # incorrect
maybe after spending a few hours debugging you suspect something is
wrong with that -1, and do:
(gdb) ptype function
type = int ()
and maybe, just maybe, you realize that the function actually returns
unsigned long long. And you try to fix it with:
(gdb) p /x (unsigned long long) function ()
$3 = 0xffffffffffffffff # incorrect
... which still produces the wrong result, because GDB simply applied
int to unsigned long long conversion. Meaning, it sign-extended the
integer that it extracted from the return of the function, to 64-bits.
and then maybe, after asking around on IRC, you realize you have to
cast the function to a pointer of the right type, and call that. It
won't be easy, but after a few missteps, you'll get to it:
..... (gdb) p /x ((unsigned long long(*) ()) function) ()
$666 = 0x7fffffffffffffff # finally! :-)
So to improve on the user experience, this patch does the following
(interrelated) things:
- makes no-debug-info functions no longer default to "int" as return
type. Instead, they're left with NULL/"<unknown return type>"
return type.
(gdb) ptype getenv
type = <unknown return type> ()
- makes calling a function with unknown return type an error.
(gdb) p getenv ("PATH")
'getenv' has unknown return type; cast the call to its declared return type
- and then to make it easier to call the function, makes it possible
to _only_ cast the return of the function to the right type,
instead of having to cast the function to a function pointer:
(gdb) p (char *) getenv ("PATH") # now Just Works
$3 = 0x7fffffffe7d7 "/usr/local/bin:/"...
(gdb) p ((char *(*) (const char *)) getenv) ("PATH") # continues working
$4 = 0x7fffffffe7d7 "/usr/local/bin:/"...
I.e., it makes GDB default the function's return type to the type
of the cast, and the function's parameters to the type of the
arguments passed down.
After this patch, here's what you'll get for the "unsigned long long"
example above:
(gdb) p function ()
'function' has unknown return type; cast the call to its declared return type
(gdb) p /x (unsigned long long) function ()
$4 = 0x7fffffffffffffff # correct!
Note that while with "print" GDB shows the name of the function that
has the problem:
(gdb) p getenv ("PATH")
'getenv' has unknown return type; cast the call to its declared return type
which can by handy in more complicated expressions, "ptype" does not:
(gdb) ptype getenv ("PATH")
function has unknown return type; cast the call to its declared return type
This will be fixed in the next patch.
gdb/ChangeLog:
2017-09-04 Pedro Alves <palves@redhat.com>
* ada-lang.c (ada_evaluate_subexp) <TYPE_CODE_FUNC>: Don't handle
TYPE_GNU_IFUNC specially here. Throw error if return type is
unknown.
* ada-typeprint.c (print_func_type): Handle functions with unknown
return type.
* c-typeprint.c (c_type_print_base): Handle functions and methods
with unknown return type.
* compile/compile-c-symbols.c (convert_symbol_bmsym)
<mst_text_gnu_ifunc>: Use nodebug_text_gnu_ifunc_symbol.
* compile/compile-c-types.c: Include "objfiles.h".
(convert_func): For functions with unknown return type, warn and
default to int.
* compile/compile-object-run.c (compile_object_run): Adjust call
to call_function_by_hand_dummy.
* elfread.c (elf_gnu_ifunc_resolve_addr): Adjust call to
call_function_by_hand.
* eval.c (evaluate_subexp_standard): Adjust calls to
call_function_by_hand. Handle functions and methods with unknown
return type. Pass expect_type to call_function_by_hand.
* f-typeprint.c (f_type_print_base): Handle functions with unknown
return type.
* gcore.c (call_target_sbrk): Adjust call to
call_function_by_hand.
* gdbtypes.c (objfile_type): Leave nodebug text symbol with NULL
return type instead of int. Make nodebug_text_gnu_ifunc_symbol be
an integer address type instead of nodebug.
* guile/scm-value.c (gdbscm_value_call): Adjust call to
call_function_by_hand.
* infcall.c (error_call_unknown_return_type): New function.
(call_function_by_hand): New "default_return_type" parameter.
Pass it down.
(call_function_by_hand_dummy): New "default_return_type"
parameter. Use it instead of defaulting to int. If there's no
default and the return type is unknown, throw an error. If
there's a default return type, and the called function has no
debug info, then assume the function is prototyped.
* infcall.h (call_function_by_hand, call_function_by_hand_dummy):
New "default_return_type" parameter.
(error_call_unknown_return_type): New declaration.
* linux-fork.c (call_lseek): Cast return type of lseek.
(inferior_call_waitpid, checkpoint_command): Adjust calls to
call_function_by_hand.
* linux-tdep.c (linux_infcall_mmap, linux_infcall_munmap): Adjust
calls to call_function_by_hand.
* m2-typeprint.c (m2_procedure): Handle functions with unknown
return type.
* objc-lang.c (lookup_objc_class, lookup_child_selector)
(value_nsstring, print_object_command): Adjust calls to
call_function_by_hand.
* p-typeprint.c (pascal_type_print_varspec_prefix): Handle
functions with unknown return type.
(pascal_type_print_func_varspec_suffix): New function.
(pascal_type_print_varspec_suffix) <TYPE_CODE_FUNC,
TYPE_CODE_METHOD>: Use it.
* python/py-value.c (valpy_call): Adjust call to
call_function_by_hand.
* rust-lang.c (rust_evaluate_funcall): Adjust call to
call_function_by_hand.
* valarith.c (value_x_binop, value_x_unop): Adjust calls to
call_function_by_hand.
* valops.c (value_allocate_space_in_inferior): Adjust call to
call_function_by_hand.
* typeprint.c (type_print_unknown_return_type): New function.
* typeprint.h (type_print_unknown_return_type): New declaration.
gdb/testsuite/ChangeLog:
2017-09-04 Pedro Alves <palves@redhat.com>
* gdb.base/break-main-file-remove-fail.exp (test_remove_bp): Cast
return type of munmap in infcall.
* gdb.base/break-probes.exp: Cast return type of foo in infcall.
* gdb.base/checkpoint.exp: Simplify using for loop. Cast return
type of ftell in infcall.
* gdb.base/dprintf-detach.exp (dprintf_detach_test): Cast return
type of getpid in infcall.
* gdb.base/infcall-exec.exp: Cast return type of execlp in
infcall.
* gdb.base/info-os.exp: Cast return type of getpid in infcall.
Bail on failure to extract the pid.
* gdb.base/nodebug.c: #include <stdint.h>.
(multf, multf_noproto, mult, mult_noproto, add8, add8_noproto):
New functions.
* gdb.base/nodebug.exp (test_call_promotion): New procedure.
Change expected output of print/whatis/ptype with functions with
no debug info. Test all supported languages. Call
test_call_promotion.
* gdb.compile/compile.exp: Adjust expected output to expect
warning.
* gdb.threads/siginfo-threads.exp: Likewise.
1636 lines
42 KiB
C
1636 lines
42 KiB
C
/* Scheme interface to values.
|
||
|
||
Copyright (C) 2008-2017 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 "infcall.h"
|
||
#include "symtab.h" /* Needed by language.h. */
|
||
#include "language.h"
|
||
#include "valprint.h"
|
||
#include "value.h"
|
||
#include "guile-internal.h"
|
||
|
||
/* The <gdb:value> smob. */
|
||
|
||
typedef struct _value_smob
|
||
{
|
||
/* This always appears first. */
|
||
gdb_smob base;
|
||
|
||
/* Doubly linked list of values in values_in_scheme.
|
||
IWBN to use a chained_gdb_smob instead, which is doable, it just requires
|
||
a bit more casting than normal. */
|
||
struct _value_smob *next;
|
||
struct _value_smob *prev;
|
||
|
||
struct value *value;
|
||
|
||
/* These are cached here to avoid making multiple copies of them.
|
||
Plus computing the dynamic_type can be a bit expensive.
|
||
We use #f to indicate that the value doesn't exist (e.g. value doesn't
|
||
have an address), so we need another value to indicate that we haven't
|
||
computed the value yet. For this we use SCM_UNDEFINED. */
|
||
SCM address;
|
||
SCM type;
|
||
SCM dynamic_type;
|
||
} value_smob;
|
||
|
||
static const char value_smob_name[] = "gdb:value";
|
||
|
||
/* The tag Guile knows the value smob by. */
|
||
static scm_t_bits value_smob_tag;
|
||
|
||
/* List of all values which are currently exposed to Scheme. It is
|
||
maintained so that when an objfile is discarded, preserve_values
|
||
can copy the values' types if needed. */
|
||
static value_smob *values_in_scheme;
|
||
|
||
/* Keywords used by Scheme procedures in this file. */
|
||
static SCM type_keyword;
|
||
static SCM encoding_keyword;
|
||
static SCM errors_keyword;
|
||
static SCM length_keyword;
|
||
|
||
/* Possible #:errors values. */
|
||
static SCM error_symbol;
|
||
static SCM escape_symbol;
|
||
static SCM substitute_symbol;
|
||
|
||
/* Administrivia for value smobs. */
|
||
|
||
/* Iterate over all the <gdb:value> objects, calling preserve_one_value on
|
||
each.
|
||
This is the extension_language_ops.preserve_values "method". */
|
||
|
||
void
|
||
gdbscm_preserve_values (const struct extension_language_defn *extlang,
|
||
struct objfile *objfile, htab_t copied_types)
|
||
{
|
||
value_smob *iter;
|
||
|
||
for (iter = values_in_scheme; iter; iter = iter->next)
|
||
preserve_one_value (iter->value, objfile, copied_types);
|
||
}
|
||
|
||
/* Helper to add a value_smob to the global list. */
|
||
|
||
static void
|
||
vlscm_remember_scheme_value (value_smob *v_smob)
|
||
{
|
||
v_smob->next = values_in_scheme;
|
||
if (v_smob->next)
|
||
v_smob->next->prev = v_smob;
|
||
v_smob->prev = NULL;
|
||
values_in_scheme = v_smob;
|
||
}
|
||
|
||
/* Helper to remove a value_smob from the global list. */
|
||
|
||
static void
|
||
vlscm_forget_value_smob (value_smob *v_smob)
|
||
{
|
||
/* Remove SELF from the global list. */
|
||
if (v_smob->prev)
|
||
v_smob->prev->next = v_smob->next;
|
||
else
|
||
{
|
||
gdb_assert (values_in_scheme == v_smob);
|
||
values_in_scheme = v_smob->next;
|
||
}
|
||
if (v_smob->next)
|
||
v_smob->next->prev = v_smob->prev;
|
||
}
|
||
|
||
/* The smob "free" function for <gdb:value>. */
|
||
|
||
static size_t
|
||
vlscm_free_value_smob (SCM self)
|
||
{
|
||
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
|
||
|
||
vlscm_forget_value_smob (v_smob);
|
||
value_free (v_smob->value);
|
||
|
||
return 0;
|
||
}
|
||
|
||
/* The smob "print" function for <gdb:value>. */
|
||
|
||
static int
|
||
vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
|
||
{
|
||
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
|
||
struct value_print_options opts;
|
||
|
||
if (pstate->writingp)
|
||
gdbscm_printf (port, "#<%s ", value_smob_name);
|
||
|
||
get_user_print_options (&opts);
|
||
opts.deref_ref = 0;
|
||
|
||
/* pstate->writingp = zero if invoked by display/~A, and nonzero if
|
||
invoked by write/~S. What to do here may need to evolve.
|
||
IWBN if we could pass an argument to format that would we could use
|
||
instead of writingp. */
|
||
opts.raw = !!pstate->writingp;
|
||
|
||
TRY
|
||
{
|
||
string_file stb;
|
||
|
||
common_val_print (v_smob->value, &stb, 0, &opts, current_language);
|
||
scm_puts (stb.c_str (), port);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
if (pstate->writingp)
|
||
scm_puts (">", port);
|
||
|
||
scm_remember_upto_here_1 (self);
|
||
|
||
/* Non-zero means success. */
|
||
return 1;
|
||
}
|
||
|
||
/* The smob "equalp" function for <gdb:value>. */
|
||
|
||
static SCM
|
||
vlscm_equal_p_value_smob (SCM v1, SCM v2)
|
||
{
|
||
const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
|
||
const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
|
||
int result = 0;
|
||
|
||
TRY
|
||
{
|
||
result = value_equal (v1_smob->value, v2_smob->value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return scm_from_bool (result);
|
||
}
|
||
|
||
/* Low level routine to create a <gdb:value> object. */
|
||
|
||
static SCM
|
||
vlscm_make_value_smob (void)
|
||
{
|
||
value_smob *v_smob = (value_smob *)
|
||
scm_gc_malloc (sizeof (value_smob), value_smob_name);
|
||
SCM v_scm;
|
||
|
||
/* These must be filled in by the caller. */
|
||
v_smob->value = NULL;
|
||
v_smob->prev = NULL;
|
||
v_smob->next = NULL;
|
||
|
||
/* These are lazily computed. */
|
||
v_smob->address = SCM_UNDEFINED;
|
||
v_smob->type = SCM_UNDEFINED;
|
||
v_smob->dynamic_type = SCM_UNDEFINED;
|
||
|
||
v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
|
||
gdbscm_init_gsmob (&v_smob->base);
|
||
|
||
return v_scm;
|
||
}
|
||
|
||
/* Return non-zero if SCM is a <gdb:value> object. */
|
||
|
||
int
|
||
vlscm_is_value (SCM scm)
|
||
{
|
||
return SCM_SMOB_PREDICATE (value_smob_tag, scm);
|
||
}
|
||
|
||
/* (value? object) -> boolean */
|
||
|
||
static SCM
|
||
gdbscm_value_p (SCM scm)
|
||
{
|
||
return scm_from_bool (vlscm_is_value (scm));
|
||
}
|
||
|
||
/* Create a new <gdb:value> object that encapsulates VALUE.
|
||
The value is released from the all_values chain so its lifetime is not
|
||
bound to the execution of a command. */
|
||
|
||
SCM
|
||
vlscm_scm_from_value (struct value *value)
|
||
{
|
||
/* N.B. It's important to not cause any side-effects until we know the
|
||
conversion worked. */
|
||
SCM v_scm = vlscm_make_value_smob ();
|
||
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
|
||
|
||
v_smob->value = value;
|
||
release_value_or_incref (value);
|
||
vlscm_remember_scheme_value (v_smob);
|
||
|
||
return v_scm;
|
||
}
|
||
|
||
/* Returns the <gdb:value> object in SELF.
|
||
Throws an exception if SELF is not a <gdb:value> object. */
|
||
|
||
static SCM
|
||
vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
|
||
{
|
||
SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
|
||
value_smob_name);
|
||
|
||
return self;
|
||
}
|
||
|
||
/* Returns a pointer to the value smob of SELF.
|
||
Throws an exception if SELF is not a <gdb:value> object. */
|
||
|
||
static value_smob *
|
||
vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
|
||
{
|
||
SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
|
||
value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
|
||
|
||
return v_smob;
|
||
}
|
||
|
||
/* Return the value field of V_SCM, an object of type <gdb:value>.
|
||
This exists so that we don't have to export the struct's contents. */
|
||
|
||
struct value *
|
||
vlscm_scm_to_value (SCM v_scm)
|
||
{
|
||
value_smob *v_smob;
|
||
|
||
gdb_assert (vlscm_is_value (v_scm));
|
||
v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
|
||
return v_smob->value;
|
||
}
|
||
|
||
/* Value methods. */
|
||
|
||
/* (make-value x [#:type type]) -> <gdb:value> */
|
||
|
||
static SCM
|
||
gdbscm_make_value (SCM x, SCM rest)
|
||
{
|
||
struct gdbarch *gdbarch = get_current_arch ();
|
||
const struct language_defn *language = current_language;
|
||
const SCM keywords[] = { type_keyword, SCM_BOOL_F };
|
||
int type_arg_pos = -1;
|
||
SCM type_scm = SCM_UNDEFINED;
|
||
SCM except_scm, result;
|
||
type_smob *t_smob;
|
||
struct type *type = NULL;
|
||
struct value *value;
|
||
struct cleanup *cleanups;
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
|
||
&type_arg_pos, &type_scm);
|
||
|
||
if (type_arg_pos > 0)
|
||
{
|
||
t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
|
||
FUNC_NAME);
|
||
type = tyscm_type_smob_type (t_smob);
|
||
}
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
|
||
type_arg_pos, type_scm, type,
|
||
&except_scm,
|
||
gdbarch, language);
|
||
if (value == NULL)
|
||
{
|
||
do_cleanups (cleanups);
|
||
gdbscm_throw (except_scm);
|
||
}
|
||
|
||
result = vlscm_scm_from_value (value);
|
||
|
||
do_cleanups (cleanups);
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
return result;
|
||
}
|
||
|
||
/* (make-lazy-value <gdb:type> address) -> <gdb:value> */
|
||
|
||
static SCM
|
||
gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
|
||
{
|
||
type_smob *t_smob;
|
||
struct type *type;
|
||
ULONGEST address;
|
||
struct value *value = NULL;
|
||
SCM result;
|
||
struct cleanup *cleanups;
|
||
|
||
t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
|
||
type = tyscm_type_smob_type (t_smob);
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
|
||
address_scm, &address);
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
/* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
|
||
and future-proofing we do. */
|
||
TRY
|
||
{
|
||
value = value_from_contents_and_address (type, NULL, address);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
|
||
}
|
||
END_CATCH
|
||
|
||
result = vlscm_scm_from_value (value);
|
||
|
||
do_cleanups (cleanups);
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
return result;
|
||
}
|
||
|
||
/* (value-optimized-out? <gdb:value>) -> boolean */
|
||
|
||
static SCM
|
||
gdbscm_value_optimized_out_p (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
int opt = 0;
|
||
|
||
TRY
|
||
{
|
||
opt = value_optimized_out (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return scm_from_bool (opt);
|
||
}
|
||
|
||
/* (value-address <gdb:value>) -> integer
|
||
Returns #f if the value doesn't have one. */
|
||
|
||
static SCM
|
||
gdbscm_value_address (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
|
||
if (SCM_UNBNDP (v_smob->address))
|
||
{
|
||
struct value *res_val = NULL;
|
||
struct cleanup *cleanup
|
||
= make_cleanup_value_free_to_mark (value_mark ());
|
||
SCM address;
|
||
|
||
TRY
|
||
{
|
||
res_val = value_addr (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
address = SCM_BOOL_F;
|
||
}
|
||
END_CATCH
|
||
|
||
if (res_val != NULL)
|
||
address = vlscm_scm_from_value (res_val);
|
||
|
||
do_cleanups (cleanup);
|
||
|
||
if (gdbscm_is_exception (address))
|
||
gdbscm_throw (address);
|
||
|
||
v_smob->address = address;
|
||
}
|
||
|
||
return v_smob->address;
|
||
}
|
||
|
||
/* (value-dereference <gdb:value>) -> <gdb:value>
|
||
Given a value of a pointer type, apply the C unary * operator to it. */
|
||
|
||
static SCM
|
||
gdbscm_value_dereference (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
SCM result;
|
||
struct value *res_val = NULL;
|
||
struct cleanup *cleanups;
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
TRY
|
||
{
|
||
res_val = value_ind (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
|
||
}
|
||
END_CATCH
|
||
|
||
result = vlscm_scm_from_value (res_val);
|
||
|
||
do_cleanups (cleanups);
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
|
||
return result;
|
||
}
|
||
|
||
/* (value-referenced-value <gdb:value>) -> <gdb:value>
|
||
Given a value of a reference type, return the value referenced.
|
||
The difference between this function and gdbscm_value_dereference is that
|
||
the latter applies * unary operator to a value, which need not always
|
||
result in the value referenced.
|
||
For example, for a value which is a reference to an 'int' pointer ('int *'),
|
||
gdbscm_value_dereference will result in a value of type 'int' while
|
||
gdbscm_value_referenced_value will result in a value of type 'int *'. */
|
||
|
||
static SCM
|
||
gdbscm_value_referenced_value (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
SCM result;
|
||
struct value *res_val = NULL;
|
||
struct cleanup *cleanups;
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
TRY
|
||
{
|
||
switch (TYPE_CODE (check_typedef (value_type (value))))
|
||
{
|
||
case TYPE_CODE_PTR:
|
||
res_val = value_ind (value);
|
||
break;
|
||
case TYPE_CODE_REF:
|
||
res_val = coerce_ref (value);
|
||
break;
|
||
default:
|
||
error (_("Trying to get the referenced value from a value which is"
|
||
" neither a pointer nor a reference"));
|
||
}
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
|
||
}
|
||
END_CATCH
|
||
|
||
result = vlscm_scm_from_value (res_val);
|
||
|
||
do_cleanups (cleanups);
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
|
||
return result;
|
||
}
|
||
|
||
/* (value-type <gdb:value>) -> <gdb:type> */
|
||
|
||
static SCM
|
||
gdbscm_value_type (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
|
||
if (SCM_UNBNDP (v_smob->type))
|
||
v_smob->type = tyscm_scm_from_type (value_type (value));
|
||
|
||
return v_smob->type;
|
||
}
|
||
|
||
/* (value-dynamic-type <gdb:value>) -> <gdb:type> */
|
||
|
||
static SCM
|
||
gdbscm_value_dynamic_type (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct type *type = NULL;
|
||
|
||
if (! SCM_UNBNDP (v_smob->dynamic_type))
|
||
return v_smob->dynamic_type;
|
||
|
||
TRY
|
||
{
|
||
struct cleanup *cleanup
|
||
= make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
type = value_type (value);
|
||
type = check_typedef (type);
|
||
|
||
if (((TYPE_CODE (type) == TYPE_CODE_PTR)
|
||
|| (TYPE_CODE (type) == TYPE_CODE_REF))
|
||
&& (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRUCT))
|
||
{
|
||
struct value *target;
|
||
int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
|
||
|
||
if (was_pointer)
|
||
target = value_ind (value);
|
||
else
|
||
target = coerce_ref (value);
|
||
type = value_rtti_type (target, NULL, NULL, NULL);
|
||
|
||
if (type)
|
||
{
|
||
if (was_pointer)
|
||
type = lookup_pointer_type (type);
|
||
else
|
||
type = lookup_lvalue_reference_type (type);
|
||
}
|
||
}
|
||
else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
|
||
type = value_rtti_type (value, NULL, NULL, NULL);
|
||
else
|
||
{
|
||
/* Re-use object's static type. */
|
||
type = NULL;
|
||
}
|
||
|
||
do_cleanups (cleanup);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
if (type == NULL)
|
||
v_smob->dynamic_type = gdbscm_value_type (self);
|
||
else
|
||
v_smob->dynamic_type = tyscm_scm_from_type (type);
|
||
|
||
return v_smob->dynamic_type;
|
||
}
|
||
|
||
/* A helper function that implements the various cast operators. */
|
||
|
||
static SCM
|
||
vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
|
||
const char *func_name)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
type_smob *t_smob
|
||
= tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
|
||
struct type *type = tyscm_type_smob_type (t_smob);
|
||
SCM result;
|
||
struct value *res_val = NULL;
|
||
struct cleanup *cleanups;
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
TRY
|
||
{
|
||
if (op == UNOP_DYNAMIC_CAST)
|
||
res_val = value_dynamic_cast (type, value);
|
||
else if (op == UNOP_REINTERPRET_CAST)
|
||
res_val = value_reinterpret_cast (type, value);
|
||
else
|
||
{
|
||
gdb_assert (op == UNOP_CAST);
|
||
res_val = value_cast (type, value);
|
||
}
|
||
}
|
||
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-cast <gdb:value> <gdb:type>) -> <gdb:value> */
|
||
|
||
static SCM
|
||
gdbscm_value_cast (SCM self, SCM new_type)
|
||
{
|
||
return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
|
||
}
|
||
|
||
/* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
|
||
|
||
static SCM
|
||
gdbscm_value_dynamic_cast (SCM self, SCM new_type)
|
||
{
|
||
return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
|
||
}
|
||
|
||
/* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
|
||
|
||
static SCM
|
||
gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
|
||
{
|
||
return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
|
||
}
|
||
|
||
/* (value-field <gdb:value> string) -> <gdb:value>
|
||
Given string name of an element inside structure, return its <gdb:value>
|
||
object. */
|
||
|
||
static SCM
|
||
gdbscm_value_field (SCM self, SCM field_scm)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
char *field = NULL;
|
||
struct value *res_val = NULL;
|
||
SCM result;
|
||
struct cleanup *cleanups;
|
||
|
||
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
|
||
_("string"));
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
field = gdbscm_scm_to_c_string (field_scm);
|
||
make_cleanup (xfree, field);
|
||
|
||
TRY
|
||
{
|
||
struct value *tmp = value;
|
||
|
||
res_val = value_struct_elt (&tmp, NULL, field, NULL,
|
||
"struct/class/union");
|
||
}
|
||
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-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
|
||
Return the specified value in an array. */
|
||
|
||
static SCM
|
||
gdbscm_value_subscript (SCM self, SCM index_scm)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct value *index = NULL;
|
||
struct value *res_val = NULL;
|
||
struct type *type = value_type (value);
|
||
struct gdbarch *gdbarch;
|
||
SCM result, except_scm;
|
||
struct cleanup *cleanups;
|
||
|
||
/* The sequencing here, as everywhere else, is important.
|
||
We can't have existing cleanups when a Scheme exception is thrown. */
|
||
|
||
SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
|
||
gdbarch = get_type_arch (type);
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
|
||
index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
|
||
&except_scm,
|
||
gdbarch, current_language);
|
||
if (index == NULL)
|
||
{
|
||
do_cleanups (cleanups);
|
||
gdbscm_throw (except_scm);
|
||
}
|
||
|
||
TRY
|
||
{
|
||
struct value *tmp = value;
|
||
|
||
/* Assume we are attempting an array access, and let the value code
|
||
throw an exception if the index has an invalid type.
|
||
Check the value's type is something that can be accessed via
|
||
a subscript. */
|
||
tmp = coerce_ref (tmp);
|
||
type = check_typedef (value_type (tmp));
|
||
if (TYPE_CODE (type) != TYPE_CODE_ARRAY
|
||
&& TYPE_CODE (type) != TYPE_CODE_PTR)
|
||
error (_("Cannot subscript requested type"));
|
||
|
||
res_val = value_subscript (tmp, value_as_long (index));
|
||
}
|
||
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-call <gdb:value> arg-list) -> <gdb:value>
|
||
Perform an inferior function call on the value. */
|
||
|
||
static SCM
|
||
gdbscm_value_call (SCM self, SCM args)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *function = v_smob->value;
|
||
struct value *mark = value_mark ();
|
||
struct type *ftype = NULL;
|
||
long args_count;
|
||
struct value **vargs = NULL;
|
||
SCM result = SCM_BOOL_F;
|
||
|
||
TRY
|
||
{
|
||
ftype = check_typedef (value_type (function));
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
|
||
SCM_ARG1, FUNC_NAME,
|
||
_("function (value of TYPE_CODE_FUNC)"));
|
||
|
||
SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
|
||
SCM_ARG2, FUNC_NAME, _("list"));
|
||
|
||
args_count = scm_ilength (args);
|
||
if (args_count > 0)
|
||
{
|
||
struct gdbarch *gdbarch = get_current_arch ();
|
||
const struct language_defn *language = current_language;
|
||
SCM except_scm;
|
||
long i;
|
||
|
||
vargs = XALLOCAVEC (struct value *, args_count);
|
||
for (i = 0; i < args_count; i++)
|
||
{
|
||
SCM arg = scm_car (args);
|
||
|
||
vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
|
||
GDBSCM_ARG_NONE, arg,
|
||
&except_scm,
|
||
gdbarch, language);
|
||
if (vargs[i] == NULL)
|
||
gdbscm_throw (except_scm);
|
||
|
||
args = scm_cdr (args);
|
||
}
|
||
gdb_assert (gdbscm_is_true (scm_null_p (args)));
|
||
}
|
||
|
||
TRY
|
||
{
|
||
struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
|
||
struct value *return_value;
|
||
|
||
return_value = call_function_by_hand (function, NULL, args_count, vargs);
|
||
result = vlscm_scm_from_value (return_value);
|
||
do_cleanups (cleanup);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
|
||
return result;
|
||
}
|
||
|
||
/* (value->bytevector <gdb:value>) -> bytevector */
|
||
|
||
static SCM
|
||
gdbscm_value_to_bytevector (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct type *type;
|
||
size_t length = 0;
|
||
const gdb_byte *contents = NULL;
|
||
SCM bv;
|
||
|
||
type = value_type (value);
|
||
|
||
TRY
|
||
{
|
||
type = check_typedef (type);
|
||
length = TYPE_LENGTH (type);
|
||
contents = value_contents (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
bv = scm_c_make_bytevector (length);
|
||
memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
|
||
|
||
return bv;
|
||
}
|
||
|
||
/* Helper function to determine if a type is "int-like". */
|
||
|
||
static int
|
||
is_intlike (struct type *type, int ptr_ok)
|
||
{
|
||
return (TYPE_CODE (type) == TYPE_CODE_INT
|
||
|| TYPE_CODE (type) == TYPE_CODE_ENUM
|
||
|| TYPE_CODE (type) == TYPE_CODE_BOOL
|
||
|| TYPE_CODE (type) == TYPE_CODE_CHAR
|
||
|| (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
|
||
}
|
||
|
||
/* (value->bool <gdb:value>) -> boolean
|
||
Throws an error if the value is not integer-like. */
|
||
|
||
static SCM
|
||
gdbscm_value_to_bool (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct type *type;
|
||
LONGEST l = 0;
|
||
|
||
type = value_type (value);
|
||
|
||
TRY
|
||
{
|
||
type = check_typedef (type);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
|
||
_("integer-like gdb value"));
|
||
|
||
TRY
|
||
{
|
||
if (TYPE_CODE (type) == TYPE_CODE_PTR)
|
||
l = value_as_address (value);
|
||
else
|
||
l = value_as_long (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return scm_from_bool (l != 0);
|
||
}
|
||
|
||
/* (value->integer <gdb:value>) -> integer
|
||
Throws an error if the value is not integer-like. */
|
||
|
||
static SCM
|
||
gdbscm_value_to_integer (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct type *type;
|
||
LONGEST l = 0;
|
||
|
||
type = value_type (value);
|
||
|
||
TRY
|
||
{
|
||
type = check_typedef (type);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
|
||
_("integer-like gdb value"));
|
||
|
||
TRY
|
||
{
|
||
if (TYPE_CODE (type) == TYPE_CODE_PTR)
|
||
l = value_as_address (value);
|
||
else
|
||
l = value_as_long (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
if (TYPE_UNSIGNED (type))
|
||
return gdbscm_scm_from_ulongest (l);
|
||
else
|
||
return gdbscm_scm_from_longest (l);
|
||
}
|
||
|
||
/* (value->real <gdb:value>) -> real
|
||
Throws an error if the value is not a number. */
|
||
|
||
static SCM
|
||
gdbscm_value_to_real (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct type *type;
|
||
DOUBLEST d = 0;
|
||
|
||
type = value_type (value);
|
||
|
||
TRY
|
||
{
|
||
type = check_typedef (type);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
|
||
self, SCM_ARG1, FUNC_NAME, _("number"));
|
||
|
||
TRY
|
||
{
|
||
d = value_as_double (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
/* TODO: Is there a better way to check if the value fits? */
|
||
if (d != (double) d)
|
||
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
|
||
_("number can't be converted to a double"));
|
||
|
||
return scm_from_double (d);
|
||
}
|
||
|
||
/* (value->string <gdb:value>
|
||
[#:encoding encoding]
|
||
[#:errors #f | 'error | 'substitute]
|
||
[#:length length])
|
||
-> string
|
||
Return Unicode string with value's contents, which must be a string.
|
||
|
||
If ENCODING is not given, the string is assumed to be encoded in
|
||
the target's charset.
|
||
|
||
ERRORS is one of #f, 'error or 'substitute.
|
||
An error setting of #f means use the default, which is Guile's
|
||
%default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
|
||
using an earlier version of Guile. Earlier versions do not properly
|
||
support obtaining the default port conversion strategy.
|
||
If the default is not one of 'error or 'substitute, 'substitute is used.
|
||
An error setting of "error" causes an exception to be thrown if there's
|
||
a decoding error. An error setting of "substitute" causes invalid
|
||
characters to be replaced with "?".
|
||
|
||
If LENGTH is provided, only fetch string to the length provided.
|
||
LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
|
||
|
||
static SCM
|
||
gdbscm_value_to_string (SCM self, SCM rest)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
const SCM keywords[] = {
|
||
encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
|
||
};
|
||
int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
|
||
char *encoding = NULL;
|
||
SCM errors = SCM_BOOL_F;
|
||
int length = -1;
|
||
gdb_byte *buffer = NULL;
|
||
const char *la_encoding = NULL;
|
||
struct type *char_type = NULL;
|
||
SCM result;
|
||
struct cleanup *cleanups;
|
||
|
||
/* The sequencing here, as everywhere else, is important.
|
||
We can't have existing cleanups when a Scheme exception is thrown. */
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
|
||
&encoding_arg_pos, &encoding,
|
||
&errors_arg_pos, &errors,
|
||
&length_arg_pos, &length);
|
||
|
||
cleanups = make_cleanup (xfree, encoding);
|
||
|
||
if (errors_arg_pos > 0
|
||
&& errors != SCM_BOOL_F
|
||
&& !scm_is_eq (errors, error_symbol)
|
||
&& !scm_is_eq (errors, substitute_symbol))
|
||
{
|
||
SCM excp
|
||
= gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
|
||
_("invalid error kind"));
|
||
|
||
do_cleanups (cleanups);
|
||
gdbscm_throw (excp);
|
||
}
|
||
if (errors == SCM_BOOL_F)
|
||
{
|
||
/* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
|
||
will throw a Scheme error when passed #f. */
|
||
if (gdbscm_guile_version_is_at_least (2, 0, 6))
|
||
errors = scm_port_conversion_strategy (SCM_BOOL_F);
|
||
else
|
||
errors = error_symbol;
|
||
}
|
||
/* We don't assume anything about the result of scm_port_conversion_strategy.
|
||
From this point on, if errors is not 'errors, use 'substitute. */
|
||
|
||
TRY
|
||
{
|
||
LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
|
||
}
|
||
END_CATCH
|
||
|
||
/* If errors is "error" scm_from_stringn may throw a Scheme exception.
|
||
Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
|
||
discard_cleanups (cleanups);
|
||
|
||
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
|
||
|
||
gdbscm_dynwind_xfree (encoding);
|
||
gdbscm_dynwind_xfree (buffer);
|
||
|
||
result = scm_from_stringn ((const char *) buffer,
|
||
length * TYPE_LENGTH (char_type),
|
||
(encoding != NULL && *encoding != '\0'
|
||
? encoding
|
||
: la_encoding),
|
||
scm_is_eq (errors, error_symbol)
|
||
? SCM_FAILED_CONVERSION_ERROR
|
||
: SCM_FAILED_CONVERSION_QUESTION_MARK);
|
||
|
||
scm_dynwind_end ();
|
||
|
||
return result;
|
||
}
|
||
|
||
/* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
|
||
-> <gdb:lazy-string>
|
||
Return a Scheme object representing a lazy_string_object type.
|
||
A lazy string is a pointer to a string with an optional encoding and length.
|
||
If ENCODING is not given, the target's charset is used.
|
||
If LENGTH is provided then the length parameter is set to LENGTH.
|
||
Otherwise if the value is an array of known length then the array's length
|
||
is used. Otherwise the length will be set to -1 (meaning first null of
|
||
appropriate with).
|
||
LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
|
||
|
||
static SCM
|
||
gdbscm_value_to_lazy_string (SCM self, SCM rest)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
|
||
int encoding_arg_pos = -1, length_arg_pos = -1;
|
||
char *encoding = NULL;
|
||
int length = -1;
|
||
SCM result = SCM_BOOL_F; /* -Wall */
|
||
struct cleanup *cleanups;
|
||
struct gdb_exception except = exception_none;
|
||
|
||
/* The sequencing here, as everywhere else, is important.
|
||
We can't have existing cleanups when a Scheme exception is thrown. */
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
|
||
&encoding_arg_pos, &encoding,
|
||
&length_arg_pos, &length);
|
||
|
||
if (length < -1)
|
||
{
|
||
gdbscm_out_of_range_error (FUNC_NAME, length_arg_pos,
|
||
scm_from_int (length),
|
||
_("invalid length"));
|
||
}
|
||
|
||
cleanups = make_cleanup (xfree, encoding);
|
||
|
||
TRY
|
||
{
|
||
struct cleanup *inner_cleanup
|
||
= make_cleanup_value_free_to_mark (value_mark ());
|
||
struct type *type, *realtype;
|
||
CORE_ADDR addr;
|
||
|
||
type = value_type (value);
|
||
realtype = check_typedef (type);
|
||
|
||
switch (TYPE_CODE (realtype))
|
||
{
|
||
case TYPE_CODE_ARRAY:
|
||
{
|
||
LONGEST array_length = -1;
|
||
LONGEST low_bound, high_bound;
|
||
|
||
/* PR 20786: There's no way to specify an array of length zero.
|
||
Record a length of [0,-1] which is how Ada does it. Anything
|
||
we do is broken, but this one possible solution. */
|
||
if (get_array_bounds (realtype, &low_bound, &high_bound))
|
||
array_length = high_bound - low_bound + 1;
|
||
if (length == -1)
|
||
length = array_length;
|
||
else if (array_length == -1)
|
||
{
|
||
type = lookup_array_range_type (TYPE_TARGET_TYPE (realtype),
|
||
0, length - 1);
|
||
}
|
||
else if (length != array_length)
|
||
{
|
||
/* We need to create a new array type with the
|
||
specified length. */
|
||
if (length > array_length)
|
||
error (_("length is larger than array size"));
|
||
type = lookup_array_range_type (TYPE_TARGET_TYPE (type),
|
||
low_bound,
|
||
low_bound + length - 1);
|
||
}
|
||
addr = value_address (value);
|
||
break;
|
||
}
|
||
case TYPE_CODE_PTR:
|
||
/* If a length is specified we defer creating an array of the
|
||
specified width until we need to. */
|
||
addr = value_as_address (value);
|
||
break;
|
||
default:
|
||
/* Should flag an error here. PR 20769. */
|
||
addr = value_address (value);
|
||
break;
|
||
}
|
||
|
||
result = lsscm_make_lazy_string (addr, length, encoding, type);
|
||
|
||
do_cleanups (inner_cleanup);
|
||
}
|
||
CATCH (ex, RETURN_MASK_ALL)
|
||
{
|
||
except = ex;
|
||
}
|
||
END_CATCH
|
||
|
||
do_cleanups (cleanups);
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
|
||
if (gdbscm_is_exception (result))
|
||
gdbscm_throw (result);
|
||
|
||
return result;
|
||
}
|
||
|
||
/* (value-lazy? <gdb:value>) -> boolean */
|
||
|
||
static SCM
|
||
gdbscm_value_lazy_p (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
|
||
return scm_from_bool (value_lazy (value));
|
||
}
|
||
|
||
/* (value-fetch-lazy! <gdb:value>) -> unspecified */
|
||
|
||
static SCM
|
||
gdbscm_value_fetch_lazy_x (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
|
||
TRY
|
||
{
|
||
if (value_lazy (value))
|
||
value_fetch_lazy (value);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
/* (value-print <gdb:value>) -> string */
|
||
|
||
static SCM
|
||
gdbscm_value_print (SCM self)
|
||
{
|
||
value_smob *v_smob
|
||
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
||
struct value *value = v_smob->value;
|
||
struct value_print_options opts;
|
||
|
||
get_user_print_options (&opts);
|
||
opts.deref_ref = 0;
|
||
|
||
string_file stb;
|
||
|
||
TRY
|
||
{
|
||
common_val_print (value, &stb, 0, &opts, current_language);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
/* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
|
||
throw an error if the encoding fails.
|
||
IWBN to use scm_take_locale_string here, but we'd have to temporarily
|
||
override the default port conversion handler because contrary to
|
||
documentation it doesn't necessarily free the input string. */
|
||
return scm_from_stringn (stb.c_str (), stb.size (), host_charset (),
|
||
SCM_FAILED_CONVERSION_QUESTION_MARK);
|
||
}
|
||
|
||
/* (parse-and-eval string) -> <gdb:value>
|
||
Parse a string and evaluate the string as an expression. */
|
||
|
||
static SCM
|
||
gdbscm_parse_and_eval (SCM expr_scm)
|
||
{
|
||
char *expr_str;
|
||
struct value *res_val = NULL;
|
||
SCM result;
|
||
struct cleanup *cleanups;
|
||
|
||
/* The sequencing here, as everywhere else, is important.
|
||
We can't have existing cleanups when a Scheme exception is thrown. */
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
|
||
expr_scm, &expr_str);
|
||
|
||
cleanups = make_cleanup_value_free_to_mark (value_mark ());
|
||
make_cleanup (xfree, expr_str);
|
||
|
||
TRY
|
||
{
|
||
res_val = parse_and_eval (expr_str);
|
||
}
|
||
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;
|
||
}
|
||
|
||
/* (history-ref integer) -> <gdb:value>
|
||
Return the specified value from GDB's value history. */
|
||
|
||
static SCM
|
||
gdbscm_history_ref (SCM index)
|
||
{
|
||
int i;
|
||
struct value *res_val = NULL; /* Initialize to appease gcc warning. */
|
||
|
||
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
|
||
|
||
TRY
|
||
{
|
||
res_val = access_value_history (i);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return vlscm_scm_from_value (res_val);
|
||
}
|
||
|
||
/* (history-append! <gdb:value>) -> index
|
||
Append VALUE to GDB's value history. Return its index in the history. */
|
||
|
||
static SCM
|
||
gdbscm_history_append_x (SCM value)
|
||
{
|
||
int res_index = -1;
|
||
struct value *v;
|
||
value_smob *v_smob;
|
||
|
||
v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
|
||
v = v_smob->value;
|
||
|
||
TRY
|
||
{
|
||
res_index = record_latest_value (v);
|
||
}
|
||
CATCH (except, RETURN_MASK_ALL)
|
||
{
|
||
GDBSCM_HANDLE_GDB_EXCEPTION (except);
|
||
}
|
||
END_CATCH
|
||
|
||
return scm_from_int (res_index);
|
||
}
|
||
|
||
/* Initialize the Scheme value code. */
|
||
|
||
static const scheme_function value_functions[] =
|
||
{
|
||
{ "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p),
|
||
"\
|
||
Return #t if the object is a <gdb:value> object." },
|
||
|
||
{ "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value),
|
||
"\
|
||
Create a <gdb:value> representing object.\n\
|
||
Typically this is used to convert numbers and strings to\n\
|
||
<gdb:value> objects.\n\
|
||
\n\
|
||
Arguments: object [#:type <gdb:type>]" },
|
||
|
||
{ "value-optimized-out?", 1, 0, 0,
|
||
as_a_scm_t_subr (gdbscm_value_optimized_out_p),
|
||
"\
|
||
Return #t if the value has been optimizd out." },
|
||
|
||
{ "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address),
|
||
"\
|
||
Return the address of the value." },
|
||
|
||
{ "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type),
|
||
"\
|
||
Return the type of the value." },
|
||
|
||
{ "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type),
|
||
"\
|
||
Return the dynamic type of the value." },
|
||
|
||
{ "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast),
|
||
"\
|
||
Cast the value to the supplied type.\n\
|
||
\n\
|
||
Arguments: <gdb:value> <gdb:type>" },
|
||
|
||
{ "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast),
|
||
"\
|
||
Cast the value to the supplied type, as if by the C++\n\
|
||
dynamic_cast operator.\n\
|
||
\n\
|
||
Arguments: <gdb:value> <gdb:type>" },
|
||
|
||
{ "value-reinterpret-cast", 2, 0, 0,
|
||
as_a_scm_t_subr (gdbscm_value_reinterpret_cast),
|
||
"\
|
||
Cast the value to the supplied type, as if by the C++\n\
|
||
reinterpret_cast operator.\n\
|
||
\n\
|
||
Arguments: <gdb:value> <gdb:type>" },
|
||
|
||
{ "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference),
|
||
"\
|
||
Return the result of applying the C unary * operator to the value." },
|
||
|
||
{ "value-referenced-value", 1, 0, 0,
|
||
as_a_scm_t_subr (gdbscm_value_referenced_value),
|
||
"\
|
||
Given a value of a reference type, return the value referenced.\n\
|
||
The difference between this function and value-dereference is that\n\
|
||
the latter applies * unary operator to a value, which need not always\n\
|
||
result in the value referenced.\n\
|
||
For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
|
||
value-dereference will result in a value of type 'int' while\n\
|
||
value-referenced-value will result in a value of type 'int *'." },
|
||
|
||
{ "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field),
|
||
"\
|
||
Return the specified field of the value.\n\
|
||
\n\
|
||
Arguments: <gdb:value> string" },
|
||
|
||
{ "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript),
|
||
"\
|
||
Return the value of the array at the specified index.\n\
|
||
\n\
|
||
Arguments: <gdb:value> integer" },
|
||
|
||
{ "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call),
|
||
"\
|
||
Perform an inferior function call taking the value as a pointer to the\n\
|
||
function to call.\n\
|
||
Each element of the argument list must be a <gdb:value> object or an object\n\
|
||
that can be converted to one.\n\
|
||
The result is the value returned by the function.\n\
|
||
\n\
|
||
Arguments: <gdb:value> arg-list" },
|
||
|
||
{ "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool),
|
||
"\
|
||
Return the Scheme boolean representing the GDB value.\n\
|
||
The value must be \"integer like\". Pointers are ok." },
|
||
|
||
{ "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer),
|
||
"\
|
||
Return the Scheme integer representing the GDB value.\n\
|
||
The value must be \"integer like\". Pointers are ok." },
|
||
|
||
{ "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real),
|
||
"\
|
||
Return the Scheme real number representing the GDB value.\n\
|
||
The value must be a number." },
|
||
|
||
{ "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector),
|
||
"\
|
||
Return a Scheme bytevector with the raw contents of the GDB value.\n\
|
||
No transformation, endian or otherwise, is performed." },
|
||
|
||
{ "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string),
|
||
"\
|
||
Return the Unicode string of the value's contents.\n\
|
||
If ENCODING is not given, the string is assumed to be encoded in\n\
|
||
the target's charset.\n\
|
||
An error setting \"error\" causes an exception to be thrown if there's\n\
|
||
a decoding error. An error setting of \"substitute\" causes invalid\n\
|
||
characters to be replaced with \"?\". The default is \"error\".\n\
|
||
If LENGTH is provided, only fetch string to the length provided.\n\
|
||
\n\
|
||
Arguments: <gdb:value>\n\
|
||
[#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
|
||
[#:length length]" },
|
||
|
||
{ "value->lazy-string", 1, 0, 1,
|
||
as_a_scm_t_subr (gdbscm_value_to_lazy_string),
|
||
"\
|
||
Return a Scheme object representing a lazily fetched Unicode string\n\
|
||
of the value's contents.\n\
|
||
If ENCODING is not given, the string is assumed to be encoded in\n\
|
||
the target's charset.\n\
|
||
If LENGTH is provided, only fetch string to the length provided.\n\
|
||
\n\
|
||
Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
|
||
|
||
{ "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p),
|
||
"\
|
||
Return #t if the value is lazy (not fetched yet from the inferior).\n\
|
||
A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
|
||
is called." },
|
||
|
||
{ "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value),
|
||
"\
|
||
Create a <gdb:value> that will be lazily fetched from the target.\n\
|
||
\n\
|
||
Arguments: <gdb:type> address" },
|
||
|
||
{ "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x),
|
||
"\
|
||
Fetch the value from the inferior, if it was lazy.\n\
|
||
The result is \"unspecified\"." },
|
||
|
||
{ "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print),
|
||
"\
|
||
Return the string representation (print form) of the value." },
|
||
|
||
{ "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval),
|
||
"\
|
||
Evaluates string in gdb and returns the result as a <gdb:value> object." },
|
||
|
||
{ "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref),
|
||
"\
|
||
Return the specified value from GDB's value history." },
|
||
|
||
{ "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x),
|
||
"\
|
||
Append the specified value onto GDB's value history." },
|
||
|
||
END_FUNCTIONS
|
||
};
|
||
|
||
void
|
||
gdbscm_initialize_values (void)
|
||
{
|
||
value_smob_tag = gdbscm_make_smob_type (value_smob_name,
|
||
sizeof (value_smob));
|
||
scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
|
||
scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
|
||
scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
|
||
|
||
gdbscm_define_functions (value_functions, 1);
|
||
|
||
type_keyword = scm_from_latin1_keyword ("type");
|
||
encoding_keyword = scm_from_latin1_keyword ("encoding");
|
||
errors_keyword = scm_from_latin1_keyword ("errors");
|
||
length_keyword = scm_from_latin1_keyword ("length");
|
||
|
||
error_symbol = scm_from_latin1_symbol ("error");
|
||
escape_symbol = scm_from_latin1_symbol ("escape");
|
||
substitute_symbol = scm_from_latin1_symbol ("substitute");
|
||
}
|