darkkirb/old-cross-binutils
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
old-cross-binutils/gdb/guile/scm-type.c
Pedro Alves 492d29ea1c Split TRY_CATCH into TRY + CATCH 
This patch splits the TRY_CATCH macro into three, so that we go from
this:

~~~
  volatile gdb_exception ex;

  TRY_CATCH (ex, RETURN_MASK_ERROR)
    {
    }
  if (ex.reason < 0)
    {
    }
~~~

to this:

~~~
  TRY
    {
    }
  CATCH (ex, RETURN_MASK_ERROR)
    {
    }
  END_CATCH
~~~

Thus, we'll be getting rid of the local volatile exception object, and
declaring the caught exception in the catch block.

This allows reimplementing TRY/CATCH in terms of C++ exceptions when
building in C++ mode, while still allowing to build GDB in C mode
(using setjmp/longjmp), as a transition step.

TBC, after this patch, is it _not_ valid to have code between the TRY
and the CATCH blocks, like:

  TRY
    {
    }

  // some code here.

  CATCH (ex, RETURN_MASK_ERROR)
    {
    }
  END_CATCH

Just like it isn't valid to do that with C++'s native try/catch.

By switching to creating the exception object inside the CATCH block
scope, we can get rid of all the explicitly allocated volatile
exception objects all over the tree, and map the CATCH block more
directly to C++'s catch blocks.

The majority of the TRY_CATCH -> TRY+CATCH+END_CATCH conversion was
done with a script, rerun from scratch at every rebase, no manual
editing involved.  After the mechanical conversion, a few places
needed manual intervention, to fix preexisting cases where we were
using the exception object outside of the TRY_CATCH block, and cases
where we were using "else" after a 'if (ex.reason) < 0)' [a CATCH
after this patch].  The result was folded into this patch so that GDB
still builds at each incremental step.

END_CATCH is necessary for two reasons:

First, because we name the exception object in the CATCH block, which
requires creating a scope, which in turn must be closed somewhere.
Declaring the exception variable in the initializer field of a for
block, like:

  #define CATCH(EXCEPTION, mask) \
    for (struct gdb_exception EXCEPTION; \
         exceptions_state_mc_catch (&EXCEPTION, MASK); \
	 EXCEPTION = exception_none)

would avoid needing END_CATCH, but alas, in C mode, we build with C90,
which doesn't allow mixed declarations and code.

Second, because when TRY/CATCH are wired to real C++ try/catch, as
long as we need to handle cleanup chains, even if there's no CATCH
block that wants to catch the exception, we need for stop at every
frame in the unwind chain and run cleanups, then rethrow.  That will
be done in END_CATCH.

After we require C++, we'll still need TRY/CATCH/END_CATCH until
cleanups are completely phased out -- TRY/CATCH in C++ mode will
save/restore the current cleanup chain, like in C mode, and END_CATCH
catches otherwise uncaugh exceptions, runs cleanups and rethrows, so
that C++ cleanups and exceptions can coexist.

IMO, this still makes the TRY/CATCH code look a bit more like a
newcomer would expect, so IMO worth it even if we weren't considering
C++.

gdb/ChangeLog.
2015-03-07  Pedro Alves  <palves@redhat.com>

	* common/common-exceptions.c (struct catcher) <exception>: No
	longer a pointer to volatile exception.  Now an exception value.
	<mask>: Delete field.
	(exceptions_state_mc_init): Remove all parameters.  Adjust.
	(exceptions_state_mc): No longer pop the catcher here.
	(exceptions_state_mc_catch): New function.
	(throw_exception): Adjust.
	* common/common-exceptions.h (exceptions_state_mc_init): Remove
	all parameters.
	(exceptions_state_mc_catch): Declare.
	(TRY_CATCH): Rename to ...
	(TRY): ... this.  Remove EXCEPTION and MASK parameters.
	(CATCH, END_CATCH): New.
	All callers adjusted.

gdb/gdbserver/ChangeLog:
2015-03-07  Pedro Alves  <palves@redhat.com>

	Adjust all callers of TRY_CATCH to use TRY/CATCH/END_CATCH
	instead.
2015-03-07 15:14:14 +00:00

1522 lines
39 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* Scheme interface to types.
Copyright (C) 2008-2015 Free Software Foundation, Inc.
This file is part of GDB.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. */
/* See README file in this directory for implementation notes, coding
conventions, et.al. */
#include "defs.h"
#include "arch-utils.h"
#include "value.h"
#include "gdbtypes.h"
#include "objfiles.h"
#include "language.h"
#include "vec.h"
#include "bcache.h"
#include "dwarf2loc.h"
#include "typeprint.h"
#include "guile-internal.h"
/* The <gdb:type> smob.
The type is chained with all types associated with its objfile, if any.
This lets us copy the underlying struct type when the objfile is
deleted.
The typedef for this struct is in guile-internal.h. */
struct _type_smob
{
/* This always appears first.
eqable_gdb_smob is used so that types are eq?-able.
Also, a type object can be associated with an objfile. eqable_gdb_smob
lets us track the lifetime of all types associated with an objfile.
When an objfile is deleted we need to invalidate the type object. */
eqable_gdb_smob base;
/* The GDB type structure this smob is wrapping. */
struct type *type;
};
/* A field smob. */
typedef struct
{
/* This always appears first. */
gdb_smob base;
/* Backlink to the containing <gdb:type> object. */
SCM type_scm;
/* The field number in TYPE_SCM. */
int field_num;
} field_smob;
static const char type_smob_name[] = "gdb:type";
static const char field_smob_name[] = "gdb:field";
static const char not_composite_error[] =
N_("type is not a structure, union, or enum type");
/* The tag Guile knows the type smob by. */
static scm_t_bits type_smob_tag;
/* The tag Guile knows the field smob by. */
static scm_t_bits field_smob_tag;
/* The "next" procedure for field iterators. */
static SCM tyscm_next_field_x_proc;
/* Keywords used in argument passing. */
static SCM block_keyword;
static const struct objfile_data *tyscm_objfile_data_key;
/* Hash table to uniquify global (non-objfile-owned) types. */
static htab_t global_types_map;
static struct type *tyscm_get_composite (struct type *type);
/* Return the type field of T_SMOB.
This exists so that we don't have to export the struct's contents. */
struct type *
tyscm_type_smob_type (type_smob *t_smob)
{
return t_smob->type;
}
/* Return the name of TYPE in expanded form.
Space for the result is malloc'd, caller must free.
If there's an error computing the name, the result is NULL and the
exception is stored in *EXCP. */
static char *
tyscm_type_name (struct type *type, SCM *excp)
{
char *name = NULL;
TRY
{
struct cleanup *old_chain;
struct ui_file *stb;
stb = mem_fileopen ();
old_chain = make_cleanup_ui_file_delete (stb);
LA_PRINT_TYPE (type, "", stb, -1, 0, &type_print_raw_options);
name = ui_file_xstrdup (stb, NULL);
do_cleanups (old_chain);
}
CATCH (except, RETURN_MASK_ALL)
{
*excp = gdbscm_scm_from_gdb_exception (except);
return NULL;
}
END_CATCH
return name;
}
/* Administrivia for type smobs. */
/* Helper function to hash a type_smob. */
static hashval_t
tyscm_hash_type_smob (const void *p)
{
const type_smob *t_smob = p;
return htab_hash_pointer (t_smob->type);
}
/* Helper function to compute equality of type_smobs. */
static int
tyscm_eq_type_smob (const void *ap, const void *bp)
{
const type_smob *a = ap;
const type_smob *b = bp;
return (a->type == b->type
&& a->type != NULL);
}
/* Return the struct type pointer -> SCM mapping table.
If type is owned by an objfile, the mapping table is created if necessary.
Otherwise, type is not owned by an objfile, and we use
global_types_map. */
static htab_t
tyscm_type_map (struct type *type)
{
struct objfile *objfile = TYPE_OBJFILE (type);
htab_t htab;
if (objfile == NULL)
return global_types_map;
htab = objfile_data (objfile, tyscm_objfile_data_key);
if (htab == NULL)
{
htab = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
tyscm_eq_type_smob);
set_objfile_data (objfile, tyscm_objfile_data_key, htab);
}
return htab;
}
/* The smob "free" function for <gdb:type>. */
static size_t
tyscm_free_type_smob (SCM self)
{
type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
if (t_smob->type != NULL)
{
htab_t htab = tyscm_type_map (t_smob->type);
gdbscm_clear_eqable_gsmob_ptr_slot (htab, &t_smob->base);
}
/* Not necessary, done to catch bugs. */
t_smob->type = NULL;
return 0;
}
/* The smob "print" function for <gdb:type>. */
static int
tyscm_print_type_smob (SCM self, SCM port, scm_print_state *pstate)
{
type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
SCM exception;
char *name = tyscm_type_name (t_smob->type, &exception);
if (name == NULL)
gdbscm_throw (exception);
/* 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. */
if (pstate->writingp)
gdbscm_printf (port, "#<%s ", type_smob_name);
scm_puts (name, port);
if (pstate->writingp)
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* The smob "equal?" function for <gdb:type>. */
static SCM
tyscm_equal_p_type_smob (SCM type1_scm, SCM type2_scm)
{
type_smob *type1_smob, *type2_smob;
struct type *type1, *type2;
int result = 0;
SCM_ASSERT_TYPE (tyscm_is_type (type1_scm), type1_scm, SCM_ARG1, FUNC_NAME,
type_smob_name);
SCM_ASSERT_TYPE (tyscm_is_type (type2_scm), type2_scm, SCM_ARG2, FUNC_NAME,
type_smob_name);
type1_smob = (type_smob *) SCM_SMOB_DATA (type1_scm);
type2_smob = (type_smob *) SCM_SMOB_DATA (type2_scm);
type1 = type1_smob->type;
type2 = type2_smob->type;
TRY
{
result = types_deeply_equal (type1, type2);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return scm_from_bool (result);
}
/* Low level routine to create a <gdb:type> object. */
static SCM
tyscm_make_type_smob (void)
{
type_smob *t_smob = (type_smob *)
scm_gc_malloc (sizeof (type_smob), type_smob_name);
SCM t_scm;
/* This must be filled in by the caller. */
t_smob->type = NULL;
t_scm = scm_new_smob (type_smob_tag, (scm_t_bits) t_smob);
gdbscm_init_eqable_gsmob (&t_smob->base, t_scm);
return t_scm;
}
/* Return non-zero if SCM is a <gdb:type> object. */
int
tyscm_is_type (SCM self)
{
return SCM_SMOB_PREDICATE (type_smob_tag, self);
}
/* (type? object) -> boolean */
static SCM
gdbscm_type_p (SCM self)
{
return scm_from_bool (tyscm_is_type (self));
}
/* Return the existing object that encapsulates TYPE, or create a new
<gdb:type> object. */
SCM
tyscm_scm_from_type (struct type *type)
{
htab_t htab;
eqable_gdb_smob **slot;
type_smob *t_smob, t_smob_for_lookup;
SCM t_scm;
/* If we've already created a gsmob for this type, return it.
This makes types eq?-able. */
htab = tyscm_type_map (type);
t_smob_for_lookup.type = type;
slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
if (*slot != NULL)
return (*slot)->containing_scm;
t_scm = tyscm_make_type_smob ();
t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
t_smob->type = type;
gdbscm_fill_eqable_gsmob_ptr_slot (slot, &t_smob->base);
return t_scm;
}
/* Returns the <gdb:type> object in SELF.
Throws an exception if SELF is not a <gdb:type> object. */
static SCM
tyscm_get_type_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (tyscm_is_type (self), self, arg_pos, func_name,
type_smob_name);
return self;
}
/* Returns a pointer to the type smob of SELF.
Throws an exception if SELF is not a <gdb:type> object. */
type_smob *
tyscm_get_type_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM t_scm = tyscm_get_type_arg_unsafe (self, arg_pos, func_name);
type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
return t_smob;
}
/* Helper function for save_objfile_types to make a deep copy of the type. */
static int
tyscm_copy_type_recursive (void **slot, void *info)
{
type_smob *t_smob = (type_smob *) *slot;
htab_t copied_types = info;
struct objfile *objfile = TYPE_OBJFILE (t_smob->type);
htab_t htab;
eqable_gdb_smob **new_slot;
type_smob t_smob_for_lookup;
gdb_assert (objfile != NULL);
htab_empty (copied_types);
t_smob->type = copy_type_recursive (objfile, t_smob->type, copied_types);
/* The eq?-hashtab that the type lived in is going away.
Add the type to its new eq?-hashtab: Otherwise if/when the type is later
garbage collected we'll assert-fail if the type isn't in the hashtab.
PR 16612.
Types now live in "arch space", and things like "char" that came from
the objfile *could* be considered eq? with the arch "char" type.
However, they weren't before the objfile got deleted, so making them
eq? now is debatable. */
htab = tyscm_type_map (t_smob->type);
t_smob_for_lookup.type = t_smob->type;
new_slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
gdb_assert (*new_slot == NULL);
gdbscm_fill_eqable_gsmob_ptr_slot (new_slot, &t_smob->base);
return 1;
}
/* Called when OBJFILE is about to be deleted.
Make a copy of all types associated with OBJFILE. */
static void
save_objfile_types (struct objfile *objfile, void *datum)
{
htab_t htab = datum;
htab_t copied_types;
if (!gdb_scheme_initialized)
return;
copied_types = create_copied_types_hash (objfile);
if (htab != NULL)
{
htab_traverse_noresize (htab, tyscm_copy_type_recursive, copied_types);
htab_delete (htab);
}
htab_delete (copied_types);
}
/* Administrivia for field smobs. */
/* The smob "print" function for <gdb:field>. */
static int
tyscm_print_field_smob (SCM self, SCM port, scm_print_state *pstate)
{
field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", field_smob_name);
scm_write (f_smob->type_scm, port);
gdbscm_printf (port, " %d", f_smob->field_num);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:field> object for field FIELD_NUM
of type TYPE_SCM. */
static SCM
tyscm_make_field_smob (SCM type_scm, int field_num)
{
field_smob *f_smob = (field_smob *)
scm_gc_malloc (sizeof (field_smob), field_smob_name);
SCM result;
f_smob->type_scm = type_scm;
f_smob->field_num = field_num;
result = scm_new_smob (field_smob_tag, (scm_t_bits) f_smob);
gdbscm_init_gsmob (&f_smob->base);
return result;
}
/* Return non-zero if SCM is a <gdb:field> object. */
static int
tyscm_is_field (SCM self)
{
return SCM_SMOB_PREDICATE (field_smob_tag, self);
}
/* (field? object) -> boolean */
static SCM
gdbscm_field_p (SCM self)
{
return scm_from_bool (tyscm_is_field (self));
}
/* Create a new <gdb:field> object that encapsulates field FIELD_NUM
in type TYPE_SCM. */
SCM
tyscm_scm_from_field (SCM type_scm, int field_num)
{
return tyscm_make_field_smob (type_scm, field_num);
}
/* Returns the <gdb:field> object in SELF.
Throws an exception if SELF is not a <gdb:field> object. */
static SCM
tyscm_get_field_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (tyscm_is_field (self), self, arg_pos, func_name,
field_smob_name);
return self;
}
/* Returns a pointer to the field smob of SELF.
Throws an exception if SELF is not a <gdb:field> object. */
static field_smob *
tyscm_get_field_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM f_scm = tyscm_get_field_arg_unsafe (self, arg_pos, func_name);
field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (f_scm);
return f_smob;
}
/* Returns a pointer to the type struct in F_SMOB
(the type the field is in). */
static struct type *
tyscm_field_smob_containing_type (field_smob *f_smob)
{
type_smob *t_smob;
gdb_assert (tyscm_is_type (f_smob->type_scm));
t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm);
return t_smob->type;
}
/* Returns a pointer to the field struct of F_SMOB. */
static struct field *
tyscm_field_smob_to_field (field_smob *f_smob)
{
struct type *type = tyscm_field_smob_containing_type (f_smob);
/* This should be non-NULL by construction. */
gdb_assert (TYPE_FIELDS (type) != NULL);
return &TYPE_FIELD (type, f_smob->field_num);
}
/* Type smob accessors. */
/* (type-code <gdb:type>) -> integer
Return the code for this type. */
static SCM
gdbscm_type_code (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
return scm_from_int (TYPE_CODE (type));
}
/* (type-fields <gdb:type>) -> list
Return a list of all fields. Each element is a <gdb:field> object.
This also supports arrays, we return a field list of one element,
the range type. */
static SCM
gdbscm_type_fields (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
struct type *containing_type;
SCM containing_type_scm, result;
int i;
containing_type = tyscm_get_composite (type);
if (containing_type == NULL)
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_(not_composite_error));
/* If SELF is a typedef or reference, we want the underlying type,
which is what tyscm_get_composite returns. */
if (containing_type == type)
containing_type_scm = self;
else
containing_type_scm = tyscm_scm_from_type (containing_type);
result = SCM_EOL;
for (i = 0; i < TYPE_NFIELDS (containing_type); ++i)
result = scm_cons (tyscm_make_field_smob (containing_type_scm, i), result);
return scm_reverse_x (result, SCM_EOL);
}
/* (type-tag <gdb:type>) -> string
Return the type's tag, or #f. */
static SCM
gdbscm_type_tag (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
if (!TYPE_TAG_NAME (type))
return SCM_BOOL_F;
return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type));
}
/* (type-name <gdb:type>) -> string
Return the type's name, or #f. */
static SCM
gdbscm_type_name (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
if (!TYPE_NAME (type))
return SCM_BOOL_F;
return gdbscm_scm_from_c_string (TYPE_NAME (type));
}
/* (type-print-name <gdb:type>) -> string
Return the print name of type.
TODO: template support elided for now. */
static SCM
gdbscm_type_print_name (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
char *thetype;
SCM exception, result;
thetype = tyscm_type_name (type, &exception);
if (thetype == NULL)
gdbscm_throw (exception);
result = gdbscm_scm_from_c_string (thetype);
xfree (thetype);
return result;
}
/* (type-sizeof <gdb:type>) -> integer
Return the size of the type represented by SELF, in bytes. */
static SCM
gdbscm_type_sizeof (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
check_typedef (type);
}
CATCH (except, RETURN_MASK_ALL)
{
}
END_CATCH
/* Ignore exceptions. */
return scm_from_long (TYPE_LENGTH (type));
}
/* (type-strip-typedefs <gdb:type>) -> <gdb:type>
Return the type, stripped of typedefs. */
static SCM
gdbscm_type_strip_typedefs (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = check_typedef (type);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* Strip typedefs and pointers/reference from a type. Then check that
it is a struct, union, or enum type. If not, return NULL. */
static struct type *
tyscm_get_composite (struct type *type)
{
for (;;)
{
TRY
{
type = check_typedef (type);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
if (TYPE_CODE (type) != TYPE_CODE_PTR
&& TYPE_CODE (type) != TYPE_CODE_REF)
break;
type = TYPE_TARGET_TYPE (type);
}
/* If this is not a struct, union, or enum type, raise TypeError
exception. */
if (TYPE_CODE (type) != TYPE_CODE_STRUCT
&& TYPE_CODE (type) != TYPE_CODE_UNION
&& TYPE_CODE (type) != TYPE_CODE_ENUM)
return NULL;
return type;
}
/* Helper for tyscm_array and tyscm_vector. */
static SCM
tyscm_array_1 (SCM self, SCM n1_scm, SCM n2_scm, int is_vector,
const char *func_name)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, func_name);
struct type *type = t_smob->type;
long n1, n2 = 0;
struct type *array = NULL;
gdbscm_parse_function_args (func_name, SCM_ARG2, NULL, "l|l",
n1_scm, &n1, n2_scm, &n2);
if (SCM_UNBNDP (n2_scm))
{
n2 = n1;
n1 = 0;
}
if (n2 < n1 - 1) /* Note: An empty array has n2 == n1 - 1. */
{
gdbscm_out_of_range_error (func_name, SCM_ARG3,
scm_cons (scm_from_long (n1),
scm_from_long (n2)),
_("Array length must not be negative"));
}
TRY
{
array = lookup_array_range_type (type, n1, n2);
if (is_vector)
make_vector_type (array);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (array);
}
/* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
The array has indices [low-bound,high-bound].
If low-bound is not provided zero is used.
Return an array type.
IWBN if the one argument version specified a size, not the high bound.
It's too easy to pass one argument thinking it is the size of the array.
The current semantics are for compatibility with the Python version.
Later we can add #:size. */
static SCM
gdbscm_type_array (SCM self, SCM n1, SCM n2)
{
return tyscm_array_1 (self, n1, n2, 0, FUNC_NAME);
}
/* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
The array has indices [low-bound,high-bound].
If low-bound is not provided zero is used.
Return a vector type.
IWBN if the one argument version specified a size, not the high bound.
It's too easy to pass one argument thinking it is the size of the array.
The current semantics are for compatibility with the Python version.
Later we can add #:size. */
static SCM
gdbscm_type_vector (SCM self, SCM n1, SCM n2)
{
return tyscm_array_1 (self, n1, n2, 1, FUNC_NAME);
}
/* (type-pointer <gdb:type>) -> <gdb:type>
Return a <gdb:type> object which represents a pointer to SELF. */
static SCM
gdbscm_type_pointer (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = lookup_pointer_type (type);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* (type-range <gdb:type>) -> (low high)
Return the range of a type represented by SELF. The return type is
a list. The first element is the low bound, and the second element
is the high bound. */
static SCM
gdbscm_type_range (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
SCM low_scm, high_scm;
/* Initialize these to appease GCC warnings. */
LONGEST low = 0, high = 0;
SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ARRAY
|| TYPE_CODE (type) == TYPE_CODE_STRING
|| TYPE_CODE (type) == TYPE_CODE_RANGE,
self, SCM_ARG1, FUNC_NAME, _("ranged type"));
switch (TYPE_CODE (type))
{
case TYPE_CODE_ARRAY:
case TYPE_CODE_STRING:
low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type));
high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type));
break;
case TYPE_CODE_RANGE:
low = TYPE_LOW_BOUND (type);
high = TYPE_HIGH_BOUND (type);
break;
}
low_scm = gdbscm_scm_from_longest (low);
high_scm = gdbscm_scm_from_longest (high);
return scm_list_2 (low_scm, high_scm);
}
/* (type-reference <gdb:type>) -> <gdb:type>
Return a <gdb:type> object which represents a reference to SELF. */
static SCM
gdbscm_type_reference (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = lookup_reference_type (type);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* (type-target <gdb:type>) -> <gdb:type>
Return a <gdb:type> object which represents the target type of SELF. */
static SCM
gdbscm_type_target (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
SCM_ASSERT (TYPE_TARGET_TYPE (type), self, SCM_ARG1, FUNC_NAME);
return tyscm_scm_from_type (TYPE_TARGET_TYPE (type));
}
/* (type-const <gdb:type>) -> <gdb:type>
Return a const-qualified type variant. */
static SCM
gdbscm_type_const (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = make_cv_type (1, 0, type, NULL);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* (type-volatile <gdb:type>) -> <gdb:type>
Return a volatile-qualified type variant. */
static SCM
gdbscm_type_volatile (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = make_cv_type (0, 1, type, NULL);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* (type-unqualified <gdb:type>) -> <gdb:type>
Return an unqualified type variant. */
static SCM
gdbscm_type_unqualified (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
TRY
{
type = make_cv_type (0, 0, type, NULL);
}
CATCH (except, RETURN_MASK_ALL)
{
GDBSCM_HANDLE_GDB_EXCEPTION (except);
}
END_CATCH
return tyscm_scm_from_type (type);
}
/* Field related accessors of types. */
/* (type-num-fields <gdb:type>) -> integer
Return number of fields. */
static SCM
gdbscm_type_num_fields (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
type = tyscm_get_composite (type);
if (type == NULL)
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_(not_composite_error));
return scm_from_long (TYPE_NFIELDS (type));
}
/* (type-field <gdb:type> string) -> <gdb:field>
Return the <gdb:field> object for the field named by the argument. */
static SCM
gdbscm_type_field (SCM self, SCM field_scm)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
char *field;
int i;
struct cleanup *cleanups;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
/* We want just fields of this type, not of base types, so instead of
using lookup_struct_elt_type, portions of that function are
copied here. */
type = tyscm_get_composite (type);
if (type == NULL)
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_(not_composite_error));
field = gdbscm_scm_to_c_string (field_scm);
cleanups = make_cleanup (xfree, field);
for (i = 0; i < TYPE_NFIELDS (type); i++)
{
const char *t_field_name = TYPE_FIELD_NAME (type, i);
if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
{
do_cleanups (cleanups);
return tyscm_make_field_smob (self, i);
}
}
do_cleanups (cleanups);
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, field_scm,
_("Unknown field"));
}
/* (type-has-field? <gdb:type> string) -> boolean
Return boolean indicating if type SELF has FIELD_SCM (a string). */
static SCM
gdbscm_type_has_field_p (SCM self, SCM field_scm)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
char *field;
int i;
struct cleanup *cleanups;
SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
_("string"));
/* We want just fields of this type, not of base types, so instead of
using lookup_struct_elt_type, portions of that function are
copied here. */
type = tyscm_get_composite (type);
if (type == NULL)
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_(not_composite_error));
field = gdbscm_scm_to_c_string (field_scm);
cleanups = make_cleanup (xfree, field);
for (i = 0; i < TYPE_NFIELDS (type); i++)
{
const char *t_field_name = TYPE_FIELD_NAME (type, i);
if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
{
do_cleanups (cleanups);
return SCM_BOOL_T;
}
}
do_cleanups (cleanups);
return SCM_BOOL_F;
}
/* (make-field-iterator <gdb:type>) -> <gdb:iterator>
Make a field iterator object. */
static SCM
gdbscm_make_field_iterator (SCM self)
{
type_smob *t_smob
= tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct type *type = t_smob->type;
struct type *containing_type;
SCM containing_type_scm;
containing_type = tyscm_get_composite (type);
if (containing_type == NULL)
gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_(not_composite_error));
/* If SELF is a typedef or reference, we want the underlying type,
which is what tyscm_get_composite returns. */
if (containing_type == type)
containing_type_scm = self;
else
containing_type_scm = tyscm_scm_from_type (containing_type);
return gdbscm_make_iterator (containing_type_scm, scm_from_int (0),
tyscm_next_field_x_proc);
}
/* (type-next-field! <gdb:iterator>) -> <gdb:field>
Return the next field in the iteration through the list of fields of the
type, or (end-of-iteration).
SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
This is the next! <gdb:iterator> function, not exported to the user. */
static SCM
gdbscm_type_next_field_x (SCM self)
{
iterator_smob *i_smob;
type_smob *t_smob;
struct type *type;
SCM it_scm, result, progress, object;
int field, rc;
it_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
i_smob = (iterator_smob *) SCM_SMOB_DATA (it_scm);
object = itscm_iterator_smob_object (i_smob);
progress = itscm_iterator_smob_progress (i_smob);
SCM_ASSERT_TYPE (tyscm_is_type (object), object,
SCM_ARG1, FUNC_NAME, type_smob_name);
t_smob = (type_smob *) SCM_SMOB_DATA (object);
type = t_smob->type;
SCM_ASSERT_TYPE (scm_is_signed_integer (progress,
0, TYPE_NFIELDS (type)),
progress, SCM_ARG1, FUNC_NAME, _("integer"));
field = scm_to_int (progress);
if (field < TYPE_NFIELDS (type))
{
result = tyscm_make_field_smob (object, field);
itscm_set_iterator_smob_progress_x (i_smob, scm_from_int (field + 1));
return result;
}
return gdbscm_end_of_iteration ();
}
/* Field smob accessors. */
/* (field-name <gdb:field>) -> string
Return the name of this field or #f if there isn't one. */
static SCM
gdbscm_field_name (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
if (FIELD_NAME (*field))
return gdbscm_scm_from_c_string (FIELD_NAME (*field));
return SCM_BOOL_F;
}
/* (field-type <gdb:field>) -> <gdb:type>
Return the <gdb:type> object of the field or #f if there isn't one. */
static SCM
gdbscm_field_type (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
/* A field can have a NULL type in some situations. */
if (FIELD_TYPE (*field))
return tyscm_scm_from_type (FIELD_TYPE (*field));
return SCM_BOOL_F;
}
/* (field-enumval <gdb:field>) -> integer
For enum values, return its value as an integer. */
static SCM
gdbscm_field_enumval (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
struct type *type = tyscm_field_smob_containing_type (f_smob);
SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ENUM,
self, SCM_ARG1, FUNC_NAME, _("enum type"));
return scm_from_long (FIELD_ENUMVAL (*field));
}
/* (field-bitpos <gdb:field>) -> integer
For bitfields, return its offset in bits. */
static SCM
gdbscm_field_bitpos (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
struct type *type = tyscm_field_smob_containing_type (f_smob);
SCM_ASSERT_TYPE (TYPE_CODE (type) != TYPE_CODE_ENUM,
self, SCM_ARG1, FUNC_NAME, _("non-enum type"));
return scm_from_long (FIELD_BITPOS (*field));
}
/* (field-bitsize <gdb:field>) -> integer
Return the size of the field in bits. */
static SCM
gdbscm_field_bitsize (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
return scm_from_long (FIELD_BITPOS (*field));
}
/* (field-artificial? <gdb:field>) -> boolean
Return #t if field is artificial. */
static SCM
gdbscm_field_artificial_p (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
return scm_from_bool (FIELD_ARTIFICIAL (*field));
}
/* (field-baseclass? <gdb:field>) -> boolean
Return #t if field is a baseclass. */
static SCM
gdbscm_field_baseclass_p (SCM self)
{
field_smob *f_smob
= tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct field *field = tyscm_field_smob_to_field (f_smob);
struct type *type = tyscm_field_smob_containing_type (f_smob);
if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
return scm_from_bool (f_smob->field_num < TYPE_N_BASECLASSES (type));
return SCM_BOOL_F;
}
/* Return the type named TYPE_NAME in BLOCK.
Returns NULL if not found.
This routine does not throw an error. */
static struct type *
tyscm_lookup_typename (const char *type_name, const struct block *block)
{
struct type *type = NULL;
TRY
{
if (startswith (type_name, "struct "))
type = lookup_struct (type_name + 7, NULL);
else if (startswith (type_name, "union "))
type = lookup_union (type_name + 6, NULL);
else if (startswith (type_name, "enum "))
type = lookup_enum (type_name + 5, NULL);
else
type = lookup_typename (current_language, get_current_arch (),
type_name, block, 0);
}
CATCH (except, RETURN_MASK_ALL)
{
return NULL;
}
END_CATCH
return type;
}
/* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
TODO: legacy template support left out until needed. */
static SCM
gdbscm_lookup_type (SCM name_scm, SCM rest)
{
SCM keywords[] = { block_keyword, SCM_BOOL_F };
char *name;
SCM block_scm = SCM_BOOL_F;
int block_arg_pos = -1;
const struct block *block = NULL;
struct type *type;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#O",
name_scm, &name,
rest, &block_arg_pos, &block_scm);
if (block_arg_pos != -1)
{
SCM exception;
block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
&exception);
if (block == NULL)
{
xfree (name);
gdbscm_throw (exception);
}
}
type = tyscm_lookup_typename (name, block);
xfree (name);
if (type != NULL)
return tyscm_scm_from_type (type);
return SCM_BOOL_F;
}
/* Initialize the Scheme type code. */
static const scheme_integer_constant type_integer_constants[] =
{
#define X(SYM) { #SYM, SYM }
X (TYPE_CODE_BITSTRING),
X (TYPE_CODE_PTR),
X (TYPE_CODE_ARRAY),
X (TYPE_CODE_STRUCT),
X (TYPE_CODE_UNION),
X (TYPE_CODE_ENUM),
X (TYPE_CODE_FLAGS),
X (TYPE_CODE_FUNC),
X (TYPE_CODE_INT),
X (TYPE_CODE_FLT),
X (TYPE_CODE_VOID),
X (TYPE_CODE_SET),
X (TYPE_CODE_RANGE),
X (TYPE_CODE_STRING),
X (TYPE_CODE_ERROR),
X (TYPE_CODE_METHOD),
X (TYPE_CODE_METHODPTR),
X (TYPE_CODE_MEMBERPTR),
X (TYPE_CODE_REF),
X (TYPE_CODE_CHAR),
X (TYPE_CODE_BOOL),
X (TYPE_CODE_COMPLEX),
X (TYPE_CODE_TYPEDEF),
X (TYPE_CODE_NAMESPACE),
X (TYPE_CODE_DECFLOAT),
X (TYPE_CODE_INTERNAL_FUNCTION),
#undef X
END_INTEGER_CONSTANTS
};
static const scheme_function type_functions[] =
{
{ "type?", 1, 0, 0, gdbscm_type_p,
"\
Return #t if the object is a <gdb:type> object." },
{ "lookup-type", 1, 0, 1, gdbscm_lookup_type,
"\
Return the <gdb:type> object representing string or #f if not found.\n\
If block is given then the type is looked for in that block.\n\
\n\
Arguments: string [#:block <gdb:block>]" },
{ "type-code", 1, 0, 0, gdbscm_type_code,
"\
Return the code of the type" },
{ "type-tag", 1, 0, 0, gdbscm_type_tag,
"\
Return the tag name of the type, or #f if there isn't one." },
{ "type-name", 1, 0, 0, gdbscm_type_name,
"\
Return the name of the type as a string, or #f if there isn't one." },
{ "type-print-name", 1, 0, 0, gdbscm_type_print_name,
"\
Return the print name of the type as a string." },
{ "type-sizeof", 1, 0, 0, gdbscm_type_sizeof,
"\
Return the size of the type, in bytes." },
{ "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs,
"\
Return a type formed by stripping the type of all typedefs." },
{ "type-array", 2, 1, 0, gdbscm_type_array,
"\
Return a type representing an array of objects of the type.\n\
\n\
Arguments: <gdb:type> [low-bound] high-bound\n\
If low-bound is not provided zero is used.\n\
N.B. If only the high-bound parameter is specified, it is not\n\
the array size.\n\
Valid bounds for array indices are [low-bound,high-bound]." },
{ "type-vector", 2, 1, 0, gdbscm_type_vector,
"\
Return a type representing a vector of objects of the type.\n\
Vectors differ from arrays in that if the current language has C-style\n\
arrays, vectors don't decay to a pointer to the first element.\n\
They are first class values.\n\
\n\
Arguments: <gdb:type> [low-bound] high-bound\n\
If low-bound is not provided zero is used.\n\
N.B. If only the high-bound parameter is specified, it is not\n\
the array size.\n\
Valid bounds for array indices are [low-bound,high-bound]." },
{ "type-pointer", 1, 0, 0, gdbscm_type_pointer,
"\
Return a type of pointer to the type." },
{ "type-range", 1, 0, 0, gdbscm_type_range,
"\
Return (low high) representing the range for the type." },
{ "type-reference", 1, 0, 0, gdbscm_type_reference,
"\
Return a type of reference to the type." },
{ "type-target", 1, 0, 0, gdbscm_type_target,
"\
Return the target type of the type." },
{ "type-const", 1, 0, 0, gdbscm_type_const,
"\
Return a const variant of the type." },
{ "type-volatile", 1, 0, 0, gdbscm_type_volatile,
"\
Return a volatile variant of the type." },
{ "type-unqualified", 1, 0, 0, gdbscm_type_unqualified,
"\
Return a variant of the type without const or volatile attributes." },
{ "type-num-fields", 1, 0, 0, gdbscm_type_num_fields,
"\
Return the number of fields of the type." },
{ "type-fields", 1, 0, 0, gdbscm_type_fields,
"\
Return the list of <gdb:field> objects of fields of the type." },
{ "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator,
"\
Return a <gdb:iterator> object for iterating over the fields of the type." },
{ "type-field", 2, 0, 0, gdbscm_type_field,
"\
Return the field named by string of the type.\n\
\n\
Arguments: <gdb:type> string" },
{ "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p,
"\
Return #t if the type has field named string.\n\
\n\
Arguments: <gdb:type> string" },
{ "field?", 1, 0, 0, gdbscm_field_p,
"\
Return #t if the object is a <gdb:field> object." },
{ "field-name", 1, 0, 0, gdbscm_field_name,
"\
Return the name of the field." },
{ "field-type", 1, 0, 0, gdbscm_field_type,
"\
Return the type of the field." },
{ "field-enumval", 1, 0, 0, gdbscm_field_enumval,
"\
Return the enum value represented by the field." },
{ "field-bitpos", 1, 0, 0, gdbscm_field_bitpos,
"\
Return the offset in bits of the field in its containing type." },
{ "field-bitsize", 1, 0, 0, gdbscm_field_bitsize,
"\
Return the size of the field in bits." },
{ "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p,
"\
Return #t if the field is artificial." },
{ "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p,
"\
Return #t if the field is a baseclass." },
END_FUNCTIONS
};
void
gdbscm_initialize_types (void)
{
type_smob_tag = gdbscm_make_smob_type (type_smob_name, sizeof (type_smob));
scm_set_smob_free (type_smob_tag, tyscm_free_type_smob);
scm_set_smob_print (type_smob_tag, tyscm_print_type_smob);
scm_set_smob_equalp (type_smob_tag, tyscm_equal_p_type_smob);
field_smob_tag = gdbscm_make_smob_type (field_smob_name,
sizeof (field_smob));
scm_set_smob_print (field_smob_tag, tyscm_print_field_smob);
gdbscm_define_integer_constants (type_integer_constants, 1);
gdbscm_define_functions (type_functions, 1);
/* This function is "private". */
tyscm_next_field_x_proc
= scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
gdbscm_type_next_field_x);
scm_set_procedure_property_x (tyscm_next_field_x_proc,
gdbscm_documentation_symbol,
gdbscm_scm_from_c_string ("\
Internal function to assist the type fields iterator."));
block_keyword = scm_from_latin1_keyword ("block");
/* Register an objfile "free" callback so we can properly copy types
associated with the objfile when it's about to be deleted. */
tyscm_objfile_data_key
= register_objfile_data_with_cleanup (save_objfile_types, NULL);
global_types_map = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
tyscm_eq_type_smob);
}
Reference in a new issue View git blame Copy permalink