1 /* Scheme interface to types.
3 Copyright (C) 2008-2018 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"
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 (except
, RETURN_MASK_ALL
)
117 SCM excp
= gdbscm_scm_from_gdb_exception (except
);
122 gdb_assert_not_reached ("no way to get here");
125 /* Administrivia for type smobs. */
127 /* Helper function to hash a type_smob. */
130 tyscm_hash_type_smob (const void *p
)
132 const type_smob
*t_smob
= (const type_smob
*) p
;
134 return htab_hash_pointer (t_smob
->type
);
137 /* Helper function to compute equality of type_smobs. */
140 tyscm_eq_type_smob (const void *ap
, const void *bp
)
142 const type_smob
*a
= (const type_smob
*) ap
;
143 const type_smob
*b
= (const type_smob
*) bp
;
145 return (a
->type
== b
->type
149 /* Return the struct type pointer -> SCM mapping table.
150 If type is owned by an objfile, the mapping table is created if necessary.
151 Otherwise, type is not owned by an objfile, and we use
155 tyscm_type_map (struct type
*type
)
157 struct objfile
*objfile
= TYPE_OBJFILE (type
);
161 return global_types_map
;
163 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
166 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
168 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
174 /* The smob "free" function for <gdb:type>. */
177 tyscm_free_type_smob (SCM self
)
179 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
181 if (t_smob
->type
!= NULL
)
183 htab_t htab
= tyscm_type_map (t_smob
->type
);
185 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
188 /* Not necessary, done to catch bugs. */
194 /* The smob "print" function for <gdb:type>. */
197 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
199 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
200 std::string name
= tyscm_type_name (t_smob
->type
);
202 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
203 invoked by write/~S. What to do here may need to evolve.
204 IWBN if we could pass an argument to format that would we could use
205 instead of writingp. */
206 if (pstate
->writingp
)
207 gdbscm_printf (port
, "#<%s ", type_smob_name
);
209 scm_puts (name
.c_str (), port
);
211 if (pstate
->writingp
)
212 scm_puts (">", port
);
214 scm_remember_upto_here_1 (self
);
216 /* Non-zero means success. */
220 /* The smob "equal?" function for <gdb:type>. */
223 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
225 type_smob
*type1_smob
, *type2_smob
;
226 struct type
*type1
, *type2
;
229 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
231 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
233 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
234 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
235 type1
= type1_smob
->type
;
236 type2
= type2_smob
->type
;
240 result
= types_deeply_equal (type1
, type2
);
242 CATCH (except
, RETURN_MASK_ALL
)
244 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
248 return scm_from_bool (result
);
251 /* Low level routine to create a <gdb:type> object. */
254 tyscm_make_type_smob (void)
256 type_smob
*t_smob
= (type_smob
*)
257 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
260 /* This must be filled in by the caller. */
263 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
264 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
269 /* Return non-zero if SCM is a <gdb:type> object. */
272 tyscm_is_type (SCM self
)
274 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
277 /* (type? object) -> boolean */
280 gdbscm_type_p (SCM self
)
282 return scm_from_bool (tyscm_is_type (self
));
285 /* Return the existing object that encapsulates TYPE, or create a new
286 <gdb:type> object. */
289 tyscm_scm_from_type (struct type
*type
)
292 eqable_gdb_smob
**slot
;
293 type_smob
*t_smob
, t_smob_for_lookup
;
296 /* If we've already created a gsmob for this type, return it.
297 This makes types eq?-able. */
298 htab
= tyscm_type_map (type
);
299 t_smob_for_lookup
.type
= type
;
300 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
302 return (*slot
)->containing_scm
;
304 t_scm
= tyscm_make_type_smob ();
305 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
307 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
312 /* Returns the <gdb:type> object in SELF.
313 Throws an exception if SELF is not a <gdb:type> object. */
316 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
318 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
324 /* Returns a pointer to the type smob of SELF.
325 Throws an exception if SELF is not a <gdb:type> object. */
328 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
330 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
331 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
336 /* Return the type field of T_SCM, an object of type <gdb:type>.
337 This exists so that we don't have to export the struct's contents. */
340 tyscm_scm_to_type (SCM t_scm
)
344 gdb_assert (tyscm_is_type (t_scm
));
345 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
349 /* Helper function for save_objfile_types to make a deep copy of the type. */
352 tyscm_copy_type_recursive (void **slot
, void *info
)
354 type_smob
*t_smob
= (type_smob
*) *slot
;
355 htab_t copied_types
= (htab_t
) info
;
356 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
358 eqable_gdb_smob
**new_slot
;
359 type_smob t_smob_for_lookup
;
361 gdb_assert (objfile
!= NULL
);
363 htab_empty (copied_types
);
364 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
366 /* The eq?-hashtab that the type lived in is going away.
367 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
368 garbage collected we'll assert-fail if the type isn't in the hashtab.
371 Types now live in "arch space", and things like "char" that came from
372 the objfile *could* be considered eq? with the arch "char" type.
373 However, they weren't before the objfile got deleted, so making them
374 eq? now is debatable. */
375 htab
= tyscm_type_map (t_smob
->type
);
376 t_smob_for_lookup
.type
= t_smob
->type
;
377 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
378 gdb_assert (*new_slot
== NULL
);
379 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
384 /* Called when OBJFILE is about to be deleted.
385 Make a copy of all types associated with OBJFILE. */
388 save_objfile_types (struct objfile
*objfile
, void *datum
)
390 htab_t htab
= (htab_t
) datum
;
393 if (!gdb_scheme_initialized
)
396 copied_types
= create_copied_types_hash (objfile
);
400 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
404 htab_delete (copied_types
);
407 /* Administrivia for field smobs. */
409 /* The smob "print" function for <gdb:field>. */
412 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
414 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
416 gdbscm_printf (port
, "#<%s ", field_smob_name
);
417 scm_write (f_smob
->type_scm
, port
);
418 gdbscm_printf (port
, " %d", f_smob
->field_num
);
419 scm_puts (">", port
);
421 scm_remember_upto_here_1 (self
);
423 /* Non-zero means success. */
427 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
431 tyscm_make_field_smob (SCM type_scm
, int field_num
)
433 field_smob
*f_smob
= (field_smob
*)
434 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
437 f_smob
->type_scm
= type_scm
;
438 f_smob
->field_num
= field_num
;
439 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
440 gdbscm_init_gsmob (&f_smob
->base
);
445 /* Return non-zero if SCM is a <gdb:field> object. */
448 tyscm_is_field (SCM self
)
450 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
453 /* (field? object) -> boolean */
456 gdbscm_field_p (SCM self
)
458 return scm_from_bool (tyscm_is_field (self
));
461 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
465 tyscm_scm_from_field (SCM type_scm
, int field_num
)
467 return tyscm_make_field_smob (type_scm
, field_num
);
470 /* Returns the <gdb:field> object in SELF.
471 Throws an exception if SELF is not a <gdb:field> object. */
474 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
476 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
482 /* Returns a pointer to the field smob of SELF.
483 Throws an exception if SELF is not a <gdb:field> object. */
486 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
488 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
489 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
494 /* Returns a pointer to the type struct in F_SMOB
495 (the type the field is in). */
498 tyscm_field_smob_containing_type (field_smob
*f_smob
)
502 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
503 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
508 /* Returns a pointer to the field struct of F_SMOB. */
510 static struct field
*
511 tyscm_field_smob_to_field (field_smob
*f_smob
)
513 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
515 /* This should be non-NULL by construction. */
516 gdb_assert (TYPE_FIELDS (type
) != NULL
);
518 return &TYPE_FIELD (type
, f_smob
->field_num
);
521 /* Type smob accessors. */
523 /* (type-code <gdb:type>) -> integer
524 Return the code for this type. */
527 gdbscm_type_code (SCM self
)
530 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
531 struct type
*type
= t_smob
->type
;
533 return scm_from_int (TYPE_CODE (type
));
536 /* (type-fields <gdb:type>) -> list
537 Return a list of all fields. Each element is a <gdb:field> object.
538 This also supports arrays, we return a field list of one element,
542 gdbscm_type_fields (SCM self
)
545 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
546 struct type
*type
= t_smob
->type
;
547 struct type
*containing_type
;
548 SCM containing_type_scm
, result
;
551 containing_type
= tyscm_get_composite (type
);
552 if (containing_type
== NULL
)
553 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
554 _(not_composite_error
));
556 /* If SELF is a typedef or reference, we want the underlying type,
557 which is what tyscm_get_composite returns. */
558 if (containing_type
== type
)
559 containing_type_scm
= self
;
561 containing_type_scm
= tyscm_scm_from_type (containing_type
);
564 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
565 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
567 return scm_reverse_x (result
, SCM_EOL
);
570 /* (type-tag <gdb:type>) -> string
571 Return the type's tag, or #f. */
574 gdbscm_type_tag (SCM self
)
577 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
578 struct type
*type
= t_smob
->type
;
579 const char *tagname
= nullptr;
581 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
582 || TYPE_CODE (type
) == TYPE_CODE_UNION
583 || TYPE_CODE (type
) == TYPE_CODE_ENUM
)
584 tagname
= TYPE_NAME (type
);
586 if (tagname
== nullptr)
588 return gdbscm_scm_from_c_string (tagname
);
591 /* (type-name <gdb:type>) -> string
592 Return the type's name, or #f. */
595 gdbscm_type_name (SCM self
)
598 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
599 struct type
*type
= t_smob
->type
;
601 if (!TYPE_NAME (type
))
603 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
606 /* (type-print-name <gdb:type>) -> string
607 Return the print name of type.
608 TODO: template support elided for now. */
611 gdbscm_type_print_name (SCM self
)
614 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
615 struct type
*type
= t_smob
->type
;
616 std::string thetype
= tyscm_type_name (type
);
617 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
622 /* (type-sizeof <gdb:type>) -> integer
623 Return the size of the type represented by SELF, in bytes. */
626 gdbscm_type_sizeof (SCM self
)
629 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
630 struct type
*type
= t_smob
->type
;
634 check_typedef (type
);
636 CATCH (except
, RETURN_MASK_ALL
)
641 /* Ignore exceptions. */
643 return scm_from_long (TYPE_LENGTH (type
));
646 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
647 Return the type, stripped of typedefs. */
650 gdbscm_type_strip_typedefs (SCM self
)
653 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
654 struct type
*type
= t_smob
->type
;
658 type
= check_typedef (type
);
660 CATCH (except
, RETURN_MASK_ALL
)
662 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
666 return tyscm_scm_from_type (type
);
669 /* Strip typedefs and pointers/reference from a type. Then check that
670 it is a struct, union, or enum type. If not, return NULL. */
673 tyscm_get_composite (struct type
*type
)
680 type
= check_typedef (type
);
682 CATCH (except
, RETURN_MASK_ALL
)
684 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
688 if (TYPE_CODE (type
) != TYPE_CODE_PTR
689 && TYPE_CODE (type
) != TYPE_CODE_REF
)
691 type
= TYPE_TARGET_TYPE (type
);
694 /* If this is not a struct, union, or enum type, raise TypeError
696 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
697 && TYPE_CODE (type
) != TYPE_CODE_UNION
698 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
704 /* Helper for tyscm_array and tyscm_vector. */
707 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
708 const char *func_name
)
711 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
712 struct type
*type
= t_smob
->type
;
714 struct type
*array
= NULL
;
716 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
717 n1_scm
, &n1
, n2_scm
, &n2
);
719 if (SCM_UNBNDP (n2_scm
))
725 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
727 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
728 scm_cons (scm_from_long (n1
),
730 _("Array length must not be negative"));
735 array
= lookup_array_range_type (type
, n1
, n2
);
737 make_vector_type (array
);
739 CATCH (except
, RETURN_MASK_ALL
)
741 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
745 return tyscm_scm_from_type (array
);
748 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
749 The array has indices [low-bound,high-bound].
750 If low-bound is not provided zero is used.
751 Return an array type.
753 IWBN if the one argument version specified a size, not the high bound.
754 It's too easy to pass one argument thinking it is the size of the array.
755 The current semantics are for compatibility with the Python version.
756 Later we can add #:size. */
759 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
761 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
764 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
765 The array has indices [low-bound,high-bound].
766 If low-bound is not provided zero is used.
767 Return a vector type.
769 IWBN if the one argument version specified a size, not the high bound.
770 It's too easy to pass one argument thinking it is the size of the array.
771 The current semantics are for compatibility with the Python version.
772 Later we can add #:size. */
775 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
777 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
780 /* (type-pointer <gdb:type>) -> <gdb:type>
781 Return a <gdb:type> object which represents a pointer to SELF. */
784 gdbscm_type_pointer (SCM self
)
787 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
788 struct type
*type
= t_smob
->type
;
792 type
= lookup_pointer_type (type
);
794 CATCH (except
, RETURN_MASK_ALL
)
796 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
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
) == TYPE_CODE_ARRAY
819 || TYPE_CODE (type
) == TYPE_CODE_STRING
820 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
821 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
823 switch (TYPE_CODE (type
))
825 case TYPE_CODE_ARRAY
:
826 case TYPE_CODE_STRING
:
827 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
828 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
830 case TYPE_CODE_RANGE
:
831 low
= TYPE_LOW_BOUND (type
);
832 high
= TYPE_HIGH_BOUND (type
);
836 low_scm
= gdbscm_scm_from_longest (low
);
837 high_scm
= gdbscm_scm_from_longest (high
);
839 return scm_list_2 (low_scm
, high_scm
);
842 /* (type-reference <gdb:type>) -> <gdb:type>
843 Return a <gdb:type> object which represents a reference to SELF. */
846 gdbscm_type_reference (SCM self
)
849 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
850 struct type
*type
= t_smob
->type
;
854 type
= lookup_lvalue_reference_type (type
);
856 CATCH (except
, RETURN_MASK_ALL
)
858 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
862 return tyscm_scm_from_type (type
);
865 /* (type-target <gdb:type>) -> <gdb:type>
866 Return a <gdb:type> object which represents the target type of SELF. */
869 gdbscm_type_target (SCM self
)
872 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
873 struct type
*type
= t_smob
->type
;
875 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
877 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
880 /* (type-const <gdb:type>) -> <gdb:type>
881 Return a const-qualified type variant. */
884 gdbscm_type_const (SCM self
)
887 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
888 struct type
*type
= t_smob
->type
;
892 type
= make_cv_type (1, 0, type
, NULL
);
894 CATCH (except
, RETURN_MASK_ALL
)
896 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
900 return tyscm_scm_from_type (type
);
903 /* (type-volatile <gdb:type>) -> <gdb:type>
904 Return a volatile-qualified type variant. */
907 gdbscm_type_volatile (SCM self
)
910 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
911 struct type
*type
= t_smob
->type
;
915 type
= make_cv_type (0, 1, type
, NULL
);
917 CATCH (except
, RETURN_MASK_ALL
)
919 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
923 return tyscm_scm_from_type (type
);
926 /* (type-unqualified <gdb:type>) -> <gdb:type>
927 Return an unqualified type variant. */
930 gdbscm_type_unqualified (SCM self
)
933 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
934 struct type
*type
= t_smob
->type
;
938 type
= make_cv_type (0, 0, type
, NULL
);
940 CATCH (except
, RETURN_MASK_ALL
)
942 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
946 return tyscm_scm_from_type (type
);
949 /* Field related accessors of types. */
951 /* (type-num-fields <gdb:type>) -> integer
952 Return number of fields. */
955 gdbscm_type_num_fields (SCM self
)
958 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
959 struct type
*type
= t_smob
->type
;
961 type
= tyscm_get_composite (type
);
963 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
964 _(not_composite_error
));
966 return scm_from_long (TYPE_NFIELDS (type
));
969 /* (type-field <gdb:type> string) -> <gdb:field>
970 Return the <gdb:field> object for the field named by the argument. */
973 gdbscm_type_field (SCM self
, SCM field_scm
)
976 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
977 struct type
*type
= t_smob
->type
;
980 struct cleanup
*cleanups
;
982 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
985 /* We want just fields of this type, not of base types, so instead of
986 using lookup_struct_elt_type, portions of that function are
989 type
= tyscm_get_composite (type
);
991 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
992 _(not_composite_error
));
994 field
= gdbscm_scm_to_c_string (field_scm
);
995 cleanups
= make_cleanup (xfree
, field
);
997 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
999 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1001 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1003 do_cleanups (cleanups
);
1004 return tyscm_make_field_smob (self
, i
);
1008 do_cleanups (cleanups
);
1010 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1011 _("Unknown field"));
1014 /* (type-has-field? <gdb:type> string) -> boolean
1015 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1018 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1021 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1022 struct type
*type
= t_smob
->type
;
1025 struct cleanup
*cleanups
;
1027 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1030 /* We want just fields of this type, not of base types, so instead of
1031 using lookup_struct_elt_type, portions of that function are
1034 type
= tyscm_get_composite (type
);
1036 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1037 _(not_composite_error
));
1039 field
= gdbscm_scm_to_c_string (field_scm
);
1040 cleanups
= make_cleanup (xfree
, field
);
1042 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1044 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1046 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1048 do_cleanups (cleanups
);
1053 do_cleanups (cleanups
);
1058 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1059 Make a field iterator object. */
1062 gdbscm_make_field_iterator (SCM self
)
1065 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1066 struct type
*type
= t_smob
->type
;
1067 struct type
*containing_type
;
1068 SCM containing_type_scm
;
1070 containing_type
= tyscm_get_composite (type
);
1071 if (containing_type
== NULL
)
1072 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1073 _(not_composite_error
));
1075 /* If SELF is a typedef or reference, we want the underlying type,
1076 which is what tyscm_get_composite returns. */
1077 if (containing_type
== type
)
1078 containing_type_scm
= self
;
1080 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1082 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1083 tyscm_next_field_x_proc
);
1086 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1087 Return the next field in the iteration through the list of fields of the
1088 type, or (end-of-iteration).
1089 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1090 This is the next! <gdb:iterator> function, not exported to the user. */
1093 gdbscm_type_next_field_x (SCM self
)
1095 iterator_smob
*i_smob
;
1098 SCM it_scm
, result
, progress
, object
;
1101 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1102 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1103 object
= itscm_iterator_smob_object (i_smob
);
1104 progress
= itscm_iterator_smob_progress (i_smob
);
1106 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1107 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1108 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1109 type
= t_smob
->type
;
1111 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1112 0, TYPE_NFIELDS (type
)),
1113 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1114 field
= scm_to_int (progress
);
1116 if (field
< TYPE_NFIELDS (type
))
1118 result
= tyscm_make_field_smob (object
, field
);
1119 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1123 return gdbscm_end_of_iteration ();
1126 /* Field smob accessors. */
1128 /* (field-name <gdb:field>) -> string
1129 Return the name of this field or #f if there isn't one. */
1132 gdbscm_field_name (SCM self
)
1135 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1136 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1138 if (FIELD_NAME (*field
))
1139 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1143 /* (field-type <gdb:field>) -> <gdb:type>
1144 Return the <gdb:type> object of the field or #f if there isn't one. */
1147 gdbscm_field_type (SCM self
)
1150 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1151 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1153 /* A field can have a NULL type in some situations. */
1154 if (FIELD_TYPE (*field
))
1155 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1159 /* (field-enumval <gdb:field>) -> integer
1160 For enum values, return its value as an integer. */
1163 gdbscm_field_enumval (SCM self
)
1166 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1167 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1168 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1170 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1171 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1173 return scm_from_long (FIELD_ENUMVAL (*field
));
1176 /* (field-bitpos <gdb:field>) -> integer
1177 For bitfields, return its offset in bits. */
1180 gdbscm_field_bitpos (SCM self
)
1183 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1184 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1185 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1187 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1188 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1190 return scm_from_long (FIELD_BITPOS (*field
));
1193 /* (field-bitsize <gdb:field>) -> integer
1194 Return the size of the field in bits. */
1197 gdbscm_field_bitsize (SCM self
)
1200 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1201 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1203 return scm_from_long (FIELD_BITPOS (*field
));
1206 /* (field-artificial? <gdb:field>) -> boolean
1207 Return #t if field is artificial. */
1210 gdbscm_field_artificial_p (SCM self
)
1213 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1214 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1216 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1219 /* (field-baseclass? <gdb:field>) -> boolean
1220 Return #t if field is a baseclass. */
1223 gdbscm_field_baseclass_p (SCM self
)
1226 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1227 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1228 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1230 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1231 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1235 /* Return the type named TYPE_NAME in BLOCK.
1236 Returns NULL if not found.
1237 This routine does not throw an error. */
1239 static struct type
*
1240 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1242 struct type
*type
= NULL
;
1246 if (startswith (type_name
, "struct "))
1247 type
= lookup_struct (type_name
+ 7, NULL
);
1248 else if (startswith (type_name
, "union "))
1249 type
= lookup_union (type_name
+ 6, NULL
);
1250 else if (startswith (type_name
, "enum "))
1251 type
= lookup_enum (type_name
+ 5, NULL
);
1253 type
= lookup_typename (current_language
, get_current_arch (),
1254 type_name
, block
, 0);
1256 CATCH (except
, RETURN_MASK_ALL
)
1265 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1266 TODO: legacy template support left out until needed. */
1269 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1271 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1273 SCM block_scm
= SCM_BOOL_F
;
1274 int block_arg_pos
= -1;
1275 const struct block
*block
= NULL
;
1278 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1280 rest
, &block_arg_pos
, &block_scm
);
1282 if (block_arg_pos
!= -1)
1286 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1291 gdbscm_throw (exception
);
1294 type
= tyscm_lookup_typename (name
, block
);
1298 return tyscm_scm_from_type (type
);
1302 /* Initialize the Scheme type code. */
1305 static const scheme_integer_constant type_integer_constants
[] =
1307 #define X(SYM) { #SYM, SYM }
1308 X (TYPE_CODE_BITSTRING
),
1310 X (TYPE_CODE_ARRAY
),
1311 X (TYPE_CODE_STRUCT
),
1312 X (TYPE_CODE_UNION
),
1314 X (TYPE_CODE_FLAGS
),
1320 X (TYPE_CODE_RANGE
),
1321 X (TYPE_CODE_STRING
),
1322 X (TYPE_CODE_ERROR
),
1323 X (TYPE_CODE_METHOD
),
1324 X (TYPE_CODE_METHODPTR
),
1325 X (TYPE_CODE_MEMBERPTR
),
1329 X (TYPE_CODE_COMPLEX
),
1330 X (TYPE_CODE_TYPEDEF
),
1331 X (TYPE_CODE_NAMESPACE
),
1332 X (TYPE_CODE_DECFLOAT
),
1333 X (TYPE_CODE_INTERNAL_FUNCTION
),
1336 END_INTEGER_CONSTANTS
1339 static const scheme_function type_functions
[] =
1341 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1343 Return #t if the object is a <gdb:type> object." },
1345 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1347 Return the <gdb:type> object representing string or #f if not found.\n\
1348 If block is given then the type is looked for in that block.\n\
1350 Arguments: string [#:block <gdb:block>]" },
1352 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1354 Return the code of the type" },
1356 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1358 Return the tag name of the type, or #f if there isn't one." },
1360 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1362 Return the name of the type as a string, or #f if there isn't one." },
1364 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1366 Return the print name of the type as a string." },
1368 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1370 Return the size of the type, in bytes." },
1372 { "type-strip-typedefs", 1, 0, 0,
1373 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1375 Return a type formed by stripping the type of all typedefs." },
1377 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1379 Return a type representing an array of objects of the type.\n\
1381 Arguments: <gdb:type> [low-bound] high-bound\n\
1382 If low-bound is not provided zero is used.\n\
1383 N.B. If only the high-bound parameter is specified, it is not\n\
1385 Valid bounds for array indices are [low-bound,high-bound]." },
1387 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1389 Return a type representing a vector of objects of the type.\n\
1390 Vectors differ from arrays in that if the current language has C-style\n\
1391 arrays, vectors don't decay to a pointer to the first element.\n\
1392 They are first class values.\n\
1394 Arguments: <gdb:type> [low-bound] high-bound\n\
1395 If low-bound is not provided zero is used.\n\
1396 N.B. If only the high-bound parameter is specified, it is not\n\
1398 Valid bounds for array indices are [low-bound,high-bound]." },
1400 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1402 Return a type of pointer to the type." },
1404 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1406 Return (low high) representing the range for the type." },
1408 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1410 Return a type of reference to the type." },
1412 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1414 Return the target type of the type." },
1416 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1418 Return a const variant of the type." },
1420 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1422 Return a volatile variant of the type." },
1424 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1426 Return a variant of the type without const or volatile attributes." },
1428 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1430 Return the number of fields of the type." },
1432 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1434 Return the list of <gdb:field> objects of fields of the type." },
1436 { "make-field-iterator", 1, 0, 0,
1437 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1439 Return a <gdb:iterator> object for iterating over the fields of the type." },
1441 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1443 Return the field named by string of the type.\n\
1445 Arguments: <gdb:type> string" },
1447 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1449 Return #t if the type has field named string.\n\
1451 Arguments: <gdb:type> string" },
1453 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1455 Return #t if the object is a <gdb:field> object." },
1457 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1459 Return the name of the field." },
1461 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1463 Return the type of the field." },
1465 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1467 Return the enum value represented by the field." },
1469 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1471 Return the offset in bits of the field in its containing type." },
1473 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1475 Return the size of the field in bits." },
1477 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1479 Return #t if the field is artificial." },
1481 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1483 Return #t if the field is a baseclass." },
1489 gdbscm_initialize_types (void)
1491 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1492 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1493 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1494 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1496 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1497 sizeof (field_smob
));
1498 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1500 gdbscm_define_integer_constants (type_integer_constants
, 1);
1501 gdbscm_define_functions (type_functions
, 1);
1503 /* This function is "private". */
1504 tyscm_next_field_x_proc
1505 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1506 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1507 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1508 gdbscm_documentation_symbol
,
1509 gdbscm_scm_from_c_string ("\
1510 Internal function to assist the type fields iterator."));
1512 block_keyword
= scm_from_latin1_keyword ("block");
1514 /* Register an objfile "free" callback so we can properly copy types
1515 associated with the objfile when it's about to be deleted. */
1516 tyscm_objfile_data_key
1517 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1519 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1520 tyscm_eq_type_smob
);