1 /* Scheme interface to types.
3 Copyright (C) 2008-2019 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"
29 #include "common/vec.h"
31 #include "dwarf2loc.h"
32 #include "typeprint.h"
33 #include "guile-internal.h"
35 /* The <gdb:type> smob.
36 The type is chained with all types associated with its objfile, if any.
37 This lets us copy the underlying struct type when the objfile is
39 The typedef for this struct is in guile-internal.h. */
43 /* This always appears first.
44 eqable_gdb_smob is used so that types are eq?-able.
45 Also, a type object can be associated with an objfile. eqable_gdb_smob
46 lets us track the lifetime of all types associated with an objfile.
47 When an objfile is deleted we need to invalidate the type object. */
50 /* The GDB type structure this smob is wrapping. */
58 /* This always appears first. */
61 /* Backlink to the containing <gdb:type> object. */
64 /* The field number in TYPE_SCM. */
68 static const char type_smob_name
[] = "gdb:type";
69 static const char field_smob_name
[] = "gdb:field";
71 static const char not_composite_error
[] =
72 N_("type is not a structure, union, or enum type");
74 /* The tag Guile knows the type smob by. */
75 static scm_t_bits type_smob_tag
;
77 /* The tag Guile knows the field smob by. */
78 static scm_t_bits field_smob_tag
;
80 /* The "next" procedure for field iterators. */
81 static SCM tyscm_next_field_x_proc
;
83 /* Keywords used in argument passing. */
84 static SCM block_keyword
;
86 static const struct objfile_data
*tyscm_objfile_data_key
;
88 /* Hash table to uniquify global (non-objfile-owned) types. */
89 static htab_t global_types_map
;
91 static struct type
*tyscm_get_composite (struct type
*type
);
93 /* Return the type field of T_SMOB.
94 This exists so that we don't have to export the struct's contents. */
97 tyscm_type_smob_type (type_smob
*t_smob
)
102 /* Return the name of TYPE in expanded form. If there's an error
103 computing the name, throws the gdb exception with scm_throw. */
106 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 SCM excp
= gdbscm_scm_from_gdb_exception (except
);
121 gdb_assert_not_reached ("no way to get here");
124 /* Administrivia for type smobs. */
126 /* Helper function to hash a type_smob. */
129 tyscm_hash_type_smob (const void *p
)
131 const type_smob
*t_smob
= (const type_smob
*) p
;
133 return htab_hash_pointer (t_smob
->type
);
136 /* Helper function to compute equality of type_smobs. */
139 tyscm_eq_type_smob (const void *ap
, const void *bp
)
141 const type_smob
*a
= (const type_smob
*) ap
;
142 const type_smob
*b
= (const type_smob
*) bp
;
144 return (a
->type
== b
->type
148 /* Return the struct type pointer -> SCM mapping table.
149 If type is owned by an objfile, the mapping table is created if necessary.
150 Otherwise, type is not owned by an objfile, and we use
154 tyscm_type_map (struct type
*type
)
156 struct objfile
*objfile
= TYPE_OBJFILE (type
);
160 return global_types_map
;
162 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
165 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
167 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
173 /* The smob "free" function for <gdb:type>. */
176 tyscm_free_type_smob (SCM self
)
178 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
180 if (t_smob
->type
!= NULL
)
182 htab_t htab
= tyscm_type_map (t_smob
->type
);
184 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
187 /* Not necessary, done to catch bugs. */
193 /* The smob "print" function for <gdb:type>. */
196 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
198 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
199 std::string name
= tyscm_type_name (t_smob
->type
);
201 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
202 invoked by write/~S. What to do here may need to evolve.
203 IWBN if we could pass an argument to format that would we could use
204 instead of writingp. */
205 if (pstate
->writingp
)
206 gdbscm_printf (port
, "#<%s ", type_smob_name
);
208 scm_puts (name
.c_str (), port
);
210 if (pstate
->writingp
)
211 scm_puts (">", port
);
213 scm_remember_upto_here_1 (self
);
215 /* Non-zero means success. */
219 /* The smob "equal?" function for <gdb:type>. */
222 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
224 type_smob
*type1_smob
, *type2_smob
;
225 struct type
*type1
, *type2
;
228 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
230 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
232 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
233 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
234 type1
= type1_smob
->type
;
235 type2
= type2_smob
->type
;
239 result
= types_deeply_equal (type1
, type2
);
241 catch (const gdb_exception
&except
)
243 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
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
= TYPE_OBJFILE (t_smob
->type
);
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
;
391 if (!gdb_scheme_initialized
)
394 copied_types
= create_copied_types_hash (objfile
);
398 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
402 htab_delete (copied_types
);
405 /* Administrivia for field smobs. */
407 /* The smob "print" function for <gdb:field>. */
410 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
412 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
414 gdbscm_printf (port
, "#<%s ", field_smob_name
);
415 scm_write (f_smob
->type_scm
, port
);
416 gdbscm_printf (port
, " %d", f_smob
->field_num
);
417 scm_puts (">", port
);
419 scm_remember_upto_here_1 (self
);
421 /* Non-zero means success. */
425 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
429 tyscm_make_field_smob (SCM type_scm
, int field_num
)
431 field_smob
*f_smob
= (field_smob
*)
432 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
435 f_smob
->type_scm
= type_scm
;
436 f_smob
->field_num
= field_num
;
437 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
438 gdbscm_init_gsmob (&f_smob
->base
);
443 /* Return non-zero if SCM is a <gdb:field> object. */
446 tyscm_is_field (SCM self
)
448 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
451 /* (field? object) -> boolean */
454 gdbscm_field_p (SCM self
)
456 return scm_from_bool (tyscm_is_field (self
));
459 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
463 tyscm_scm_from_field (SCM type_scm
, int field_num
)
465 return tyscm_make_field_smob (type_scm
, field_num
);
468 /* Returns the <gdb:field> object in SELF.
469 Throws an exception if SELF is not a <gdb:field> object. */
472 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
474 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
480 /* Returns a pointer to the field smob of SELF.
481 Throws an exception if SELF is not a <gdb:field> object. */
484 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
486 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
487 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
492 /* Returns a pointer to the type struct in F_SMOB
493 (the type the field is in). */
496 tyscm_field_smob_containing_type (field_smob
*f_smob
)
500 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
501 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
506 /* Returns a pointer to the field struct of F_SMOB. */
508 static struct field
*
509 tyscm_field_smob_to_field (field_smob
*f_smob
)
511 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
513 /* This should be non-NULL by construction. */
514 gdb_assert (TYPE_FIELDS (type
) != NULL
);
516 return &TYPE_FIELD (type
, f_smob
->field_num
);
519 /* Type smob accessors. */
521 /* (type-code <gdb:type>) -> integer
522 Return the code for this type. */
525 gdbscm_type_code (SCM self
)
528 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
529 struct type
*type
= t_smob
->type
;
531 return scm_from_int (TYPE_CODE (type
));
534 /* (type-fields <gdb:type>) -> list
535 Return a list of all fields. Each element is a <gdb:field> object.
536 This also supports arrays, we return a field list of one element,
540 gdbscm_type_fields (SCM self
)
543 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
544 struct type
*type
= t_smob
->type
;
545 struct type
*containing_type
;
546 SCM containing_type_scm
, result
;
549 containing_type
= tyscm_get_composite (type
);
550 if (containing_type
== NULL
)
551 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
552 _(not_composite_error
));
554 /* If SELF is a typedef or reference, we want the underlying type,
555 which is what tyscm_get_composite returns. */
556 if (containing_type
== type
)
557 containing_type_scm
= self
;
559 containing_type_scm
= tyscm_scm_from_type (containing_type
);
562 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
563 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
565 return scm_reverse_x (result
, SCM_EOL
);
568 /* (type-tag <gdb:type>) -> string
569 Return the type's tag, or #f. */
572 gdbscm_type_tag (SCM self
)
575 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
576 struct type
*type
= t_smob
->type
;
577 const char *tagname
= nullptr;
579 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
580 || TYPE_CODE (type
) == TYPE_CODE_UNION
581 || TYPE_CODE (type
) == TYPE_CODE_ENUM
)
582 tagname
= TYPE_NAME (type
);
584 if (tagname
== nullptr)
586 return gdbscm_scm_from_c_string (tagname
);
589 /* (type-name <gdb:type>) -> string
590 Return the type's name, or #f. */
593 gdbscm_type_name (SCM self
)
596 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
597 struct type
*type
= t_smob
->type
;
599 if (!TYPE_NAME (type
))
601 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
604 /* (type-print-name <gdb:type>) -> string
605 Return the print name of type.
606 TODO: template support elided for now. */
609 gdbscm_type_print_name (SCM self
)
612 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
613 struct type
*type
= t_smob
->type
;
614 std::string thetype
= tyscm_type_name (type
);
615 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
620 /* (type-sizeof <gdb:type>) -> integer
621 Return the size of the type represented by SELF, in bytes. */
624 gdbscm_type_sizeof (SCM self
)
627 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
628 struct type
*type
= t_smob
->type
;
632 check_typedef (type
);
634 catch (const gdb_exception
&except
)
638 /* Ignore exceptions. */
640 return scm_from_long (TYPE_LENGTH (type
));
643 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
644 Return the type, stripped of typedefs. */
647 gdbscm_type_strip_typedefs (SCM self
)
650 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
651 struct type
*type
= t_smob
->type
;
655 type
= check_typedef (type
);
657 catch (const gdb_exception
&except
)
659 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
662 return tyscm_scm_from_type (type
);
665 /* Strip typedefs and pointers/reference from a type. Then check that
666 it is a struct, union, or enum type. If not, return NULL. */
669 tyscm_get_composite (struct type
*type
)
676 type
= check_typedef (type
);
678 catch (const gdb_exception
&except
)
680 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
683 if (TYPE_CODE (type
) != TYPE_CODE_PTR
684 && TYPE_CODE (type
) != TYPE_CODE_REF
)
686 type
= TYPE_TARGET_TYPE (type
);
689 /* If this is not a struct, union, or enum type, raise TypeError
691 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
692 && TYPE_CODE (type
) != TYPE_CODE_UNION
693 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
699 /* Helper for tyscm_array and tyscm_vector. */
702 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
703 const char *func_name
)
706 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
707 struct type
*type
= t_smob
->type
;
709 struct type
*array
= NULL
;
711 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
712 n1_scm
, &n1
, n2_scm
, &n2
);
714 if (SCM_UNBNDP (n2_scm
))
720 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
722 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
723 scm_cons (scm_from_long (n1
),
725 _("Array length must not be negative"));
730 array
= lookup_array_range_type (type
, n1
, n2
);
732 make_vector_type (array
);
734 catch (const gdb_exception
&except
)
736 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
739 return tyscm_scm_from_type (array
);
742 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
743 The array has indices [low-bound,high-bound].
744 If low-bound is not provided zero is used.
745 Return an array type.
747 IWBN if the one argument version specified a size, not the high bound.
748 It's too easy to pass one argument thinking it is the size of the array.
749 The current semantics are for compatibility with the Python version.
750 Later we can add #:size. */
753 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
755 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
758 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
759 The array has indices [low-bound,high-bound].
760 If low-bound is not provided zero is used.
761 Return a vector type.
763 IWBN if the one argument version specified a size, not the high bound.
764 It's too easy to pass one argument thinking it is the size of the array.
765 The current semantics are for compatibility with the Python version.
766 Later we can add #:size. */
769 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
771 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
774 /* (type-pointer <gdb:type>) -> <gdb:type>
775 Return a <gdb:type> object which represents a pointer to SELF. */
778 gdbscm_type_pointer (SCM self
)
781 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
782 struct type
*type
= t_smob
->type
;
786 type
= lookup_pointer_type (type
);
788 catch (const gdb_exception
&except
)
790 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
793 return tyscm_scm_from_type (type
);
796 /* (type-range <gdb:type>) -> (low high)
797 Return the range of a type represented by SELF. The return type is
798 a list. The first element is the low bound, and the second element
799 is the high bound. */
802 gdbscm_type_range (SCM self
)
805 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
806 struct type
*type
= t_smob
->type
;
807 SCM low_scm
, high_scm
;
808 /* Initialize these to appease GCC warnings. */
809 LONGEST low
= 0, high
= 0;
811 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
812 || TYPE_CODE (type
) == TYPE_CODE_STRING
813 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
814 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
816 switch (TYPE_CODE (type
))
818 case TYPE_CODE_ARRAY
:
819 case TYPE_CODE_STRING
:
820 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
821 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
823 case TYPE_CODE_RANGE
:
824 low
= TYPE_LOW_BOUND (type
);
825 high
= TYPE_HIGH_BOUND (type
);
829 low_scm
= gdbscm_scm_from_longest (low
);
830 high_scm
= gdbscm_scm_from_longest (high
);
832 return scm_list_2 (low_scm
, high_scm
);
835 /* (type-reference <gdb:type>) -> <gdb:type>
836 Return a <gdb:type> object which represents a reference to SELF. */
839 gdbscm_type_reference (SCM self
)
842 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
843 struct type
*type
= t_smob
->type
;
847 type
= lookup_lvalue_reference_type (type
);
849 catch (const gdb_exception
&except
)
851 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
854 return tyscm_scm_from_type (type
);
857 /* (type-target <gdb:type>) -> <gdb:type>
858 Return a <gdb:type> object which represents the target type of SELF. */
861 gdbscm_type_target (SCM self
)
864 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
865 struct type
*type
= t_smob
->type
;
867 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
869 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
872 /* (type-const <gdb:type>) -> <gdb:type>
873 Return a const-qualified type variant. */
876 gdbscm_type_const (SCM self
)
879 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
880 struct type
*type
= t_smob
->type
;
884 type
= make_cv_type (1, 0, type
, NULL
);
886 catch (const gdb_exception
&except
)
888 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
891 return tyscm_scm_from_type (type
);
894 /* (type-volatile <gdb:type>) -> <gdb:type>
895 Return a volatile-qualified type variant. */
898 gdbscm_type_volatile (SCM self
)
901 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
902 struct type
*type
= t_smob
->type
;
906 type
= make_cv_type (0, 1, type
, NULL
);
908 catch (const gdb_exception
&except
)
910 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
913 return tyscm_scm_from_type (type
);
916 /* (type-unqualified <gdb:type>) -> <gdb:type>
917 Return an unqualified type variant. */
920 gdbscm_type_unqualified (SCM self
)
923 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
924 struct type
*type
= t_smob
->type
;
928 type
= make_cv_type (0, 0, type
, NULL
);
930 catch (const gdb_exception
&except
)
932 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
935 return tyscm_scm_from_type (type
);
938 /* Field related accessors of types. */
940 /* (type-num-fields <gdb:type>) -> integer
941 Return number of fields. */
944 gdbscm_type_num_fields (SCM self
)
947 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
948 struct type
*type
= t_smob
->type
;
950 type
= tyscm_get_composite (type
);
952 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
953 _(not_composite_error
));
955 return scm_from_long (TYPE_NFIELDS (type
));
958 /* (type-field <gdb:type> string) -> <gdb:field>
959 Return the <gdb:field> object for the field named by the argument. */
962 gdbscm_type_field (SCM self
, SCM field_scm
)
965 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
966 struct type
*type
= t_smob
->type
;
968 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
971 /* We want just fields of this type, not of base types, so instead of
972 using lookup_struct_elt_type, portions of that function are
975 type
= tyscm_get_composite (type
);
977 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
978 _(not_composite_error
));
981 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
983 for (int i
= 0; i
< TYPE_NFIELDS (type
); i
++)
985 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
987 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
989 field
.reset (nullptr);
990 return tyscm_make_field_smob (self
, i
);
995 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
999 /* (type-has-field? <gdb:type> string) -> boolean
1000 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1003 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1006 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1007 struct type
*type
= t_smob
->type
;
1009 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1012 /* We want just fields of this type, not of base types, so instead of
1013 using lookup_struct_elt_type, portions of that function are
1016 type
= tyscm_get_composite (type
);
1018 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1019 _(not_composite_error
));
1022 gdb::unique_xmalloc_ptr
<char> field
1023 = gdbscm_scm_to_c_string (field_scm
);
1025 for (int i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1027 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1029 if (t_field_name
&& (strcmp_iw (t_field_name
, field
.get ()) == 0))
1037 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1038 Make a field iterator object. */
1041 gdbscm_make_field_iterator (SCM self
)
1044 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1045 struct type
*type
= t_smob
->type
;
1046 struct type
*containing_type
;
1047 SCM containing_type_scm
;
1049 containing_type
= tyscm_get_composite (type
);
1050 if (containing_type
== NULL
)
1051 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1052 _(not_composite_error
));
1054 /* If SELF is a typedef or reference, we want the underlying type,
1055 which is what tyscm_get_composite returns. */
1056 if (containing_type
== type
)
1057 containing_type_scm
= self
;
1059 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1061 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1062 tyscm_next_field_x_proc
);
1065 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1066 Return the next field in the iteration through the list of fields of the
1067 type, or (end-of-iteration).
1068 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1069 This is the next! <gdb:iterator> function, not exported to the user. */
1072 gdbscm_type_next_field_x (SCM self
)
1074 iterator_smob
*i_smob
;
1077 SCM it_scm
, result
, progress
, object
;
1080 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1081 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1082 object
= itscm_iterator_smob_object (i_smob
);
1083 progress
= itscm_iterator_smob_progress (i_smob
);
1085 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1086 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1087 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1088 type
= t_smob
->type
;
1090 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1091 0, TYPE_NFIELDS (type
)),
1092 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1093 field
= scm_to_int (progress
);
1095 if (field
< TYPE_NFIELDS (type
))
1097 result
= tyscm_make_field_smob (object
, field
);
1098 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1102 return gdbscm_end_of_iteration ();
1105 /* Field smob accessors. */
1107 /* (field-name <gdb:field>) -> string
1108 Return the name of this field or #f if there isn't one. */
1111 gdbscm_field_name (SCM self
)
1114 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1115 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1117 if (FIELD_NAME (*field
))
1118 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1122 /* (field-type <gdb:field>) -> <gdb:type>
1123 Return the <gdb:type> object of the field or #f if there isn't one. */
1126 gdbscm_field_type (SCM self
)
1129 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1130 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1132 /* A field can have a NULL type in some situations. */
1133 if (FIELD_TYPE (*field
))
1134 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1138 /* (field-enumval <gdb:field>) -> integer
1139 For enum values, return its value as an integer. */
1142 gdbscm_field_enumval (SCM self
)
1145 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1146 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1147 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1149 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1150 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1152 return scm_from_long (FIELD_ENUMVAL (*field
));
1155 /* (field-bitpos <gdb:field>) -> integer
1156 For bitfields, return its offset in bits. */
1159 gdbscm_field_bitpos (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
) != TYPE_CODE_ENUM
,
1167 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1169 return scm_from_long (FIELD_BITPOS (*field
));
1172 /* (field-bitsize <gdb:field>) -> integer
1173 Return the size of the field in bits. */
1176 gdbscm_field_bitsize (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
);
1182 return scm_from_long (FIELD_BITPOS (*field
));
1185 /* (field-artificial? <gdb:field>) -> boolean
1186 Return #t if field is artificial. */
1189 gdbscm_field_artificial_p (SCM self
)
1192 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1193 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1195 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1198 /* (field-baseclass? <gdb:field>) -> boolean
1199 Return #t if field is a baseclass. */
1202 gdbscm_field_baseclass_p (SCM self
)
1205 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1206 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1208 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1209 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1213 /* Return the type named TYPE_NAME in BLOCK.
1214 Returns NULL if not found.
1215 This routine does not throw an error. */
1217 static struct type
*
1218 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1220 struct type
*type
= NULL
;
1224 if (startswith (type_name
, "struct "))
1225 type
= lookup_struct (type_name
+ 7, NULL
);
1226 else if (startswith (type_name
, "union "))
1227 type
= lookup_union (type_name
+ 6, NULL
);
1228 else if (startswith (type_name
, "enum "))
1229 type
= lookup_enum (type_name
+ 5, NULL
);
1231 type
= lookup_typename (current_language
, get_current_arch (),
1232 type_name
, block
, 0);
1234 catch (const gdb_exception
&except
)
1242 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1243 TODO: legacy template support left out until needed. */
1246 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1248 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1250 SCM block_scm
= SCM_BOOL_F
;
1251 int block_arg_pos
= -1;
1252 const struct block
*block
= NULL
;
1255 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1257 rest
, &block_arg_pos
, &block_scm
);
1259 if (block_arg_pos
!= -1)
1263 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1268 gdbscm_throw (exception
);
1271 type
= tyscm_lookup_typename (name
, block
);
1275 return tyscm_scm_from_type (type
);
1279 /* Initialize the Scheme type code. */
1282 static const scheme_integer_constant type_integer_constants
[] =
1284 #define X(SYM) { #SYM, SYM }
1285 X (TYPE_CODE_BITSTRING
),
1287 X (TYPE_CODE_ARRAY
),
1288 X (TYPE_CODE_STRUCT
),
1289 X (TYPE_CODE_UNION
),
1291 X (TYPE_CODE_FLAGS
),
1297 X (TYPE_CODE_RANGE
),
1298 X (TYPE_CODE_STRING
),
1299 X (TYPE_CODE_ERROR
),
1300 X (TYPE_CODE_METHOD
),
1301 X (TYPE_CODE_METHODPTR
),
1302 X (TYPE_CODE_MEMBERPTR
),
1306 X (TYPE_CODE_COMPLEX
),
1307 X (TYPE_CODE_TYPEDEF
),
1308 X (TYPE_CODE_NAMESPACE
),
1309 X (TYPE_CODE_DECFLOAT
),
1310 X (TYPE_CODE_INTERNAL_FUNCTION
),
1313 END_INTEGER_CONSTANTS
1316 static const scheme_function type_functions
[] =
1318 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1320 Return #t if the object is a <gdb:type> object." },
1322 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1324 Return the <gdb:type> object representing string or #f if not found.\n\
1325 If block is given then the type is looked for in that block.\n\
1327 Arguments: string [#:block <gdb:block>]" },
1329 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1331 Return the code of the type" },
1333 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1335 Return the tag name of the type, or #f if there isn't one." },
1337 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1339 Return the name of the type as a string, or #f if there isn't one." },
1341 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1343 Return the print name of the type as a string." },
1345 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1347 Return the size of the type, in bytes." },
1349 { "type-strip-typedefs", 1, 0, 0,
1350 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1352 Return a type formed by stripping the type of all typedefs." },
1354 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1356 Return a type representing an array of objects of the type.\n\
1358 Arguments: <gdb:type> [low-bound] high-bound\n\
1359 If low-bound is not provided zero is used.\n\
1360 N.B. If only the high-bound parameter is specified, it is not\n\
1362 Valid bounds for array indices are [low-bound,high-bound]." },
1364 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1366 Return a type representing a vector of objects of the type.\n\
1367 Vectors differ from arrays in that if the current language has C-style\n\
1368 arrays, vectors don't decay to a pointer to the first element.\n\
1369 They are first class values.\n\
1371 Arguments: <gdb:type> [low-bound] high-bound\n\
1372 If low-bound is not provided zero is used.\n\
1373 N.B. If only the high-bound parameter is specified, it is not\n\
1375 Valid bounds for array indices are [low-bound,high-bound]." },
1377 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1379 Return a type of pointer to the type." },
1381 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1383 Return (low high) representing the range for the type." },
1385 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1387 Return a type of reference to the type." },
1389 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1391 Return the target type of the type." },
1393 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1395 Return a const variant of the type." },
1397 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1399 Return a volatile variant of the type." },
1401 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1403 Return a variant of the type without const or volatile attributes." },
1405 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1407 Return the number of fields of the type." },
1409 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1411 Return the list of <gdb:field> objects of fields of the type." },
1413 { "make-field-iterator", 1, 0, 0,
1414 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1416 Return a <gdb:iterator> object for iterating over the fields of the type." },
1418 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1420 Return the field named by string of the type.\n\
1422 Arguments: <gdb:type> string" },
1424 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1426 Return #t if the type has field named string.\n\
1428 Arguments: <gdb:type> string" },
1430 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1432 Return #t if the object is a <gdb:field> object." },
1434 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1436 Return the name of the field." },
1438 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1440 Return the type of the field." },
1442 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1444 Return the enum value represented by the field." },
1446 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1448 Return the offset in bits of the field in its containing type." },
1450 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1452 Return the size of the field in bits." },
1454 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1456 Return #t if the field is artificial." },
1458 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1460 Return #t if the field is a baseclass." },
1466 gdbscm_initialize_types (void)
1468 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1469 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1470 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1471 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1473 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1474 sizeof (field_smob
));
1475 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1477 gdbscm_define_integer_constants (type_integer_constants
, 1);
1478 gdbscm_define_functions (type_functions
, 1);
1480 /* This function is "private". */
1481 tyscm_next_field_x_proc
1482 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1483 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1484 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1485 gdbscm_documentation_symbol
,
1486 gdbscm_scm_from_c_string ("\
1487 Internal function to assist the type fields iterator."));
1489 block_keyword
= scm_from_latin1_keyword ("block");
1491 /* Register an objfile "free" callback so we can properly copy types
1492 associated with the objfile when it's about to be deleted. */
1493 tyscm_objfile_data_key
1494 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1496 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1497 tyscm_eq_type_smob
);