[PATCH v2 29/36] Guile extension language: scm-type.c
Doug Evans
xdje42@gmail.com
Mon Jan 20 21:54:00 GMT 2014
This patch adds the interface to target types.
2014-01-20 Doug Evans <xdje42@gmail.com>
* guile/scm-type.c: New file.
testsuite/
* gdb.guile/scm-type.c: New file.
* gdb.guile/scm-type.exp: New file.
diff --git a/gdb/guile/scm-type.c b/gdb/guile/scm-type.c
new file mode 100644
index 0000000..906809b
--- /dev/null
+++ b/gdb/guile/scm-type.c
@@ -0,0 +1,1477 @@
+/* Scheme interface to types.
+
+ Copyright (C) 2008-2014 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 "exceptions.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. */
+
+typedef 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;
+} type_smob;
+
+/* 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ 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);
+ }
+ if (except.reason < 0)
+ {
+ *excp = gdbscm_scm_from_gdb_exception (except);
+ return NULL;
+ }
+
+ 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 "mark" function for <gdb:type>. */
+
+static SCM
+tyscm_mark_type_smob (SCM self)
+{
+ type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&t_smob->base);
+}
+
+/* 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;
+ volatile struct gdb_exception except;
+
+ 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_CATCH (except, RETURN_MASK_ALL)
+ {
+ result = types_deeply_equal (type1, type2);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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);
+
+ 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, t_scm);
+
+ 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);
+
+ gdb_assert (objfile != NULL);
+
+ htab_empty (copied_types);
+ t_smob->type = copy_type_recursive (objfile, t_smob->type, copied_types);
+ 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 "mark" function for <gdb:field>. */
+
+static SCM
+tyscm_mark_field_smob (SCM self)
+{
+ field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (f_smob->type_scm);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&f_smob->base);
+}
+
+/* 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-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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ check_typedef (type);
+ }
+ /* 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = check_typedef (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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)
+{
+ volatile struct gdb_exception except;
+
+ for (;;)
+ {
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = check_typedef (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ 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)
+ {
+ 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_CATCH (except, RETURN_MASK_ALL)
+ {
+ array = lookup_array_range_type (type, n1, n2);
+ if (is_vector)
+ make_vector_type (array);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = lookup_pointer_type (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = lookup_reference_type (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (1, 0, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (0, 1, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (0, 0, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (type-name <gdb:type>) -> string
+ Return the name of type.
+ FIXMExyzdje: check python, recent addition
+ TODO: template support elided for now. */
+
+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;
+ 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;
+}
+
+/* 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_CLASS)
+ 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;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (!strncmp (type_name, "struct ", 7))
+ type = lookup_struct (type_name + 7, NULL);
+ else if (!strncmp (type_name, "union ", 6))
+ type = lookup_union (type_name + 6, NULL);
+ else if (!strncmp (type_name, "enum ", 5))
+ type = lookup_enum (type_name + 5, NULL);
+ else
+ type = lookup_typename (current_language, get_current_arch (),
+ type_name, block, 0);
+ }
+ if (except.reason < 0)
+ return NULL;
+
+ 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-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-name", 1, 0, 0, gdbscm_type_name,
+ "\
+Return the name of the type as a string." },
+
+ { "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_mark (type_smob_tag, tyscm_mark_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_mark (field_smob_tag, tyscm_mark_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);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-type.c b/gdb/testsuite/gdb.guile/scm-type.c
new file mode 100644
index 0000000..7cee383
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-type.c
@@ -0,0 +1,77 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2009-2014 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+struct s
+{
+ int a;
+ int b;
+};
+
+typedef struct s TS;
+TS ts;
+
+#ifdef __cplusplus
+struct C
+{
+ int c;
+ int d;
+};
+
+struct D : C
+{
+ int e;
+ int f;
+};
+
+template<typename T, int I, int C::*MP>
+struct Temargs
+{
+};
+
+Temargs<D, 23, &C::c> temvar;
+
+#endif
+
+enum E
+{ v1, v2, v3
+};
+
+struct s vec_data_1 = {1, 1};
+struct s vec_data_2 = {1, 2};
+
+int
+main ()
+{
+ int ar[2] = {1,2};
+ struct s st;
+#ifdef __cplusplus
+ C c;
+ c.c = 1;
+ c.d = 2;
+ D d;
+ d.e = 3;
+ d.f = 4;
+#endif
+ enum E e;
+
+ st.a = 3;
+ st.b = 5;
+
+ e = v2;
+
+ return 0; /* break to inspect struct and array. */
+}
diff --git a/gdb/testsuite/gdb.guile/scm-type.exp b/gdb/testsuite/gdb.guile/scm-type.exp
new file mode 100644
index 0000000..4a3969e
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-type.exp
@@ -0,0 +1,299 @@
+# Copyright (C) 2009-2014 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This file is part of the GDB testsuite.
+# It tests the mechanism of exposing types to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if [get_compiler_info c++] {
+ return -1
+}
+
+# Build inferior to language specification.
+
+proc build_inferior {exefile lang} {
+ global srcdir subdir srcfile
+
+ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
+ untested "Couldn't compile ${srcfile} in $lang mode"
+ return -1
+ }
+ return 0
+}
+
+# Restart GDB.
+# The result is the same as gdb_guile_runto_main.
+
+proc restart_gdb {exefile} {
+ global srcdir subdir
+
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load ${exefile}
+
+ if { [skip_guile_tests] } {
+ return 0
+ }
+
+ if ![gdb_guile_runto_main] {
+ return 0
+ }
+ gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
+ "load iterator module"
+
+ return 1
+}
+
+# Set breakpoint and run to that breakpoint.
+
+proc runto_bp {bp} {
+ gdb_breakpoint [gdb_get_line_number $bp]
+ gdb_continue_to_breakpoint $bp
+}
+
+proc test_fields {lang} {
+ with_test_prefix "test_fields" {
+ global gdb_prompt
+
+ # fields of a typedef should still return the underlying field list
+ gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
+ "= 2" "$lang typedef field list"
+
+ if {$lang == "c++"} {
+ # Test usage with a class.
+ gdb_scm_test_silent_cmd "print c" "print value (c)"
+ gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
+ "get value (c) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
+ "get fields from c type"
+ gdb_test "guile (print (length fields))" \
+ "= 2" "check number of fields of c"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= c" "check class field c name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= d" "check class field d name"
+ }
+
+ # Test normal fields usage in structs.
+ gdb_scm_test_silent_cmd "print st" "print value (st)"
+ gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
+ "get value (st) from history"
+ gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
+ "get st-type"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
+ "get fields from st.type"
+ gdb_test "guile (print (length fields))" \
+ "= 2" "check number of fields (st)"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= a" "check structure field a name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= b" "check structure field b name"
+ gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
+ "= a" "check fields lookup by name"
+
+ # Test has-field?
+ gdb_test "guile (print (type-has-field? st-type \"b\"))" \
+ "= #t" "check existent field"
+ gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
+ "= #f" "check non-existent field"
+
+ # Test Guile mapping behavior of gdb:type for structs/classes.
+ gdb_test "guile (print (type-num-fields (value-type st)))" \
+ "= 2" "check number of fields (st) with type-num-fields"
+ gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
+ "create field iterator"
+ gdb_test "guile (print (iterator-map field-bitpos fi))" \
+ "= \\(0 32\\)" "check field iterator"
+
+ # Test rejection of mapping operations on scalar types.
+ gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
+ "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
+ "check field iterator on bad type"
+
+ # Test type-array.
+ gdb_scm_test_silent_cmd "print ar" "print value (ar)"
+ gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
+ "get value (ar) from history"
+ gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
+ "define ar0"
+ gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
+ "= \\{1, 2\\}" "cast to array with one argument"
+ gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
+ "= \\{1, 2\\}" "cast to array with two arguments"
+
+ # Test type-vector.
+ # Note: vectors cast differently than arrays. Here ar[0] is replicated
+ # for the size of the vector.
+ gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)"
+ gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
+ "get value (vec_data_1) from history"
+
+ gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)"
+ gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
+ "get value (vec_data_2) from history"
+
+ gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
+ "set vec1"
+ gdb_test "guile (print vec1)" \
+ "= \\{1, 1\\}" "cast to vector with one argument"
+ gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
+ "set vec2"
+ gdb_test "guile (print vec2)" \
+ "= \\{1, 1\\}" "cast to vector with two arguments"
+ gdb_test "guile (print (value=? vec1 vec2))" \
+ "= #t"
+ gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
+ "set vec3"
+ gdb_test "guile (print (value=? vec1 vec3))" \
+ "= #f"
+ }
+}
+
+proc test_equality {lang} {
+ with_test_prefix "test_equality" {
+ gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
+ "get st"
+ gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
+ "get ar"
+ gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
+ "= #t" "test type eq? on equal types"
+ gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
+ "= #f" "test type eq? on not-equal types"
+ gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
+ "= #t" "test type eq? on equal types"
+ gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
+ "= #f" "test type eq? on not-equal types"
+
+ if {$lang == "c++"} {
+ gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
+ "get c"
+ gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
+ "get d"
+ gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
+ "= #t" "test c++ type eq? on equal types"
+ gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
+ "= #f" "test c++ type eq? on not-equal types"
+ gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
+ "= #t" "test c++ type equal? on equal types"
+ gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
+ "= #f" "test c++ type equal? on not-equal types"
+ }
+ }
+}
+
+proc test_enums {} {
+ with_test_prefix "test_enum" {
+ gdb_scm_test_silent_cmd "print e" "print value (e)"
+ gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
+ "get value (e) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
+ "extract type fields from e"
+ gdb_test "guile (print (length fields))" \
+ "= 3" "check the number of enum fields"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= v1" "check enum field\[0\] name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= v2" "check enum field\[1\]name"
+
+ # Ditto but by mapping operations.
+ gdb_test "guile (print (type-num-fields (value-type e)))" \
+ "= 3" "check the number of enum values"
+ gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
+ "= v1" "check enum field lookup by name (v1)"
+ gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
+ "= v3" "check enum field lookup by name (v3)"
+ gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
+ "\\(0 1 2\\)" "check enum fields iteration"
+ }
+}
+
+proc test_base_class {} {
+ with_test_prefix "test_base_class" {
+ gdb_scm_test_silent_cmd "print d" "print value (d)"
+ gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
+ "get value (d) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
+ "extract type fields from d"
+ gdb_test "guile (print (length fields))" \
+ "= 3" "check the number of fields"
+ gdb_test "guile (print (field-baseclass? (car fields)))" \
+ "= #t" "check base class (fields\[0\])"
+ gdb_test "guile (print (field-baseclass? (cadr fields)))" \
+ "= #f" "check base class (fields\[1\])"
+ }
+}
+
+proc test_range {} {
+ with_test_prefix "test_range" {
+ with_test_prefix "on ranged value" {
+ # Test a valid range request.
+ gdb_scm_test_silent_cmd "print ar" "print value (ar)"
+ gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
+ "get value (ar) from history"
+ gdb_test "guile (print (length (type-range (value-type ar))))" \
+ "= 2" "check correct tuple length"
+ gdb_test "guile (print (type-range (value-type ar)))" \
+ "= \\(0 1\\)" "check range"
+ }
+
+ with_test_prefix "on unranged value" {
+ # Test where a range does not exist.
+ gdb_scm_test_silent_cmd "print st" "print value (st)"
+ gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
+ "get value (st) from history"
+ gdb_test "guile (print (type-range (value-type st)))" \
+ "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
+ "check range for non ranged type"
+ }
+ }
+}
+
+# Perform C Tests.
+
+if { [build_inferior "${binfile}" "c"] < 0 } {
+ return
+}
+if ![restart_gdb "${binfile}"] {
+ return
+}
+
+with_test_prefix "lang_c" {
+ runto_bp "break to inspect struct and array."
+ test_fields "c"
+ test_equality "c"
+ test_enums
+}
+
+# Perform C++ Tests.
+
+if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
+ return
+}
+if ![restart_gdb "${binfile}-cxx"] {
+ return
+}
+
+with_test_prefix "lang_cpp" {
+ runto_bp "break to inspect struct and array."
+ test_fields "c++"
+ test_base_class
+ test_range
+ test_equality "c++"
+ test_enums
+}
More information about the Gdb-patches
mailing list