1 /* Scheme interface to types.
3 Copyright (C) 2008-2015 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.
103 Space for the result is malloc'd, caller must free.
104 If there's an error computing the name, the result is NULL and the
105 exception is stored in *EXCP. */
108 tyscm_type_name (struct type
*type
, SCM
*excp
)
111 volatile struct gdb_exception except
;
113 TRY_CATCH (except
, RETURN_MASK_ALL
)
115 struct cleanup
*old_chain
;
118 stb
= mem_fileopen ();
119 old_chain
= make_cleanup_ui_file_delete (stb
);
121 LA_PRINT_TYPE (type
, "", stb
, -1, 0, &type_print_raw_options
);
123 name
= ui_file_xstrdup (stb
, NULL
);
124 do_cleanups (old_chain
);
126 if (except
.reason
< 0)
128 *excp
= gdbscm_scm_from_gdb_exception (except
);
135 /* Administrivia for type smobs. */
137 /* Helper function to hash a type_smob. */
140 tyscm_hash_type_smob (const void *p
)
142 const type_smob
*t_smob
= p
;
144 return htab_hash_pointer (t_smob
->type
);
147 /* Helper function to compute equality of type_smobs. */
150 tyscm_eq_type_smob (const void *ap
, const void *bp
)
152 const type_smob
*a
= ap
;
153 const type_smob
*b
= bp
;
155 return (a
->type
== b
->type
159 /* Return the struct type pointer -> SCM mapping table.
160 If type is owned by an objfile, the mapping table is created if necessary.
161 Otherwise, type is not owned by an objfile, and we use
165 tyscm_type_map (struct type
*type
)
167 struct objfile
*objfile
= TYPE_OBJFILE (type
);
171 return global_types_map
;
173 htab
= objfile_data (objfile
, tyscm_objfile_data_key
);
176 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
178 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
184 /* The smob "free" function for <gdb:type>. */
187 tyscm_free_type_smob (SCM self
)
189 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
191 if (t_smob
->type
!= NULL
)
193 htab_t htab
= tyscm_type_map (t_smob
->type
);
195 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
198 /* Not necessary, done to catch bugs. */
204 /* The smob "print" function for <gdb:type>. */
207 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
209 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
211 char *name
= tyscm_type_name (t_smob
->type
, &exception
);
214 gdbscm_throw (exception
);
216 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
217 invoked by write/~S. What to do here may need to evolve.
218 IWBN if we could pass an argument to format that would we could use
219 instead of writingp. */
220 if (pstate
->writingp
)
221 gdbscm_printf (port
, "#<%s ", type_smob_name
);
223 scm_puts (name
, port
);
225 if (pstate
->writingp
)
226 scm_puts (">", port
);
228 scm_remember_upto_here_1 (self
);
230 /* Non-zero means success. */
234 /* The smob "equal?" function for <gdb:type>. */
237 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
239 type_smob
*type1_smob
, *type2_smob
;
240 struct type
*type1
, *type2
;
242 volatile struct gdb_exception except
;
244 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
246 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
248 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
249 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
250 type1
= type1_smob
->type
;
251 type2
= type2_smob
->type
;
253 TRY_CATCH (except
, RETURN_MASK_ALL
)
255 result
= types_deeply_equal (type1
, type2
);
257 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
259 return scm_from_bool (result
);
262 /* Low level routine to create a <gdb:type> object. */
265 tyscm_make_type_smob (void)
267 type_smob
*t_smob
= (type_smob
*)
268 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
271 /* This must be filled in by the caller. */
274 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
275 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
280 /* Return non-zero if SCM is a <gdb:type> object. */
283 tyscm_is_type (SCM self
)
285 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
288 /* (type? object) -> boolean */
291 gdbscm_type_p (SCM self
)
293 return scm_from_bool (tyscm_is_type (self
));
296 /* Return the existing object that encapsulates TYPE, or create a new
297 <gdb:type> object. */
300 tyscm_scm_from_type (struct type
*type
)
303 eqable_gdb_smob
**slot
;
304 type_smob
*t_smob
, t_smob_for_lookup
;
307 /* If we've already created a gsmob for this type, return it.
308 This makes types eq?-able. */
309 htab
= tyscm_type_map (type
);
310 t_smob_for_lookup
.type
= type
;
311 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
313 return (*slot
)->containing_scm
;
315 t_scm
= tyscm_make_type_smob ();
316 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
318 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
323 /* Returns the <gdb:type> object in SELF.
324 Throws an exception if SELF is not a <gdb:type> object. */
327 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
329 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
335 /* Returns a pointer to the type smob of SELF.
336 Throws an exception if SELF is not a <gdb:type> object. */
339 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
341 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
342 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
347 /* Helper function for save_objfile_types to make a deep copy of the type. */
350 tyscm_copy_type_recursive (void **slot
, void *info
)
352 type_smob
*t_smob
= (type_smob
*) *slot
;
353 htab_t copied_types
= info
;
354 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
356 eqable_gdb_smob
**new_slot
;
357 type_smob t_smob_for_lookup
;
359 gdb_assert (objfile
!= NULL
);
361 htab_empty (copied_types
);
362 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
364 /* The eq?-hashtab that the type lived in is going away.
365 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
366 garbage collected we'll assert-fail if the type isn't in the hashtab.
369 Types now live in "arch space", and things like "char" that came from
370 the objfile *could* be considered eq? with the arch "char" type.
371 However, they weren't before the objfile got deleted, so making them
372 eq? now is debatable. */
373 htab
= tyscm_type_map (t_smob
->type
);
374 t_smob_for_lookup
.type
= t_smob
->type
;
375 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
376 gdb_assert (*new_slot
== NULL
);
377 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
382 /* Called when OBJFILE is about to be deleted.
383 Make a copy of all types associated with OBJFILE. */
386 save_objfile_types (struct objfile
*objfile
, void *datum
)
391 if (!gdb_scheme_initialized
)
394 copied_types
= create_copied_types_hash (objfile
);
398 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
402 htab_delete (copied_types
);
405 /* Administrivia for field smobs. */
407 /* The smob "print" function for <gdb:field>. */
410 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
412 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
414 gdbscm_printf (port
, "#<%s ", field_smob_name
);
415 scm_write (f_smob
->type_scm
, port
);
416 gdbscm_printf (port
, " %d", f_smob
->field_num
);
417 scm_puts (">", port
);
419 scm_remember_upto_here_1 (self
);
421 /* Non-zero means success. */
425 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
429 tyscm_make_field_smob (SCM type_scm
, int field_num
)
431 field_smob
*f_smob
= (field_smob
*)
432 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
435 f_smob
->type_scm
= type_scm
;
436 f_smob
->field_num
= field_num
;
437 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
438 gdbscm_init_gsmob (&f_smob
->base
);
443 /* Return non-zero if SCM is a <gdb:field> object. */
446 tyscm_is_field (SCM self
)
448 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
451 /* (field? object) -> boolean */
454 gdbscm_field_p (SCM self
)
456 return scm_from_bool (tyscm_is_field (self
));
459 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
463 tyscm_scm_from_field (SCM type_scm
, int field_num
)
465 return tyscm_make_field_smob (type_scm
, field_num
);
468 /* Returns the <gdb:field> object in SELF.
469 Throws an exception if SELF is not a <gdb:field> object. */
472 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
474 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
480 /* Returns a pointer to the field smob of SELF.
481 Throws an exception if SELF is not a <gdb:field> object. */
484 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
486 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
487 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
492 /* Returns a pointer to the type struct in F_SMOB
493 (the type the field is in). */
496 tyscm_field_smob_containing_type (field_smob
*f_smob
)
500 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
501 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
506 /* Returns a pointer to the field struct of F_SMOB. */
508 static struct field
*
509 tyscm_field_smob_to_field (field_smob
*f_smob
)
511 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
513 /* This should be non-NULL by construction. */
514 gdb_assert (TYPE_FIELDS (type
) != NULL
);
516 return &TYPE_FIELD (type
, f_smob
->field_num
);
519 /* Type smob accessors. */
521 /* (type-code <gdb:type>) -> integer
522 Return the code for this type. */
525 gdbscm_type_code (SCM self
)
528 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
529 struct type
*type
= t_smob
->type
;
531 return scm_from_int (TYPE_CODE (type
));
534 /* (type-fields <gdb:type>) -> list
535 Return a list of all fields. Each element is a <gdb:field> object.
536 This also supports arrays, we return a field list of one element,
540 gdbscm_type_fields (SCM self
)
543 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
544 struct type
*type
= t_smob
->type
;
545 struct type
*containing_type
;
546 SCM containing_type_scm
, result
;
549 containing_type
= tyscm_get_composite (type
);
550 if (containing_type
== NULL
)
551 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
552 _(not_composite_error
));
554 /* If SELF is a typedef or reference, we want the underlying type,
555 which is what tyscm_get_composite returns. */
556 if (containing_type
== type
)
557 containing_type_scm
= self
;
559 containing_type_scm
= tyscm_scm_from_type (containing_type
);
562 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
563 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
565 return scm_reverse_x (result
, SCM_EOL
);
568 /* (type-tag <gdb:type>) -> string
569 Return the type's tag, or #f. */
572 gdbscm_type_tag (SCM self
)
575 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
576 struct type
*type
= t_smob
->type
;
578 if (!TYPE_TAG_NAME (type
))
580 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
583 /* (type-name <gdb:type>) -> string
584 Return the type's name, or #f. */
587 gdbscm_type_name (SCM self
)
590 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
591 struct type
*type
= t_smob
->type
;
593 if (!TYPE_NAME (type
))
595 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
598 /* (type-print-name <gdb:type>) -> string
599 Return the print name of type.
600 TODO: template support elided for now. */
603 gdbscm_type_print_name (SCM self
)
606 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
607 struct type
*type
= t_smob
->type
;
609 SCM exception
, result
;
611 thetype
= tyscm_type_name (type
, &exception
);
614 gdbscm_throw (exception
);
616 result
= gdbscm_scm_from_c_string (thetype
);
622 /* (type-sizeof <gdb:type>) -> integer
623 Return the size of the type represented by SELF, in bytes. */
626 gdbscm_type_sizeof (SCM self
)
629 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
630 struct type
*type
= t_smob
->type
;
631 volatile struct gdb_exception except
;
633 TRY_CATCH (except
, RETURN_MASK_ALL
)
635 check_typedef (type
);
637 /* Ignore exceptions. */
639 return scm_from_long (TYPE_LENGTH (type
));
642 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
643 Return the type, stripped of typedefs. */
646 gdbscm_type_strip_typedefs (SCM self
)
649 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
650 struct type
*type
= t_smob
->type
;
651 volatile struct gdb_exception except
;
653 TRY_CATCH (except
, RETURN_MASK_ALL
)
655 type
= check_typedef (type
);
657 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
659 return tyscm_scm_from_type (type
);
662 /* Strip typedefs and pointers/reference from a type. Then check that
663 it is a struct, union, or enum type. If not, return NULL. */
666 tyscm_get_composite (struct type
*type
)
668 volatile struct gdb_exception except
;
672 TRY_CATCH (except
, RETURN_MASK_ALL
)
674 type
= check_typedef (type
);
676 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
678 if (TYPE_CODE (type
) != TYPE_CODE_PTR
679 && TYPE_CODE (type
) != TYPE_CODE_REF
)
681 type
= TYPE_TARGET_TYPE (type
);
684 /* If this is not a struct, union, or enum type, raise TypeError
686 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
687 && TYPE_CODE (type
) != TYPE_CODE_UNION
688 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
694 /* Helper for tyscm_array and tyscm_vector. */
697 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
698 const char *func_name
)
701 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
702 struct type
*type
= t_smob
->type
;
704 struct type
*array
= NULL
;
705 volatile struct gdb_exception except
;
707 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
708 n1_scm
, &n1
, n2_scm
, &n2
);
710 if (SCM_UNBNDP (n2_scm
))
716 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
718 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
719 scm_cons (scm_from_long (n1
),
721 _("Array length must not be negative"));
724 TRY_CATCH (except
, RETURN_MASK_ALL
)
726 array
= lookup_array_range_type (type
, n1
, n2
);
728 make_vector_type (array
);
730 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
732 return tyscm_scm_from_type (array
);
735 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
736 The array has indices [low-bound,high-bound].
737 If low-bound is not provided zero is used.
738 Return an array type.
740 IWBN if the one argument version specified a size, not the high bound.
741 It's too easy to pass one argument thinking it is the size of the array.
742 The current semantics are for compatibility with the Python version.
743 Later we can add #:size. */
746 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
748 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
751 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
752 The array has indices [low-bound,high-bound].
753 If low-bound is not provided zero is used.
754 Return a vector type.
756 IWBN if the one argument version specified a size, not the high bound.
757 It's too easy to pass one argument thinking it is the size of the array.
758 The current semantics are for compatibility with the Python version.
759 Later we can add #:size. */
762 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
764 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
767 /* (type-pointer <gdb:type>) -> <gdb:type>
768 Return a <gdb:type> object which represents a pointer to SELF. */
771 gdbscm_type_pointer (SCM self
)
774 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
775 struct type
*type
= t_smob
->type
;
776 volatile struct gdb_exception except
;
778 TRY_CATCH (except
, RETURN_MASK_ALL
)
780 type
= lookup_pointer_type (type
);
782 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
784 return tyscm_scm_from_type (type
);
787 /* (type-range <gdb:type>) -> (low high)
788 Return the range of a type represented by SELF. The return type is
789 a list. The first element is the low bound, and the second element
790 is the high bound. */
793 gdbscm_type_range (SCM self
)
796 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
797 struct type
*type
= t_smob
->type
;
798 SCM low_scm
, high_scm
;
799 /* Initialize these to appease GCC warnings. */
800 LONGEST low
= 0, high
= 0;
802 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
803 || TYPE_CODE (type
) == TYPE_CODE_STRING
804 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
805 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
807 switch (TYPE_CODE (type
))
809 case TYPE_CODE_ARRAY
:
810 case TYPE_CODE_STRING
:
811 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
812 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
814 case TYPE_CODE_RANGE
:
815 low
= TYPE_LOW_BOUND (type
);
816 high
= TYPE_HIGH_BOUND (type
);
820 low_scm
= gdbscm_scm_from_longest (low
);
821 high_scm
= gdbscm_scm_from_longest (high
);
823 return scm_list_2 (low_scm
, high_scm
);
826 /* (type-reference <gdb:type>) -> <gdb:type>
827 Return a <gdb:type> object which represents a reference to SELF. */
830 gdbscm_type_reference (SCM self
)
833 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
834 struct type
*type
= t_smob
->type
;
835 volatile struct gdb_exception except
;
837 TRY_CATCH (except
, RETURN_MASK_ALL
)
839 type
= lookup_reference_type (type
);
841 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
;
870 volatile struct gdb_exception except
;
872 TRY_CATCH (except
, RETURN_MASK_ALL
)
874 type
= make_cv_type (1, 0, type
, NULL
);
876 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
878 return tyscm_scm_from_type (type
);
881 /* (type-volatile <gdb:type>) -> <gdb:type>
882 Return a volatile-qualified type variant. */
885 gdbscm_type_volatile (SCM self
)
888 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
889 struct type
*type
= t_smob
->type
;
890 volatile struct gdb_exception except
;
892 TRY_CATCH (except
, RETURN_MASK_ALL
)
894 type
= make_cv_type (0, 1, type
, NULL
);
896 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
898 return tyscm_scm_from_type (type
);
901 /* (type-unqualified <gdb:type>) -> <gdb:type>
902 Return an unqualified type variant. */
905 gdbscm_type_unqualified (SCM self
)
908 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
909 struct type
*type
= t_smob
->type
;
910 volatile struct gdb_exception except
;
912 TRY_CATCH (except
, RETURN_MASK_ALL
)
914 type
= make_cv_type (0, 0, type
, NULL
);
916 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
918 return tyscm_scm_from_type (type
);
921 /* Field related accessors of types. */
923 /* (type-num-fields <gdb:type>) -> integer
924 Return number of fields. */
927 gdbscm_type_num_fields (SCM self
)
930 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
931 struct type
*type
= t_smob
->type
;
933 type
= tyscm_get_composite (type
);
935 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
936 _(not_composite_error
));
938 return scm_from_long (TYPE_NFIELDS (type
));
941 /* (type-field <gdb:type> string) -> <gdb:field>
942 Return the <gdb:field> object for the field named by the argument. */
945 gdbscm_type_field (SCM self
, SCM field_scm
)
948 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
949 struct type
*type
= t_smob
->type
;
952 struct cleanup
*cleanups
;
954 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
957 /* We want just fields of this type, not of base types, so instead of
958 using lookup_struct_elt_type, portions of that function are
961 type
= tyscm_get_composite (type
);
963 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
964 _(not_composite_error
));
966 field
= gdbscm_scm_to_c_string (field_scm
);
967 cleanups
= make_cleanup (xfree
, field
);
969 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
971 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
973 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
975 do_cleanups (cleanups
);
976 return tyscm_make_field_smob (self
, i
);
980 do_cleanups (cleanups
);
982 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
986 /* (type-has-field? <gdb:type> string) -> boolean
987 Return boolean indicating if type SELF has FIELD_SCM (a string). */
990 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
993 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
994 struct type
*type
= t_smob
->type
;
997 struct cleanup
*cleanups
;
999 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1002 /* We want just fields of this type, not of base types, so instead of
1003 using lookup_struct_elt_type, portions of that function are
1006 type
= tyscm_get_composite (type
);
1008 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1009 _(not_composite_error
));
1011 field
= gdbscm_scm_to_c_string (field_scm
);
1012 cleanups
= make_cleanup (xfree
, field
);
1014 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1016 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1018 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1020 do_cleanups (cleanups
);
1025 do_cleanups (cleanups
);
1030 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1031 Make a field iterator object. */
1034 gdbscm_make_field_iterator (SCM self
)
1037 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1038 struct type
*type
= t_smob
->type
;
1039 struct type
*containing_type
;
1040 SCM containing_type_scm
;
1042 containing_type
= tyscm_get_composite (type
);
1043 if (containing_type
== NULL
)
1044 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1045 _(not_composite_error
));
1047 /* If SELF is a typedef or reference, we want the underlying type,
1048 which is what tyscm_get_composite returns. */
1049 if (containing_type
== type
)
1050 containing_type_scm
= self
;
1052 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1054 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1055 tyscm_next_field_x_proc
);
1058 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1059 Return the next field in the iteration through the list of fields of the
1060 type, or (end-of-iteration).
1061 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1062 This is the next! <gdb:iterator> function, not exported to the user. */
1065 gdbscm_type_next_field_x (SCM self
)
1067 iterator_smob
*i_smob
;
1070 SCM it_scm
, result
, progress
, object
;
1073 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1074 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1075 object
= itscm_iterator_smob_object (i_smob
);
1076 progress
= itscm_iterator_smob_progress (i_smob
);
1078 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1079 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1080 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1081 type
= t_smob
->type
;
1083 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1084 0, TYPE_NFIELDS (type
)),
1085 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1086 field
= scm_to_int (progress
);
1088 if (field
< TYPE_NFIELDS (type
))
1090 result
= tyscm_make_field_smob (object
, field
);
1091 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1095 return gdbscm_end_of_iteration ();
1098 /* Field smob accessors. */
1100 /* (field-name <gdb:field>) -> string
1101 Return the name of this field or #f if there isn't one. */
1104 gdbscm_field_name (SCM self
)
1107 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1108 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1110 if (FIELD_NAME (*field
))
1111 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1115 /* (field-type <gdb:field>) -> <gdb:type>
1116 Return the <gdb:type> object of the field or #f if there isn't one. */
1119 gdbscm_field_type (SCM self
)
1122 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1123 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1125 /* A field can have a NULL type in some situations. */
1126 if (FIELD_TYPE (*field
))
1127 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1131 /* (field-enumval <gdb:field>) -> integer
1132 For enum values, return its value as an integer. */
1135 gdbscm_field_enumval (SCM self
)
1138 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1139 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1140 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1142 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1143 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1145 return scm_from_long (FIELD_ENUMVAL (*field
));
1148 /* (field-bitpos <gdb:field>) -> integer
1149 For bitfields, return its offset in bits. */
1152 gdbscm_field_bitpos (SCM self
)
1155 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1156 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1157 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1159 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1160 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1162 return scm_from_long (FIELD_BITPOS (*field
));
1165 /* (field-bitsize <gdb:field>) -> integer
1166 Return the size of the field in bits. */
1169 gdbscm_field_bitsize (SCM self
)
1172 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1173 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1175 return scm_from_long (FIELD_BITPOS (*field
));
1178 /* (field-artificial? <gdb:field>) -> boolean
1179 Return #t if field is artificial. */
1182 gdbscm_field_artificial_p (SCM self
)
1185 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1186 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1188 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1191 /* (field-baseclass? <gdb:field>) -> boolean
1192 Return #t if field is a baseclass. */
1195 gdbscm_field_baseclass_p (SCM self
)
1198 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1199 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1200 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1202 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1203 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1207 /* Return the type named TYPE_NAME in BLOCK.
1208 Returns NULL if not found.
1209 This routine does not throw an error. */
1211 static struct type
*
1212 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1214 struct type
*type
= NULL
;
1215 volatile struct gdb_exception except
;
1217 TRY_CATCH (except
, RETURN_MASK_ALL
)
1219 if (startswith (type_name
, "struct "))
1220 type
= lookup_struct (type_name
+ 7, NULL
);
1221 else if (startswith (type_name
, "union "))
1222 type
= lookup_union (type_name
+ 6, NULL
);
1223 else if (startswith (type_name
, "enum "))
1224 type
= lookup_enum (type_name
+ 5, NULL
);
1226 type
= lookup_typename (current_language
, get_current_arch (),
1227 type_name
, block
, 0);
1229 if (except
.reason
< 0)
1235 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1236 TODO: legacy template support left out until needed. */
1239 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1241 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1243 SCM block_scm
= SCM_BOOL_F
;
1244 int block_arg_pos
= -1;
1245 const struct block
*block
= NULL
;
1248 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1250 rest
, &block_arg_pos
, &block_scm
);
1252 if (block_arg_pos
!= -1)
1256 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1261 gdbscm_throw (exception
);
1264 type
= tyscm_lookup_typename (name
, block
);
1268 return tyscm_scm_from_type (type
);
1272 /* Initialize the Scheme type code. */
1275 static const scheme_integer_constant type_integer_constants
[] =
1277 #define X(SYM) { #SYM, SYM }
1278 X (TYPE_CODE_BITSTRING
),
1280 X (TYPE_CODE_ARRAY
),
1281 X (TYPE_CODE_STRUCT
),
1282 X (TYPE_CODE_UNION
),
1284 X (TYPE_CODE_FLAGS
),
1290 X (TYPE_CODE_RANGE
),
1291 X (TYPE_CODE_STRING
),
1292 X (TYPE_CODE_ERROR
),
1293 X (TYPE_CODE_METHOD
),
1294 X (TYPE_CODE_METHODPTR
),
1295 X (TYPE_CODE_MEMBERPTR
),
1299 X (TYPE_CODE_COMPLEX
),
1300 X (TYPE_CODE_TYPEDEF
),
1301 X (TYPE_CODE_NAMESPACE
),
1302 X (TYPE_CODE_DECFLOAT
),
1303 X (TYPE_CODE_INTERNAL_FUNCTION
),
1306 END_INTEGER_CONSTANTS
1309 static const scheme_function type_functions
[] =
1311 { "type?", 1, 0, 0, gdbscm_type_p
,
1313 Return #t if the object is a <gdb:type> object." },
1315 { "lookup-type", 1, 0, 1, gdbscm_lookup_type
,
1317 Return the <gdb:type> object representing string or #f if not found.\n\
1318 If block is given then the type is looked for in that block.\n\
1320 Arguments: string [#:block <gdb:block>]" },
1322 { "type-code", 1, 0, 0, gdbscm_type_code
,
1324 Return the code of the type" },
1326 { "type-tag", 1, 0, 0, gdbscm_type_tag
,
1328 Return the tag name of the type, or #f if there isn't one." },
1330 { "type-name", 1, 0, 0, gdbscm_type_name
,
1332 Return the name of the type as a string, or #f if there isn't one." },
1334 { "type-print-name", 1, 0, 0, gdbscm_type_print_name
,
1336 Return the print name of the type as a string." },
1338 { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof
,
1340 Return the size of the type, in bytes." },
1342 { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs
,
1344 Return a type formed by stripping the type of all typedefs." },
1346 { "type-array", 2, 1, 0, gdbscm_type_array
,
1348 Return a type representing an array of objects of the type.\n\
1350 Arguments: <gdb:type> [low-bound] high-bound\n\
1351 If low-bound is not provided zero is used.\n\
1352 N.B. If only the high-bound parameter is specified, it is not\n\
1354 Valid bounds for array indices are [low-bound,high-bound]." },
1356 { "type-vector", 2, 1, 0, gdbscm_type_vector
,
1358 Return a type representing a vector of objects of the type.\n\
1359 Vectors differ from arrays in that if the current language has C-style\n\
1360 arrays, vectors don't decay to a pointer to the first element.\n\
1361 They are first class values.\n\
1363 Arguments: <gdb:type> [low-bound] high-bound\n\
1364 If low-bound is not provided zero is used.\n\
1365 N.B. If only the high-bound parameter is specified, it is not\n\
1367 Valid bounds for array indices are [low-bound,high-bound]." },
1369 { "type-pointer", 1, 0, 0, gdbscm_type_pointer
,
1371 Return a type of pointer to the type." },
1373 { "type-range", 1, 0, 0, gdbscm_type_range
,
1375 Return (low high) representing the range for the type." },
1377 { "type-reference", 1, 0, 0, gdbscm_type_reference
,
1379 Return a type of reference to the type." },
1381 { "type-target", 1, 0, 0, gdbscm_type_target
,
1383 Return the target type of the type." },
1385 { "type-const", 1, 0, 0, gdbscm_type_const
,
1387 Return a const variant of the type." },
1389 { "type-volatile", 1, 0, 0, gdbscm_type_volatile
,
1391 Return a volatile variant of the type." },
1393 { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified
,
1395 Return a variant of the type without const or volatile attributes." },
1397 { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields
,
1399 Return the number of fields of the type." },
1401 { "type-fields", 1, 0, 0, gdbscm_type_fields
,
1403 Return the list of <gdb:field> objects of fields of the type." },
1405 { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator
,
1407 Return a <gdb:iterator> object for iterating over the fields of the type." },
1409 { "type-field", 2, 0, 0, gdbscm_type_field
,
1411 Return the field named by string of the type.\n\
1413 Arguments: <gdb:type> string" },
1415 { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p
,
1417 Return #t if the type has field named string.\n\
1419 Arguments: <gdb:type> string" },
1421 { "field?", 1, 0, 0, gdbscm_field_p
,
1423 Return #t if the object is a <gdb:field> object." },
1425 { "field-name", 1, 0, 0, gdbscm_field_name
,
1427 Return the name of the field." },
1429 { "field-type", 1, 0, 0, gdbscm_field_type
,
1431 Return the type of the field." },
1433 { "field-enumval", 1, 0, 0, gdbscm_field_enumval
,
1435 Return the enum value represented by the field." },
1437 { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos
,
1439 Return the offset in bits of the field in its containing type." },
1441 { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize
,
1443 Return the size of the field in bits." },
1445 { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p
,
1447 Return #t if the field is artificial." },
1449 { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p
,
1451 Return #t if the field is a baseclass." },
1457 gdbscm_initialize_types (void)
1459 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1460 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1461 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1462 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1464 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1465 sizeof (field_smob
));
1466 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1468 gdbscm_define_integer_constants (type_integer_constants
, 1);
1469 gdbscm_define_functions (type_functions
, 1);
1471 /* This function is "private". */
1472 tyscm_next_field_x_proc
1473 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1474 gdbscm_type_next_field_x
);
1475 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1476 gdbscm_documentation_symbol
,
1477 gdbscm_scm_from_c_string ("\
1478 Internal function to assist the type fields iterator."));
1480 block_keyword
= scm_from_latin1_keyword ("block");
1482 /* Register an objfile "free" callback so we can properly copy types
1483 associated with the objfile when it's about to be deleted. */
1484 tyscm_objfile_data_key
1485 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1487 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1488 tyscm_eq_type_smob
);