1 /* Scheme interface to types.
3 Copyright (C) 2008-2021 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 const struct objfile_data
*tyscm_objfile_data_key
;
86 /* Hash table to uniquify global (non-objfile-owned) types. */
87 static htab_t global_types_map
;
89 static struct type
*tyscm_get_composite (struct type
*type
);
91 /* Return the type field of T_SMOB.
92 This exists so that we don't have to export the struct's contents. */
95 tyscm_type_smob_type (type_smob
*t_smob
)
100 /* Return the name of TYPE in expanded form. If there's an error
101 computing the name, throws the gdb exception with scm_throw. */
104 tyscm_type_name (struct type
*type
)
111 LA_PRINT_TYPE (type
, "", &stb
, -1, 0, &type_print_raw_options
);
112 return std::move (stb
.string ());
114 catch (const gdb_exception
&except
)
116 excp
= gdbscm_scm_from_gdb_exception (unpack (except
));
122 /* Administrivia for type smobs. */
124 /* Helper function to hash a type_smob. */
127 tyscm_hash_type_smob (const void *p
)
129 const type_smob
*t_smob
= (const type_smob
*) p
;
131 return htab_hash_pointer (t_smob
->type
);
134 /* Helper function to compute equality of type_smobs. */
137 tyscm_eq_type_smob (const void *ap
, const void *bp
)
139 const type_smob
*a
= (const type_smob
*) ap
;
140 const type_smob
*b
= (const type_smob
*) bp
;
142 return (a
->type
== b
->type
146 /* Return the struct type pointer -> SCM mapping table.
147 If type is owned by an objfile, the mapping table is created if necessary.
148 Otherwise, type is not owned by an objfile, and we use
152 tyscm_type_map (struct type
*type
)
154 struct objfile
*objfile
= type
->objfile_owner ();
158 return global_types_map
;
160 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
163 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
165 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
171 /* The smob "free" function for <gdb:type>. */
174 tyscm_free_type_smob (SCM self
)
176 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
178 if (t_smob
->type
!= NULL
)
180 htab_t htab
= tyscm_type_map (t_smob
->type
);
182 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
185 /* Not necessary, done to catch bugs. */
191 /* The smob "print" function for <gdb:type>. */
194 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
196 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
197 std::string name
= tyscm_type_name (t_smob
->type
);
199 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
200 invoked by write/~S. What to do here may need to evolve.
201 IWBN if we could pass an argument to format that would we could use
202 instead of writingp. */
203 if (pstate
->writingp
)
204 gdbscm_printf (port
, "#<%s ", type_smob_name
);
206 scm_puts (name
.c_str (), port
);
208 if (pstate
->writingp
)
209 scm_puts (">", port
);
211 scm_remember_upto_here_1 (self
);
213 /* Non-zero means success. */
217 /* The smob "equal?" function for <gdb:type>. */
220 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
222 type_smob
*type1_smob
, *type2_smob
;
223 struct type
*type1
, *type2
;
226 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
228 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
230 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
231 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
232 type1
= type1_smob
->type
;
233 type2
= type2_smob
->type
;
235 gdbscm_gdb_exception exc
{};
238 result
= types_deeply_equal (type1
, type2
);
240 catch (const gdb_exception
&except
)
242 exc
= unpack (except
);
245 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
246 return scm_from_bool (result
);
249 /* Low level routine to create a <gdb:type> object. */
252 tyscm_make_type_smob (void)
254 type_smob
*t_smob
= (type_smob
*)
255 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
258 /* This must be filled in by the caller. */
261 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
262 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
267 /* Return non-zero if SCM is a <gdb:type> object. */
270 tyscm_is_type (SCM self
)
272 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
275 /* (type? object) -> boolean */
278 gdbscm_type_p (SCM self
)
280 return scm_from_bool (tyscm_is_type (self
));
283 /* Return the existing object that encapsulates TYPE, or create a new
284 <gdb:type> object. */
287 tyscm_scm_from_type (struct type
*type
)
290 eqable_gdb_smob
**slot
;
291 type_smob
*t_smob
, t_smob_for_lookup
;
294 /* If we've already created a gsmob for this type, return it.
295 This makes types eq?-able. */
296 htab
= tyscm_type_map (type
);
297 t_smob_for_lookup
.type
= type
;
298 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
300 return (*slot
)->containing_scm
;
302 t_scm
= tyscm_make_type_smob ();
303 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
305 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
310 /* Returns the <gdb:type> object in SELF.
311 Throws an exception if SELF is not a <gdb:type> object. */
314 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
316 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
322 /* Returns a pointer to the type smob of SELF.
323 Throws an exception if SELF is not a <gdb:type> object. */
326 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
328 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
329 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
334 /* Return the type field of T_SCM, an object of type <gdb:type>.
335 This exists so that we don't have to export the struct's contents. */
338 tyscm_scm_to_type (SCM t_scm
)
342 gdb_assert (tyscm_is_type (t_scm
));
343 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
347 /* Helper function for save_objfile_types to make a deep copy of the type. */
350 tyscm_copy_type_recursive (void **slot
, void *info
)
352 type_smob
*t_smob
= (type_smob
*) *slot
;
353 htab_t copied_types
= (htab_t
) info
;
354 struct objfile
*objfile
= t_smob
->type
->objfile_owner ();
356 eqable_gdb_smob
**new_slot
;
357 type_smob t_smob_for_lookup
;
359 gdb_assert (objfile
!= NULL
);
361 htab_empty (copied_types
);
362 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
364 /* The eq?-hashtab that the type lived in is going away.
365 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
366 garbage collected we'll assert-fail if the type isn't in the hashtab.
369 Types now live in "arch space", and things like "char" that came from
370 the objfile *could* be considered eq? with the arch "char" type.
371 However, they weren't before the objfile got deleted, so making them
372 eq? now is debatable. */
373 htab
= tyscm_type_map (t_smob
->type
);
374 t_smob_for_lookup
.type
= t_smob
->type
;
375 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
376 gdb_assert (*new_slot
== NULL
);
377 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
382 /* Called when OBJFILE is about to be deleted.
383 Make a copy of all types associated with OBJFILE. */
386 save_objfile_types (struct objfile
*objfile
, void *datum
)
388 htab_t htab
= (htab_t
) datum
;
390 if (!gdb_scheme_initialized
)
393 htab_up copied_types
= create_copied_types_hash (objfile
);
397 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
.get ());
402 /* Administrivia for field smobs. */
404 /* The smob "print" function for <gdb:field>. */
407 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
409 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
411 gdbscm_printf (port
, "#<%s ", field_smob_name
);
412 scm_write (f_smob
->type_scm
, port
);
413 gdbscm_printf (port
, " %d", f_smob
->field_num
);
414 scm_puts (">", port
);
416 scm_remember_upto_here_1 (self
);
418 /* Non-zero means success. */
422 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
426 tyscm_make_field_smob (SCM type_scm
, int field_num
)
428 field_smob
*f_smob
= (field_smob
*)
429 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
432 f_smob
->type_scm
= type_scm
;
433 f_smob
->field_num
= field_num
;
434 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
435 gdbscm_init_gsmob (&f_smob
->base
);
440 /* Return non-zero if SCM is a <gdb:field> object. */
443 tyscm_is_field (SCM self
)
445 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
448 /* (field? object) -> boolean */
451 gdbscm_field_p (SCM self
)
453 return scm_from_bool (tyscm_is_field (self
));
456 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
460 tyscm_scm_from_field (SCM type_scm
, int field_num
)
462 return tyscm_make_field_smob (type_scm
, field_num
);
465 /* Returns the <gdb:field> object in SELF.
466 Throws an exception if SELF is not a <gdb:field> object. */
469 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
471 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
477 /* Returns a pointer to the field smob of SELF.
478 Throws an exception if SELF is not a <gdb:field> object. */
481 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
483 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
484 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
489 /* Returns a pointer to the type struct in F_SMOB
490 (the type the field is in). */
493 tyscm_field_smob_containing_type (field_smob
*f_smob
)
497 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
498 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
503 /* Returns a pointer to the field struct of F_SMOB. */
505 static struct field
*
506 tyscm_field_smob_to_field (field_smob
*f_smob
)
508 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
510 /* This should be non-NULL by construction. */
511 gdb_assert (type
->fields () != NULL
);
513 return &type
->field (f_smob
->field_num
);
516 /* Type smob accessors. */
518 /* (type-code <gdb:type>) -> integer
519 Return the code for this type. */
522 gdbscm_type_code (SCM self
)
525 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
526 struct type
*type
= t_smob
->type
;
528 return scm_from_int (type
->code ());
531 /* (type-fields <gdb:type>) -> list
532 Return a list of all fields. Each element is a <gdb:field> object.
533 This also supports arrays, we return a field list of one element,
537 gdbscm_type_fields (SCM self
)
540 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
541 struct type
*type
= t_smob
->type
;
542 struct type
*containing_type
;
543 SCM containing_type_scm
, result
;
546 containing_type
= tyscm_get_composite (type
);
547 if (containing_type
== NULL
)
548 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
549 _(not_composite_error
));
551 /* If SELF is a typedef or reference, we want the underlying type,
552 which is what tyscm_get_composite returns. */
553 if (containing_type
== type
)
554 containing_type_scm
= self
;
556 containing_type_scm
= tyscm_scm_from_type (containing_type
);
559 for (i
= 0; i
< containing_type
->num_fields (); ++i
)
560 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
562 return scm_reverse_x (result
, SCM_EOL
);
565 /* (type-tag <gdb:type>) -> string
566 Return the type's tag, or #f. */
569 gdbscm_type_tag (SCM self
)
572 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
573 struct type
*type
= t_smob
->type
;
574 const char *tagname
= nullptr;
576 if (type
->code () == TYPE_CODE_STRUCT
577 || type
->code () == TYPE_CODE_UNION
578 || type
->code () == TYPE_CODE_ENUM
)
579 tagname
= type
->name ();
581 if (tagname
== nullptr)
583 return gdbscm_scm_from_c_string (tagname
);
586 /* (type-name <gdb:type>) -> string
587 Return the type's name, or #f. */
590 gdbscm_type_name (SCM self
)
593 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
594 struct type
*type
= t_smob
->type
;
598 return gdbscm_scm_from_c_string (type
->name ());
601 /* (type-print-name <gdb:type>) -> string
602 Return the print name of type.
603 TODO: template support elided for now. */
606 gdbscm_type_print_name (SCM self
)
609 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
610 struct type
*type
= t_smob
->type
;
611 std::string thetype
= tyscm_type_name (type
);
612 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
617 /* (type-sizeof <gdb:type>) -> integer
618 Return the size of the type represented by SELF, in bytes. */
621 gdbscm_type_sizeof (SCM self
)
624 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
625 struct type
*type
= t_smob
->type
;
629 check_typedef (type
);
631 catch (const gdb_exception
&except
)
635 /* Ignore exceptions. */
637 return scm_from_long (TYPE_LENGTH (type
));
640 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
641 Return the type, stripped of typedefs. */
644 gdbscm_type_strip_typedefs (SCM self
)
647 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
648 struct type
*type
= t_smob
->type
;
650 gdbscm_gdb_exception exc
{};
653 type
= check_typedef (type
);
655 catch (const gdb_exception
&except
)
657 exc
= unpack (except
);
660 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
661 return tyscm_scm_from_type (type
);
664 /* Strip typedefs and pointers/reference from a type. Then check that
665 it is a struct, union, or enum type. If not, return NULL. */
668 tyscm_get_composite (struct type
*type
)
673 gdbscm_gdb_exception exc
{};
676 type
= check_typedef (type
);
678 catch (const gdb_exception
&except
)
680 exc
= unpack (except
);
683 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
684 if (type
->code () != TYPE_CODE_PTR
685 && type
->code () != TYPE_CODE_REF
)
687 type
= TYPE_TARGET_TYPE (type
);
690 /* If this is not a struct, union, or enum type, raise TypeError
692 if (type
->code () != TYPE_CODE_STRUCT
693 && type
->code () != TYPE_CODE_UNION
694 && type
->code () != TYPE_CODE_ENUM
)
700 /* Helper for tyscm_array and tyscm_vector. */
703 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
704 const char *func_name
)
707 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
708 struct type
*type
= t_smob
->type
;
710 struct type
*array
= NULL
;
712 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
713 n1_scm
, &n1
, n2_scm
, &n2
);
715 if (SCM_UNBNDP (n2_scm
))
721 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
723 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
724 scm_cons (scm_from_long (n1
),
726 _("Array length must not be negative"));
729 gdbscm_gdb_exception exc
{};
732 array
= lookup_array_range_type (type
, n1
, n2
);
734 make_vector_type (array
);
736 catch (const gdb_exception
&except
)
738 exc
= unpack (except
);
741 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
742 return tyscm_scm_from_type (array
);
745 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
746 The array has indices [low-bound,high-bound].
747 If low-bound is not provided zero is used.
748 Return an array type.
750 IWBN if the one argument version specified a size, not the high bound.
751 It's too easy to pass one argument thinking it is the size of the array.
752 The current semantics are for compatibility with the Python version.
753 Later we can add #:size. */
756 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
758 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
761 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
762 The array has indices [low-bound,high-bound].
763 If low-bound is not provided zero is used.
764 Return a vector type.
766 IWBN if the one argument version specified a size, not the high bound.
767 It's too easy to pass one argument thinking it is the size of the array.
768 The current semantics are for compatibility with the Python version.
769 Later we can add #:size. */
772 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
774 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
777 /* (type-pointer <gdb:type>) -> <gdb:type>
778 Return a <gdb:type> object which represents a pointer to SELF. */
781 gdbscm_type_pointer (SCM self
)
784 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
785 struct type
*type
= t_smob
->type
;
787 gdbscm_gdb_exception exc
{};
790 type
= lookup_pointer_type (type
);
792 catch (const gdb_exception
&except
)
794 exc
= unpack (except
);
797 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
798 return tyscm_scm_from_type (type
);
801 /* (type-range <gdb:type>) -> (low high)
802 Return the range of a type represented by SELF. The return type is
803 a list. The first element is the low bound, and the second element
804 is the high bound. */
807 gdbscm_type_range (SCM self
)
810 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
811 struct type
*type
= t_smob
->type
;
812 SCM low_scm
, high_scm
;
813 /* Initialize these to appease GCC warnings. */
814 LONGEST low
= 0, high
= 0;
816 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ARRAY
817 || type
->code () == TYPE_CODE_STRING
818 || type
->code () == TYPE_CODE_RANGE
,
819 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
821 switch (type
->code ())
823 case TYPE_CODE_ARRAY
:
824 case TYPE_CODE_STRING
:
825 case TYPE_CODE_RANGE
:
826 if (type
->bounds ()->low
.kind () == PROP_CONST
)
827 low
= type
->bounds ()->low
.const_val ();
831 if (type
->bounds ()->high
.kind () == PROP_CONST
)
832 high
= type
->bounds ()->high
.const_val ();
838 low_scm
= gdbscm_scm_from_longest (low
);
839 high_scm
= gdbscm_scm_from_longest (high
);
841 return scm_list_2 (low_scm
, high_scm
);
844 /* (type-reference <gdb:type>) -> <gdb:type>
845 Return a <gdb:type> object which represents a reference to SELF. */
848 gdbscm_type_reference (SCM self
)
851 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
852 struct type
*type
= t_smob
->type
;
854 gdbscm_gdb_exception exc
{};
857 type
= lookup_lvalue_reference_type (type
);
859 catch (const gdb_exception
&except
)
861 exc
= unpack (except
);
864 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
865 return tyscm_scm_from_type (type
);
868 /* (type-target <gdb:type>) -> <gdb:type>
869 Return a <gdb:type> object which represents the target type of SELF. */
872 gdbscm_type_target (SCM self
)
875 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
876 struct type
*type
= t_smob
->type
;
878 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
880 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
883 /* (type-const <gdb:type>) -> <gdb:type>
884 Return a const-qualified type variant. */
887 gdbscm_type_const (SCM self
)
890 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
891 struct type
*type
= t_smob
->type
;
893 gdbscm_gdb_exception exc
{};
896 type
= make_cv_type (1, 0, type
, NULL
);
898 catch (const gdb_exception
&except
)
900 exc
= unpack (except
);
903 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
904 return tyscm_scm_from_type (type
);
907 /* (type-volatile <gdb:type>) -> <gdb:type>
908 Return a volatile-qualified type variant. */
911 gdbscm_type_volatile (SCM self
)
914 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
915 struct type
*type
= t_smob
->type
;
917 gdbscm_gdb_exception exc
{};
920 type
= make_cv_type (0, 1, type
, NULL
);
922 catch (const gdb_exception
&except
)
924 exc
= unpack (except
);
927 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
928 return tyscm_scm_from_type (type
);
931 /* (type-unqualified <gdb:type>) -> <gdb:type>
932 Return an unqualified type variant. */
935 gdbscm_type_unqualified (SCM self
)
938 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
939 struct type
*type
= t_smob
->type
;
941 gdbscm_gdb_exception exc
{};
944 type
= make_cv_type (0, 0, type
, NULL
);
946 catch (const gdb_exception
&except
)
948 exc
= unpack (except
);
951 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
952 return tyscm_scm_from_type (type
);
955 /* Field related accessors of types. */
957 /* (type-num-fields <gdb:type>) -> integer
958 Return number of fields. */
961 gdbscm_type_num_fields (SCM self
)
964 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
965 struct type
*type
= t_smob
->type
;
967 type
= tyscm_get_composite (type
);
969 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
970 _(not_composite_error
));
972 return scm_from_long (type
->num_fields ());
975 /* (type-field <gdb:type> string) -> <gdb:field>
976 Return the <gdb:field> object for the field named by the argument. */
979 gdbscm_type_field (SCM self
, SCM field_scm
)
982 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
983 struct type
*type
= t_smob
->type
;
985 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
988 /* We want just fields of this type, not of base types, so instead of
989 using lookup_struct_elt_type, portions of that function are
992 type
= tyscm_get_composite (type
);
994 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
995 _(not_composite_error
));
998 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
1000 for (int i
= 0; i
< type
->num_fields (); i
++)
1002 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1004 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1006 field
.reset (nullptr);
1007 return tyscm_make_field_smob (self
, i
);
1012 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1013 _("Unknown field"));
1016 /* (type-has-field? <gdb:type> string) -> boolean
1017 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1020 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1023 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1024 struct type
*type
= t_smob
->type
;
1026 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1029 /* We want just fields of this type, not of base types, so instead of
1030 using lookup_struct_elt_type, portions of that function are
1033 type
= tyscm_get_composite (type
);
1035 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1036 _(not_composite_error
));
1039 gdb::unique_xmalloc_ptr
<char> field
1040 = gdbscm_scm_to_c_string (field_scm
);
1042 for (int i
= 0; i
< type
->num_fields (); i
++)
1044 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1046 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1054 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1055 Make a field iterator object. */
1058 gdbscm_make_field_iterator (SCM self
)
1061 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1062 struct type
*type
= t_smob
->type
;
1063 struct type
*containing_type
;
1064 SCM containing_type_scm
;
1066 containing_type
= tyscm_get_composite (type
);
1067 if (containing_type
== NULL
)
1068 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1069 _(not_composite_error
));
1071 /* If SELF is a typedef or reference, we want the underlying type,
1072 which is what tyscm_get_composite returns. */
1073 if (containing_type
== type
)
1074 containing_type_scm
= self
;
1076 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1078 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1079 tyscm_next_field_x_proc
);
1082 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1083 Return the next field in the iteration through the list of fields of the
1084 type, or (end-of-iteration).
1085 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1086 This is the next! <gdb:iterator> function, not exported to the user. */
1089 gdbscm_type_next_field_x (SCM self
)
1091 iterator_smob
*i_smob
;
1094 SCM it_scm
, result
, progress
, object
;
1097 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1098 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1099 object
= itscm_iterator_smob_object (i_smob
);
1100 progress
= itscm_iterator_smob_progress (i_smob
);
1102 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1103 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1104 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1105 type
= t_smob
->type
;
1107 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1108 0, type
->num_fields ()),
1109 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1110 field
= scm_to_int (progress
);
1112 if (field
< type
->num_fields ())
1114 result
= tyscm_make_field_smob (object
, field
);
1115 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1119 return gdbscm_end_of_iteration ();
1122 /* Field smob accessors. */
1124 /* (field-name <gdb:field>) -> string
1125 Return the name of this field or #f if there isn't one. */
1128 gdbscm_field_name (SCM self
)
1131 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1132 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1134 if (FIELD_NAME (*field
))
1135 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1139 /* (field-type <gdb:field>) -> <gdb:type>
1140 Return the <gdb:type> object of the field or #f if there isn't one. */
1143 gdbscm_field_type (SCM self
)
1146 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1147 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1149 /* A field can have a NULL type in some situations. */
1151 return tyscm_scm_from_type (field
->type ());
1155 /* (field-enumval <gdb:field>) -> integer
1156 For enum values, return its value as an integer. */
1159 gdbscm_field_enumval (SCM self
)
1162 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1163 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1164 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1166 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ENUM
,
1167 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1169 return scm_from_long (FIELD_ENUMVAL (*field
));
1172 /* (field-bitpos <gdb:field>) -> integer
1173 For bitfields, return its offset in bits. */
1176 gdbscm_field_bitpos (SCM self
)
1179 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1180 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1181 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1183 SCM_ASSERT_TYPE (type
->code () != TYPE_CODE_ENUM
,
1184 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1186 return scm_from_long (FIELD_BITPOS (*field
));
1189 /* (field-bitsize <gdb:field>) -> integer
1190 Return the size of the field in bits. */
1193 gdbscm_field_bitsize (SCM self
)
1196 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1197 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1199 return scm_from_long (FIELD_BITPOS (*field
));
1202 /* (field-artificial? <gdb:field>) -> boolean
1203 Return #t if field is artificial. */
1206 gdbscm_field_artificial_p (SCM self
)
1209 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1210 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1212 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1215 /* (field-baseclass? <gdb:field>) -> boolean
1216 Return #t if field is a baseclass. */
1219 gdbscm_field_baseclass_p (SCM self
)
1222 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1223 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1225 if (type
->code () == TYPE_CODE_STRUCT
)
1226 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1230 /* Return the type named TYPE_NAME in BLOCK.
1231 Returns NULL if not found.
1232 This routine does not throw an error. */
1234 static struct type
*
1235 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1237 struct type
*type
= NULL
;
1241 if (startswith (type_name
, "struct "))
1242 type
= lookup_struct (type_name
+ 7, NULL
);
1243 else if (startswith (type_name
, "union "))
1244 type
= lookup_union (type_name
+ 6, NULL
);
1245 else if (startswith (type_name
, "enum "))
1246 type
= lookup_enum (type_name
+ 5, NULL
);
1248 type
= lookup_typename (current_language
,
1249 type_name
, block
, 0);
1251 catch (const gdb_exception
&except
)
1259 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1260 TODO: legacy template support left out until needed. */
1263 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1265 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1267 SCM block_scm
= SCM_BOOL_F
;
1268 int block_arg_pos
= -1;
1269 const struct block
*block
= NULL
;
1272 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1274 rest
, &block_arg_pos
, &block_scm
);
1276 if (block_arg_pos
!= -1)
1280 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1285 gdbscm_throw (exception
);
1288 type
= tyscm_lookup_typename (name
, block
);
1292 return tyscm_scm_from_type (type
);
1296 /* Initialize the Scheme type code. */
1299 static const scheme_integer_constant type_integer_constants
[] =
1301 #define X(SYM) { #SYM, SYM }
1302 X (TYPE_CODE_BITSTRING
),
1304 X (TYPE_CODE_ARRAY
),
1305 X (TYPE_CODE_STRUCT
),
1306 X (TYPE_CODE_UNION
),
1308 X (TYPE_CODE_FLAGS
),
1314 X (TYPE_CODE_RANGE
),
1315 X (TYPE_CODE_STRING
),
1316 X (TYPE_CODE_ERROR
),
1317 X (TYPE_CODE_METHOD
),
1318 X (TYPE_CODE_METHODPTR
),
1319 X (TYPE_CODE_MEMBERPTR
),
1321 X (TYPE_CODE_RVALUE_REF
),
1324 X (TYPE_CODE_COMPLEX
),
1325 X (TYPE_CODE_TYPEDEF
),
1326 X (TYPE_CODE_NAMESPACE
),
1327 X (TYPE_CODE_DECFLOAT
),
1328 X (TYPE_CODE_INTERNAL_FUNCTION
),
1331 END_INTEGER_CONSTANTS
1334 static const scheme_function type_functions
[] =
1336 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1338 Return #t if the object is a <gdb:type> object." },
1340 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1342 Return the <gdb:type> object representing string or #f if not found.\n\
1343 If block is given then the type is looked for in that block.\n\
1345 Arguments: string [#:block <gdb:block>]" },
1347 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1349 Return the code of the type" },
1351 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1353 Return the tag name of the type, or #f if there isn't one." },
1355 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1357 Return the name of the type as a string, or #f if there isn't one." },
1359 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1361 Return the print name of the type as a string." },
1363 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1365 Return the size of the type, in bytes." },
1367 { "type-strip-typedefs", 1, 0, 0,
1368 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1370 Return a type formed by stripping the type of all typedefs." },
1372 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1374 Return a type representing an array of objects of the type.\n\
1376 Arguments: <gdb:type> [low-bound] high-bound\n\
1377 If low-bound is not provided zero is used.\n\
1378 N.B. If only the high-bound parameter is specified, it is not\n\
1380 Valid bounds for array indices are [low-bound,high-bound]." },
1382 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1384 Return a type representing a vector of objects of the type.\n\
1385 Vectors differ from arrays in that if the current language has C-style\n\
1386 arrays, vectors don't decay to a pointer to the first element.\n\
1387 They are first class values.\n\
1389 Arguments: <gdb:type> [low-bound] high-bound\n\
1390 If low-bound is not provided zero is used.\n\
1391 N.B. If only the high-bound parameter is specified, it is not\n\
1393 Valid bounds for array indices are [low-bound,high-bound]." },
1395 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1397 Return a type of pointer to the type." },
1399 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1401 Return (low high) representing the range for the type." },
1403 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1405 Return a type of reference to the type." },
1407 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1409 Return the target type of the type." },
1411 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1413 Return a const variant of the type." },
1415 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1417 Return a volatile variant of the type." },
1419 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1421 Return a variant of the type without const or volatile attributes." },
1423 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1425 Return the number of fields of the type." },
1427 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1429 Return the list of <gdb:field> objects of fields of the type." },
1431 { "make-field-iterator", 1, 0, 0,
1432 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1434 Return a <gdb:iterator> object for iterating over the fields of the type." },
1436 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1438 Return the field named by string of the type.\n\
1440 Arguments: <gdb:type> string" },
1442 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1444 Return #t if the type has field named string.\n\
1446 Arguments: <gdb:type> string" },
1448 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1450 Return #t if the object is a <gdb:field> object." },
1452 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1454 Return the name of the field." },
1456 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1458 Return the type of the field." },
1460 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1462 Return the enum value represented by the field." },
1464 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1466 Return the offset in bits of the field in its containing type." },
1468 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1470 Return the size of the field in bits." },
1472 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1474 Return #t if the field is artificial." },
1476 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1478 Return #t if the field is a baseclass." },
1484 gdbscm_initialize_types (void)
1486 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1487 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1488 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1489 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1491 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1492 sizeof (field_smob
));
1493 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1495 gdbscm_define_integer_constants (type_integer_constants
, 1);
1496 gdbscm_define_functions (type_functions
, 1);
1498 /* This function is "private". */
1499 tyscm_next_field_x_proc
1500 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1501 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1502 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1503 gdbscm_documentation_symbol
,
1504 gdbscm_scm_from_c_string ("\
1505 Internal function to assist the type fields iterator."));
1507 block_keyword
= scm_from_latin1_keyword ("block");
1509 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1510 tyscm_eq_type_smob
);
1513 void _initialize_scm_type ();
1515 _initialize_scm_type ()
1517 /* Register an objfile "free" callback so we can properly copy types
1518 associated with the objfile when it's about to be deleted. */
1519 tyscm_objfile_data_key
1520 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);