1 /* Scheme interface to types.
3 Copyright (C) 2008-2020 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
24 #include "arch-utils.h"
30 #include "dwarf2/loc.h"
31 #include "typeprint.h"
32 #include "guile-internal.h"
34 /* The <gdb:type> smob.
35 The type is chained with all types associated with its objfile, if any.
36 This lets us copy the underlying struct type when the objfile is
38 The typedef for this struct is in guile-internal.h. */
42 /* This always appears first.
43 eqable_gdb_smob is used so that types are eq?-able.
44 Also, a type object can be associated with an objfile. eqable_gdb_smob
45 lets us track the lifetime of all types associated with an objfile.
46 When an objfile is deleted we need to invalidate the type object. */
49 /* The GDB type structure this smob is wrapping. */
57 /* This always appears first. */
60 /* Backlink to the containing <gdb:type> object. */
63 /* The field number in TYPE_SCM. */
67 static const char type_smob_name
[] = "gdb:type";
68 static const char field_smob_name
[] = "gdb:field";
70 static const char not_composite_error
[] =
71 N_("type is not a structure, union, or enum type");
73 /* The tag Guile knows the type smob by. */
74 static scm_t_bits type_smob_tag
;
76 /* The tag Guile knows the field smob by. */
77 static scm_t_bits field_smob_tag
;
79 /* The "next" procedure for field iterators. */
80 static SCM tyscm_next_field_x_proc
;
82 /* Keywords used in argument passing. */
83 static SCM block_keyword
;
85 static const struct objfile_data
*tyscm_objfile_data_key
;
87 /* Hash table to uniquify global (non-objfile-owned) types. */
88 static htab_t global_types_map
;
90 static struct type
*tyscm_get_composite (struct type
*type
);
92 /* Return the type field of T_SMOB.
93 This exists so that we don't have to export the struct's contents. */
96 tyscm_type_smob_type (type_smob
*t_smob
)
101 /* Return the name of TYPE in expanded form. If there's an error
102 computing the name, throws the gdb exception with scm_throw. */
105 tyscm_type_name (struct type
*type
)
112 LA_PRINT_TYPE (type
, "", &stb
, -1, 0, &type_print_raw_options
);
113 return std::move (stb
.string ());
115 catch (const gdb_exception
&except
)
117 excp
= gdbscm_scm_from_gdb_exception (unpack (except
));
123 /* Administrivia for type smobs. */
125 /* Helper function to hash a type_smob. */
128 tyscm_hash_type_smob (const void *p
)
130 const type_smob
*t_smob
= (const type_smob
*) p
;
132 return htab_hash_pointer (t_smob
->type
);
135 /* Helper function to compute equality of type_smobs. */
138 tyscm_eq_type_smob (const void *ap
, const void *bp
)
140 const type_smob
*a
= (const type_smob
*) ap
;
141 const type_smob
*b
= (const type_smob
*) bp
;
143 return (a
->type
== b
->type
147 /* Return the struct type pointer -> SCM mapping table.
148 If type is owned by an objfile, the mapping table is created if necessary.
149 Otherwise, type is not owned by an objfile, and we use
153 tyscm_type_map (struct type
*type
)
155 struct objfile
*objfile
= TYPE_OBJFILE (type
);
159 return global_types_map
;
161 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
164 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
166 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
172 /* The smob "free" function for <gdb:type>. */
175 tyscm_free_type_smob (SCM self
)
177 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
179 if (t_smob
->type
!= NULL
)
181 htab_t htab
= tyscm_type_map (t_smob
->type
);
183 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
186 /* Not necessary, done to catch bugs. */
192 /* The smob "print" function for <gdb:type>. */
195 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
197 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
198 std::string name
= tyscm_type_name (t_smob
->type
);
200 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
201 invoked by write/~S. What to do here may need to evolve.
202 IWBN if we could pass an argument to format that would we could use
203 instead of writingp. */
204 if (pstate
->writingp
)
205 gdbscm_printf (port
, "#<%s ", type_smob_name
);
207 scm_puts (name
.c_str (), port
);
209 if (pstate
->writingp
)
210 scm_puts (">", port
);
212 scm_remember_upto_here_1 (self
);
214 /* Non-zero means success. */
218 /* The smob "equal?" function for <gdb:type>. */
221 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
223 type_smob
*type1_smob
, *type2_smob
;
224 struct type
*type1
, *type2
;
227 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
229 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
231 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
232 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
233 type1
= type1_smob
->type
;
234 type2
= type2_smob
->type
;
236 gdbscm_gdb_exception exc
{};
239 result
= types_deeply_equal (type1
, type2
);
241 catch (const gdb_exception
&except
)
243 exc
= unpack (except
);
246 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
247 return scm_from_bool (result
);
250 /* Low level routine to create a <gdb:type> object. */
253 tyscm_make_type_smob (void)
255 type_smob
*t_smob
= (type_smob
*)
256 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
259 /* This must be filled in by the caller. */
262 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
263 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
268 /* Return non-zero if SCM is a <gdb:type> object. */
271 tyscm_is_type (SCM self
)
273 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
276 /* (type? object) -> boolean */
279 gdbscm_type_p (SCM self
)
281 return scm_from_bool (tyscm_is_type (self
));
284 /* Return the existing object that encapsulates TYPE, or create a new
285 <gdb:type> object. */
288 tyscm_scm_from_type (struct type
*type
)
291 eqable_gdb_smob
**slot
;
292 type_smob
*t_smob
, t_smob_for_lookup
;
295 /* If we've already created a gsmob for this type, return it.
296 This makes types eq?-able. */
297 htab
= tyscm_type_map (type
);
298 t_smob_for_lookup
.type
= type
;
299 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
301 return (*slot
)->containing_scm
;
303 t_scm
= tyscm_make_type_smob ();
304 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
306 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
311 /* Returns the <gdb:type> object in SELF.
312 Throws an exception if SELF is not a <gdb:type> object. */
315 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
317 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
323 /* Returns a pointer to the type smob of SELF.
324 Throws an exception if SELF is not a <gdb:type> object. */
327 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
329 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
330 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
335 /* Return the type field of T_SCM, an object of type <gdb:type>.
336 This exists so that we don't have to export the struct's contents. */
339 tyscm_scm_to_type (SCM t_scm
)
343 gdb_assert (tyscm_is_type (t_scm
));
344 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
348 /* Helper function for save_objfile_types to make a deep copy of the type. */
351 tyscm_copy_type_recursive (void **slot
, void *info
)
353 type_smob
*t_smob
= (type_smob
*) *slot
;
354 htab_t copied_types
= (htab_t
) info
;
355 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
357 eqable_gdb_smob
**new_slot
;
358 type_smob t_smob_for_lookup
;
360 gdb_assert (objfile
!= NULL
);
362 htab_empty (copied_types
);
363 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
365 /* The eq?-hashtab that the type lived in is going away.
366 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
367 garbage collected we'll assert-fail if the type isn't in the hashtab.
370 Types now live in "arch space", and things like "char" that came from
371 the objfile *could* be considered eq? with the arch "char" type.
372 However, they weren't before the objfile got deleted, so making them
373 eq? now is debatable. */
374 htab
= tyscm_type_map (t_smob
->type
);
375 t_smob_for_lookup
.type
= t_smob
->type
;
376 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
377 gdb_assert (*new_slot
== NULL
);
378 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
383 /* Called when OBJFILE is about to be deleted.
384 Make a copy of all types associated with OBJFILE. */
387 save_objfile_types (struct objfile
*objfile
, void *datum
)
389 htab_t htab
= (htab_t
) datum
;
392 if (!gdb_scheme_initialized
)
395 copied_types
= create_copied_types_hash (objfile
);
399 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
403 htab_delete (copied_types
);
406 /* Administrivia for field smobs. */
408 /* The smob "print" function for <gdb:field>. */
411 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
413 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
415 gdbscm_printf (port
, "#<%s ", field_smob_name
);
416 scm_write (f_smob
->type_scm
, port
);
417 gdbscm_printf (port
, " %d", f_smob
->field_num
);
418 scm_puts (">", port
);
420 scm_remember_upto_here_1 (self
);
422 /* Non-zero means success. */
426 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
430 tyscm_make_field_smob (SCM type_scm
, int field_num
)
432 field_smob
*f_smob
= (field_smob
*)
433 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
436 f_smob
->type_scm
= type_scm
;
437 f_smob
->field_num
= field_num
;
438 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
439 gdbscm_init_gsmob (&f_smob
->base
);
444 /* Return non-zero if SCM is a <gdb:field> object. */
447 tyscm_is_field (SCM self
)
449 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
452 /* (field? object) -> boolean */
455 gdbscm_field_p (SCM self
)
457 return scm_from_bool (tyscm_is_field (self
));
460 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
464 tyscm_scm_from_field (SCM type_scm
, int field_num
)
466 return tyscm_make_field_smob (type_scm
, field_num
);
469 /* Returns the <gdb:field> object in SELF.
470 Throws an exception if SELF is not a <gdb:field> object. */
473 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
475 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
481 /* Returns a pointer to the field smob of SELF.
482 Throws an exception if SELF is not a <gdb:field> object. */
485 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
487 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
488 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
493 /* Returns a pointer to the type struct in F_SMOB
494 (the type the field is in). */
497 tyscm_field_smob_containing_type (field_smob
*f_smob
)
501 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
502 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
507 /* Returns a pointer to the field struct of F_SMOB. */
509 static struct field
*
510 tyscm_field_smob_to_field (field_smob
*f_smob
)
512 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
514 /* This should be non-NULL by construction. */
515 gdb_assert (type
->fields () != NULL
);
517 return &type
->field (f_smob
->field_num
);
520 /* Type smob accessors. */
522 /* (type-code <gdb:type>) -> integer
523 Return the code for this type. */
526 gdbscm_type_code (SCM self
)
529 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
530 struct type
*type
= t_smob
->type
;
532 return scm_from_int (type
->code ());
535 /* (type-fields <gdb:type>) -> list
536 Return a list of all fields. Each element is a <gdb:field> object.
537 This also supports arrays, we return a field list of one element,
541 gdbscm_type_fields (SCM self
)
544 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
545 struct type
*type
= t_smob
->type
;
546 struct type
*containing_type
;
547 SCM containing_type_scm
, result
;
550 containing_type
= tyscm_get_composite (type
);
551 if (containing_type
== NULL
)
552 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
553 _(not_composite_error
));
555 /* If SELF is a typedef or reference, we want the underlying type,
556 which is what tyscm_get_composite returns. */
557 if (containing_type
== type
)
558 containing_type_scm
= self
;
560 containing_type_scm
= tyscm_scm_from_type (containing_type
);
563 for (i
= 0; i
< containing_type
->num_fields (); ++i
)
564 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
566 return scm_reverse_x (result
, SCM_EOL
);
569 /* (type-tag <gdb:type>) -> string
570 Return the type's tag, or #f. */
573 gdbscm_type_tag (SCM self
)
576 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
577 struct type
*type
= t_smob
->type
;
578 const char *tagname
= nullptr;
580 if (type
->code () == TYPE_CODE_STRUCT
581 || type
->code () == TYPE_CODE_UNION
582 || type
->code () == TYPE_CODE_ENUM
)
583 tagname
= type
->name ();
585 if (tagname
== nullptr)
587 return gdbscm_scm_from_c_string (tagname
);
590 /* (type-name <gdb:type>) -> string
591 Return the type's name, or #f. */
594 gdbscm_type_name (SCM self
)
597 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
598 struct type
*type
= t_smob
->type
;
602 return gdbscm_scm_from_c_string (type
->name ());
605 /* (type-print-name <gdb:type>) -> string
606 Return the print name of type.
607 TODO: template support elided for now. */
610 gdbscm_type_print_name (SCM self
)
613 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
614 struct type
*type
= t_smob
->type
;
615 std::string thetype
= tyscm_type_name (type
);
616 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
621 /* (type-sizeof <gdb:type>) -> integer
622 Return the size of the type represented by SELF, in bytes. */
625 gdbscm_type_sizeof (SCM self
)
628 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
629 struct type
*type
= t_smob
->type
;
633 check_typedef (type
);
635 catch (const gdb_exception
&except
)
639 /* Ignore exceptions. */
641 return scm_from_long (TYPE_LENGTH (type
));
644 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
645 Return the type, stripped of typedefs. */
648 gdbscm_type_strip_typedefs (SCM self
)
651 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
652 struct type
*type
= t_smob
->type
;
654 gdbscm_gdb_exception exc
{};
657 type
= check_typedef (type
);
659 catch (const gdb_exception
&except
)
661 exc
= unpack (except
);
664 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
665 return tyscm_scm_from_type (type
);
668 /* Strip typedefs and pointers/reference from a type. Then check that
669 it is a struct, union, or enum type. If not, return NULL. */
672 tyscm_get_composite (struct type
*type
)
677 gdbscm_gdb_exception exc
{};
680 type
= check_typedef (type
);
682 catch (const gdb_exception
&except
)
684 exc
= unpack (except
);
687 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
688 if (type
->code () != TYPE_CODE_PTR
689 && type
->code () != TYPE_CODE_REF
)
691 type
= TYPE_TARGET_TYPE (type
);
694 /* If this is not a struct, union, or enum type, raise TypeError
696 if (type
->code () != TYPE_CODE_STRUCT
697 && type
->code () != TYPE_CODE_UNION
698 && type
->code () != TYPE_CODE_ENUM
)
704 /* Helper for tyscm_array and tyscm_vector. */
707 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
708 const char *func_name
)
711 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
712 struct type
*type
= t_smob
->type
;
714 struct type
*array
= NULL
;
716 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
717 n1_scm
, &n1
, n2_scm
, &n2
);
719 if (SCM_UNBNDP (n2_scm
))
725 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
727 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
728 scm_cons (scm_from_long (n1
),
730 _("Array length must not be negative"));
733 gdbscm_gdb_exception exc
{};
736 array
= lookup_array_range_type (type
, n1
, n2
);
738 make_vector_type (array
);
740 catch (const gdb_exception
&except
)
742 exc
= unpack (except
);
745 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
746 return tyscm_scm_from_type (array
);
749 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
750 The array has indices [low-bound,high-bound].
751 If low-bound is not provided zero is used.
752 Return an array type.
754 IWBN if the one argument version specified a size, not the high bound.
755 It's too easy to pass one argument thinking it is the size of the array.
756 The current semantics are for compatibility with the Python version.
757 Later we can add #:size. */
760 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
762 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
765 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
766 The array has indices [low-bound,high-bound].
767 If low-bound is not provided zero is used.
768 Return a vector type.
770 IWBN if the one argument version specified a size, not the high bound.
771 It's too easy to pass one argument thinking it is the size of the array.
772 The current semantics are for compatibility with the Python version.
773 Later we can add #:size. */
776 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
778 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
781 /* (type-pointer <gdb:type>) -> <gdb:type>
782 Return a <gdb:type> object which represents a pointer to SELF. */
785 gdbscm_type_pointer (SCM self
)
788 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
789 struct type
*type
= t_smob
->type
;
791 gdbscm_gdb_exception exc
{};
794 type
= lookup_pointer_type (type
);
796 catch (const gdb_exception
&except
)
798 exc
= unpack (except
);
801 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
802 return tyscm_scm_from_type (type
);
805 /* (type-range <gdb:type>) -> (low high)
806 Return the range of a type represented by SELF. The return type is
807 a list. The first element is the low bound, and the second element
808 is the high bound. */
811 gdbscm_type_range (SCM self
)
814 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
815 struct type
*type
= t_smob
->type
;
816 SCM low_scm
, high_scm
;
817 /* Initialize these to appease GCC warnings. */
818 LONGEST low
= 0, high
= 0;
820 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ARRAY
821 || type
->code () == TYPE_CODE_STRING
822 || type
->code () == TYPE_CODE_RANGE
,
823 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
825 switch (type
->code ())
827 case TYPE_CODE_ARRAY
:
828 case TYPE_CODE_STRING
:
829 case TYPE_CODE_RANGE
:
830 low
= type
->bounds ()->low
.const_val ();
831 high
= type
->bounds ()->high
.const_val ();
835 low_scm
= gdbscm_scm_from_longest (low
);
836 high_scm
= gdbscm_scm_from_longest (high
);
838 return scm_list_2 (low_scm
, high_scm
);
841 /* (type-reference <gdb:type>) -> <gdb:type>
842 Return a <gdb:type> object which represents a reference to SELF. */
845 gdbscm_type_reference (SCM self
)
848 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
849 struct type
*type
= t_smob
->type
;
851 gdbscm_gdb_exception exc
{};
854 type
= lookup_lvalue_reference_type (type
);
856 catch (const gdb_exception
&except
)
858 exc
= unpack (except
);
861 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
862 return tyscm_scm_from_type (type
);
865 /* (type-target <gdb:type>) -> <gdb:type>
866 Return a <gdb:type> object which represents the target type of SELF. */
869 gdbscm_type_target (SCM self
)
872 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
873 struct type
*type
= t_smob
->type
;
875 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
877 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
880 /* (type-const <gdb:type>) -> <gdb:type>
881 Return a const-qualified type variant. */
884 gdbscm_type_const (SCM self
)
887 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
888 struct type
*type
= t_smob
->type
;
890 gdbscm_gdb_exception exc
{};
893 type
= make_cv_type (1, 0, type
, NULL
);
895 catch (const gdb_exception
&except
)
897 exc
= unpack (except
);
900 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
901 return tyscm_scm_from_type (type
);
904 /* (type-volatile <gdb:type>) -> <gdb:type>
905 Return a volatile-qualified type variant. */
908 gdbscm_type_volatile (SCM self
)
911 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
912 struct type
*type
= t_smob
->type
;
914 gdbscm_gdb_exception exc
{};
917 type
= make_cv_type (0, 1, type
, NULL
);
919 catch (const gdb_exception
&except
)
921 exc
= unpack (except
);
924 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
925 return tyscm_scm_from_type (type
);
928 /* (type-unqualified <gdb:type>) -> <gdb:type>
929 Return an unqualified type variant. */
932 gdbscm_type_unqualified (SCM self
)
935 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
936 struct type
*type
= t_smob
->type
;
938 gdbscm_gdb_exception exc
{};
941 type
= make_cv_type (0, 0, type
, NULL
);
943 catch (const gdb_exception
&except
)
945 exc
= unpack (except
);
948 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
949 return tyscm_scm_from_type (type
);
952 /* Field related accessors of types. */
954 /* (type-num-fields <gdb:type>) -> integer
955 Return number of fields. */
958 gdbscm_type_num_fields (SCM self
)
961 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
962 struct type
*type
= t_smob
->type
;
964 type
= tyscm_get_composite (type
);
966 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
967 _(not_composite_error
));
969 return scm_from_long (type
->num_fields ());
972 /* (type-field <gdb:type> string) -> <gdb:field>
973 Return the <gdb:field> object for the field named by the argument. */
976 gdbscm_type_field (SCM self
, SCM field_scm
)
979 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
980 struct type
*type
= t_smob
->type
;
982 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
985 /* We want just fields of this type, not of base types, so instead of
986 using lookup_struct_elt_type, portions of that function are
989 type
= tyscm_get_composite (type
);
991 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
992 _(not_composite_error
));
995 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
997 for (int i
= 0; i
< type
->num_fields (); i
++)
999 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1001 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1003 field
.reset (nullptr);
1004 return tyscm_make_field_smob (self
, i
);
1009 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1010 _("Unknown field"));
1013 /* (type-has-field? <gdb:type> string) -> boolean
1014 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1017 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1020 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1021 struct type
*type
= t_smob
->type
;
1023 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1026 /* We want just fields of this type, not of base types, so instead of
1027 using lookup_struct_elt_type, portions of that function are
1030 type
= tyscm_get_composite (type
);
1032 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1033 _(not_composite_error
));
1036 gdb::unique_xmalloc_ptr
<char> field
1037 = gdbscm_scm_to_c_string (field_scm
);
1039 for (int i
= 0; i
< type
->num_fields (); i
++)
1041 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1043 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1051 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1052 Make a field iterator object. */
1055 gdbscm_make_field_iterator (SCM self
)
1058 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1059 struct type
*type
= t_smob
->type
;
1060 struct type
*containing_type
;
1061 SCM containing_type_scm
;
1063 containing_type
= tyscm_get_composite (type
);
1064 if (containing_type
== NULL
)
1065 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1066 _(not_composite_error
));
1068 /* If SELF is a typedef or reference, we want the underlying type,
1069 which is what tyscm_get_composite returns. */
1070 if (containing_type
== type
)
1071 containing_type_scm
= self
;
1073 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1075 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1076 tyscm_next_field_x_proc
);
1079 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1080 Return the next field in the iteration through the list of fields of the
1081 type, or (end-of-iteration).
1082 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1083 This is the next! <gdb:iterator> function, not exported to the user. */
1086 gdbscm_type_next_field_x (SCM self
)
1088 iterator_smob
*i_smob
;
1091 SCM it_scm
, result
, progress
, object
;
1094 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1095 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1096 object
= itscm_iterator_smob_object (i_smob
);
1097 progress
= itscm_iterator_smob_progress (i_smob
);
1099 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1100 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1101 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1102 type
= t_smob
->type
;
1104 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1105 0, type
->num_fields ()),
1106 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1107 field
= scm_to_int (progress
);
1109 if (field
< type
->num_fields ())
1111 result
= tyscm_make_field_smob (object
, field
);
1112 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1116 return gdbscm_end_of_iteration ();
1119 /* Field smob accessors. */
1121 /* (field-name <gdb:field>) -> string
1122 Return the name of this field or #f if there isn't one. */
1125 gdbscm_field_name (SCM self
)
1128 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1129 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1131 if (FIELD_NAME (*field
))
1132 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1136 /* (field-type <gdb:field>) -> <gdb:type>
1137 Return the <gdb:type> object of the field or #f if there isn't one. */
1140 gdbscm_field_type (SCM self
)
1143 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1144 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1146 /* A field can have a NULL type in some situations. */
1148 return tyscm_scm_from_type (field
->type ());
1152 /* (field-enumval <gdb:field>) -> integer
1153 For enum values, return its value as an integer. */
1156 gdbscm_field_enumval (SCM self
)
1159 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1160 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1161 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1163 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ENUM
,
1164 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1166 return scm_from_long (FIELD_ENUMVAL (*field
));
1169 /* (field-bitpos <gdb:field>) -> integer
1170 For bitfields, return its offset in bits. */
1173 gdbscm_field_bitpos (SCM self
)
1176 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1177 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1178 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1180 SCM_ASSERT_TYPE (type
->code () != TYPE_CODE_ENUM
,
1181 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1183 return scm_from_long (FIELD_BITPOS (*field
));
1186 /* (field-bitsize <gdb:field>) -> integer
1187 Return the size of the field in bits. */
1190 gdbscm_field_bitsize (SCM self
)
1193 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1194 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1196 return scm_from_long (FIELD_BITPOS (*field
));
1199 /* (field-artificial? <gdb:field>) -> boolean
1200 Return #t if field is artificial. */
1203 gdbscm_field_artificial_p (SCM self
)
1206 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1207 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1209 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1212 /* (field-baseclass? <gdb:field>) -> boolean
1213 Return #t if field is a baseclass. */
1216 gdbscm_field_baseclass_p (SCM self
)
1219 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1220 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1222 if (type
->code () == TYPE_CODE_STRUCT
)
1223 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1227 /* Return the type named TYPE_NAME in BLOCK.
1228 Returns NULL if not found.
1229 This routine does not throw an error. */
1231 static struct type
*
1232 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1234 struct type
*type
= NULL
;
1238 if (startswith (type_name
, "struct "))
1239 type
= lookup_struct (type_name
+ 7, NULL
);
1240 else if (startswith (type_name
, "union "))
1241 type
= lookup_union (type_name
+ 6, NULL
);
1242 else if (startswith (type_name
, "enum "))
1243 type
= lookup_enum (type_name
+ 5, NULL
);
1245 type
= lookup_typename (current_language
,
1246 type_name
, block
, 0);
1248 catch (const gdb_exception
&except
)
1256 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1257 TODO: legacy template support left out until needed. */
1260 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1262 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1264 SCM block_scm
= SCM_BOOL_F
;
1265 int block_arg_pos
= -1;
1266 const struct block
*block
= NULL
;
1269 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1271 rest
, &block_arg_pos
, &block_scm
);
1273 if (block_arg_pos
!= -1)
1277 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1282 gdbscm_throw (exception
);
1285 type
= tyscm_lookup_typename (name
, block
);
1289 return tyscm_scm_from_type (type
);
1293 /* Initialize the Scheme type code. */
1296 static const scheme_integer_constant type_integer_constants
[] =
1298 #define X(SYM) { #SYM, SYM }
1299 X (TYPE_CODE_BITSTRING
),
1301 X (TYPE_CODE_ARRAY
),
1302 X (TYPE_CODE_STRUCT
),
1303 X (TYPE_CODE_UNION
),
1305 X (TYPE_CODE_FLAGS
),
1311 X (TYPE_CODE_RANGE
),
1312 X (TYPE_CODE_STRING
),
1313 X (TYPE_CODE_ERROR
),
1314 X (TYPE_CODE_METHOD
),
1315 X (TYPE_CODE_METHODPTR
),
1316 X (TYPE_CODE_MEMBERPTR
),
1320 X (TYPE_CODE_COMPLEX
),
1321 X (TYPE_CODE_TYPEDEF
),
1322 X (TYPE_CODE_NAMESPACE
),
1323 X (TYPE_CODE_DECFLOAT
),
1324 X (TYPE_CODE_INTERNAL_FUNCTION
),
1327 END_INTEGER_CONSTANTS
1330 static const scheme_function type_functions
[] =
1332 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1334 Return #t if the object is a <gdb:type> object." },
1336 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1338 Return the <gdb:type> object representing string or #f if not found.\n\
1339 If block is given then the type is looked for in that block.\n\
1341 Arguments: string [#:block <gdb:block>]" },
1343 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1345 Return the code of the type" },
1347 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1349 Return the tag name of the type, or #f if there isn't one." },
1351 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1353 Return the name of the type as a string, or #f if there isn't one." },
1355 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1357 Return the print name of the type as a string." },
1359 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1361 Return the size of the type, in bytes." },
1363 { "type-strip-typedefs", 1, 0, 0,
1364 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1366 Return a type formed by stripping the type of all typedefs." },
1368 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1370 Return a type representing an array of objects of the type.\n\
1372 Arguments: <gdb:type> [low-bound] high-bound\n\
1373 If low-bound is not provided zero is used.\n\
1374 N.B. If only the high-bound parameter is specified, it is not\n\
1376 Valid bounds for array indices are [low-bound,high-bound]." },
1378 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1380 Return a type representing a vector of objects of the type.\n\
1381 Vectors differ from arrays in that if the current language has C-style\n\
1382 arrays, vectors don't decay to a pointer to the first element.\n\
1383 They are first class values.\n\
1385 Arguments: <gdb:type> [low-bound] high-bound\n\
1386 If low-bound is not provided zero is used.\n\
1387 N.B. If only the high-bound parameter is specified, it is not\n\
1389 Valid bounds for array indices are [low-bound,high-bound]." },
1391 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1393 Return a type of pointer to the type." },
1395 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1397 Return (low high) representing the range for the type." },
1399 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1401 Return a type of reference to the type." },
1403 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1405 Return the target type of the type." },
1407 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1409 Return a const variant of the type." },
1411 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1413 Return a volatile variant of the type." },
1415 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1417 Return a variant of the type without const or volatile attributes." },
1419 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1421 Return the number of fields of the type." },
1423 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1425 Return the list of <gdb:field> objects of fields of the type." },
1427 { "make-field-iterator", 1, 0, 0,
1428 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1430 Return a <gdb:iterator> object for iterating over the fields of the type." },
1432 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1434 Return the field named by string of the type.\n\
1436 Arguments: <gdb:type> string" },
1438 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1440 Return #t if the type has field named string.\n\
1442 Arguments: <gdb:type> string" },
1444 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1446 Return #t if the object is a <gdb:field> object." },
1448 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1450 Return the name of the field." },
1452 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1454 Return the type of the field." },
1456 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1458 Return the enum value represented by the field." },
1460 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1462 Return the offset in bits of the field in its containing type." },
1464 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1466 Return the size of the field in bits." },
1468 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1470 Return #t if the field is artificial." },
1472 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1474 Return #t if the field is a baseclass." },
1480 gdbscm_initialize_types (void)
1482 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1483 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1484 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1485 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1487 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1488 sizeof (field_smob
));
1489 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1491 gdbscm_define_integer_constants (type_integer_constants
, 1);
1492 gdbscm_define_functions (type_functions
, 1);
1494 /* This function is "private". */
1495 tyscm_next_field_x_proc
1496 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1497 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1498 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1499 gdbscm_documentation_symbol
,
1500 gdbscm_scm_from_c_string ("\
1501 Internal function to assist the type fields iterator."));
1503 block_keyword
= scm_from_latin1_keyword ("block");
1505 /* Register an objfile "free" callback so we can properly copy types
1506 associated with the objfile when it's about to be deleted. */
1507 tyscm_objfile_data_key
1508 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1510 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1511 tyscm_eq_type_smob
);