|
|
/* Scheme interface to values.
|
|
|
|
|
|
Copyright (C) 2008-2022 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 "target-float.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. */
|
|
|
|
|
|
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. */
|
|
|
value_smob *next;
|
|
|
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;
|
|
|
};
|
|
|
|
|
|
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_decref (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;
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
string_file stb;
|
|
|
|
|
|
common_val_print (v_smob->value, &stb, 0, &opts, current_language);
|
|
|
scm_puts (stb.c_str (), port);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
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;
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
result = value_equal (v1_smob->value, v2_smob->value);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
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 = release_value (value).release ();
|
|
|
vlscm_remember_scheme_value (v_smob);
|
|
|
|
|
|
return v_scm;
|
|
|
}
|
|
|
|
|
|
/* Create a new <gdb:value> object that encapsulates VALUE.
|
|
|
The value is not released from the all_values chain. */
|
|
|
|
|
|
SCM
|
|
|
vlscm_scm_from_value_no_release (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);
|
|
|
|
|
|
value_incref (value);
|
|
|
v_smob->value = 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)
|
|
|
{
|
|
|
const SCM keywords[] = { type_keyword, SCM_BOOL_F };
|
|
|
|
|
|
int type_arg_pos = -1;
|
|
|
SCM type_scm = SCM_UNDEFINED;
|
|
|
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
|
|
|
&type_arg_pos, &type_scm);
|
|
|
|
|
|
struct type *type = NULL;
|
|
|
if (type_arg_pos > 0)
|
|
|
{
|
|
|
type_smob *t_smob = tyscm_get_type_smob_arg_unsafe (type_scm,
|
|
|
type_arg_pos,
|
|
|
FUNC_NAME);
|
|
|
type = tyscm_type_smob_type (t_smob);
|
|
|
}
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
SCM except_scm;
|
|
|
struct value *value
|
|
|
= vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
|
|
|
type_arg_pos, type_scm, type,
|
|
|
&except_scm,
|
|
|
get_current_arch (),
|
|
|
current_language);
|
|
|
if (value == NULL)
|
|
|
return except_scm;
|
|
|
|
|
|
return vlscm_scm_from_value (value);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (make-lazy-value <gdb:type> address) -> <gdb:value> */
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
|
|
|
{
|
|
|
type_smob *t_smob = tyscm_get_type_smob_arg_unsafe (type_scm,
|
|
|
SCM_ARG1, FUNC_NAME);
|
|
|
struct type *type = tyscm_type_smob_type (t_smob);
|
|
|
|
|
|
ULONGEST address;
|
|
|
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
|
|
|
address_scm, &address);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *value = value_from_contents_and_address (type, NULL,
|
|
|
address);
|
|
|
return vlscm_scm_from_value (value);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
return scm_from_bool (value_optimized_out (v_smob->value));
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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;
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
if (SCM_UNBNDP (v_smob->address))
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
SCM address = SCM_BOOL_F;
|
|
|
|
|
|
try
|
|
|
{
|
|
|
address = vlscm_scm_from_value (value_addr (value));
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
}
|
|
|
|
|
|
if (gdbscm_is_exception (address))
|
|
|
return 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);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *res_val = value_ind (v_smob->value);
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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;
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *res_val;
|
|
|
|
|
|
switch (check_typedef (value_type (value))->code ())
|
|
|
{
|
|
|
case TYPE_CODE_PTR:
|
|
|
res_val = value_ind (value);
|
|
|
break;
|
|
|
case TYPE_CODE_REF:
|
|
|
case TYPE_CODE_RVALUE_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"));
|
|
|
}
|
|
|
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_reference_value (SCM self, enum type_code refcode)
|
|
|
{
|
|
|
value_smob *v_smob
|
|
|
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
|
|
struct value *value = v_smob->value;
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *res_val = value_ref (value, refcode);
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (value-reference-value <gdb:value>) -> <gdb:value> */
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_value_reference_value (SCM self)
|
|
|
{
|
|
|
return gdbscm_reference_value (self, TYPE_CODE_REF);
|
|
|
}
|
|
|
|
|
|
/* (value-rvalue-reference-value <gdb:value>) -> <gdb:value> */
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_value_rvalue_reference_value (SCM self)
|
|
|
{
|
|
|
return gdbscm_reference_value (self, TYPE_CODE_RVALUE_REF);
|
|
|
}
|
|
|
|
|
|
/* (value-const-value <gdb:value>) -> <gdb:value> */
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_value_const_value (SCM self)
|
|
|
{
|
|
|
value_smob *v_smob
|
|
|
= vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
|
|
|
struct value *value = v_smob->value;
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *res_val = make_cv_value (1, 0, value);
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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;
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
type = value_type (value);
|
|
|
type = check_typedef (type);
|
|
|
|
|
|
if (((type->code () == TYPE_CODE_PTR)
|
|
|
|| (type->code () == TYPE_CODE_REF))
|
|
|
&& (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_STRUCT))
|
|
|
{
|
|
|
struct value *target;
|
|
|
int was_pointer = type->code () == 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_CODE_STRUCT)
|
|
|
type = value_rtti_type (value, NULL, NULL, NULL);
|
|
|
else
|
|
|
{
|
|
|
/* Re-use object's static type. */
|
|
|
type = NULL;
|
|
|
}
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
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);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct value *res_val;
|
|
|
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);
|
|
|
}
|
|
|
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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);
|
|
|
|
|
|
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
|
|
|
_("string"));
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
gdb::unique_xmalloc_ptr<char> field = gdbscm_scm_to_c_string (field_scm);
|
|
|
|
|
|
struct value *tmp = v_smob->value;
|
|
|
|
|
|
struct value *res_val = value_struct_elt (&tmp, {}, field.get (), NULL,
|
|
|
"struct/class/union");
|
|
|
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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 type *type = value_type (value);
|
|
|
|
|
|
SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
SCM except_scm;
|
|
|
struct value *index
|
|
|
= vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
|
|
|
&except_scm,
|
|
|
type->arch (),
|
|
|
current_language);
|
|
|
if (index == NULL)
|
|
|
return except_scm;
|
|
|
|
|
|
/* 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. */
|
|
|
struct value *tmp = coerce_ref (value);
|
|
|
struct type *tmp_type = check_typedef (value_type (tmp));
|
|
|
if (tmp_type->code () != TYPE_CODE_ARRAY
|
|
|
&& tmp_type->code () != TYPE_CODE_PTR)
|
|
|
error (_("Cannot subscript requested type"));
|
|
|
|
|
|
struct value *res_val = value_subscript (tmp, value_as_long (index));
|
|
|
return vlscm_scm_from_value (res_val);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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 type *ftype = NULL;
|
|
|
long args_count;
|
|
|
struct value **vargs = NULL;
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
ftype = check_typedef (value_type (function));
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
SCM_ASSERT_TYPE (ftype->code () == 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)));
|
|
|
}
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
auto av = gdb::make_array_view (vargs, args_count);
|
|
|
value *return_value = call_function_by_hand (function, NULL, av);
|
|
|
return vlscm_scm_from_value (return_value);
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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);
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
type = check_typedef (type);
|
|
|
length = TYPE_LENGTH (type);
|
|
|
contents = value_contents (value).data ();
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
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_CODE_INT
|
|
|
|| type->code () == TYPE_CODE_ENUM
|
|
|
|| type->code () == TYPE_CODE_BOOL
|
|
|
|| type->code () == TYPE_CODE_CHAR
|
|
|
|| (ptr_ok && type->code () == 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);
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
type = check_typedef (type);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
|
|
|
_("integer-like gdb value"));
|
|
|
|
|
|
try
|
|
|
{
|
|
|
if (type->code () == TYPE_CODE_PTR)
|
|
|
l = value_as_address (value);
|
|
|
else
|
|
|
l = value_as_long (value);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
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);
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
type = check_typedef (type);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
|
|
|
_("integer-like gdb value"));
|
|
|
|
|
|
try
|
|
|
{
|
|
|
if (type->code () == TYPE_CODE_PTR)
|
|
|
l = value_as_address (value);
|
|
|
else
|
|
|
l = value_as_long (value);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
if (type->is_unsigned ())
|
|
|
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;
|
|
|
double d = 0;
|
|
|
struct value *check = nullptr;
|
|
|
|
|
|
type = value_type (value);
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
type = check_typedef (type);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
SCM_ASSERT_TYPE (is_intlike (type, 0) || type->code () == TYPE_CODE_FLT,
|
|
|
self, SCM_ARG1, FUNC_NAME, _("number"));
|
|
|
|
|
|
try
|
|
|
{
|
|
|
if (is_floating_value (value))
|
|
|
{
|
|
|
d = target_float_to_host_double (value_contents (value).data (),
|
|
|
type);
|
|
|
check = value_from_host_double (type, d);
|
|
|
}
|
|
|
else if (type->is_unsigned ())
|
|
|
{
|
|
|
d = (ULONGEST) value_as_long (value);
|
|
|
check = value_from_ulongest (type, (ULONGEST) d);
|
|
|
}
|
|
|
else
|
|
|
{
|
|
|
d = value_as_long (value);
|
|
|
check = value_from_longest (type, (LONGEST) d);
|
|
|
}
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
/* TODO: Is there a better way to check if the value fits? */
|
|
|
if (!value_equal (value, check))
|
|
|
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;
|
|
|
/* Avoid an uninitialized warning from gcc. */
|
|
|
gdb_byte *buffer_contents = nullptr;
|
|
|
int length = -1;
|
|
|
const char *la_encoding = NULL;
|
|
|
struct type *char_type = NULL;
|
|
|
SCM result;
|
|
|
|
|
|
/* 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);
|
|
|
|
|
|
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"));
|
|
|
|
|
|
xfree (encoding);
|
|
|
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. */
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
gdb::unique_xmalloc_ptr<gdb_byte> buffer;
|
|
|
c_get_string (value, &buffer, &length, &char_type, &la_encoding);
|
|
|
buffer_contents = buffer.release ();
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
xfree (encoding);
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
|
|
|
/* 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. */
|
|
|
|
|
|
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
|
|
|
|
|
|
gdbscm_dynwind_xfree (encoding);
|
|
|
gdbscm_dynwind_xfree (buffer_contents);
|
|
|
|
|
|
result = scm_from_stringn ((const char *) buffer_contents,
|
|
|
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 */
|
|
|
gdbscm_gdb_exception except {};
|
|
|
|
|
|
/* 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"));
|
|
|
}
|
|
|
|
|
|
try
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
|
|
|
struct type *type, *realtype;
|
|
|
CORE_ADDR addr;
|
|
|
|
|
|
type = value_type (value);
|
|
|
realtype = check_typedef (type);
|
|
|
|
|
|
switch (realtype->code ())
|
|
|
{
|
|
|
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);
|
|
|
}
|
|
|
catch (const gdb_exception &ex)
|
|
|
{
|
|
|
except = unpack (ex);
|
|
|
}
|
|
|
|
|
|
xfree (encoding);
|
|
|
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;
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
if (value_lazy (value))
|
|
|
value_fetch_lazy (value);
|
|
|
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;
|
|
|
|
|
|
gdbscm_gdb_exception exc {};
|
|
|
try
|
|
|
{
|
|
|
common_val_print (value, &stb, 0, &opts, current_language);
|
|
|
}
|
|
|
catch (const gdb_exception &except)
|
|
|
{
|
|
|
exc = unpack (except);
|
|
|
}
|
|
|
|
|
|
GDBSCM_HANDLE_GDB_EXCEPTION (exc);
|
|
|
/* 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;
|
|
|
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
|
|
|
expr_scm, &expr_str);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
scoped_value_mark free_values;
|
|
|
return vlscm_scm_from_value (parse_and_eval (expr_str));
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (history-ref integer) -> <gdb:value>
|
|
|
Return the specified value from GDB's value history. */
|
|
|
|
|
|
static SCM
|
|
|
gdbscm_history_ref (SCM index)
|
|
|
{
|
|
|
int i;
|
|
|
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
|
|
|
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
return vlscm_scm_from_value (access_value_history (i));
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* (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)
|
|
|
{
|
|
|
value_smob *v_smob
|
|
|
= vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
|
|
|
return gdbscm_wrap ([=]
|
|
|
{
|
|
|
return scm_from_int (record_latest_value (v_smob->value));
|
|
|
});
|
|
|
}
|
|
|
|
|
|
/* 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-reference-value", 1, 0, 0,
|
|
|
as_a_scm_t_subr (gdbscm_value_reference_value),
|
|
|
"\
|
|
|
Return a <gdb:value> object which is a reference to the given value." },
|
|
|
|
|
|
{ "value-rvalue-reference-value", 1, 0, 0,
|
|
|
as_a_scm_t_subr (gdbscm_value_rvalue_reference_value),
|
|
|
"\
|
|
|
Return a <gdb:value> object which is an rvalue reference to the given value." },
|
|
|
|
|
|
{ "value-const-value", 1, 0, 0,
|
|
|
as_a_scm_t_subr (gdbscm_value_const_value),
|
|
|
"\
|
|
|
Return a <gdb:value> object which is a 'const' version of the given value." },
|
|
|
|
|
|
{ "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");
|
|
|
}
|