1 /* Scheme interface to types.
3 Copyright (C) 2008-2022 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
41 /* This always appears first.
42 eqable_gdb_smob is used so that types are eq?-able.
43 Also, a type object can be associated with an objfile. eqable_gdb_smob
44 lets us track the lifetime of all types associated with an objfile.
45 When an objfile is deleted we need to invalidate the type object. */
48 /* The GDB type structure this smob is wrapping. */
56 /* This always appears first. */
59 /* Backlink to the containing <gdb:type> object. */
62 /* The field number in TYPE_SCM. */
66 static const char type_smob_name
[] = "gdb:type";
67 static const char field_smob_name
[] = "gdb:field";
69 static const char not_composite_error
[] =
70 N_("type is not a structure, union, or enum type");
72 /* The tag Guile knows the type smob by. */
73 static scm_t_bits type_smob_tag
;
75 /* The tag Guile knows the field smob by. */
76 static scm_t_bits field_smob_tag
;
78 /* The "next" procedure for field iterators. */
79 static SCM tyscm_next_field_x_proc
;
81 /* Keywords used in argument passing. */
82 static SCM block_keyword
;
84 static int tyscm_copy_type_recursive (void **slot
, void *info
);
86 /* Called when an objfile is about to be deleted.
87 Make a copy of all types associated with OBJFILE. */
91 void operator() (htab_t htab
)
93 if (!gdb_scheme_initialized
)
96 htab_up copied_types
= create_copied_types_hash ();
100 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
.get ());
106 static const registry
<objfile
>::key
<htab
, tyscm_deleter
>
107 tyscm_objfile_data_key
;
109 /* Hash table to uniquify global (non-objfile-owned) types. */
110 static htab_t global_types_map
;
112 static struct type
*tyscm_get_composite (struct type
*type
);
114 /* Return the type field of T_SMOB.
115 This exists so that we don't have to export the struct's contents. */
118 tyscm_type_smob_type (type_smob
*t_smob
)
123 /* Return the name of TYPE in expanded form. If there's an error
124 computing the name, throws the gdb exception with scm_throw. */
127 tyscm_type_name (struct type
*type
)
134 current_language
->print_type (type
, "", &stb
, -1, 0,
135 &type_print_raw_options
);
136 return stb
.release ();
138 catch (const gdb_exception
&except
)
140 excp
= gdbscm_scm_from_gdb_exception (unpack (except
));
146 /* Administrivia for type smobs. */
148 /* Helper function to hash a type_smob. */
151 tyscm_hash_type_smob (const void *p
)
153 const type_smob
*t_smob
= (const type_smob
*) p
;
155 return htab_hash_pointer (t_smob
->type
);
158 /* Helper function to compute equality of type_smobs. */
161 tyscm_eq_type_smob (const void *ap
, const void *bp
)
163 const type_smob
*a
= (const type_smob
*) ap
;
164 const type_smob
*b
= (const type_smob
*) bp
;
166 return (a
->type
== b
->type
170 /* Return the struct type pointer -> SCM mapping table.
171 If type is owned by an objfile, the mapping table is created if necessary.
172 Otherwise, type is not owned by an objfile, and we use
176 tyscm_type_map (struct type
*type
)
178 struct objfile
*objfile
= type
->objfile_owner ();
182 return global_types_map
;
184 htab
= tyscm_objfile_data_key
.get (objfile
);
187 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
189 tyscm_objfile_data_key
.set (objfile
, htab
);
195 /* The smob "free" function for <gdb:type>. */
198 tyscm_free_type_smob (SCM self
)
200 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
202 if (t_smob
->type
!= NULL
)
204 htab_t htab
= tyscm_type_map (t_smob
->type
);
206 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
209 /* Not necessary, done to catch bugs. */
215 /* The smob "print" function for <gdb:type>. */
218 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
220 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
221 std::string name
= tyscm_type_name (t_smob
->type
);
223 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
224 invoked by write/~S. What to do here may need to evolve.
225 IWBN if we could pass an argument to format that would we could use
226 instead of writingp. */
227 if (pstate
->writingp
)
228 gdbscm_printf (port
, "#<%s ", type_smob_name
);
230 scm_puts (name
.c_str (), port
);
232 if (pstate
->writingp
)
233 scm_puts (">", port
);
235 scm_remember_upto_here_1 (self
);
237 /* Non-zero means success. */
241 /* The smob "equal?" function for <gdb:type>. */
244 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
246 type_smob
*type1_smob
, *type2_smob
;
247 struct type
*type1
, *type2
;
250 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
252 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
254 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
255 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
256 type1
= type1_smob
->type
;
257 type2
= type2_smob
->type
;
259 gdbscm_gdb_exception exc
{};
262 result
= types_deeply_equal (type1
, type2
);
264 catch (const gdb_exception
&except
)
266 exc
= unpack (except
);
269 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
270 return scm_from_bool (result
);
273 /* Low level routine to create a <gdb:type> object. */
276 tyscm_make_type_smob (void)
278 type_smob
*t_smob
= (type_smob
*)
279 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
282 /* This must be filled in by the caller. */
285 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
286 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
291 /* Return non-zero if SCM is a <gdb:type> object. */
294 tyscm_is_type (SCM self
)
296 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
299 /* (type? object) -> boolean */
302 gdbscm_type_p (SCM self
)
304 return scm_from_bool (tyscm_is_type (self
));
307 /* Return the existing object that encapsulates TYPE, or create a new
308 <gdb:type> object. */
311 tyscm_scm_from_type (struct type
*type
)
314 eqable_gdb_smob
**slot
;
315 type_smob
*t_smob
, t_smob_for_lookup
;
318 /* If we've already created a gsmob for this type, return it.
319 This makes types eq?-able. */
320 htab
= tyscm_type_map (type
);
321 t_smob_for_lookup
.type
= type
;
322 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
324 return (*slot
)->containing_scm
;
326 t_scm
= tyscm_make_type_smob ();
327 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
329 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
334 /* Returns the <gdb:type> object in SELF.
335 Throws an exception if SELF is not a <gdb:type> object. */
338 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
340 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
346 /* Returns a pointer to the type smob of SELF.
347 Throws an exception if SELF is not a <gdb:type> object. */
350 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
352 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
353 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
358 /* Return the type field of T_SCM, an object of type <gdb:type>.
359 This exists so that we don't have to export the struct's contents. */
362 tyscm_scm_to_type (SCM t_scm
)
366 gdb_assert (tyscm_is_type (t_scm
));
367 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
371 /* Helper function to make a deep copy of the type. */
374 tyscm_copy_type_recursive (void **slot
, void *info
)
376 type_smob
*t_smob
= (type_smob
*) *slot
;
377 htab_t copied_types
= (htab_t
) info
;
379 eqable_gdb_smob
**new_slot
;
380 type_smob t_smob_for_lookup
;
382 htab_empty (copied_types
);
383 t_smob
->type
= copy_type_recursive (t_smob
->type
, copied_types
);
385 /* The eq?-hashtab that the type lived in is going away.
386 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
387 garbage collected we'll assert-fail if the type isn't in the hashtab.
390 Types now live in "arch space", and things like "char" that came from
391 the objfile *could* be considered eq? with the arch "char" type.
392 However, they weren't before the objfile got deleted, so making them
393 eq? now is debatable. */
394 htab
= tyscm_type_map (t_smob
->type
);
395 t_smob_for_lookup
.type
= t_smob
->type
;
396 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
397 gdb_assert (*new_slot
== NULL
);
398 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
404 /* Administrivia for field smobs. */
406 /* The smob "print" function for <gdb:field>. */
409 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
411 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
413 gdbscm_printf (port
, "#<%s ", field_smob_name
);
414 scm_write (f_smob
->type_scm
, port
);
415 gdbscm_printf (port
, " %d", f_smob
->field_num
);
416 scm_puts (">", port
);
418 scm_remember_upto_here_1 (self
);
420 /* Non-zero means success. */
424 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
428 tyscm_make_field_smob (SCM type_scm
, int field_num
)
430 field_smob
*f_smob
= (field_smob
*)
431 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
434 f_smob
->type_scm
= type_scm
;
435 f_smob
->field_num
= field_num
;
436 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
437 gdbscm_init_gsmob (&f_smob
->base
);
442 /* Return non-zero if SCM is a <gdb:field> object. */
445 tyscm_is_field (SCM self
)
447 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
450 /* (field? object) -> boolean */
453 gdbscm_field_p (SCM self
)
455 return scm_from_bool (tyscm_is_field (self
));
458 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
462 tyscm_scm_from_field (SCM type_scm
, int field_num
)
464 return tyscm_make_field_smob (type_scm
, field_num
);
467 /* Returns the <gdb:field> object in SELF.
468 Throws an exception if SELF is not a <gdb:field> object. */
471 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
473 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
479 /* Returns a pointer to the field smob of SELF.
480 Throws an exception if SELF is not a <gdb:field> object. */
483 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
485 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
486 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
491 /* Returns a pointer to the type struct in F_SMOB
492 (the type the field is in). */
495 tyscm_field_smob_containing_type (field_smob
*f_smob
)
499 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
500 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
505 /* Returns a pointer to the field struct of F_SMOB. */
507 static struct field
*
508 tyscm_field_smob_to_field (field_smob
*f_smob
)
510 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
512 /* This should be non-NULL by construction. */
513 gdb_assert (type
->fields () != NULL
);
515 return &type
->field (f_smob
->field_num
);
518 /* Type smob accessors. */
520 /* (type-code <gdb:type>) -> integer
521 Return the code for this type. */
524 gdbscm_type_code (SCM self
)
527 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
528 struct type
*type
= t_smob
->type
;
530 return scm_from_int (type
->code ());
533 /* (type-fields <gdb:type>) -> list
534 Return a list of all fields. Each element is a <gdb:field> object.
535 This also supports arrays, we return a field list of one element,
539 gdbscm_type_fields (SCM self
)
542 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
543 struct type
*type
= t_smob
->type
;
544 struct type
*containing_type
;
545 SCM containing_type_scm
, result
;
548 containing_type
= tyscm_get_composite (type
);
549 if (containing_type
== NULL
)
550 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
551 _(not_composite_error
));
553 /* If SELF is a typedef or reference, we want the underlying type,
554 which is what tyscm_get_composite returns. */
555 if (containing_type
== type
)
556 containing_type_scm
= self
;
558 containing_type_scm
= tyscm_scm_from_type (containing_type
);
561 for (i
= 0; i
< containing_type
->num_fields (); ++i
)
562 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
564 return scm_reverse_x (result
, SCM_EOL
);
567 /* (type-tag <gdb:type>) -> string
568 Return the type's tag, or #f. */
571 gdbscm_type_tag (SCM self
)
574 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
575 struct type
*type
= t_smob
->type
;
576 const char *tagname
= nullptr;
578 if (type
->code () == TYPE_CODE_STRUCT
579 || type
->code () == TYPE_CODE_UNION
580 || type
->code () == TYPE_CODE_ENUM
)
581 tagname
= type
->name ();
583 if (tagname
== nullptr)
585 return gdbscm_scm_from_c_string (tagname
);
588 /* (type-name <gdb:type>) -> string
589 Return the type's name, or #f. */
592 gdbscm_type_name (SCM self
)
595 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
596 struct type
*type
= t_smob
->type
;
600 return gdbscm_scm_from_c_string (type
->name ());
603 /* (type-print-name <gdb:type>) -> string
604 Return the print name of type.
605 TODO: template support elided for now. */
608 gdbscm_type_print_name (SCM self
)
611 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
612 struct type
*type
= t_smob
->type
;
613 std::string thetype
= tyscm_type_name (type
);
614 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
619 /* (type-sizeof <gdb:type>) -> integer
620 Return the size of the type represented by SELF, in bytes. */
623 gdbscm_type_sizeof (SCM self
)
626 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
627 struct type
*type
= t_smob
->type
;
631 check_typedef (type
);
633 catch (const gdb_exception
&except
)
637 /* Ignore exceptions. */
639 return scm_from_long (TYPE_LENGTH (type
));
642 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
643 Return the type, stripped of typedefs. */
646 gdbscm_type_strip_typedefs (SCM self
)
649 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
650 struct type
*type
= t_smob
->type
;
652 gdbscm_gdb_exception exc
{};
655 type
= check_typedef (type
);
657 catch (const gdb_exception
&except
)
659 exc
= unpack (except
);
662 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
663 return tyscm_scm_from_type (type
);
666 /* Strip typedefs and pointers/reference from a type. Then check that
667 it is a struct, union, or enum type. If not, return NULL. */
670 tyscm_get_composite (struct type
*type
)
675 gdbscm_gdb_exception exc
{};
678 type
= check_typedef (type
);
680 catch (const gdb_exception
&except
)
682 exc
= unpack (except
);
685 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
686 if (type
->code () != TYPE_CODE_PTR
687 && type
->code () != TYPE_CODE_REF
)
689 type
= TYPE_TARGET_TYPE (type
);
692 /* If this is not a struct, union, or enum type, raise TypeError
694 if (type
->code () != TYPE_CODE_STRUCT
695 && type
->code () != TYPE_CODE_UNION
696 && type
->code () != TYPE_CODE_ENUM
)
702 /* Helper for tyscm_array and tyscm_vector. */
705 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
706 const char *func_name
)
709 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
710 struct type
*type
= t_smob
->type
;
712 struct type
*array
= NULL
;
714 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
715 n1_scm
, &n1
, n2_scm
, &n2
);
717 if (SCM_UNBNDP (n2_scm
))
723 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
725 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
726 scm_cons (scm_from_long (n1
),
728 _("Array length must not be negative"));
731 gdbscm_gdb_exception exc
{};
734 array
= lookup_array_range_type (type
, n1
, n2
);
736 make_vector_type (array
);
738 catch (const gdb_exception
&except
)
740 exc
= unpack (except
);
743 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
744 return tyscm_scm_from_type (array
);
747 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
748 The array has indices [low-bound,high-bound].
749 If low-bound is not provided zero is used.
750 Return an array type.
752 IWBN if the one argument version specified a size, not the high bound.
753 It's too easy to pass one argument thinking it is the size of the array.
754 The current semantics are for compatibility with the Python version.
755 Later we can add #:size. */
758 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
760 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
763 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
764 The array has indices [low-bound,high-bound].
765 If low-bound is not provided zero is used.
766 Return a vector type.
768 IWBN if the one argument version specified a size, not the high bound.
769 It's too easy to pass one argument thinking it is the size of the array.
770 The current semantics are for compatibility with the Python version.
771 Later we can add #:size. */
774 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
776 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
779 /* (type-pointer <gdb:type>) -> <gdb:type>
780 Return a <gdb:type> object which represents a pointer to SELF. */
783 gdbscm_type_pointer (SCM self
)
786 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
787 struct type
*type
= t_smob
->type
;
789 gdbscm_gdb_exception exc
{};
792 type
= lookup_pointer_type (type
);
794 catch (const gdb_exception
&except
)
796 exc
= unpack (except
);
799 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
800 return tyscm_scm_from_type (type
);
803 /* (type-range <gdb:type>) -> (low high)
804 Return the range of a type represented by SELF. The return type is
805 a list. The first element is the low bound, and the second element
806 is the high bound. */
809 gdbscm_type_range (SCM self
)
812 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
813 struct type
*type
= t_smob
->type
;
814 SCM low_scm
, high_scm
;
815 /* Initialize these to appease GCC warnings. */
816 LONGEST low
= 0, high
= 0;
818 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ARRAY
819 || type
->code () == TYPE_CODE_STRING
820 || type
->code () == TYPE_CODE_RANGE
,
821 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
823 switch (type
->code ())
825 case TYPE_CODE_ARRAY
:
826 case TYPE_CODE_STRING
:
827 case TYPE_CODE_RANGE
:
828 if (type
->bounds ()->low
.kind () == PROP_CONST
)
829 low
= type
->bounds ()->low
.const_val ();
833 if (type
->bounds ()->high
.kind () == PROP_CONST
)
834 high
= type
->bounds ()->high
.const_val ();
840 low_scm
= gdbscm_scm_from_longest (low
);
841 high_scm
= gdbscm_scm_from_longest (high
);
843 return scm_list_2 (low_scm
, high_scm
);
846 /* (type-reference <gdb:type>) -> <gdb:type>
847 Return a <gdb:type> object which represents a reference to SELF. */
850 gdbscm_type_reference (SCM self
)
853 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
854 struct type
*type
= t_smob
->type
;
856 gdbscm_gdb_exception exc
{};
859 type
= lookup_lvalue_reference_type (type
);
861 catch (const gdb_exception
&except
)
863 exc
= unpack (except
);
866 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
867 return tyscm_scm_from_type (type
);
870 /* (type-target <gdb:type>) -> <gdb:type>
871 Return a <gdb:type> object which represents the target type of SELF. */
874 gdbscm_type_target (SCM self
)
877 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
878 struct type
*type
= t_smob
->type
;
880 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
882 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
885 /* (type-const <gdb:type>) -> <gdb:type>
886 Return a const-qualified type variant. */
889 gdbscm_type_const (SCM self
)
892 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
893 struct type
*type
= t_smob
->type
;
895 gdbscm_gdb_exception exc
{};
898 type
= make_cv_type (1, 0, type
, NULL
);
900 catch (const gdb_exception
&except
)
902 exc
= unpack (except
);
905 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
906 return tyscm_scm_from_type (type
);
909 /* (type-volatile <gdb:type>) -> <gdb:type>
910 Return a volatile-qualified type variant. */
913 gdbscm_type_volatile (SCM self
)
916 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
917 struct type
*type
= t_smob
->type
;
919 gdbscm_gdb_exception exc
{};
922 type
= make_cv_type (0, 1, type
, NULL
);
924 catch (const gdb_exception
&except
)
926 exc
= unpack (except
);
929 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
930 return tyscm_scm_from_type (type
);
933 /* (type-unqualified <gdb:type>) -> <gdb:type>
934 Return an unqualified type variant. */
937 gdbscm_type_unqualified (SCM self
)
940 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
941 struct type
*type
= t_smob
->type
;
943 gdbscm_gdb_exception exc
{};
946 type
= make_cv_type (0, 0, type
, NULL
);
948 catch (const gdb_exception
&except
)
950 exc
= unpack (except
);
953 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
954 return tyscm_scm_from_type (type
);
957 /* Field related accessors of types. */
959 /* (type-num-fields <gdb:type>) -> integer
960 Return number of fields. */
963 gdbscm_type_num_fields (SCM self
)
966 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
967 struct type
*type
= t_smob
->type
;
969 type
= tyscm_get_composite (type
);
971 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
972 _(not_composite_error
));
974 return scm_from_long (type
->num_fields ());
977 /* (type-field <gdb:type> string) -> <gdb:field>
978 Return the <gdb:field> object for the field named by the argument. */
981 gdbscm_type_field (SCM self
, SCM field_scm
)
984 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
985 struct type
*type
= t_smob
->type
;
987 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
990 /* We want just fields of this type, not of base types, so instead of
991 using lookup_struct_elt_type, portions of that function are
994 type
= tyscm_get_composite (type
);
996 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
997 _(not_composite_error
));
1000 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
1002 for (int i
= 0; i
< type
->num_fields (); i
++)
1004 const char *t_field_name
= type
->field (i
).name ();
1006 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1008 field
.reset (nullptr);
1009 return tyscm_make_field_smob (self
, i
);
1014 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1015 _("Unknown field"));
1018 /* (type-has-field? <gdb:type> string) -> boolean
1019 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1022 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1025 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1026 struct type
*type
= t_smob
->type
;
1028 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1031 /* We want just fields of this type, not of base types, so instead of
1032 using lookup_struct_elt_type, portions of that function are
1035 type
= tyscm_get_composite (type
);
1037 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1038 _(not_composite_error
));
1041 gdb::unique_xmalloc_ptr
<char> field
1042 = gdbscm_scm_to_c_string (field_scm
);
1044 for (int i
= 0; i
< type
->num_fields (); i
++)
1046 const char *t_field_name
= type
->field (i
).name ();
1048 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1056 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1057 Make a field iterator object. */
1060 gdbscm_make_field_iterator (SCM self
)
1063 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1064 struct type
*type
= t_smob
->type
;
1065 struct type
*containing_type
;
1066 SCM containing_type_scm
;
1068 containing_type
= tyscm_get_composite (type
);
1069 if (containing_type
== NULL
)
1070 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1071 _(not_composite_error
));
1073 /* If SELF is a typedef or reference, we want the underlying type,
1074 which is what tyscm_get_composite returns. */
1075 if (containing_type
== type
)
1076 containing_type_scm
= self
;
1078 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1080 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1081 tyscm_next_field_x_proc
);
1084 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1085 Return the next field in the iteration through the list of fields of the
1086 type, or (end-of-iteration).
1087 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1088 This is the next! <gdb:iterator> function, not exported to the user. */
1091 gdbscm_type_next_field_x (SCM self
)
1093 iterator_smob
*i_smob
;
1096 SCM it_scm
, result
, progress
, object
;
1099 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1100 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1101 object
= itscm_iterator_smob_object (i_smob
);
1102 progress
= itscm_iterator_smob_progress (i_smob
);
1104 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1105 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1106 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1107 type
= t_smob
->type
;
1109 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1110 0, type
->num_fields ()),
1111 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1112 field
= scm_to_int (progress
);
1114 if (field
< type
->num_fields ())
1116 result
= tyscm_make_field_smob (object
, field
);
1117 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1121 return gdbscm_end_of_iteration ();
1124 /* Field smob accessors. */
1126 /* (field-name <gdb:field>) -> string
1127 Return the name of this field or #f if there isn't one. */
1130 gdbscm_field_name (SCM self
)
1133 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1134 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1136 if (field
->name () != nullptr)
1137 return gdbscm_scm_from_c_string (field
->name ());
1141 /* (field-type <gdb:field>) -> <gdb:type>
1142 Return the <gdb:type> object of the field or #f if there isn't one. */
1145 gdbscm_field_type (SCM self
)
1148 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1149 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1151 /* A field can have a NULL type in some situations. */
1153 return tyscm_scm_from_type (field
->type ());
1157 /* (field-enumval <gdb:field>) -> integer
1158 For enum values, return its value as an integer. */
1161 gdbscm_field_enumval (SCM self
)
1164 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1165 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1166 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1168 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ENUM
,
1169 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1171 return scm_from_long (field
->loc_enumval ());
1174 /* (field-bitpos <gdb:field>) -> integer
1175 For bitfields, return its offset in bits. */
1178 gdbscm_field_bitpos (SCM self
)
1181 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1182 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1183 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1185 SCM_ASSERT_TYPE (type
->code () != TYPE_CODE_ENUM
,
1186 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1188 return scm_from_long (field
->loc_bitpos ());
1191 /* (field-bitsize <gdb:field>) -> integer
1192 Return the size of the field in bits. */
1195 gdbscm_field_bitsize (SCM self
)
1198 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1199 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1201 return scm_from_long (field
->loc_bitpos ());
1204 /* (field-artificial? <gdb:field>) -> boolean
1205 Return #t if field is artificial. */
1208 gdbscm_field_artificial_p (SCM self
)
1211 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1212 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1214 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1217 /* (field-baseclass? <gdb:field>) -> boolean
1218 Return #t if field is a baseclass. */
1221 gdbscm_field_baseclass_p (SCM self
)
1224 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1225 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1227 if (type
->code () == TYPE_CODE_STRUCT
)
1228 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1232 /* Return the type named TYPE_NAME in BLOCK.
1233 Returns NULL if not found.
1234 This routine does not throw an error. */
1236 static struct type
*
1237 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1239 struct type
*type
= NULL
;
1243 if (startswith (type_name
, "struct "))
1244 type
= lookup_struct (type_name
+ 7, NULL
);
1245 else if (startswith (type_name
, "union "))
1246 type
= lookup_union (type_name
+ 6, NULL
);
1247 else if (startswith (type_name
, "enum "))
1248 type
= lookup_enum (type_name
+ 5, NULL
);
1250 type
= lookup_typename (current_language
,
1251 type_name
, block
, 0);
1253 catch (const gdb_exception
&except
)
1261 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1262 TODO: legacy template support left out until needed. */
1265 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1267 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1269 SCM block_scm
= SCM_BOOL_F
;
1270 int block_arg_pos
= -1;
1271 const struct block
*block
= NULL
;
1274 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1276 rest
, &block_arg_pos
, &block_scm
);
1278 if (block_arg_pos
!= -1)
1282 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1287 gdbscm_throw (exception
);
1290 type
= tyscm_lookup_typename (name
, block
);
1294 return tyscm_scm_from_type (type
);
1298 /* Initialize the Scheme type code. */
1301 static const scheme_integer_constant type_integer_constants
[] =
1303 #define X(SYM) { #SYM, SYM }
1304 X (TYPE_CODE_BITSTRING
),
1306 X (TYPE_CODE_ARRAY
),
1307 X (TYPE_CODE_STRUCT
),
1308 X (TYPE_CODE_UNION
),
1310 X (TYPE_CODE_FLAGS
),
1316 X (TYPE_CODE_RANGE
),
1317 X (TYPE_CODE_STRING
),
1318 X (TYPE_CODE_ERROR
),
1319 X (TYPE_CODE_METHOD
),
1320 X (TYPE_CODE_METHODPTR
),
1321 X (TYPE_CODE_MEMBERPTR
),
1323 X (TYPE_CODE_RVALUE_REF
),
1326 X (TYPE_CODE_COMPLEX
),
1327 X (TYPE_CODE_TYPEDEF
),
1328 X (TYPE_CODE_NAMESPACE
),
1329 X (TYPE_CODE_DECFLOAT
),
1330 X (TYPE_CODE_INTERNAL_FUNCTION
),
1333 END_INTEGER_CONSTANTS
1336 static const scheme_function type_functions
[] =
1338 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1340 Return #t if the object is a <gdb:type> object." },
1342 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1344 Return the <gdb:type> object representing string or #f if not found.\n\
1345 If block is given then the type is looked for in that block.\n\
1347 Arguments: string [#:block <gdb:block>]" },
1349 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1351 Return the code of the type" },
1353 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1355 Return the tag name of the type, or #f if there isn't one." },
1357 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1359 Return the name of the type as a string, or #f if there isn't one." },
1361 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1363 Return the print name of the type as a string." },
1365 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1367 Return the size of the type, in bytes." },
1369 { "type-strip-typedefs", 1, 0, 0,
1370 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1372 Return a type formed by stripping the type of all typedefs." },
1374 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1376 Return a type representing an array of objects of the type.\n\
1378 Arguments: <gdb:type> [low-bound] high-bound\n\
1379 If low-bound is not provided zero is used.\n\
1380 N.B. If only the high-bound parameter is specified, it is not\n\
1382 Valid bounds for array indices are [low-bound,high-bound]." },
1384 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1386 Return a type representing a vector of objects of the type.\n\
1387 Vectors differ from arrays in that if the current language has C-style\n\
1388 arrays, vectors don't decay to a pointer to the first element.\n\
1389 They are first class values.\n\
1391 Arguments: <gdb:type> [low-bound] high-bound\n\
1392 If low-bound is not provided zero is used.\n\
1393 N.B. If only the high-bound parameter is specified, it is not\n\
1395 Valid bounds for array indices are [low-bound,high-bound]." },
1397 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1399 Return a type of pointer to the type." },
1401 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1403 Return (low high) representing the range for the type." },
1405 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1407 Return a type of reference to the type." },
1409 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1411 Return the target type of the type." },
1413 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1415 Return a const variant of the type." },
1417 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1419 Return a volatile variant of the type." },
1421 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1423 Return a variant of the type without const or volatile attributes." },
1425 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1427 Return the number of fields of the type." },
1429 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1431 Return the list of <gdb:field> objects of fields of the type." },
1433 { "make-field-iterator", 1, 0, 0,
1434 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1436 Return a <gdb:iterator> object for iterating over the fields of the type." },
1438 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1440 Return the field named by string of the type.\n\
1442 Arguments: <gdb:type> string" },
1444 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1446 Return #t if the type has field named string.\n\
1448 Arguments: <gdb:type> string" },
1450 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1452 Return #t if the object is a <gdb:field> object." },
1454 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1456 Return the name of the field." },
1458 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1460 Return the type of the field." },
1462 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1464 Return the enum value represented by the field." },
1466 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1468 Return the offset in bits of the field in its containing type." },
1470 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1472 Return the size of the field in bits." },
1474 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1476 Return #t if the field is artificial." },
1478 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1480 Return #t if the field is a baseclass." },
1486 gdbscm_initialize_types (void)
1488 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1489 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1490 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1491 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1493 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1494 sizeof (field_smob
));
1495 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1497 gdbscm_define_integer_constants (type_integer_constants
, 1);
1498 gdbscm_define_functions (type_functions
, 1);
1500 /* This function is "private". */
1501 tyscm_next_field_x_proc
1502 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1503 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1504 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1505 gdbscm_documentation_symbol
,
1506 gdbscm_scm_from_c_string ("\
1507 Internal function to assist the type fields iterator."));
1509 block_keyword
= scm_from_latin1_keyword ("block");
1511 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1512 tyscm_eq_type_smob
);