1 /* Scheme interface to types.
3 Copyright (C) 2008-2014 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"
26 #include "exceptions.h"
32 #include "dwarf2loc.h"
33 #include "typeprint.h"
34 #include "guile-internal.h"
36 /* The <gdb:type> smob.
37 The type is chained with all types associated with its objfile, if any.
38 This lets us copy the underlying struct type when the objfile is
40 The typedef for this struct is in guile-internal.h. */
44 /* This always appears first.
45 eqable_gdb_smob is used so that types are eq?-able.
46 Also, a type object can be associated with an objfile. eqable_gdb_smob
47 lets us track the lifetime of all types associated with an objfile.
48 When an objfile is deleted we need to invalidate the type object. */
51 /* The GDB type structure this smob is wrapping. */
59 /* This always appears first. */
62 /* Backlink to the containing <gdb:type> object. */
65 /* The field number in TYPE_SCM. */
69 static const char type_smob_name
[] = "gdb:type";
70 static const char field_smob_name
[] = "gdb:field";
72 static const char not_composite_error
[] =
73 N_("type is not a structure, union, or enum type");
75 /* The tag Guile knows the type smob by. */
76 static scm_t_bits type_smob_tag
;
78 /* The tag Guile knows the field smob by. */
79 static scm_t_bits field_smob_tag
;
81 /* The "next" procedure for field iterators. */
82 static SCM tyscm_next_field_x_proc
;
84 /* Keywords used in argument passing. */
85 static SCM block_keyword
;
87 static const struct objfile_data
*tyscm_objfile_data_key
;
89 /* Hash table to uniquify global (non-objfile-owned) types. */
90 static htab_t global_types_map
;
92 static struct type
*tyscm_get_composite (struct type
*type
);
94 /* Return the type field of T_SMOB.
95 This exists so that we don't have to export the struct's contents. */
98 tyscm_type_smob_type (type_smob
*t_smob
)
103 /* Return the name of TYPE in expanded form.
104 Space for the result is malloc'd, caller must free.
105 If there's an error computing the name, the result is NULL and the
106 exception is stored in *EXCP. */
109 tyscm_type_name (struct type
*type
, SCM
*excp
)
112 volatile struct gdb_exception except
;
114 TRY_CATCH (except
, RETURN_MASK_ALL
)
116 struct cleanup
*old_chain
;
119 stb
= mem_fileopen ();
120 old_chain
= make_cleanup_ui_file_delete (stb
);
122 LA_PRINT_TYPE (type
, "", stb
, -1, 0, &type_print_raw_options
);
124 name
= ui_file_xstrdup (stb
, NULL
);
125 do_cleanups (old_chain
);
127 if (except
.reason
< 0)
129 *excp
= gdbscm_scm_from_gdb_exception (except
);
136 /* Administrivia for type smobs. */
138 /* Helper function to hash a type_smob. */
141 tyscm_hash_type_smob (const void *p
)
143 const type_smob
*t_smob
= p
;
145 return htab_hash_pointer (t_smob
->type
);
148 /* Helper function to compute equality of type_smobs. */
151 tyscm_eq_type_smob (const void *ap
, const void *bp
)
153 const type_smob
*a
= ap
;
154 const type_smob
*b
= bp
;
156 return (a
->type
== b
->type
160 /* Return the struct type pointer -> SCM mapping table.
161 If type is owned by an objfile, the mapping table is created if necessary.
162 Otherwise, type is not owned by an objfile, and we use
166 tyscm_type_map (struct type
*type
)
168 struct objfile
*objfile
= TYPE_OBJFILE (type
);
172 return global_types_map
;
174 htab
= objfile_data (objfile
, tyscm_objfile_data_key
);
177 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
179 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
185 /* The smob "free" function for <gdb:type>. */
188 tyscm_free_type_smob (SCM self
)
190 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
192 if (t_smob
->type
!= NULL
)
194 htab_t htab
= tyscm_type_map (t_smob
->type
);
196 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
199 /* Not necessary, done to catch bugs. */
205 /* The smob "print" function for <gdb:type>. */
208 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
210 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
212 char *name
= tyscm_type_name (t_smob
->type
, &exception
);
215 gdbscm_throw (exception
);
217 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
218 invoked by write/~S. What to do here may need to evolve.
219 IWBN if we could pass an argument to format that would we could use
220 instead of writingp. */
221 if (pstate
->writingp
)
222 gdbscm_printf (port
, "#<%s ", type_smob_name
);
224 scm_puts (name
, port
);
226 if (pstate
->writingp
)
227 scm_puts (">", port
);
229 scm_remember_upto_here_1 (self
);
231 /* Non-zero means success. */
235 /* The smob "equal?" function for <gdb:type>. */
238 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
240 type_smob
*type1_smob
, *type2_smob
;
241 struct type
*type1
, *type2
;
243 volatile struct gdb_exception except
;
245 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
247 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
249 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
250 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
251 type1
= type1_smob
->type
;
252 type2
= type2_smob
->type
;
254 TRY_CATCH (except
, RETURN_MASK_ALL
)
256 result
= types_deeply_equal (type1
, type2
);
258 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
260 return scm_from_bool (result
);
263 /* Low level routine to create a <gdb:type> object. */
266 tyscm_make_type_smob (void)
268 type_smob
*t_smob
= (type_smob
*)
269 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
272 /* This must be filled in by the caller. */
275 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
276 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
281 /* Return non-zero if SCM is a <gdb:type> object. */
284 tyscm_is_type (SCM self
)
286 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
289 /* (type? object) -> boolean */
292 gdbscm_type_p (SCM self
)
294 return scm_from_bool (tyscm_is_type (self
));
297 /* Return the existing object that encapsulates TYPE, or create a new
298 <gdb:type> object. */
301 tyscm_scm_from_type (struct type
*type
)
304 eqable_gdb_smob
**slot
;
305 type_smob
*t_smob
, t_smob_for_lookup
;
308 /* If we've already created a gsmob for this type, return it.
309 This makes types eq?-able. */
310 htab
= tyscm_type_map (type
);
311 t_smob_for_lookup
.type
= type
;
312 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
314 return (*slot
)->containing_scm
;
316 t_scm
= tyscm_make_type_smob ();
317 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
319 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
324 /* Returns the <gdb:type> object in SELF.
325 Throws an exception if SELF is not a <gdb:type> object. */
328 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
330 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
336 /* Returns a pointer to the type smob of SELF.
337 Throws an exception if SELF is not a <gdb:type> object. */
340 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
342 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
343 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
348 /* Helper function for save_objfile_types to make a deep copy of the type. */
351 tyscm_copy_type_recursive (void **slot
, void *info
)
353 type_smob
*t_smob
= (type_smob
*) *slot
;
354 htab_t copied_types
= info
;
355 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
357 eqable_gdb_smob
**new_slot
;
358 type_smob t_smob_for_lookup
;
360 gdb_assert (objfile
!= NULL
);
362 htab_empty (copied_types
);
363 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
365 /* The eq?-hashtab that the type lived in is going away.
366 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
367 garbage collected we'll assert-fail if the type isn't in the hashtab.
370 Types now live in "arch space", and things like "char" that came from
371 the objfile *could* be considered eq? with the arch "char" type.
372 However, they weren't before the objfile got deleted, so making them
373 eq? now is debatable. */
374 htab
= tyscm_type_map (t_smob
->type
);
375 t_smob_for_lookup
.type
= t_smob
->type
;
376 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
377 gdb_assert (*new_slot
== NULL
);
378 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
383 /* Called when OBJFILE is about to be deleted.
384 Make a copy of all types associated with OBJFILE. */
387 save_objfile_types (struct objfile
*objfile
, void *datum
)
392 if (!gdb_scheme_initialized
)
395 copied_types
= create_copied_types_hash (objfile
);
399 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
403 htab_delete (copied_types
);
406 /* Administrivia for field smobs. */
408 /* The smob "print" function for <gdb:field>. */
411 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
413 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
415 gdbscm_printf (port
, "#<%s ", field_smob_name
);
416 scm_write (f_smob
->type_scm
, port
);
417 gdbscm_printf (port
, " %d", f_smob
->field_num
);
418 scm_puts (">", port
);
420 scm_remember_upto_here_1 (self
);
422 /* Non-zero means success. */
426 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
430 tyscm_make_field_smob (SCM type_scm
, int field_num
)
432 field_smob
*f_smob
= (field_smob
*)
433 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
436 f_smob
->type_scm
= type_scm
;
437 f_smob
->field_num
= field_num
;
438 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
439 gdbscm_init_gsmob (&f_smob
->base
);
444 /* Return non-zero if SCM is a <gdb:field> object. */
447 tyscm_is_field (SCM self
)
449 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
452 /* (field? object) -> boolean */
455 gdbscm_field_p (SCM self
)
457 return scm_from_bool (tyscm_is_field (self
));
460 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
464 tyscm_scm_from_field (SCM type_scm
, int field_num
)
466 return tyscm_make_field_smob (type_scm
, field_num
);
469 /* Returns the <gdb:field> object in SELF.
470 Throws an exception if SELF is not a <gdb:field> object. */
473 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
475 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
481 /* Returns a pointer to the field smob of SELF.
482 Throws an exception if SELF is not a <gdb:field> object. */
485 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
487 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
488 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
493 /* Returns a pointer to the type struct in F_SMOB
494 (the type the field is in). */
497 tyscm_field_smob_containing_type (field_smob
*f_smob
)
501 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
502 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
507 /* Returns a pointer to the field struct of F_SMOB. */
509 static struct field
*
510 tyscm_field_smob_to_field (field_smob
*f_smob
)
512 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
514 /* This should be non-NULL by construction. */
515 gdb_assert (TYPE_FIELDS (type
) != NULL
);
517 return &TYPE_FIELD (type
, f_smob
->field_num
);
520 /* Type smob accessors. */
522 /* (type-code <gdb:type>) -> integer
523 Return the code for this type. */
526 gdbscm_type_code (SCM self
)
529 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
530 struct type
*type
= t_smob
->type
;
532 return scm_from_int (TYPE_CODE (type
));
535 /* (type-fields <gdb:type>) -> list
536 Return a list of all fields. Each element is a <gdb:field> object.
537 This also supports arrays, we return a field list of one element,
541 gdbscm_type_fields (SCM self
)
544 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
545 struct type
*type
= t_smob
->type
;
546 struct type
*containing_type
;
547 SCM containing_type_scm
, result
;
550 containing_type
= tyscm_get_composite (type
);
551 if (containing_type
== NULL
)
552 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
553 _(not_composite_error
));
555 /* If SELF is a typedef or reference, we want the underlying type,
556 which is what tyscm_get_composite returns. */
557 if (containing_type
== type
)
558 containing_type_scm
= self
;
560 containing_type_scm
= tyscm_scm_from_type (containing_type
);
563 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
564 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
566 return scm_reverse_x (result
, SCM_EOL
);
569 /* (type-tag <gdb:type>) -> string
570 Return the type's tag, or #f. */
573 gdbscm_type_tag (SCM self
)
576 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
577 struct type
*type
= t_smob
->type
;
579 if (!TYPE_TAG_NAME (type
))
581 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
584 /* (type-name <gdb:type>) -> string
585 Return the type's name, or #f. */
588 gdbscm_type_name (SCM self
)
591 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
592 struct type
*type
= t_smob
->type
;
594 if (!TYPE_NAME (type
))
596 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
599 /* (type-print-name <gdb:type>) -> string
600 Return the print name of type.
601 TODO: template support elided for now. */
604 gdbscm_type_print_name (SCM self
)
607 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
608 struct type
*type
= t_smob
->type
;
610 SCM exception
, result
;
612 thetype
= tyscm_type_name (type
, &exception
);
615 gdbscm_throw (exception
);
617 result
= gdbscm_scm_from_c_string (thetype
);
623 /* (type-sizeof <gdb:type>) -> integer
624 Return the size of the type represented by SELF, in bytes. */
627 gdbscm_type_sizeof (SCM self
)
630 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
631 struct type
*type
= t_smob
->type
;
632 volatile struct gdb_exception except
;
634 TRY_CATCH (except
, RETURN_MASK_ALL
)
636 check_typedef (type
);
638 /* Ignore exceptions. */
640 return scm_from_long (TYPE_LENGTH (type
));
643 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
644 Return the type, stripped of typedefs. */
647 gdbscm_type_strip_typedefs (SCM self
)
650 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
651 struct type
*type
= t_smob
->type
;
652 volatile struct gdb_exception except
;
654 TRY_CATCH (except
, RETURN_MASK_ALL
)
656 type
= check_typedef (type
);
658 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
)
669 volatile struct gdb_exception except
;
673 TRY_CATCH (except
, RETURN_MASK_ALL
)
675 type
= check_typedef (type
);
677 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
679 if (TYPE_CODE (type
) != TYPE_CODE_PTR
680 && TYPE_CODE (type
) != TYPE_CODE_REF
)
682 type
= TYPE_TARGET_TYPE (type
);
685 /* If this is not a struct, union, or enum type, raise TypeError
687 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
688 && TYPE_CODE (type
) != TYPE_CODE_UNION
689 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
695 /* Helper for tyscm_array and tyscm_vector. */
698 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
699 const char *func_name
)
702 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
703 struct type
*type
= t_smob
->type
;
705 struct type
*array
= NULL
;
706 volatile struct gdb_exception except
;
708 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
709 n1_scm
, &n1
, n2_scm
, &n2
);
711 if (SCM_UNBNDP (n2_scm
))
719 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
720 scm_cons (scm_from_long (n1
),
722 _("Array length must not be negative"));
725 TRY_CATCH (except
, RETURN_MASK_ALL
)
727 array
= lookup_array_range_type (type
, n1
, n2
);
729 make_vector_type (array
);
731 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
733 return tyscm_scm_from_type (array
);
736 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
737 The array has indices [low-bound,high-bound].
738 If low-bound is not provided zero is used.
739 Return an array type.
741 IWBN if the one argument version specified a size, not the high bound.
742 It's too easy to pass one argument thinking it is the size of the array.
743 The current semantics are for compatibility with the Python version.
744 Later we can add #:size. */
747 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
749 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
752 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
753 The array has indices [low-bound,high-bound].
754 If low-bound is not provided zero is used.
755 Return a vector type.
757 IWBN if the one argument version specified a size, not the high bound.
758 It's too easy to pass one argument thinking it is the size of the array.
759 The current semantics are for compatibility with the Python version.
760 Later we can add #:size. */
763 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
765 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
768 /* (type-pointer <gdb:type>) -> <gdb:type>
769 Return a <gdb:type> object which represents a pointer to SELF. */
772 gdbscm_type_pointer (SCM self
)
775 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
776 struct type
*type
= t_smob
->type
;
777 volatile struct gdb_exception except
;
779 TRY_CATCH (except
, RETURN_MASK_ALL
)
781 type
= lookup_pointer_type (type
);
783 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
785 return tyscm_scm_from_type (type
);
788 /* (type-range <gdb:type>) -> (low high)
789 Return the range of a type represented by SELF. The return type is
790 a list. The first element is the low bound, and the second element
791 is the high bound. */
794 gdbscm_type_range (SCM self
)
797 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
798 struct type
*type
= t_smob
->type
;
799 SCM low_scm
, high_scm
;
800 /* Initialize these to appease GCC warnings. */
801 LONGEST low
= 0, high
= 0;
803 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
804 || TYPE_CODE (type
) == TYPE_CODE_STRING
805 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
806 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
808 switch (TYPE_CODE (type
))
810 case TYPE_CODE_ARRAY
:
811 case TYPE_CODE_STRING
:
812 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
813 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
815 case TYPE_CODE_RANGE
:
816 low
= TYPE_LOW_BOUND (type
);
817 high
= TYPE_HIGH_BOUND (type
);
821 low_scm
= gdbscm_scm_from_longest (low
);
822 high_scm
= gdbscm_scm_from_longest (high
);
824 return scm_list_2 (low_scm
, high_scm
);
827 /* (type-reference <gdb:type>) -> <gdb:type>
828 Return a <gdb:type> object which represents a reference to SELF. */
831 gdbscm_type_reference (SCM self
)
834 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
835 struct type
*type
= t_smob
->type
;
836 volatile struct gdb_exception except
;
838 TRY_CATCH (except
, RETURN_MASK_ALL
)
840 type
= lookup_reference_type (type
);
842 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
844 return tyscm_scm_from_type (type
);
847 /* (type-target <gdb:type>) -> <gdb:type>
848 Return a <gdb:type> object which represents the target type of SELF. */
851 gdbscm_type_target (SCM self
)
854 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
855 struct type
*type
= t_smob
->type
;
857 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
859 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
862 /* (type-const <gdb:type>) -> <gdb:type>
863 Return a const-qualified type variant. */
866 gdbscm_type_const (SCM self
)
869 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
870 struct type
*type
= t_smob
->type
;
871 volatile struct gdb_exception except
;
873 TRY_CATCH (except
, RETURN_MASK_ALL
)
875 type
= make_cv_type (1, 0, type
, NULL
);
877 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
879 return tyscm_scm_from_type (type
);
882 /* (type-volatile <gdb:type>) -> <gdb:type>
883 Return a volatile-qualified type variant. */
886 gdbscm_type_volatile (SCM self
)
889 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
890 struct type
*type
= t_smob
->type
;
891 volatile struct gdb_exception except
;
893 TRY_CATCH (except
, RETURN_MASK_ALL
)
895 type
= make_cv_type (0, 1, type
, NULL
);
897 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
899 return tyscm_scm_from_type (type
);
902 /* (type-unqualified <gdb:type>) -> <gdb:type>
903 Return an unqualified type variant. */
906 gdbscm_type_unqualified (SCM self
)
909 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
910 struct type
*type
= t_smob
->type
;
911 volatile struct gdb_exception except
;
913 TRY_CATCH (except
, RETURN_MASK_ALL
)
915 type
= make_cv_type (0, 0, type
, NULL
);
917 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
919 return tyscm_scm_from_type (type
);
922 /* Field related accessors of types. */
924 /* (type-num-fields <gdb:type>) -> integer
925 Return number of fields. */
928 gdbscm_type_num_fields (SCM self
)
931 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
932 struct type
*type
= t_smob
->type
;
934 type
= tyscm_get_composite (type
);
936 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
937 _(not_composite_error
));
939 return scm_from_long (TYPE_NFIELDS (type
));
942 /* (type-field <gdb:type> string) -> <gdb:field>
943 Return the <gdb:field> object for the field named by the argument. */
946 gdbscm_type_field (SCM self
, SCM field_scm
)
949 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
950 struct type
*type
= t_smob
->type
;
953 struct cleanup
*cleanups
;
955 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
958 /* We want just fields of this type, not of base types, so instead of
959 using lookup_struct_elt_type, portions of that function are
962 type
= tyscm_get_composite (type
);
964 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
965 _(not_composite_error
));
967 field
= gdbscm_scm_to_c_string (field_scm
);
968 cleanups
= make_cleanup (xfree
, field
);
970 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
972 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
974 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
976 do_cleanups (cleanups
);
977 return tyscm_make_field_smob (self
, i
);
981 do_cleanups (cleanups
);
983 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
987 /* (type-has-field? <gdb:type> string) -> boolean
988 Return boolean indicating if type SELF has FIELD_SCM (a string). */
991 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
994 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
995 struct type
*type
= t_smob
->type
;
998 struct cleanup
*cleanups
;
1000 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1003 /* We want just fields of this type, not of base types, so instead of
1004 using lookup_struct_elt_type, portions of that function are
1007 type
= tyscm_get_composite (type
);
1009 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1010 _(not_composite_error
));
1012 field
= gdbscm_scm_to_c_string (field_scm
);
1013 cleanups
= make_cleanup (xfree
, field
);
1015 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1017 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1019 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1021 do_cleanups (cleanups
);
1026 do_cleanups (cleanups
);
1031 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1032 Make a field iterator object. */
1035 gdbscm_make_field_iterator (SCM self
)
1038 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1039 struct type
*type
= t_smob
->type
;
1040 struct type
*containing_type
;
1041 SCM containing_type_scm
;
1043 containing_type
= tyscm_get_composite (type
);
1044 if (containing_type
== NULL
)
1045 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1046 _(not_composite_error
));
1048 /* If SELF is a typedef or reference, we want the underlying type,
1049 which is what tyscm_get_composite returns. */
1050 if (containing_type
== type
)
1051 containing_type_scm
= self
;
1053 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1055 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1056 tyscm_next_field_x_proc
);
1059 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1060 Return the next field in the iteration through the list of fields of the
1061 type, or (end-of-iteration).
1062 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1063 This is the next! <gdb:iterator> function, not exported to the user. */
1066 gdbscm_type_next_field_x (SCM self
)
1068 iterator_smob
*i_smob
;
1071 SCM it_scm
, result
, progress
, object
;
1074 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1075 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1076 object
= itscm_iterator_smob_object (i_smob
);
1077 progress
= itscm_iterator_smob_progress (i_smob
);
1079 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1080 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1081 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1082 type
= t_smob
->type
;
1084 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1085 0, TYPE_NFIELDS (type
)),
1086 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1087 field
= scm_to_int (progress
);
1089 if (field
< TYPE_NFIELDS (type
))
1091 result
= tyscm_make_field_smob (object
, field
);
1092 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1096 return gdbscm_end_of_iteration ();
1099 /* Field smob accessors. */
1101 /* (field-name <gdb:field>) -> string
1102 Return the name of this field or #f if there isn't one. */
1105 gdbscm_field_name (SCM self
)
1108 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1109 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1111 if (FIELD_NAME (*field
))
1112 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1116 /* (field-type <gdb:field>) -> <gdb:type>
1117 Return the <gdb:type> object of the field or #f if there isn't one. */
1120 gdbscm_field_type (SCM self
)
1123 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1124 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1126 /* A field can have a NULL type in some situations. */
1127 if (FIELD_TYPE (*field
))
1128 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1132 /* (field-enumval <gdb:field>) -> integer
1133 For enum values, return its value as an integer. */
1136 gdbscm_field_enumval (SCM self
)
1139 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1140 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1141 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1143 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1144 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1146 return scm_from_long (FIELD_ENUMVAL (*field
));
1149 /* (field-bitpos <gdb:field>) -> integer
1150 For bitfields, return its offset in bits. */
1153 gdbscm_field_bitpos (SCM self
)
1156 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1157 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1158 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1160 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1161 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1163 return scm_from_long (FIELD_BITPOS (*field
));
1166 /* (field-bitsize <gdb:field>) -> integer
1167 Return the size of the field in bits. */
1170 gdbscm_field_bitsize (SCM self
)
1173 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1174 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1176 return scm_from_long (FIELD_BITPOS (*field
));
1179 /* (field-artificial? <gdb:field>) -> boolean
1180 Return #t if field is artificial. */
1183 gdbscm_field_artificial_p (SCM self
)
1186 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1187 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1189 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1192 /* (field-baseclass? <gdb:field>) -> boolean
1193 Return #t if field is a baseclass. */
1196 gdbscm_field_baseclass_p (SCM self
)
1199 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1200 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1201 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1203 if (TYPE_CODE (type
) == TYPE_CODE_CLASS
)
1204 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1208 /* Return the type named TYPE_NAME in BLOCK.
1209 Returns NULL if not found.
1210 This routine does not throw an error. */
1212 static struct type
*
1213 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1215 struct type
*type
= NULL
;
1216 volatile struct gdb_exception except
;
1218 TRY_CATCH (except
, RETURN_MASK_ALL
)
1220 if (!strncmp (type_name
, "struct ", 7))
1221 type
= lookup_struct (type_name
+ 7, NULL
);
1222 else if (!strncmp (type_name
, "union ", 6))
1223 type
= lookup_union (type_name
+ 6, NULL
);
1224 else if (!strncmp (type_name
, "enum ", 5))
1225 type
= lookup_enum (type_name
+ 5, NULL
);
1227 type
= lookup_typename (current_language
, get_current_arch (),
1228 type_name
, block
, 0);
1230 if (except
.reason
< 0)
1236 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1237 TODO: legacy template support left out until needed. */
1240 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1242 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1244 SCM block_scm
= SCM_BOOL_F
;
1245 int block_arg_pos
= -1;
1246 const struct block
*block
= NULL
;
1249 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1251 rest
, &block_arg_pos
, &block_scm
);
1253 if (block_arg_pos
!= -1)
1257 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1262 gdbscm_throw (exception
);
1265 type
= tyscm_lookup_typename (name
, block
);
1269 return tyscm_scm_from_type (type
);
1273 /* Initialize the Scheme type code. */
1276 static const scheme_integer_constant type_integer_constants
[] =
1278 #define X(SYM) { #SYM, SYM }
1279 X (TYPE_CODE_BITSTRING
),
1281 X (TYPE_CODE_ARRAY
),
1282 X (TYPE_CODE_STRUCT
),
1283 X (TYPE_CODE_UNION
),
1285 X (TYPE_CODE_FLAGS
),
1291 X (TYPE_CODE_RANGE
),
1292 X (TYPE_CODE_STRING
),
1293 X (TYPE_CODE_ERROR
),
1294 X (TYPE_CODE_METHOD
),
1295 X (TYPE_CODE_METHODPTR
),
1296 X (TYPE_CODE_MEMBERPTR
),
1300 X (TYPE_CODE_COMPLEX
),
1301 X (TYPE_CODE_TYPEDEF
),
1302 X (TYPE_CODE_NAMESPACE
),
1303 X (TYPE_CODE_DECFLOAT
),
1304 X (TYPE_CODE_INTERNAL_FUNCTION
),
1307 END_INTEGER_CONSTANTS
1310 static const scheme_function type_functions
[] =
1312 { "type?", 1, 0, 0, gdbscm_type_p
,
1314 Return #t if the object is a <gdb:type> object." },
1316 { "lookup-type", 1, 0, 1, gdbscm_lookup_type
,
1318 Return the <gdb:type> object representing string or #f if not found.\n\
1319 If block is given then the type is looked for in that block.\n\
1321 Arguments: string [#:block <gdb:block>]" },
1323 { "type-code", 1, 0, 0, gdbscm_type_code
,
1325 Return the code of the type" },
1327 { "type-tag", 1, 0, 0, gdbscm_type_tag
,
1329 Return the tag name of the type, or #f if there isn't one." },
1331 { "type-name", 1, 0, 0, gdbscm_type_name
,
1333 Return the name of the type as a string, or #f if there isn't one." },
1335 { "type-print-name", 1, 0, 0, gdbscm_type_print_name
,
1337 Return the print name of the type as a string." },
1339 { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof
,
1341 Return the size of the type, in bytes." },
1343 { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs
,
1345 Return a type formed by stripping the type of all typedefs." },
1347 { "type-array", 2, 1, 0, gdbscm_type_array
,
1349 Return a type representing an array of objects of the type.\n\
1351 Arguments: <gdb:type> [low-bound] high-bound\n\
1352 If low-bound is not provided zero is used.\n\
1353 N.B. If only the high-bound parameter is specified, it is not\n\
1355 Valid bounds for array indices are [low-bound,high-bound]." },
1357 { "type-vector", 2, 1, 0, gdbscm_type_vector
,
1359 Return a type representing a vector of objects of the type.\n\
1360 Vectors differ from arrays in that if the current language has C-style\n\
1361 arrays, vectors don't decay to a pointer to the first element.\n\
1362 They are first class values.\n\
1364 Arguments: <gdb:type> [low-bound] high-bound\n\
1365 If low-bound is not provided zero is used.\n\
1366 N.B. If only the high-bound parameter is specified, it is not\n\
1368 Valid bounds for array indices are [low-bound,high-bound]." },
1370 { "type-pointer", 1, 0, 0, gdbscm_type_pointer
,
1372 Return a type of pointer to the type." },
1374 { "type-range", 1, 0, 0, gdbscm_type_range
,
1376 Return (low high) representing the range for the type." },
1378 { "type-reference", 1, 0, 0, gdbscm_type_reference
,
1380 Return a type of reference to the type." },
1382 { "type-target", 1, 0, 0, gdbscm_type_target
,
1384 Return the target type of the type." },
1386 { "type-const", 1, 0, 0, gdbscm_type_const
,
1388 Return a const variant of the type." },
1390 { "type-volatile", 1, 0, 0, gdbscm_type_volatile
,
1392 Return a volatile variant of the type." },
1394 { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified
,
1396 Return a variant of the type without const or volatile attributes." },
1398 { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields
,
1400 Return the number of fields of the type." },
1402 { "type-fields", 1, 0, 0, gdbscm_type_fields
,
1404 Return the list of <gdb:field> objects of fields of the type." },
1406 { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator
,
1408 Return a <gdb:iterator> object for iterating over the fields of the type." },
1410 { "type-field", 2, 0, 0, gdbscm_type_field
,
1412 Return the field named by string of the type.\n\
1414 Arguments: <gdb:type> string" },
1416 { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p
,
1418 Return #t if the type has field named string.\n\
1420 Arguments: <gdb:type> string" },
1422 { "field?", 1, 0, 0, gdbscm_field_p
,
1424 Return #t if the object is a <gdb:field> object." },
1426 { "field-name", 1, 0, 0, gdbscm_field_name
,
1428 Return the name of the field." },
1430 { "field-type", 1, 0, 0, gdbscm_field_type
,
1432 Return the type of the field." },
1434 { "field-enumval", 1, 0, 0, gdbscm_field_enumval
,
1436 Return the enum value represented by the field." },
1438 { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos
,
1440 Return the offset in bits of the field in its containing type." },
1442 { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize
,
1444 Return the size of the field in bits." },
1446 { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p
,
1448 Return #t if the field is artificial." },
1450 { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p
,
1452 Return #t if the field is a baseclass." },
1458 gdbscm_initialize_types (void)
1460 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1461 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1462 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1463 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1465 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1466 sizeof (field_smob
));
1467 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1469 gdbscm_define_integer_constants (type_integer_constants
, 1);
1470 gdbscm_define_functions (type_functions
, 1);
1472 /* This function is "private". */
1473 tyscm_next_field_x_proc
1474 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1475 gdbscm_type_next_field_x
);
1476 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1477 gdbscm_documentation_symbol
,
1478 gdbscm_scm_from_c_string ("\
1479 Internal function to assist the type fields iterator."));
1481 block_keyword
= scm_from_latin1_keyword ("block");
1483 /* Register an objfile "free" callback so we can properly copy types
1484 associated with the objfile when it's about to be deleted. */
1485 tyscm_objfile_data_key
1486 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1488 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1489 tyscm_eq_type_smob
);