1 /* Scheme interface to types.
3 Copyright (C) 2008-2017 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 /* Helper function for save_objfile_types to make a deep copy of the type. */
339 tyscm_copy_type_recursive (void **slot
, void *info
)
341 type_smob
*t_smob
= (type_smob
*) *slot
;
342 htab_t copied_types
= (htab_t
) info
;
343 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
345 eqable_gdb_smob
**new_slot
;
346 type_smob t_smob_for_lookup
;
348 gdb_assert (objfile
!= NULL
);
350 htab_empty (copied_types
);
351 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
353 /* The eq?-hashtab that the type lived in is going away.
354 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
355 garbage collected we'll assert-fail if the type isn't in the hashtab.
358 Types now live in "arch space", and things like "char" that came from
359 the objfile *could* be considered eq? with the arch "char" type.
360 However, they weren't before the objfile got deleted, so making them
361 eq? now is debatable. */
362 htab
= tyscm_type_map (t_smob
->type
);
363 t_smob_for_lookup
.type
= t_smob
->type
;
364 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
365 gdb_assert (*new_slot
== NULL
);
366 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
371 /* Called when OBJFILE is about to be deleted.
372 Make a copy of all types associated with OBJFILE. */
375 save_objfile_types (struct objfile
*objfile
, void *datum
)
377 htab_t htab
= (htab_t
) datum
;
380 if (!gdb_scheme_initialized
)
383 copied_types
= create_copied_types_hash (objfile
);
387 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
391 htab_delete (copied_types
);
394 /* Administrivia for field smobs. */
396 /* The smob "print" function for <gdb:field>. */
399 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
401 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
403 gdbscm_printf (port
, "#<%s ", field_smob_name
);
404 scm_write (f_smob
->type_scm
, port
);
405 gdbscm_printf (port
, " %d", f_smob
->field_num
);
406 scm_puts (">", port
);
408 scm_remember_upto_here_1 (self
);
410 /* Non-zero means success. */
414 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
418 tyscm_make_field_smob (SCM type_scm
, int field_num
)
420 field_smob
*f_smob
= (field_smob
*)
421 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
424 f_smob
->type_scm
= type_scm
;
425 f_smob
->field_num
= field_num
;
426 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
427 gdbscm_init_gsmob (&f_smob
->base
);
432 /* Return non-zero if SCM is a <gdb:field> object. */
435 tyscm_is_field (SCM self
)
437 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
440 /* (field? object) -> boolean */
443 gdbscm_field_p (SCM self
)
445 return scm_from_bool (tyscm_is_field (self
));
448 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
452 tyscm_scm_from_field (SCM type_scm
, int field_num
)
454 return tyscm_make_field_smob (type_scm
, field_num
);
457 /* Returns the <gdb:field> object in SELF.
458 Throws an exception if SELF is not a <gdb:field> object. */
461 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
463 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
469 /* Returns a pointer to the field smob of SELF.
470 Throws an exception if SELF is not a <gdb:field> object. */
473 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
475 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
476 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
481 /* Returns a pointer to the type struct in F_SMOB
482 (the type the field is in). */
485 tyscm_field_smob_containing_type (field_smob
*f_smob
)
489 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
490 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
495 /* Returns a pointer to the field struct of F_SMOB. */
497 static struct field
*
498 tyscm_field_smob_to_field (field_smob
*f_smob
)
500 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
502 /* This should be non-NULL by construction. */
503 gdb_assert (TYPE_FIELDS (type
) != NULL
);
505 return &TYPE_FIELD (type
, f_smob
->field_num
);
508 /* Type smob accessors. */
510 /* (type-code <gdb:type>) -> integer
511 Return the code for this type. */
514 gdbscm_type_code (SCM self
)
517 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
518 struct type
*type
= t_smob
->type
;
520 return scm_from_int (TYPE_CODE (type
));
523 /* (type-fields <gdb:type>) -> list
524 Return a list of all fields. Each element is a <gdb:field> object.
525 This also supports arrays, we return a field list of one element,
529 gdbscm_type_fields (SCM self
)
532 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
533 struct type
*type
= t_smob
->type
;
534 struct type
*containing_type
;
535 SCM containing_type_scm
, result
;
538 containing_type
= tyscm_get_composite (type
);
539 if (containing_type
== NULL
)
540 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
541 _(not_composite_error
));
543 /* If SELF is a typedef or reference, we want the underlying type,
544 which is what tyscm_get_composite returns. */
545 if (containing_type
== type
)
546 containing_type_scm
= self
;
548 containing_type_scm
= tyscm_scm_from_type (containing_type
);
551 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
552 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
554 return scm_reverse_x (result
, SCM_EOL
);
557 /* (type-tag <gdb:type>) -> string
558 Return the type's tag, or #f. */
561 gdbscm_type_tag (SCM self
)
564 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
565 struct type
*type
= t_smob
->type
;
567 if (!TYPE_TAG_NAME (type
))
569 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
572 /* (type-name <gdb:type>) -> string
573 Return the type's name, or #f. */
576 gdbscm_type_name (SCM self
)
579 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
580 struct type
*type
= t_smob
->type
;
582 if (!TYPE_NAME (type
))
584 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
587 /* (type-print-name <gdb:type>) -> string
588 Return the print name of type.
589 TODO: template support elided for now. */
592 gdbscm_type_print_name (SCM self
)
595 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
596 struct type
*type
= t_smob
->type
;
597 std::string thetype
= tyscm_type_name (type
);
598 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
603 /* (type-sizeof <gdb:type>) -> integer
604 Return the size of the type represented by SELF, in bytes. */
607 gdbscm_type_sizeof (SCM self
)
610 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
611 struct type
*type
= t_smob
->type
;
615 check_typedef (type
);
617 CATCH (except
, RETURN_MASK_ALL
)
622 /* Ignore exceptions. */
624 return scm_from_long (TYPE_LENGTH (type
));
627 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
628 Return the type, stripped of typedefs. */
631 gdbscm_type_strip_typedefs (SCM self
)
634 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
635 struct type
*type
= t_smob
->type
;
639 type
= check_typedef (type
);
641 CATCH (except
, RETURN_MASK_ALL
)
643 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
647 return tyscm_scm_from_type (type
);
650 /* Strip typedefs and pointers/reference from a type. Then check that
651 it is a struct, union, or enum type. If not, return NULL. */
654 tyscm_get_composite (struct type
*type
)
661 type
= check_typedef (type
);
663 CATCH (except
, RETURN_MASK_ALL
)
665 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
669 if (TYPE_CODE (type
) != TYPE_CODE_PTR
670 && TYPE_CODE (type
) != TYPE_CODE_REF
)
672 type
= TYPE_TARGET_TYPE (type
);
675 /* If this is not a struct, union, or enum type, raise TypeError
677 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
678 && TYPE_CODE (type
) != TYPE_CODE_UNION
679 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
685 /* Helper for tyscm_array and tyscm_vector. */
688 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
689 const char *func_name
)
692 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
693 struct type
*type
= t_smob
->type
;
695 struct type
*array
= NULL
;
697 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
698 n1_scm
, &n1
, n2_scm
, &n2
);
700 if (SCM_UNBNDP (n2_scm
))
706 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
708 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
709 scm_cons (scm_from_long (n1
),
711 _("Array length must not be negative"));
716 array
= lookup_array_range_type (type
, n1
, n2
);
718 make_vector_type (array
);
720 CATCH (except
, RETURN_MASK_ALL
)
722 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
726 return tyscm_scm_from_type (array
);
729 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
730 The array has indices [low-bound,high-bound].
731 If low-bound is not provided zero is used.
732 Return an array type.
734 IWBN if the one argument version specified a size, not the high bound.
735 It's too easy to pass one argument thinking it is the size of the array.
736 The current semantics are for compatibility with the Python version.
737 Later we can add #:size. */
740 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
742 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
745 /* (type-vector <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 a vector 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_vector (SCM self
, SCM n1
, SCM n2
)
758 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
761 /* (type-pointer <gdb:type>) -> <gdb:type>
762 Return a <gdb:type> object which represents a pointer to SELF. */
765 gdbscm_type_pointer (SCM self
)
768 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
769 struct type
*type
= t_smob
->type
;
773 type
= lookup_pointer_type (type
);
775 CATCH (except
, RETURN_MASK_ALL
)
777 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
781 return tyscm_scm_from_type (type
);
784 /* (type-range <gdb:type>) -> (low high)
785 Return the range of a type represented by SELF. The return type is
786 a list. The first element is the low bound, and the second element
787 is the high bound. */
790 gdbscm_type_range (SCM self
)
793 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
794 struct type
*type
= t_smob
->type
;
795 SCM low_scm
, high_scm
;
796 /* Initialize these to appease GCC warnings. */
797 LONGEST low
= 0, high
= 0;
799 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
800 || TYPE_CODE (type
) == TYPE_CODE_STRING
801 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
802 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
804 switch (TYPE_CODE (type
))
806 case TYPE_CODE_ARRAY
:
807 case TYPE_CODE_STRING
:
808 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
809 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
811 case TYPE_CODE_RANGE
:
812 low
= TYPE_LOW_BOUND (type
);
813 high
= TYPE_HIGH_BOUND (type
);
817 low_scm
= gdbscm_scm_from_longest (low
);
818 high_scm
= gdbscm_scm_from_longest (high
);
820 return scm_list_2 (low_scm
, high_scm
);
823 /* (type-reference <gdb:type>) -> <gdb:type>
824 Return a <gdb:type> object which represents a reference to SELF. */
827 gdbscm_type_reference (SCM self
)
830 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
831 struct type
*type
= t_smob
->type
;
835 type
= lookup_reference_type (type
);
837 CATCH (except
, RETURN_MASK_ALL
)
839 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
843 return tyscm_scm_from_type (type
);
846 /* (type-target <gdb:type>) -> <gdb:type>
847 Return a <gdb:type> object which represents the target type of SELF. */
850 gdbscm_type_target (SCM self
)
853 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
854 struct type
*type
= t_smob
->type
;
856 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
858 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
861 /* (type-const <gdb:type>) -> <gdb:type>
862 Return a const-qualified type variant. */
865 gdbscm_type_const (SCM self
)
868 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
869 struct type
*type
= t_smob
->type
;
873 type
= make_cv_type (1, 0, type
, NULL
);
875 CATCH (except
, RETURN_MASK_ALL
)
877 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
881 return tyscm_scm_from_type (type
);
884 /* (type-volatile <gdb:type>) -> <gdb:type>
885 Return a volatile-qualified type variant. */
888 gdbscm_type_volatile (SCM self
)
891 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
892 struct type
*type
= t_smob
->type
;
896 type
= make_cv_type (0, 1, type
, NULL
);
898 CATCH (except
, RETURN_MASK_ALL
)
900 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
904 return tyscm_scm_from_type (type
);
907 /* (type-unqualified <gdb:type>) -> <gdb:type>
908 Return an unqualified type variant. */
911 gdbscm_type_unqualified (SCM self
)
914 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
915 struct type
*type
= t_smob
->type
;
919 type
= make_cv_type (0, 0, type
, NULL
);
921 CATCH (except
, RETURN_MASK_ALL
)
923 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
927 return tyscm_scm_from_type (type
);
930 /* Field related accessors of types. */
932 /* (type-num-fields <gdb:type>) -> integer
933 Return number of fields. */
936 gdbscm_type_num_fields (SCM self
)
939 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
940 struct type
*type
= t_smob
->type
;
942 type
= tyscm_get_composite (type
);
944 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
945 _(not_composite_error
));
947 return scm_from_long (TYPE_NFIELDS (type
));
950 /* (type-field <gdb:type> string) -> <gdb:field>
951 Return the <gdb:field> object for the field named by the argument. */
954 gdbscm_type_field (SCM self
, SCM field_scm
)
957 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
958 struct type
*type
= t_smob
->type
;
961 struct cleanup
*cleanups
;
963 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
966 /* We want just fields of this type, not of base types, so instead of
967 using lookup_struct_elt_type, portions of that function are
970 type
= tyscm_get_composite (type
);
972 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
973 _(not_composite_error
));
975 field
= gdbscm_scm_to_c_string (field_scm
);
976 cleanups
= make_cleanup (xfree
, field
);
978 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
980 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
982 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
984 do_cleanups (cleanups
);
985 return tyscm_make_field_smob (self
, i
);
989 do_cleanups (cleanups
);
991 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
995 /* (type-has-field? <gdb:type> string) -> boolean
996 Return boolean indicating if type SELF has FIELD_SCM (a string). */
999 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1002 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1003 struct type
*type
= t_smob
->type
;
1006 struct cleanup
*cleanups
;
1008 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1011 /* We want just fields of this type, not of base types, so instead of
1012 using lookup_struct_elt_type, portions of that function are
1015 type
= tyscm_get_composite (type
);
1017 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1018 _(not_composite_error
));
1020 field
= gdbscm_scm_to_c_string (field_scm
);
1021 cleanups
= make_cleanup (xfree
, field
);
1023 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1025 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1027 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1029 do_cleanups (cleanups
);
1034 do_cleanups (cleanups
);
1039 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1040 Make a field iterator object. */
1043 gdbscm_make_field_iterator (SCM self
)
1046 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1047 struct type
*type
= t_smob
->type
;
1048 struct type
*containing_type
;
1049 SCM containing_type_scm
;
1051 containing_type
= tyscm_get_composite (type
);
1052 if (containing_type
== NULL
)
1053 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1054 _(not_composite_error
));
1056 /* If SELF is a typedef or reference, we want the underlying type,
1057 which is what tyscm_get_composite returns. */
1058 if (containing_type
== type
)
1059 containing_type_scm
= self
;
1061 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1063 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1064 tyscm_next_field_x_proc
);
1067 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1068 Return the next field in the iteration through the list of fields of the
1069 type, or (end-of-iteration).
1070 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1071 This is the next! <gdb:iterator> function, not exported to the user. */
1074 gdbscm_type_next_field_x (SCM self
)
1076 iterator_smob
*i_smob
;
1079 SCM it_scm
, result
, progress
, object
;
1082 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1083 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1084 object
= itscm_iterator_smob_object (i_smob
);
1085 progress
= itscm_iterator_smob_progress (i_smob
);
1087 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1088 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1089 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1090 type
= t_smob
->type
;
1092 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1093 0, TYPE_NFIELDS (type
)),
1094 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1095 field
= scm_to_int (progress
);
1097 if (field
< TYPE_NFIELDS (type
))
1099 result
= tyscm_make_field_smob (object
, field
);
1100 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1104 return gdbscm_end_of_iteration ();
1107 /* Field smob accessors. */
1109 /* (field-name <gdb:field>) -> string
1110 Return the name of this field or #f if there isn't one. */
1113 gdbscm_field_name (SCM self
)
1116 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1117 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1119 if (FIELD_NAME (*field
))
1120 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1124 /* (field-type <gdb:field>) -> <gdb:type>
1125 Return the <gdb:type> object of the field or #f if there isn't one. */
1128 gdbscm_field_type (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 /* A field can have a NULL type in some situations. */
1135 if (FIELD_TYPE (*field
))
1136 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1140 /* (field-enumval <gdb:field>) -> integer
1141 For enum values, return its value as an integer. */
1144 gdbscm_field_enumval (SCM self
)
1147 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1148 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1149 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1151 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1152 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1154 return scm_from_long (FIELD_ENUMVAL (*field
));
1157 /* (field-bitpos <gdb:field>) -> integer
1158 For bitfields, return its offset in bits. */
1161 gdbscm_field_bitpos (SCM self
)
1164 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1165 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1166 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1168 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1169 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1171 return scm_from_long (FIELD_BITPOS (*field
));
1174 /* (field-bitsize <gdb:field>) -> integer
1175 Return the size of the field in bits. */
1178 gdbscm_field_bitsize (SCM self
)
1181 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1182 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1184 return scm_from_long (FIELD_BITPOS (*field
));
1187 /* (field-artificial? <gdb:field>) -> boolean
1188 Return #t if field is artificial. */
1191 gdbscm_field_artificial_p (SCM self
)
1194 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1195 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1197 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1200 /* (field-baseclass? <gdb:field>) -> boolean
1201 Return #t if field is a baseclass. */
1204 gdbscm_field_baseclass_p (SCM self
)
1207 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1208 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1209 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1211 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1212 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1216 /* Return the type named TYPE_NAME in BLOCK.
1217 Returns NULL if not found.
1218 This routine does not throw an error. */
1220 static struct type
*
1221 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1223 struct type
*type
= NULL
;
1227 if (startswith (type_name
, "struct "))
1228 type
= lookup_struct (type_name
+ 7, NULL
);
1229 else if (startswith (type_name
, "union "))
1230 type
= lookup_union (type_name
+ 6, NULL
);
1231 else if (startswith (type_name
, "enum "))
1232 type
= lookup_enum (type_name
+ 5, NULL
);
1234 type
= lookup_typename (current_language
, get_current_arch (),
1235 type_name
, block
, 0);
1237 CATCH (except
, RETURN_MASK_ALL
)
1246 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1247 TODO: legacy template support left out until needed. */
1250 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1252 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1254 SCM block_scm
= SCM_BOOL_F
;
1255 int block_arg_pos
= -1;
1256 const struct block
*block
= NULL
;
1259 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1261 rest
, &block_arg_pos
, &block_scm
);
1263 if (block_arg_pos
!= -1)
1267 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1272 gdbscm_throw (exception
);
1275 type
= tyscm_lookup_typename (name
, block
);
1279 return tyscm_scm_from_type (type
);
1283 /* Initialize the Scheme type code. */
1286 static const scheme_integer_constant type_integer_constants
[] =
1288 #define X(SYM) { #SYM, SYM }
1289 X (TYPE_CODE_BITSTRING
),
1291 X (TYPE_CODE_ARRAY
),
1292 X (TYPE_CODE_STRUCT
),
1293 X (TYPE_CODE_UNION
),
1295 X (TYPE_CODE_FLAGS
),
1301 X (TYPE_CODE_RANGE
),
1302 X (TYPE_CODE_STRING
),
1303 X (TYPE_CODE_ERROR
),
1304 X (TYPE_CODE_METHOD
),
1305 X (TYPE_CODE_METHODPTR
),
1306 X (TYPE_CODE_MEMBERPTR
),
1310 X (TYPE_CODE_COMPLEX
),
1311 X (TYPE_CODE_TYPEDEF
),
1312 X (TYPE_CODE_NAMESPACE
),
1313 X (TYPE_CODE_DECFLOAT
),
1314 X (TYPE_CODE_INTERNAL_FUNCTION
),
1317 END_INTEGER_CONSTANTS
1320 static const scheme_function type_functions
[] =
1322 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1324 Return #t if the object is a <gdb:type> object." },
1326 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1328 Return the <gdb:type> object representing string or #f if not found.\n\
1329 If block is given then the type is looked for in that block.\n\
1331 Arguments: string [#:block <gdb:block>]" },
1333 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1335 Return the code of the type" },
1337 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1339 Return the tag name of the type, or #f if there isn't one." },
1341 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1343 Return the name of the type as a string, or #f if there isn't one." },
1345 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1347 Return the print name of the type as a string." },
1349 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1351 Return the size of the type, in bytes." },
1353 { "type-strip-typedefs", 1, 0, 0,
1354 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1356 Return a type formed by stripping the type of all typedefs." },
1358 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1360 Return a type representing an array of objects of the type.\n\
1362 Arguments: <gdb:type> [low-bound] high-bound\n\
1363 If low-bound is not provided zero is used.\n\
1364 N.B. If only the high-bound parameter is specified, it is not\n\
1366 Valid bounds for array indices are [low-bound,high-bound]." },
1368 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1370 Return a type representing a vector of objects of the type.\n\
1371 Vectors differ from arrays in that if the current language has C-style\n\
1372 arrays, vectors don't decay to a pointer to the first element.\n\
1373 They are first class values.\n\
1375 Arguments: <gdb:type> [low-bound] high-bound\n\
1376 If low-bound is not provided zero is used.\n\
1377 N.B. If only the high-bound parameter is specified, it is not\n\
1379 Valid bounds for array indices are [low-bound,high-bound]." },
1381 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1383 Return a type of pointer to the type." },
1385 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1387 Return (low high) representing the range for the type." },
1389 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1391 Return a type of reference to the type." },
1393 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1395 Return the target type of the type." },
1397 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1399 Return a const variant of the type." },
1401 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1403 Return a volatile variant of the type." },
1405 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1407 Return a variant of the type without const or volatile attributes." },
1409 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1411 Return the number of fields of the type." },
1413 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1415 Return the list of <gdb:field> objects of fields of the type." },
1417 { "make-field-iterator", 1, 0, 0,
1418 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1420 Return a <gdb:iterator> object for iterating over the fields of the type." },
1422 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1424 Return the field named by string of the type.\n\
1426 Arguments: <gdb:type> string" },
1428 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1430 Return #t if the type has field named string.\n\
1432 Arguments: <gdb:type> string" },
1434 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1436 Return #t if the object is a <gdb:field> object." },
1438 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1440 Return the name of the field." },
1442 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1444 Return the type of the field." },
1446 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1448 Return the enum value represented by the field." },
1450 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1452 Return the offset in bits of the field in its containing type." },
1454 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1456 Return the size of the field in bits." },
1458 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1460 Return #t if the field is artificial." },
1462 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1464 Return #t if the field is a baseclass." },
1470 gdbscm_initialize_types (void)
1472 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1473 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1474 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1475 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1477 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1478 sizeof (field_smob
));
1479 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1481 gdbscm_define_integer_constants (type_integer_constants
, 1);
1482 gdbscm_define_functions (type_functions
, 1);
1484 /* This function is "private". */
1485 tyscm_next_field_x_proc
1486 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1487 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1488 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1489 gdbscm_documentation_symbol
,
1490 gdbscm_scm_from_c_string ("\
1491 Internal function to assist the type fields iterator."));
1493 block_keyword
= scm_from_latin1_keyword ("block");
1495 /* Register an objfile "free" callback so we can properly copy types
1496 associated with the objfile when it's about to be deleted. */
1497 tyscm_objfile_data_key
1498 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1500 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1501 tyscm_eq_type_smob
);