1 /* Scheme interface to types.
3 Copyright (C) 2008-2017 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
24 #include "arch-utils.h"
31 #include "dwarf2loc.h"
32 #include "typeprint.h"
33 #include "guile-internal.h"
35 /* The <gdb:type> smob.
36 The type is chained with all types associated with its objfile, if any.
37 This lets us copy the underlying struct type when the objfile is
39 The typedef for this struct is in guile-internal.h. */
43 /* This always appears first.
44 eqable_gdb_smob is used so that types are eq?-able.
45 Also, a type object can be associated with an objfile. eqable_gdb_smob
46 lets us track the lifetime of all types associated with an objfile.
47 When an objfile is deleted we need to invalidate the type object. */
50 /* The GDB type structure this smob is wrapping. */
58 /* This always appears first. */
61 /* Backlink to the containing <gdb:type> object. */
64 /* The field number in TYPE_SCM. */
68 static const char type_smob_name
[] = "gdb:type";
69 static const char field_smob_name
[] = "gdb:field";
71 static const char not_composite_error
[] =
72 N_("type is not a structure, union, or enum type");
74 /* The tag Guile knows the type smob by. */
75 static scm_t_bits type_smob_tag
;
77 /* The tag Guile knows the field smob by. */
78 static scm_t_bits field_smob_tag
;
80 /* The "next" procedure for field iterators. */
81 static SCM tyscm_next_field_x_proc
;
83 /* Keywords used in argument passing. */
84 static SCM block_keyword
;
86 static const struct objfile_data
*tyscm_objfile_data_key
;
88 /* Hash table to uniquify global (non-objfile-owned) types. */
89 static htab_t global_types_map
;
91 static struct type
*tyscm_get_composite (struct type
*type
);
93 /* Return the type field of T_SMOB.
94 This exists so that we don't have to export the struct's contents. */
97 tyscm_type_smob_type (type_smob
*t_smob
)
102 /* Return the name of TYPE in expanded form. If there's an error
103 computing the name, throws the gdb exception with scm_throw. */
106 tyscm_type_name (struct type
*type
)
110 struct cleanup
*old_chain
;
113 stb
= mem_fileopen ();
114 old_chain
= make_cleanup_ui_file_delete (stb
);
116 LA_PRINT_TYPE (type
, "", stb
, -1, 0, &type_print_raw_options
);
118 std::string name
= ui_file_as_string (stb
);
119 do_cleanups (old_chain
);
123 CATCH (except
, RETURN_MASK_ALL
)
125 SCM excp
= gdbscm_scm_from_gdb_exception (except
);
130 gdb_assert_not_reached ("no way to get here");
133 /* Administrivia for type smobs. */
135 /* Helper function to hash a type_smob. */
138 tyscm_hash_type_smob (const void *p
)
140 const type_smob
*t_smob
= (const type_smob
*) p
;
142 return htab_hash_pointer (t_smob
->type
);
145 /* Helper function to compute equality of type_smobs. */
148 tyscm_eq_type_smob (const void *ap
, const void *bp
)
150 const type_smob
*a
= (const type_smob
*) ap
;
151 const type_smob
*b
= (const type_smob
*) bp
;
153 return (a
->type
== b
->type
157 /* Return the struct type pointer -> SCM mapping table.
158 If type is owned by an objfile, the mapping table is created if necessary.
159 Otherwise, type is not owned by an objfile, and we use
163 tyscm_type_map (struct type
*type
)
165 struct objfile
*objfile
= TYPE_OBJFILE (type
);
169 return global_types_map
;
171 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
174 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
176 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
182 /* The smob "free" function for <gdb:type>. */
185 tyscm_free_type_smob (SCM self
)
187 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
189 if (t_smob
->type
!= NULL
)
191 htab_t htab
= tyscm_type_map (t_smob
->type
);
193 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
196 /* Not necessary, done to catch bugs. */
202 /* The smob "print" function for <gdb:type>. */
205 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
207 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
208 std::string name
= tyscm_type_name (t_smob
->type
);
210 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
211 invoked by write/~S. What to do here may need to evolve.
212 IWBN if we could pass an argument to format that would we could use
213 instead of writingp. */
214 if (pstate
->writingp
)
215 gdbscm_printf (port
, "#<%s ", type_smob_name
);
217 scm_puts (name
.c_str (), port
);
219 if (pstate
->writingp
)
220 scm_puts (">", port
);
222 scm_remember_upto_here_1 (self
);
224 /* Non-zero means success. */
228 /* The smob "equal?" function for <gdb:type>. */
231 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
233 type_smob
*type1_smob
, *type2_smob
;
234 struct type
*type1
, *type2
;
237 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
239 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
241 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
242 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
243 type1
= type1_smob
->type
;
244 type2
= type2_smob
->type
;
248 result
= types_deeply_equal (type1
, type2
);
250 CATCH (except
, RETURN_MASK_ALL
)
252 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
256 return scm_from_bool (result
);
259 /* Low level routine to create a <gdb:type> object. */
262 tyscm_make_type_smob (void)
264 type_smob
*t_smob
= (type_smob
*)
265 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
268 /* This must be filled in by the caller. */
271 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
272 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
277 /* Return non-zero if SCM is a <gdb:type> object. */
280 tyscm_is_type (SCM self
)
282 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
285 /* (type? object) -> boolean */
288 gdbscm_type_p (SCM self
)
290 return scm_from_bool (tyscm_is_type (self
));
293 /* Return the existing object that encapsulates TYPE, or create a new
294 <gdb:type> object. */
297 tyscm_scm_from_type (struct type
*type
)
300 eqable_gdb_smob
**slot
;
301 type_smob
*t_smob
, t_smob_for_lookup
;
304 /* If we've already created a gsmob for this type, return it.
305 This makes types eq?-able. */
306 htab
= tyscm_type_map (type
);
307 t_smob_for_lookup
.type
= type
;
308 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
310 return (*slot
)->containing_scm
;
312 t_scm
= tyscm_make_type_smob ();
313 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
315 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
320 /* Returns the <gdb:type> object in SELF.
321 Throws an exception if SELF is not a <gdb:type> object. */
324 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
326 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
332 /* Returns a pointer to the type smob of SELF.
333 Throws an exception if SELF is not a <gdb:type> object. */
336 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
338 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
339 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
344 /* Helper function for save_objfile_types to make a deep copy of the type. */
347 tyscm_copy_type_recursive (void **slot
, void *info
)
349 type_smob
*t_smob
= (type_smob
*) *slot
;
350 htab_t copied_types
= (htab_t
) info
;
351 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
353 eqable_gdb_smob
**new_slot
;
354 type_smob t_smob_for_lookup
;
356 gdb_assert (objfile
!= NULL
);
358 htab_empty (copied_types
);
359 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
361 /* The eq?-hashtab that the type lived in is going away.
362 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
363 garbage collected we'll assert-fail if the type isn't in the hashtab.
366 Types now live in "arch space", and things like "char" that came from
367 the objfile *could* be considered eq? with the arch "char" type.
368 However, they weren't before the objfile got deleted, so making them
369 eq? now is debatable. */
370 htab
= tyscm_type_map (t_smob
->type
);
371 t_smob_for_lookup
.type
= t_smob
->type
;
372 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
373 gdb_assert (*new_slot
== NULL
);
374 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
379 /* Called when OBJFILE is about to be deleted.
380 Make a copy of all types associated with OBJFILE. */
383 save_objfile_types (struct objfile
*objfile
, void *datum
)
385 htab_t htab
= (htab_t
) datum
;
388 if (!gdb_scheme_initialized
)
391 copied_types
= create_copied_types_hash (objfile
);
395 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
399 htab_delete (copied_types
);
402 /* Administrivia for field smobs. */
404 /* The smob "print" function for <gdb:field>. */
407 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
409 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
411 gdbscm_printf (port
, "#<%s ", field_smob_name
);
412 scm_write (f_smob
->type_scm
, port
);
413 gdbscm_printf (port
, " %d", f_smob
->field_num
);
414 scm_puts (">", port
);
416 scm_remember_upto_here_1 (self
);
418 /* Non-zero means success. */
422 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
426 tyscm_make_field_smob (SCM type_scm
, int field_num
)
428 field_smob
*f_smob
= (field_smob
*)
429 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
432 f_smob
->type_scm
= type_scm
;
433 f_smob
->field_num
= field_num
;
434 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
435 gdbscm_init_gsmob (&f_smob
->base
);
440 /* Return non-zero if SCM is a <gdb:field> object. */
443 tyscm_is_field (SCM self
)
445 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
448 /* (field? object) -> boolean */
451 gdbscm_field_p (SCM self
)
453 return scm_from_bool (tyscm_is_field (self
));
456 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
460 tyscm_scm_from_field (SCM type_scm
, int field_num
)
462 return tyscm_make_field_smob (type_scm
, field_num
);
465 /* Returns the <gdb:field> object in SELF.
466 Throws an exception if SELF is not a <gdb:field> object. */
469 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
471 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
477 /* Returns a pointer to the field smob of SELF.
478 Throws an exception if SELF is not a <gdb:field> object. */
481 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
483 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
484 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
489 /* Returns a pointer to the type struct in F_SMOB
490 (the type the field is in). */
493 tyscm_field_smob_containing_type (field_smob
*f_smob
)
497 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
498 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
503 /* Returns a pointer to the field struct of F_SMOB. */
505 static struct field
*
506 tyscm_field_smob_to_field (field_smob
*f_smob
)
508 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
510 /* This should be non-NULL by construction. */
511 gdb_assert (TYPE_FIELDS (type
) != NULL
);
513 return &TYPE_FIELD (type
, f_smob
->field_num
);
516 /* Type smob accessors. */
518 /* (type-code <gdb:type>) -> integer
519 Return the code for this type. */
522 gdbscm_type_code (SCM self
)
525 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
526 struct type
*type
= t_smob
->type
;
528 return scm_from_int (TYPE_CODE (type
));
531 /* (type-fields <gdb:type>) -> list
532 Return a list of all fields. Each element is a <gdb:field> object.
533 This also supports arrays, we return a field list of one element,
537 gdbscm_type_fields (SCM self
)
540 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
541 struct type
*type
= t_smob
->type
;
542 struct type
*containing_type
;
543 SCM containing_type_scm
, result
;
546 containing_type
= tyscm_get_composite (type
);
547 if (containing_type
== NULL
)
548 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
549 _(not_composite_error
));
551 /* If SELF is a typedef or reference, we want the underlying type,
552 which is what tyscm_get_composite returns. */
553 if (containing_type
== type
)
554 containing_type_scm
= self
;
556 containing_type_scm
= tyscm_scm_from_type (containing_type
);
559 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
560 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
562 return scm_reverse_x (result
, SCM_EOL
);
565 /* (type-tag <gdb:type>) -> string
566 Return the type's tag, or #f. */
569 gdbscm_type_tag (SCM self
)
572 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
573 struct type
*type
= t_smob
->type
;
575 if (!TYPE_TAG_NAME (type
))
577 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
580 /* (type-name <gdb:type>) -> string
581 Return the type's name, or #f. */
584 gdbscm_type_name (SCM self
)
587 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
588 struct type
*type
= t_smob
->type
;
590 if (!TYPE_NAME (type
))
592 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
595 /* (type-print-name <gdb:type>) -> string
596 Return the print name of type.
597 TODO: template support elided for now. */
600 gdbscm_type_print_name (SCM self
)
603 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
604 struct type
*type
= t_smob
->type
;
605 std::string thetype
= tyscm_type_name (type
);
606 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
611 /* (type-sizeof <gdb:type>) -> integer
612 Return the size of the type represented by SELF, in bytes. */
615 gdbscm_type_sizeof (SCM self
)
618 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
619 struct type
*type
= t_smob
->type
;
623 check_typedef (type
);
625 CATCH (except
, RETURN_MASK_ALL
)
630 /* Ignore exceptions. */
632 return scm_from_long (TYPE_LENGTH (type
));
635 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
636 Return the type, stripped of typedefs. */
639 gdbscm_type_strip_typedefs (SCM self
)
642 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
643 struct type
*type
= t_smob
->type
;
647 type
= check_typedef (type
);
649 CATCH (except
, RETURN_MASK_ALL
)
651 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
655 return tyscm_scm_from_type (type
);
658 /* Strip typedefs and pointers/reference from a type. Then check that
659 it is a struct, union, or enum type. If not, return NULL. */
662 tyscm_get_composite (struct type
*type
)
669 type
= check_typedef (type
);
671 CATCH (except
, RETURN_MASK_ALL
)
673 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
677 if (TYPE_CODE (type
) != TYPE_CODE_PTR
678 && TYPE_CODE (type
) != TYPE_CODE_REF
)
680 type
= TYPE_TARGET_TYPE (type
);
683 /* If this is not a struct, union, or enum type, raise TypeError
685 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
686 && TYPE_CODE (type
) != TYPE_CODE_UNION
687 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
693 /* Helper for tyscm_array and tyscm_vector. */
696 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
697 const char *func_name
)
700 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
701 struct type
*type
= t_smob
->type
;
703 struct type
*array
= NULL
;
705 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
706 n1_scm
, &n1
, n2_scm
, &n2
);
708 if (SCM_UNBNDP (n2_scm
))
714 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
716 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
717 scm_cons (scm_from_long (n1
),
719 _("Array length must not be negative"));
724 array
= lookup_array_range_type (type
, n1
, n2
);
726 make_vector_type (array
);
728 CATCH (except
, RETURN_MASK_ALL
)
730 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
734 return tyscm_scm_from_type (array
);
737 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
738 The array has indices [low-bound,high-bound].
739 If low-bound is not provided zero is used.
740 Return an array type.
742 IWBN if the one argument version specified a size, not the high bound.
743 It's too easy to pass one argument thinking it is the size of the array.
744 The current semantics are for compatibility with the Python version.
745 Later we can add #:size. */
748 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
750 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
753 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
754 The array has indices [low-bound,high-bound].
755 If low-bound is not provided zero is used.
756 Return a vector type.
758 IWBN if the one argument version specified a size, not the high bound.
759 It's too easy to pass one argument thinking it is the size of the array.
760 The current semantics are for compatibility with the Python version.
761 Later we can add #:size. */
764 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
766 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
769 /* (type-pointer <gdb:type>) -> <gdb:type>
770 Return a <gdb:type> object which represents a pointer to SELF. */
773 gdbscm_type_pointer (SCM self
)
776 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
777 struct type
*type
= t_smob
->type
;
781 type
= lookup_pointer_type (type
);
783 CATCH (except
, RETURN_MASK_ALL
)
785 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
789 return tyscm_scm_from_type (type
);
792 /* (type-range <gdb:type>) -> (low high)
793 Return the range of a type represented by SELF. The return type is
794 a list. The first element is the low bound, and the second element
795 is the high bound. */
798 gdbscm_type_range (SCM self
)
801 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
802 struct type
*type
= t_smob
->type
;
803 SCM low_scm
, high_scm
;
804 /* Initialize these to appease GCC warnings. */
805 LONGEST low
= 0, high
= 0;
807 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
808 || TYPE_CODE (type
) == TYPE_CODE_STRING
809 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
810 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
812 switch (TYPE_CODE (type
))
814 case TYPE_CODE_ARRAY
:
815 case TYPE_CODE_STRING
:
816 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
817 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
819 case TYPE_CODE_RANGE
:
820 low
= TYPE_LOW_BOUND (type
);
821 high
= TYPE_HIGH_BOUND (type
);
825 low_scm
= gdbscm_scm_from_longest (low
);
826 high_scm
= gdbscm_scm_from_longest (high
);
828 return scm_list_2 (low_scm
, high_scm
);
831 /* (type-reference <gdb:type>) -> <gdb:type>
832 Return a <gdb:type> object which represents a reference to SELF. */
835 gdbscm_type_reference (SCM self
)
838 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
839 struct type
*type
= t_smob
->type
;
843 type
= lookup_reference_type (type
);
845 CATCH (except
, RETURN_MASK_ALL
)
847 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
851 return tyscm_scm_from_type (type
);
854 /* (type-target <gdb:type>) -> <gdb:type>
855 Return a <gdb:type> object which represents the target type of SELF. */
858 gdbscm_type_target (SCM self
)
861 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
862 struct type
*type
= t_smob
->type
;
864 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
866 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
869 /* (type-const <gdb:type>) -> <gdb:type>
870 Return a const-qualified type variant. */
873 gdbscm_type_const (SCM self
)
876 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
877 struct type
*type
= t_smob
->type
;
881 type
= make_cv_type (1, 0, type
, NULL
);
883 CATCH (except
, RETURN_MASK_ALL
)
885 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
889 return tyscm_scm_from_type (type
);
892 /* (type-volatile <gdb:type>) -> <gdb:type>
893 Return a volatile-qualified type variant. */
896 gdbscm_type_volatile (SCM self
)
899 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
900 struct type
*type
= t_smob
->type
;
904 type
= make_cv_type (0, 1, type
, NULL
);
906 CATCH (except
, RETURN_MASK_ALL
)
908 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
912 return tyscm_scm_from_type (type
);
915 /* (type-unqualified <gdb:type>) -> <gdb:type>
916 Return an unqualified type variant. */
919 gdbscm_type_unqualified (SCM self
)
922 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
923 struct type
*type
= t_smob
->type
;
927 type
= make_cv_type (0, 0, type
, NULL
);
929 CATCH (except
, RETURN_MASK_ALL
)
931 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
935 return tyscm_scm_from_type (type
);
938 /* Field related accessors of types. */
940 /* (type-num-fields <gdb:type>) -> integer
941 Return number of fields. */
944 gdbscm_type_num_fields (SCM self
)
947 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
948 struct type
*type
= t_smob
->type
;
950 type
= tyscm_get_composite (type
);
952 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
953 _(not_composite_error
));
955 return scm_from_long (TYPE_NFIELDS (type
));
958 /* (type-field <gdb:type> string) -> <gdb:field>
959 Return the <gdb:field> object for the field named by the argument. */
962 gdbscm_type_field (SCM self
, SCM field_scm
)
965 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
966 struct type
*type
= t_smob
->type
;
969 struct cleanup
*cleanups
;
971 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
974 /* We want just fields of this type, not of base types, so instead of
975 using lookup_struct_elt_type, portions of that function are
978 type
= tyscm_get_composite (type
);
980 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
981 _(not_composite_error
));
983 field
= gdbscm_scm_to_c_string (field_scm
);
984 cleanups
= make_cleanup (xfree
, field
);
986 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
988 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
990 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
992 do_cleanups (cleanups
);
993 return tyscm_make_field_smob (self
, i
);
997 do_cleanups (cleanups
);
999 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1000 _("Unknown field"));
1003 /* (type-has-field? <gdb:type> string) -> boolean
1004 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1007 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1010 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1011 struct type
*type
= t_smob
->type
;
1014 struct cleanup
*cleanups
;
1016 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1019 /* We want just fields of this type, not of base types, so instead of
1020 using lookup_struct_elt_type, portions of that function are
1023 type
= tyscm_get_composite (type
);
1025 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1026 _(not_composite_error
));
1028 field
= gdbscm_scm_to_c_string (field_scm
);
1029 cleanups
= make_cleanup (xfree
, field
);
1031 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1033 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1035 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1037 do_cleanups (cleanups
);
1042 do_cleanups (cleanups
);
1047 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1048 Make a field iterator object. */
1051 gdbscm_make_field_iterator (SCM self
)
1054 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1055 struct type
*type
= t_smob
->type
;
1056 struct type
*containing_type
;
1057 SCM containing_type_scm
;
1059 containing_type
= tyscm_get_composite (type
);
1060 if (containing_type
== NULL
)
1061 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1062 _(not_composite_error
));
1064 /* If SELF is a typedef or reference, we want the underlying type,
1065 which is what tyscm_get_composite returns. */
1066 if (containing_type
== type
)
1067 containing_type_scm
= self
;
1069 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1071 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1072 tyscm_next_field_x_proc
);
1075 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1076 Return the next field in the iteration through the list of fields of the
1077 type, or (end-of-iteration).
1078 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1079 This is the next! <gdb:iterator> function, not exported to the user. */
1082 gdbscm_type_next_field_x (SCM self
)
1084 iterator_smob
*i_smob
;
1087 SCM it_scm
, result
, progress
, object
;
1090 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1091 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1092 object
= itscm_iterator_smob_object (i_smob
);
1093 progress
= itscm_iterator_smob_progress (i_smob
);
1095 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1096 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1097 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1098 type
= t_smob
->type
;
1100 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1101 0, TYPE_NFIELDS (type
)),
1102 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1103 field
= scm_to_int (progress
);
1105 if (field
< TYPE_NFIELDS (type
))
1107 result
= tyscm_make_field_smob (object
, field
);
1108 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1112 return gdbscm_end_of_iteration ();
1115 /* Field smob accessors. */
1117 /* (field-name <gdb:field>) -> string
1118 Return the name of this field or #f if there isn't one. */
1121 gdbscm_field_name (SCM self
)
1124 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1125 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1127 if (FIELD_NAME (*field
))
1128 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1132 /* (field-type <gdb:field>) -> <gdb:type>
1133 Return the <gdb:type> object of the field or #f if there isn't one. */
1136 gdbscm_field_type (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
);
1142 /* A field can have a NULL type in some situations. */
1143 if (FIELD_TYPE (*field
))
1144 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1148 /* (field-enumval <gdb:field>) -> integer
1149 For enum values, return its value as an integer. */
1152 gdbscm_field_enumval (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
, _("enum type"));
1162 return scm_from_long (FIELD_ENUMVAL (*field
));
1165 /* (field-bitpos <gdb:field>) -> integer
1166 For bitfields, return its offset in bits. */
1169 gdbscm_field_bitpos (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
);
1174 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1176 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1177 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1179 return scm_from_long (FIELD_BITPOS (*field
));
1182 /* (field-bitsize <gdb:field>) -> integer
1183 Return the size of the field in bits. */
1186 gdbscm_field_bitsize (SCM self
)
1189 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1190 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1192 return scm_from_long (FIELD_BITPOS (*field
));
1195 /* (field-artificial? <gdb:field>) -> boolean
1196 Return #t if field is artificial. */
1199 gdbscm_field_artificial_p (SCM self
)
1202 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1203 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1205 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1208 /* (field-baseclass? <gdb:field>) -> boolean
1209 Return #t if field is a baseclass. */
1212 gdbscm_field_baseclass_p (SCM self
)
1215 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1216 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1217 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1219 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1220 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1224 /* Return the type named TYPE_NAME in BLOCK.
1225 Returns NULL if not found.
1226 This routine does not throw an error. */
1228 static struct type
*
1229 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1231 struct type
*type
= NULL
;
1235 if (startswith (type_name
, "struct "))
1236 type
= lookup_struct (type_name
+ 7, NULL
);
1237 else if (startswith (type_name
, "union "))
1238 type
= lookup_union (type_name
+ 6, NULL
);
1239 else if (startswith (type_name
, "enum "))
1240 type
= lookup_enum (type_name
+ 5, NULL
);
1242 type
= lookup_typename (current_language
, get_current_arch (),
1243 type_name
, block
, 0);
1245 CATCH (except
, RETURN_MASK_ALL
)
1254 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1255 TODO: legacy template support left out until needed. */
1258 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1260 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1262 SCM block_scm
= SCM_BOOL_F
;
1263 int block_arg_pos
= -1;
1264 const struct block
*block
= NULL
;
1267 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1269 rest
, &block_arg_pos
, &block_scm
);
1271 if (block_arg_pos
!= -1)
1275 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1280 gdbscm_throw (exception
);
1283 type
= tyscm_lookup_typename (name
, block
);
1287 return tyscm_scm_from_type (type
);
1291 /* Initialize the Scheme type code. */
1294 static const scheme_integer_constant type_integer_constants
[] =
1296 #define X(SYM) { #SYM, SYM }
1297 X (TYPE_CODE_BITSTRING
),
1299 X (TYPE_CODE_ARRAY
),
1300 X (TYPE_CODE_STRUCT
),
1301 X (TYPE_CODE_UNION
),
1303 X (TYPE_CODE_FLAGS
),
1309 X (TYPE_CODE_RANGE
),
1310 X (TYPE_CODE_STRING
),
1311 X (TYPE_CODE_ERROR
),
1312 X (TYPE_CODE_METHOD
),
1313 X (TYPE_CODE_METHODPTR
),
1314 X (TYPE_CODE_MEMBERPTR
),
1318 X (TYPE_CODE_COMPLEX
),
1319 X (TYPE_CODE_TYPEDEF
),
1320 X (TYPE_CODE_NAMESPACE
),
1321 X (TYPE_CODE_DECFLOAT
),
1322 X (TYPE_CODE_INTERNAL_FUNCTION
),
1325 END_INTEGER_CONSTANTS
1328 static const scheme_function type_functions
[] =
1330 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1332 Return #t if the object is a <gdb:type> object." },
1334 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1336 Return the <gdb:type> object representing string or #f if not found.\n\
1337 If block is given then the type is looked for in that block.\n\
1339 Arguments: string [#:block <gdb:block>]" },
1341 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1343 Return the code of the type" },
1345 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1347 Return the tag name of the type, or #f if there isn't one." },
1349 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1351 Return the name of the type as a string, or #f if there isn't one." },
1353 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1355 Return the print name of the type as a string." },
1357 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1359 Return the size of the type, in bytes." },
1361 { "type-strip-typedefs", 1, 0, 0,
1362 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1364 Return a type formed by stripping the type of all typedefs." },
1366 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1368 Return a type representing an array of objects of the type.\n\
1370 Arguments: <gdb:type> [low-bound] high-bound\n\
1371 If low-bound is not provided zero is used.\n\
1372 N.B. If only the high-bound parameter is specified, it is not\n\
1374 Valid bounds for array indices are [low-bound,high-bound]." },
1376 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1378 Return a type representing a vector of objects of the type.\n\
1379 Vectors differ from arrays in that if the current language has C-style\n\
1380 arrays, vectors don't decay to a pointer to the first element.\n\
1381 They are first class values.\n\
1383 Arguments: <gdb:type> [low-bound] high-bound\n\
1384 If low-bound is not provided zero is used.\n\
1385 N.B. If only the high-bound parameter is specified, it is not\n\
1387 Valid bounds for array indices are [low-bound,high-bound]." },
1389 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1391 Return a type of pointer to the type." },
1393 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1395 Return (low high) representing the range for the type." },
1397 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1399 Return a type of reference to the type." },
1401 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1403 Return the target type of the type." },
1405 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1407 Return a const variant of the type." },
1409 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1411 Return a volatile variant of the type." },
1413 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1415 Return a variant of the type without const or volatile attributes." },
1417 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1419 Return the number of fields of the type." },
1421 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1423 Return the list of <gdb:field> objects of fields of the type." },
1425 { "make-field-iterator", 1, 0, 0,
1426 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1428 Return a <gdb:iterator> object for iterating over the fields of the type." },
1430 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1432 Return the field named by string of the type.\n\
1434 Arguments: <gdb:type> string" },
1436 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1438 Return #t if the type has field named string.\n\
1440 Arguments: <gdb:type> string" },
1442 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1444 Return #t if the object is a <gdb:field> object." },
1446 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1448 Return the name of the field." },
1450 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1452 Return the type of the field." },
1454 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1456 Return the enum value represented by the field." },
1458 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1460 Return the offset in bits of the field in its containing type." },
1462 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1464 Return the size of the field in bits." },
1466 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1468 Return #t if the field is artificial." },
1470 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1472 Return #t if the field is a baseclass." },
1478 gdbscm_initialize_types (void)
1480 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1481 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1482 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1483 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1485 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1486 sizeof (field_smob
));
1487 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1489 gdbscm_define_integer_constants (type_integer_constants
, 1);
1490 gdbscm_define_functions (type_functions
, 1);
1492 /* This function is "private". */
1493 tyscm_next_field_x_proc
1494 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1495 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1496 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1497 gdbscm_documentation_symbol
,
1498 gdbscm_scm_from_c_string ("\
1499 Internal function to assist the type fields iterator."));
1501 block_keyword
= scm_from_latin1_keyword ("block");
1503 /* Register an objfile "free" callback so we can properly copy types
1504 associated with the objfile when it's about to be deleted. */
1505 tyscm_objfile_data_key
1506 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1508 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1509 tyscm_eq_type_smob
);