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
)
114 struct cleanup
*old_chain
;
117 stb
= mem_fileopen ();
118 old_chain
= make_cleanup_ui_file_delete (stb
);
120 LA_PRINT_TYPE (type
, "", stb
, -1, 0, &type_print_raw_options
);
122 name
= ui_file_xstrdup (stb
, NULL
);
123 do_cleanups (old_chain
);
125 CATCH (except
, RETURN_MASK_ALL
)
127 *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
= (const type_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
= (const type_smob
*) ap
;
153 const type_smob
*b
= (const type_smob
*) 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
= (htab_t
) 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
;
243 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
245 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
247 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
248 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
249 type1
= type1_smob
->type
;
250 type2
= type2_smob
->type
;
254 result
= types_deeply_equal (type1
, type2
);
256 CATCH (except
, RETURN_MASK_ALL
)
258 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
262 return scm_from_bool (result
);
265 /* Low level routine to create a <gdb:type> object. */
268 tyscm_make_type_smob (void)
270 type_smob
*t_smob
= (type_smob
*)
271 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
274 /* This must be filled in by the caller. */
277 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
278 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
283 /* Return non-zero if SCM is a <gdb:type> object. */
286 tyscm_is_type (SCM self
)
288 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
291 /* (type? object) -> boolean */
294 gdbscm_type_p (SCM self
)
296 return scm_from_bool (tyscm_is_type (self
));
299 /* Return the existing object that encapsulates TYPE, or create a new
300 <gdb:type> object. */
303 tyscm_scm_from_type (struct type
*type
)
306 eqable_gdb_smob
**slot
;
307 type_smob
*t_smob
, t_smob_for_lookup
;
310 /* If we've already created a gsmob for this type, return it.
311 This makes types eq?-able. */
312 htab
= tyscm_type_map (type
);
313 t_smob_for_lookup
.type
= type
;
314 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
316 return (*slot
)->containing_scm
;
318 t_scm
= tyscm_make_type_smob ();
319 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
321 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
326 /* Returns the <gdb:type> object in SELF.
327 Throws an exception if SELF is not a <gdb:type> object. */
330 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
332 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
338 /* Returns a pointer to the type smob of SELF.
339 Throws an exception if SELF is not a <gdb:type> object. */
342 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
344 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
345 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
350 /* Helper function for save_objfile_types to make a deep copy of the type. */
353 tyscm_copy_type_recursive (void **slot
, void *info
)
355 type_smob
*t_smob
= (type_smob
*) *slot
;
356 htab_t copied_types
= (htab_t
) info
;
357 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
359 eqable_gdb_smob
**new_slot
;
360 type_smob t_smob_for_lookup
;
362 gdb_assert (objfile
!= NULL
);
364 htab_empty (copied_types
);
365 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
367 /* The eq?-hashtab that the type lived in is going away.
368 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
369 garbage collected we'll assert-fail if the type isn't in the hashtab.
372 Types now live in "arch space", and things like "char" that came from
373 the objfile *could* be considered eq? with the arch "char" type.
374 However, they weren't before the objfile got deleted, so making them
375 eq? now is debatable. */
376 htab
= tyscm_type_map (t_smob
->type
);
377 t_smob_for_lookup
.type
= t_smob
->type
;
378 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
379 gdb_assert (*new_slot
== NULL
);
380 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
385 /* Called when OBJFILE is about to be deleted.
386 Make a copy of all types associated with OBJFILE. */
389 save_objfile_types (struct objfile
*objfile
, void *datum
)
391 htab_t htab
= (htab_t
) datum
;
394 if (!gdb_scheme_initialized
)
397 copied_types
= create_copied_types_hash (objfile
);
401 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
405 htab_delete (copied_types
);
408 /* Administrivia for field smobs. */
410 /* The smob "print" function for <gdb:field>. */
413 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
415 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
417 gdbscm_printf (port
, "#<%s ", field_smob_name
);
418 scm_write (f_smob
->type_scm
, port
);
419 gdbscm_printf (port
, " %d", f_smob
->field_num
);
420 scm_puts (">", port
);
422 scm_remember_upto_here_1 (self
);
424 /* Non-zero means success. */
428 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
432 tyscm_make_field_smob (SCM type_scm
, int field_num
)
434 field_smob
*f_smob
= (field_smob
*)
435 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
438 f_smob
->type_scm
= type_scm
;
439 f_smob
->field_num
= field_num
;
440 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
441 gdbscm_init_gsmob (&f_smob
->base
);
446 /* Return non-zero if SCM is a <gdb:field> object. */
449 tyscm_is_field (SCM self
)
451 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
454 /* (field? object) -> boolean */
457 gdbscm_field_p (SCM self
)
459 return scm_from_bool (tyscm_is_field (self
));
462 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
466 tyscm_scm_from_field (SCM type_scm
, int field_num
)
468 return tyscm_make_field_smob (type_scm
, field_num
);
471 /* Returns the <gdb:field> object in SELF.
472 Throws an exception if SELF is not a <gdb:field> object. */
475 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
477 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
483 /* Returns a pointer to the field smob of SELF.
484 Throws an exception if SELF is not a <gdb:field> object. */
487 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
489 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
490 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
495 /* Returns a pointer to the type struct in F_SMOB
496 (the type the field is in). */
499 tyscm_field_smob_containing_type (field_smob
*f_smob
)
503 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
504 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
509 /* Returns a pointer to the field struct of F_SMOB. */
511 static struct field
*
512 tyscm_field_smob_to_field (field_smob
*f_smob
)
514 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
516 /* This should be non-NULL by construction. */
517 gdb_assert (TYPE_FIELDS (type
) != NULL
);
519 return &TYPE_FIELD (type
, f_smob
->field_num
);
522 /* Type smob accessors. */
524 /* (type-code <gdb:type>) -> integer
525 Return the code for this type. */
528 gdbscm_type_code (SCM self
)
531 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
532 struct type
*type
= t_smob
->type
;
534 return scm_from_int (TYPE_CODE (type
));
537 /* (type-fields <gdb:type>) -> list
538 Return a list of all fields. Each element is a <gdb:field> object.
539 This also supports arrays, we return a field list of one element,
543 gdbscm_type_fields (SCM self
)
546 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
547 struct type
*type
= t_smob
->type
;
548 struct type
*containing_type
;
549 SCM containing_type_scm
, result
;
552 containing_type
= tyscm_get_composite (type
);
553 if (containing_type
== NULL
)
554 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
555 _(not_composite_error
));
557 /* If SELF is a typedef or reference, we want the underlying type,
558 which is what tyscm_get_composite returns. */
559 if (containing_type
== type
)
560 containing_type_scm
= self
;
562 containing_type_scm
= tyscm_scm_from_type (containing_type
);
565 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
566 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
568 return scm_reverse_x (result
, SCM_EOL
);
571 /* (type-tag <gdb:type>) -> string
572 Return the type's tag, or #f. */
575 gdbscm_type_tag (SCM self
)
578 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
579 struct type
*type
= t_smob
->type
;
581 if (!TYPE_TAG_NAME (type
))
583 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
586 /* (type-name <gdb:type>) -> string
587 Return the type's name, or #f. */
590 gdbscm_type_name (SCM self
)
593 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
594 struct type
*type
= t_smob
->type
;
596 if (!TYPE_NAME (type
))
598 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
601 /* (type-print-name <gdb:type>) -> string
602 Return the print name of type.
603 TODO: template support elided for now. */
606 gdbscm_type_print_name (SCM self
)
609 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
610 struct type
*type
= t_smob
->type
;
612 SCM exception
, result
;
614 thetype
= tyscm_type_name (type
, &exception
);
617 gdbscm_throw (exception
);
619 result
= gdbscm_scm_from_c_string (thetype
);
625 /* (type-sizeof <gdb:type>) -> integer
626 Return the size of the type represented by SELF, in bytes. */
629 gdbscm_type_sizeof (SCM self
)
632 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
633 struct type
*type
= t_smob
->type
;
637 check_typedef (type
);
639 CATCH (except
, RETURN_MASK_ALL
)
644 /* Ignore exceptions. */
646 return scm_from_long (TYPE_LENGTH (type
));
649 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
650 Return the type, stripped of typedefs. */
653 gdbscm_type_strip_typedefs (SCM self
)
656 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
657 struct type
*type
= t_smob
->type
;
661 type
= check_typedef (type
);
663 CATCH (except
, RETURN_MASK_ALL
)
665 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
669 return tyscm_scm_from_type (type
);
672 /* Strip typedefs and pointers/reference from a type. Then check that
673 it is a struct, union, or enum type. If not, return NULL. */
676 tyscm_get_composite (struct type
*type
)
683 type
= check_typedef (type
);
685 CATCH (except
, RETURN_MASK_ALL
)
687 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
691 if (TYPE_CODE (type
) != TYPE_CODE_PTR
692 && TYPE_CODE (type
) != TYPE_CODE_REF
)
694 type
= TYPE_TARGET_TYPE (type
);
697 /* If this is not a struct, union, or enum type, raise TypeError
699 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
700 && TYPE_CODE (type
) != TYPE_CODE_UNION
701 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
707 /* Helper for tyscm_array and tyscm_vector. */
710 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
711 const char *func_name
)
714 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
715 struct type
*type
= t_smob
->type
;
717 struct type
*array
= NULL
;
719 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
720 n1_scm
, &n1
, n2_scm
, &n2
);
722 if (SCM_UNBNDP (n2_scm
))
728 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
730 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
731 scm_cons (scm_from_long (n1
),
733 _("Array length must not be negative"));
738 array
= lookup_array_range_type (type
, n1
, n2
);
740 make_vector_type (array
);
742 CATCH (except
, RETURN_MASK_ALL
)
744 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
748 return tyscm_scm_from_type (array
);
751 /* (type-array <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 an array 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_array (SCM self
, SCM n1
, SCM n2
)
764 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
767 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
768 The array has indices [low-bound,high-bound].
769 If low-bound is not provided zero is used.
770 Return a vector type.
772 IWBN if the one argument version specified a size, not the high bound.
773 It's too easy to pass one argument thinking it is the size of the array.
774 The current semantics are for compatibility with the Python version.
775 Later we can add #:size. */
778 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
780 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
783 /* (type-pointer <gdb:type>) -> <gdb:type>
784 Return a <gdb:type> object which represents a pointer to SELF. */
787 gdbscm_type_pointer (SCM self
)
790 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
791 struct type
*type
= t_smob
->type
;
795 type
= lookup_pointer_type (type
);
797 CATCH (except
, RETURN_MASK_ALL
)
799 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
803 return tyscm_scm_from_type (type
);
806 /* (type-range <gdb:type>) -> (low high)
807 Return the range of a type represented by SELF. The return type is
808 a list. The first element is the low bound, and the second element
809 is the high bound. */
812 gdbscm_type_range (SCM self
)
815 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
816 struct type
*type
= t_smob
->type
;
817 SCM low_scm
, high_scm
;
818 /* Initialize these to appease GCC warnings. */
819 LONGEST low
= 0, high
= 0;
821 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
822 || TYPE_CODE (type
) == TYPE_CODE_STRING
823 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
824 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
826 switch (TYPE_CODE (type
))
828 case TYPE_CODE_ARRAY
:
829 case TYPE_CODE_STRING
:
830 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
831 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
833 case TYPE_CODE_RANGE
:
834 low
= TYPE_LOW_BOUND (type
);
835 high
= TYPE_HIGH_BOUND (type
);
839 low_scm
= gdbscm_scm_from_longest (low
);
840 high_scm
= gdbscm_scm_from_longest (high
);
842 return scm_list_2 (low_scm
, high_scm
);
845 /* (type-reference <gdb:type>) -> <gdb:type>
846 Return a <gdb:type> object which represents a reference to SELF. */
849 gdbscm_type_reference (SCM self
)
852 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
853 struct type
*type
= t_smob
->type
;
857 type
= lookup_reference_type (type
);
859 CATCH (except
, RETURN_MASK_ALL
)
861 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
865 return tyscm_scm_from_type (type
);
868 /* (type-target <gdb:type>) -> <gdb:type>
869 Return a <gdb:type> object which represents the target type of SELF. */
872 gdbscm_type_target (SCM self
)
875 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
876 struct type
*type
= t_smob
->type
;
878 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
880 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
883 /* (type-const <gdb:type>) -> <gdb:type>
884 Return a const-qualified type variant. */
887 gdbscm_type_const (SCM self
)
890 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
891 struct type
*type
= t_smob
->type
;
895 type
= make_cv_type (1, 0, type
, NULL
);
897 CATCH (except
, RETURN_MASK_ALL
)
899 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
903 return tyscm_scm_from_type (type
);
906 /* (type-volatile <gdb:type>) -> <gdb:type>
907 Return a volatile-qualified type variant. */
910 gdbscm_type_volatile (SCM self
)
913 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
914 struct type
*type
= t_smob
->type
;
918 type
= make_cv_type (0, 1, type
, NULL
);
920 CATCH (except
, RETURN_MASK_ALL
)
922 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
926 return tyscm_scm_from_type (type
);
929 /* (type-unqualified <gdb:type>) -> <gdb:type>
930 Return an unqualified type variant. */
933 gdbscm_type_unqualified (SCM self
)
936 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
937 struct type
*type
= t_smob
->type
;
941 type
= make_cv_type (0, 0, type
, NULL
);
943 CATCH (except
, RETURN_MASK_ALL
)
945 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
949 return tyscm_scm_from_type (type
);
952 /* Field related accessors of types. */
954 /* (type-num-fields <gdb:type>) -> integer
955 Return number of fields. */
958 gdbscm_type_num_fields (SCM self
)
961 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
962 struct type
*type
= t_smob
->type
;
964 type
= tyscm_get_composite (type
);
966 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
967 _(not_composite_error
));
969 return scm_from_long (TYPE_NFIELDS (type
));
972 /* (type-field <gdb:type> string) -> <gdb:field>
973 Return the <gdb:field> object for the field named by the argument. */
976 gdbscm_type_field (SCM self
, SCM field_scm
)
979 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
980 struct type
*type
= t_smob
->type
;
983 struct cleanup
*cleanups
;
985 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
988 /* We want just fields of this type, not of base types, so instead of
989 using lookup_struct_elt_type, portions of that function are
992 type
= tyscm_get_composite (type
);
994 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
995 _(not_composite_error
));
997 field
= gdbscm_scm_to_c_string (field_scm
);
998 cleanups
= make_cleanup (xfree
, field
);
1000 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1002 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1004 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1006 do_cleanups (cleanups
);
1007 return tyscm_make_field_smob (self
, i
);
1011 do_cleanups (cleanups
);
1013 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1014 _("Unknown field"));
1017 /* (type-has-field? <gdb:type> string) -> boolean
1018 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1021 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1024 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1025 struct type
*type
= t_smob
->type
;
1028 struct cleanup
*cleanups
;
1030 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1033 /* We want just fields of this type, not of base types, so instead of
1034 using lookup_struct_elt_type, portions of that function are
1037 type
= tyscm_get_composite (type
);
1039 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1040 _(not_composite_error
));
1042 field
= gdbscm_scm_to_c_string (field_scm
);
1043 cleanups
= make_cleanup (xfree
, field
);
1045 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1047 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1049 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1051 do_cleanups (cleanups
);
1056 do_cleanups (cleanups
);
1061 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1062 Make a field iterator object. */
1065 gdbscm_make_field_iterator (SCM self
)
1068 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1069 struct type
*type
= t_smob
->type
;
1070 struct type
*containing_type
;
1071 SCM containing_type_scm
;
1073 containing_type
= tyscm_get_composite (type
);
1074 if (containing_type
== NULL
)
1075 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1076 _(not_composite_error
));
1078 /* If SELF is a typedef or reference, we want the underlying type,
1079 which is what tyscm_get_composite returns. */
1080 if (containing_type
== type
)
1081 containing_type_scm
= self
;
1083 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1085 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1086 tyscm_next_field_x_proc
);
1089 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1090 Return the next field in the iteration through the list of fields of the
1091 type, or (end-of-iteration).
1092 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1093 This is the next! <gdb:iterator> function, not exported to the user. */
1096 gdbscm_type_next_field_x (SCM self
)
1098 iterator_smob
*i_smob
;
1101 SCM it_scm
, result
, progress
, object
;
1104 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1105 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1106 object
= itscm_iterator_smob_object (i_smob
);
1107 progress
= itscm_iterator_smob_progress (i_smob
);
1109 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1110 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1111 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1112 type
= t_smob
->type
;
1114 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1115 0, TYPE_NFIELDS (type
)),
1116 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1117 field
= scm_to_int (progress
);
1119 if (field
< TYPE_NFIELDS (type
))
1121 result
= tyscm_make_field_smob (object
, field
);
1122 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1126 return gdbscm_end_of_iteration ();
1129 /* Field smob accessors. */
1131 /* (field-name <gdb:field>) -> string
1132 Return the name of this field or #f if there isn't one. */
1135 gdbscm_field_name (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
);
1141 if (FIELD_NAME (*field
))
1142 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1146 /* (field-type <gdb:field>) -> <gdb:type>
1147 Return the <gdb:type> object of the field or #f if there isn't one. */
1150 gdbscm_field_type (SCM self
)
1153 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1154 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1156 /* A field can have a NULL type in some situations. */
1157 if (FIELD_TYPE (*field
))
1158 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1162 /* (field-enumval <gdb:field>) -> integer
1163 For enum values, return its value as an integer. */
1166 gdbscm_field_enumval (SCM self
)
1169 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1170 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1171 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1173 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1174 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1176 return scm_from_long (FIELD_ENUMVAL (*field
));
1179 /* (field-bitpos <gdb:field>) -> integer
1180 For bitfields, return its offset in bits. */
1183 gdbscm_field_bitpos (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
);
1188 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1190 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1191 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1193 return scm_from_long (FIELD_BITPOS (*field
));
1196 /* (field-bitsize <gdb:field>) -> integer
1197 Return the size of the field in bits. */
1200 gdbscm_field_bitsize (SCM self
)
1203 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1204 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1206 return scm_from_long (FIELD_BITPOS (*field
));
1209 /* (field-artificial? <gdb:field>) -> boolean
1210 Return #t if field is artificial. */
1213 gdbscm_field_artificial_p (SCM self
)
1216 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1217 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1219 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1222 /* (field-baseclass? <gdb:field>) -> boolean
1223 Return #t if field is a baseclass. */
1226 gdbscm_field_baseclass_p (SCM self
)
1229 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1230 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1231 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1233 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1234 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1238 /* Return the type named TYPE_NAME in BLOCK.
1239 Returns NULL if not found.
1240 This routine does not throw an error. */
1242 static struct type
*
1243 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1245 struct type
*type
= NULL
;
1249 if (startswith (type_name
, "struct "))
1250 type
= lookup_struct (type_name
+ 7, NULL
);
1251 else if (startswith (type_name
, "union "))
1252 type
= lookup_union (type_name
+ 6, NULL
);
1253 else if (startswith (type_name
, "enum "))
1254 type
= lookup_enum (type_name
+ 5, NULL
);
1256 type
= lookup_typename (current_language
, get_current_arch (),
1257 type_name
, block
, 0);
1259 CATCH (except
, RETURN_MASK_ALL
)
1268 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1269 TODO: legacy template support left out until needed. */
1272 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1274 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1276 SCM block_scm
= SCM_BOOL_F
;
1277 int block_arg_pos
= -1;
1278 const struct block
*block
= NULL
;
1281 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1283 rest
, &block_arg_pos
, &block_scm
);
1285 if (block_arg_pos
!= -1)
1289 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1294 gdbscm_throw (exception
);
1297 type
= tyscm_lookup_typename (name
, block
);
1301 return tyscm_scm_from_type (type
);
1305 /* Initialize the Scheme type code. */
1308 static const scheme_integer_constant type_integer_constants
[] =
1310 #define X(SYM) { #SYM, SYM }
1311 X (TYPE_CODE_BITSTRING
),
1313 X (TYPE_CODE_ARRAY
),
1314 X (TYPE_CODE_STRUCT
),
1315 X (TYPE_CODE_UNION
),
1317 X (TYPE_CODE_FLAGS
),
1323 X (TYPE_CODE_RANGE
),
1324 X (TYPE_CODE_STRING
),
1325 X (TYPE_CODE_ERROR
),
1326 X (TYPE_CODE_METHOD
),
1327 X (TYPE_CODE_METHODPTR
),
1328 X (TYPE_CODE_MEMBERPTR
),
1332 X (TYPE_CODE_COMPLEX
),
1333 X (TYPE_CODE_TYPEDEF
),
1334 X (TYPE_CODE_NAMESPACE
),
1335 X (TYPE_CODE_DECFLOAT
),
1336 X (TYPE_CODE_INTERNAL_FUNCTION
),
1339 END_INTEGER_CONSTANTS
1342 static const scheme_function type_functions
[] =
1344 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1346 Return #t if the object is a <gdb:type> object." },
1348 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1350 Return the <gdb:type> object representing string or #f if not found.\n\
1351 If block is given then the type is looked for in that block.\n\
1353 Arguments: string [#:block <gdb:block>]" },
1355 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1357 Return the code of the type" },
1359 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1361 Return the tag name of the type, or #f if there isn't one." },
1363 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1365 Return the name of the type as a string, or #f if there isn't one." },
1367 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1369 Return the print name of the type as a string." },
1371 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1373 Return the size of the type, in bytes." },
1375 { "type-strip-typedefs", 1, 0, 0,
1376 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1378 Return a type formed by stripping the type of all typedefs." },
1380 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1382 Return a type representing an array of objects of the type.\n\
1384 Arguments: <gdb:type> [low-bound] high-bound\n\
1385 If low-bound is not provided zero is used.\n\
1386 N.B. If only the high-bound parameter is specified, it is not\n\
1388 Valid bounds for array indices are [low-bound,high-bound]." },
1390 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1392 Return a type representing a vector of objects of the type.\n\
1393 Vectors differ from arrays in that if the current language has C-style\n\
1394 arrays, vectors don't decay to a pointer to the first element.\n\
1395 They are first class values.\n\
1397 Arguments: <gdb:type> [low-bound] high-bound\n\
1398 If low-bound is not provided zero is used.\n\
1399 N.B. If only the high-bound parameter is specified, it is not\n\
1401 Valid bounds for array indices are [low-bound,high-bound]." },
1403 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1405 Return a type of pointer to the type." },
1407 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1409 Return (low high) representing the range for the type." },
1411 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1413 Return a type of reference to the type." },
1415 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1417 Return the target type of the type." },
1419 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1421 Return a const variant of the type." },
1423 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1425 Return a volatile variant of the type." },
1427 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1429 Return a variant of the type without const or volatile attributes." },
1431 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1433 Return the number of fields of the type." },
1435 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1437 Return the list of <gdb:field> objects of fields of the type." },
1439 { "make-field-iterator", 1, 0, 0,
1440 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1442 Return a <gdb:iterator> object for iterating over the fields of the type." },
1444 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1446 Return the field named by string of the type.\n\
1448 Arguments: <gdb:type> string" },
1450 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1452 Return #t if the type has field named string.\n\
1454 Arguments: <gdb:type> string" },
1456 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1458 Return #t if the object is a <gdb:field> object." },
1460 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1462 Return the name of the field." },
1464 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1466 Return the type of the field." },
1468 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1470 Return the enum value represented by the field." },
1472 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1474 Return the offset in bits of the field in its containing type." },
1476 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1478 Return the size of the field in bits." },
1480 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1482 Return #t if the field is artificial." },
1484 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1486 Return #t if the field is a baseclass." },
1492 gdbscm_initialize_types (void)
1494 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1495 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1496 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1497 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1499 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1500 sizeof (field_smob
));
1501 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1503 gdbscm_define_integer_constants (type_integer_constants
, 1);
1504 gdbscm_define_functions (type_functions
, 1);
1506 /* This function is "private". */
1507 tyscm_next_field_x_proc
1508 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1509 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1510 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1511 gdbscm_documentation_symbol
,
1512 gdbscm_scm_from_c_string ("\
1513 Internal function to assist the type fields iterator."));
1515 block_keyword
= scm_from_latin1_keyword ("block");
1517 /* Register an objfile "free" callback so we can properly copy types
1518 associated with the objfile when it's about to be deleted. */
1519 tyscm_objfile_data_key
1520 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1522 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1523 tyscm_eq_type_smob
);