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
;
580 if (!TYPE_TAG_NAME (type
))
582 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
585 /* (type-name <gdb:type>) -> string
586 Return the type's name, or #f. */
589 gdbscm_type_name (SCM self
)
592 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
593 struct type
*type
= t_smob
->type
;
595 if (!TYPE_NAME (type
))
597 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
600 /* (type-print-name <gdb:type>) -> string
601 Return the print name of type.
602 TODO: template support elided for now. */
605 gdbscm_type_print_name (SCM self
)
608 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
609 struct type
*type
= t_smob
->type
;
610 std::string thetype
= tyscm_type_name (type
);
611 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
616 /* (type-sizeof <gdb:type>) -> integer
617 Return the size of the type represented by SELF, in bytes. */
620 gdbscm_type_sizeof (SCM self
)
623 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
624 struct type
*type
= t_smob
->type
;
628 check_typedef (type
);
630 CATCH (except
, RETURN_MASK_ALL
)
635 /* Ignore exceptions. */
637 return scm_from_long (TYPE_LENGTH (type
));
640 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
641 Return the type, stripped of typedefs. */
644 gdbscm_type_strip_typedefs (SCM self
)
647 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
648 struct type
*type
= t_smob
->type
;
652 type
= check_typedef (type
);
654 CATCH (except
, RETURN_MASK_ALL
)
656 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
660 return tyscm_scm_from_type (type
);
663 /* Strip typedefs and pointers/reference from a type. Then check that
664 it is a struct, union, or enum type. If not, return NULL. */
667 tyscm_get_composite (struct type
*type
)
674 type
= check_typedef (type
);
676 CATCH (except
, RETURN_MASK_ALL
)
678 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
682 if (TYPE_CODE (type
) != TYPE_CODE_PTR
683 && TYPE_CODE (type
) != TYPE_CODE_REF
)
685 type
= TYPE_TARGET_TYPE (type
);
688 /* If this is not a struct, union, or enum type, raise TypeError
690 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
691 && TYPE_CODE (type
) != TYPE_CODE_UNION
692 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
698 /* Helper for tyscm_array and tyscm_vector. */
701 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
702 const char *func_name
)
705 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
706 struct type
*type
= t_smob
->type
;
708 struct type
*array
= NULL
;
710 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
711 n1_scm
, &n1
, n2_scm
, &n2
);
713 if (SCM_UNBNDP (n2_scm
))
719 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
721 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
722 scm_cons (scm_from_long (n1
),
724 _("Array length must not be negative"));
729 array
= lookup_array_range_type (type
, n1
, n2
);
731 make_vector_type (array
);
733 CATCH (except
, RETURN_MASK_ALL
)
735 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 (except
, RETURN_MASK_ALL
)
790 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
794 return tyscm_scm_from_type (type
);
797 /* (type-range <gdb:type>) -> (low high)
798 Return the range of a type represented by SELF. The return type is
799 a list. The first element is the low bound, and the second element
800 is the high bound. */
803 gdbscm_type_range (SCM self
)
806 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
807 struct type
*type
= t_smob
->type
;
808 SCM low_scm
, high_scm
;
809 /* Initialize these to appease GCC warnings. */
810 LONGEST low
= 0, high
= 0;
812 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
813 || TYPE_CODE (type
) == TYPE_CODE_STRING
814 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
815 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
817 switch (TYPE_CODE (type
))
819 case TYPE_CODE_ARRAY
:
820 case TYPE_CODE_STRING
:
821 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
822 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
824 case TYPE_CODE_RANGE
:
825 low
= TYPE_LOW_BOUND (type
);
826 high
= TYPE_HIGH_BOUND (type
);
830 low_scm
= gdbscm_scm_from_longest (low
);
831 high_scm
= gdbscm_scm_from_longest (high
);
833 return scm_list_2 (low_scm
, high_scm
);
836 /* (type-reference <gdb:type>) -> <gdb:type>
837 Return a <gdb:type> object which represents a reference to SELF. */
840 gdbscm_type_reference (SCM self
)
843 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
844 struct type
*type
= t_smob
->type
;
848 type
= lookup_lvalue_reference_type (type
);
850 CATCH (except
, RETURN_MASK_ALL
)
852 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
856 return tyscm_scm_from_type (type
);
859 /* (type-target <gdb:type>) -> <gdb:type>
860 Return a <gdb:type> object which represents the target type of SELF. */
863 gdbscm_type_target (SCM self
)
866 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
867 struct type
*type
= t_smob
->type
;
869 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
871 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
874 /* (type-const <gdb:type>) -> <gdb:type>
875 Return a const-qualified type variant. */
878 gdbscm_type_const (SCM self
)
881 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
882 struct type
*type
= t_smob
->type
;
886 type
= make_cv_type (1, 0, type
, NULL
);
888 CATCH (except
, RETURN_MASK_ALL
)
890 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
894 return tyscm_scm_from_type (type
);
897 /* (type-volatile <gdb:type>) -> <gdb:type>
898 Return a volatile-qualified type variant. */
901 gdbscm_type_volatile (SCM self
)
904 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
905 struct type
*type
= t_smob
->type
;
909 type
= make_cv_type (0, 1, type
, NULL
);
911 CATCH (except
, RETURN_MASK_ALL
)
913 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
917 return tyscm_scm_from_type (type
);
920 /* (type-unqualified <gdb:type>) -> <gdb:type>
921 Return an unqualified type variant. */
924 gdbscm_type_unqualified (SCM self
)
927 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
928 struct type
*type
= t_smob
->type
;
932 type
= make_cv_type (0, 0, type
, NULL
);
934 CATCH (except
, RETURN_MASK_ALL
)
936 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
940 return tyscm_scm_from_type (type
);
943 /* Field related accessors of types. */
945 /* (type-num-fields <gdb:type>) -> integer
946 Return number of fields. */
949 gdbscm_type_num_fields (SCM self
)
952 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
953 struct type
*type
= t_smob
->type
;
955 type
= tyscm_get_composite (type
);
957 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
958 _(not_composite_error
));
960 return scm_from_long (TYPE_NFIELDS (type
));
963 /* (type-field <gdb:type> string) -> <gdb:field>
964 Return the <gdb:field> object for the field named by the argument. */
967 gdbscm_type_field (SCM self
, SCM field_scm
)
970 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
971 struct type
*type
= t_smob
->type
;
974 struct cleanup
*cleanups
;
976 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
979 /* We want just fields of this type, not of base types, so instead of
980 using lookup_struct_elt_type, portions of that function are
983 type
= tyscm_get_composite (type
);
985 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
986 _(not_composite_error
));
988 field
= gdbscm_scm_to_c_string (field_scm
);
989 cleanups
= make_cleanup (xfree
, field
);
991 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
993 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
995 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
997 do_cleanups (cleanups
);
998 return tyscm_make_field_smob (self
, i
);
1002 do_cleanups (cleanups
);
1004 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1005 _("Unknown field"));
1008 /* (type-has-field? <gdb:type> string) -> boolean
1009 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1012 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1015 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1016 struct type
*type
= t_smob
->type
;
1019 struct cleanup
*cleanups
;
1021 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1024 /* We want just fields of this type, not of base types, so instead of
1025 using lookup_struct_elt_type, portions of that function are
1028 type
= tyscm_get_composite (type
);
1030 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1031 _(not_composite_error
));
1033 field
= gdbscm_scm_to_c_string (field_scm
);
1034 cleanups
= make_cleanup (xfree
, field
);
1036 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1038 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1040 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1042 do_cleanups (cleanups
);
1047 do_cleanups (cleanups
);
1052 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1053 Make a field iterator object. */
1056 gdbscm_make_field_iterator (SCM self
)
1059 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1060 struct type
*type
= t_smob
->type
;
1061 struct type
*containing_type
;
1062 SCM containing_type_scm
;
1064 containing_type
= tyscm_get_composite (type
);
1065 if (containing_type
== NULL
)
1066 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1067 _(not_composite_error
));
1069 /* If SELF is a typedef or reference, we want the underlying type,
1070 which is what tyscm_get_composite returns. */
1071 if (containing_type
== type
)
1072 containing_type_scm
= self
;
1074 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1076 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1077 tyscm_next_field_x_proc
);
1080 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1081 Return the next field in the iteration through the list of fields of the
1082 type, or (end-of-iteration).
1083 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1084 This is the next! <gdb:iterator> function, not exported to the user. */
1087 gdbscm_type_next_field_x (SCM self
)
1089 iterator_smob
*i_smob
;
1092 SCM it_scm
, result
, progress
, object
;
1095 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1096 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1097 object
= itscm_iterator_smob_object (i_smob
);
1098 progress
= itscm_iterator_smob_progress (i_smob
);
1100 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1101 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1102 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1103 type
= t_smob
->type
;
1105 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1106 0, TYPE_NFIELDS (type
)),
1107 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1108 field
= scm_to_int (progress
);
1110 if (field
< TYPE_NFIELDS (type
))
1112 result
= tyscm_make_field_smob (object
, field
);
1113 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1117 return gdbscm_end_of_iteration ();
1120 /* Field smob accessors. */
1122 /* (field-name <gdb:field>) -> string
1123 Return the name of this field or #f if there isn't one. */
1126 gdbscm_field_name (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 if (FIELD_NAME (*field
))
1133 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1137 /* (field-type <gdb:field>) -> <gdb:type>
1138 Return the <gdb:type> object of the field or #f if there isn't one. */
1141 gdbscm_field_type (SCM self
)
1144 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1145 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1147 /* A field can have a NULL type in some situations. */
1148 if (FIELD_TYPE (*field
))
1149 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1153 /* (field-enumval <gdb:field>) -> integer
1154 For enum values, return its value as an integer. */
1157 gdbscm_field_enumval (SCM self
)
1160 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1161 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1162 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1164 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1165 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1167 return scm_from_long (FIELD_ENUMVAL (*field
));
1170 /* (field-bitpos <gdb:field>) -> integer
1171 For bitfields, return its offset in bits. */
1174 gdbscm_field_bitpos (SCM self
)
1177 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1178 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1179 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1181 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1182 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1184 return scm_from_long (FIELD_BITPOS (*field
));
1187 /* (field-bitsize <gdb:field>) -> integer
1188 Return the size of the field in bits. */
1191 gdbscm_field_bitsize (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_long (FIELD_BITPOS (*field
));
1200 /* (field-artificial? <gdb:field>) -> boolean
1201 Return #t if field is artificial. */
1204 gdbscm_field_artificial_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
);
1210 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1213 /* (field-baseclass? <gdb:field>) -> boolean
1214 Return #t if field is a baseclass. */
1217 gdbscm_field_baseclass_p (SCM self
)
1220 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1221 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1222 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1224 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1225 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1229 /* Return the type named TYPE_NAME in BLOCK.
1230 Returns NULL if not found.
1231 This routine does not throw an error. */
1233 static struct type
*
1234 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1236 struct type
*type
= NULL
;
1240 if (startswith (type_name
, "struct "))
1241 type
= lookup_struct (type_name
+ 7, NULL
);
1242 else if (startswith (type_name
, "union "))
1243 type
= lookup_union (type_name
+ 6, NULL
);
1244 else if (startswith (type_name
, "enum "))
1245 type
= lookup_enum (type_name
+ 5, NULL
);
1247 type
= lookup_typename (current_language
, get_current_arch (),
1248 type_name
, block
, 0);
1250 CATCH (except
, RETURN_MASK_ALL
)
1259 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1260 TODO: legacy template support left out until needed. */
1263 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1265 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1267 SCM block_scm
= SCM_BOOL_F
;
1268 int block_arg_pos
= -1;
1269 const struct block
*block
= NULL
;
1272 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1274 rest
, &block_arg_pos
, &block_scm
);
1276 if (block_arg_pos
!= -1)
1280 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1285 gdbscm_throw (exception
);
1288 type
= tyscm_lookup_typename (name
, block
);
1292 return tyscm_scm_from_type (type
);
1296 /* Initialize the Scheme type code. */
1299 static const scheme_integer_constant type_integer_constants
[] =
1301 #define X(SYM) { #SYM, SYM }
1302 X (TYPE_CODE_BITSTRING
),
1304 X (TYPE_CODE_ARRAY
),
1305 X (TYPE_CODE_STRUCT
),
1306 X (TYPE_CODE_UNION
),
1308 X (TYPE_CODE_FLAGS
),
1314 X (TYPE_CODE_RANGE
),
1315 X (TYPE_CODE_STRING
),
1316 X (TYPE_CODE_ERROR
),
1317 X (TYPE_CODE_METHOD
),
1318 X (TYPE_CODE_METHODPTR
),
1319 X (TYPE_CODE_MEMBERPTR
),
1323 X (TYPE_CODE_COMPLEX
),
1324 X (TYPE_CODE_TYPEDEF
),
1325 X (TYPE_CODE_NAMESPACE
),
1326 X (TYPE_CODE_DECFLOAT
),
1327 X (TYPE_CODE_INTERNAL_FUNCTION
),
1330 END_INTEGER_CONSTANTS
1333 static const scheme_function type_functions
[] =
1335 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1337 Return #t if the object is a <gdb:type> object." },
1339 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1341 Return the <gdb:type> object representing string or #f if not found.\n\
1342 If block is given then the type is looked for in that block.\n\
1344 Arguments: string [#:block <gdb:block>]" },
1346 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1348 Return the code of the type" },
1350 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1352 Return the tag name of the type, or #f if there isn't one." },
1354 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1356 Return the name of the type as a string, or #f if there isn't one." },
1358 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1360 Return the print name of the type as a string." },
1362 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1364 Return the size of the type, in bytes." },
1366 { "type-strip-typedefs", 1, 0, 0,
1367 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1369 Return a type formed by stripping the type of all typedefs." },
1371 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1373 Return a type representing an array of objects of the type.\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-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1383 Return a type representing a vector of objects of the type.\n\
1384 Vectors differ from arrays in that if the current language has C-style\n\
1385 arrays, vectors don't decay to a pointer to the first element.\n\
1386 They are first class values.\n\
1388 Arguments: <gdb:type> [low-bound] high-bound\n\
1389 If low-bound is not provided zero is used.\n\
1390 N.B. If only the high-bound parameter is specified, it is not\n\
1392 Valid bounds for array indices are [low-bound,high-bound]." },
1394 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1396 Return a type of pointer to the type." },
1398 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1400 Return (low high) representing the range for the type." },
1402 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1404 Return a type of reference to the type." },
1406 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1408 Return the target type of the type." },
1410 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1412 Return a const variant of the type." },
1414 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1416 Return a volatile variant of the type." },
1418 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1420 Return a variant of the type without const or volatile attributes." },
1422 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1424 Return the number of fields of the type." },
1426 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1428 Return the list of <gdb:field> objects of fields of the type." },
1430 { "make-field-iterator", 1, 0, 0,
1431 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1433 Return a <gdb:iterator> object for iterating over the fields of the type." },
1435 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1437 Return the field named by string of the type.\n\
1439 Arguments: <gdb:type> string" },
1441 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1443 Return #t if the type has field named string.\n\
1445 Arguments: <gdb:type> string" },
1447 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1449 Return #t if the object is a <gdb:field> object." },
1451 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1453 Return the name of the field." },
1455 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1457 Return the type of the field." },
1459 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1461 Return the enum value represented by the field." },
1463 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1465 Return the offset in bits of the field in its containing type." },
1467 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1469 Return the size of the field in bits." },
1471 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1473 Return #t if the field is artificial." },
1475 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1477 Return #t if the field is a baseclass." },
1483 gdbscm_initialize_types (void)
1485 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1486 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1487 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1488 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1490 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1491 sizeof (field_smob
));
1492 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1494 gdbscm_define_integer_constants (type_integer_constants
, 1);
1495 gdbscm_define_functions (type_functions
, 1);
1497 /* This function is "private". */
1498 tyscm_next_field_x_proc
1499 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1500 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1501 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1502 gdbscm_documentation_symbol
,
1503 gdbscm_scm_from_c_string ("\
1504 Internal function to assist the type fields iterator."));
1506 block_keyword
= scm_from_latin1_keyword ("block");
1508 /* Register an objfile "free" callback so we can properly copy types
1509 associated with the objfile when it's about to be deleted. */
1510 tyscm_objfile_data_key
1511 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1513 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1514 tyscm_eq_type_smob
);