1 /* Scheme interface to types.
3 Copyright (C) 2008-2019 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"
29 #include "common/vec.h"
31 #include "dwarf2loc.h"
32 #include "typeprint.h"
33 #include "guile-internal.h"
35 /* The <gdb:type> smob.
36 The type is chained with all types associated with its objfile, if any.
37 This lets us copy the underlying struct type when the objfile is
39 The typedef for this struct is in guile-internal.h. */
43 /* This always appears first.
44 eqable_gdb_smob is used so that types are eq?-able.
45 Also, a type object can be associated with an objfile. eqable_gdb_smob
46 lets us track the lifetime of all types associated with an objfile.
47 When an objfile is deleted we need to invalidate the type object. */
50 /* The GDB type structure this smob is wrapping. */
58 /* This always appears first. */
61 /* Backlink to the containing <gdb:type> object. */
64 /* The field number in TYPE_SCM. */
68 static const char type_smob_name[] = "gdb:type";
69 static const char field_smob_name[] = "gdb:field";
71 static const char not_composite_error[] =
72 N_("type is not a structure, union, or enum type");
74 /* The tag Guile knows the type smob by. */
75 static scm_t_bits type_smob_tag;
77 /* The tag Guile knows the field smob by. */
78 static scm_t_bits field_smob_tag;
80 /* The "next" procedure for field iterators. */
81 static SCM tyscm_next_field_x_proc;
83 /* Keywords used in argument passing. */
84 static SCM block_keyword;
86 static const struct objfile_data *tyscm_objfile_data_key;
88 /* Hash table to uniquify global (non-objfile-owned) types. */
89 static htab_t global_types_map;
91 static struct type *tyscm_get_composite (struct type *type);
93 /* Return the type field of T_SMOB.
94 This exists so that we don't have to export the struct's contents. */
97 tyscm_type_smob_type (type_smob *t_smob)
102 /* Return the name of TYPE in expanded form. If there's an error
103 computing the name, throws the gdb exception with scm_throw. */
106 tyscm_type_name (struct type *type)
112 LA_PRINT_TYPE (type, "", &stb, -1, 0, &type_print_raw_options);
113 return std::move (stb.string ());
115 CATCH (except, RETURN_MASK_ALL)
117 SCM excp = gdbscm_scm_from_gdb_exception (except);
122 gdb_assert_not_reached ("no way to get here");
125 /* Administrivia for type smobs. */
127 /* Helper function to hash a type_smob. */
130 tyscm_hash_type_smob (const void *p)
132 const type_smob *t_smob = (const type_smob *) p;
134 return htab_hash_pointer (t_smob->type);
137 /* Helper function to compute equality of type_smobs. */
140 tyscm_eq_type_smob (const void *ap, const void *bp)
142 const type_smob *a = (const type_smob *) ap;
143 const type_smob *b = (const type_smob *) bp;
145 return (a->type == b->type
149 /* Return the struct type pointer -> SCM mapping table.
150 If type is owned by an objfile, the mapping table is created if necessary.
151 Otherwise, type is not owned by an objfile, and we use
155 tyscm_type_map (struct type *type)
157 struct objfile *objfile = TYPE_OBJFILE (type);
161 return global_types_map;
163 htab = (htab_t) objfile_data (objfile, tyscm_objfile_data_key);
166 htab = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
168 set_objfile_data (objfile, tyscm_objfile_data_key, htab);
174 /* The smob "free" function for <gdb:type>. */
177 tyscm_free_type_smob (SCM self)
179 type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
181 if (t_smob->type != NULL)
183 htab_t htab = tyscm_type_map (t_smob->type);
185 gdbscm_clear_eqable_gsmob_ptr_slot (htab, &t_smob->base);
188 /* Not necessary, done to catch bugs. */
194 /* The smob "print" function for <gdb:type>. */
197 tyscm_print_type_smob (SCM self, SCM port, scm_print_state *pstate)
199 type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
200 std::string name = tyscm_type_name (t_smob->type);
202 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
203 invoked by write/~S. What to do here may need to evolve.
204 IWBN if we could pass an argument to format that would we could use
205 instead of writingp. */
206 if (pstate->writingp)
207 gdbscm_printf (port, "#<%s ", type_smob_name);
209 scm_puts (name.c_str (), port);
211 if (pstate->writingp)
212 scm_puts (">", port);
214 scm_remember_upto_here_1 (self);
216 /* Non-zero means success. */
220 /* The smob "equal?" function for <gdb:type>. */
223 tyscm_equal_p_type_smob (SCM type1_scm, SCM type2_scm)
225 type_smob *type1_smob, *type2_smob;
226 struct type *type1, *type2;
229 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm), type1_scm, SCM_ARG1, FUNC_NAME,
231 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm), type2_scm, SCM_ARG2, FUNC_NAME,
233 type1_smob = (type_smob *) SCM_SMOB_DATA (type1_scm);
234 type2_smob = (type_smob *) SCM_SMOB_DATA (type2_scm);
235 type1 = type1_smob->type;
236 type2 = type2_smob->type;
240 result = types_deeply_equal (type1, type2);
242 CATCH (except, RETURN_MASK_ALL)
244 GDBSCM_HANDLE_GDB_EXCEPTION (except);
248 return scm_from_bool (result);
251 /* Low level routine to create a <gdb:type> object. */
254 tyscm_make_type_smob (void)
256 type_smob *t_smob = (type_smob *)
257 scm_gc_malloc (sizeof (type_smob), type_smob_name);
260 /* This must be filled in by the caller. */
263 t_scm = scm_new_smob (type_smob_tag, (scm_t_bits) t_smob);
264 gdbscm_init_eqable_gsmob (&t_smob->base, t_scm);
269 /* Return non-zero if SCM is a <gdb:type> object. */
272 tyscm_is_type (SCM self)
274 return SCM_SMOB_PREDICATE (type_smob_tag, self);
277 /* (type? object) -> boolean */
280 gdbscm_type_p (SCM self)
282 return scm_from_bool (tyscm_is_type (self));
285 /* Return the existing object that encapsulates TYPE, or create a new
286 <gdb:type> object. */
289 tyscm_scm_from_type (struct type *type)
292 eqable_gdb_smob **slot;
293 type_smob *t_smob, t_smob_for_lookup;
296 /* If we've already created a gsmob for this type, return it.
297 This makes types eq?-able. */
298 htab = tyscm_type_map (type);
299 t_smob_for_lookup.type = type;
300 slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
302 return (*slot)->containing_scm;
304 t_scm = tyscm_make_type_smob ();
305 t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
307 gdbscm_fill_eqable_gsmob_ptr_slot (slot, &t_smob->base);
312 /* Returns the <gdb:type> object in SELF.
313 Throws an exception if SELF is not a <gdb:type> object. */
316 tyscm_get_type_arg_unsafe (SCM self, int arg_pos, const char *func_name)
318 SCM_ASSERT_TYPE (tyscm_is_type (self), self, arg_pos, func_name,
324 /* Returns a pointer to the type smob of SELF.
325 Throws an exception if SELF is not a <gdb:type> object. */
328 tyscm_get_type_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
330 SCM t_scm = tyscm_get_type_arg_unsafe (self, arg_pos, func_name);
331 type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
336 /* Return the type field of T_SCM, an object of type <gdb:type>.
337 This exists so that we don't have to export the struct's contents. */
340 tyscm_scm_to_type (SCM t_scm)
344 gdb_assert (tyscm_is_type (t_scm));
345 t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
349 /* Helper function for save_objfile_types to make a deep copy of the type. */
352 tyscm_copy_type_recursive (void **slot, void *info)
354 type_smob *t_smob = (type_smob *) *slot;
355 htab_t copied_types = (htab_t) info;
356 struct objfile *objfile = TYPE_OBJFILE (t_smob->type);
358 eqable_gdb_smob **new_slot;
359 type_smob t_smob_for_lookup;
361 gdb_assert (objfile != NULL);
363 htab_empty (copied_types);
364 t_smob->type = copy_type_recursive (objfile, t_smob->type, copied_types);
366 /* The eq?-hashtab that the type lived in is going away.
367 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
368 garbage collected we'll assert-fail if the type isn't in the hashtab.
371 Types now live in "arch space", and things like "char" that came from
372 the objfile *could* be considered eq? with the arch "char" type.
373 However, they weren't before the objfile got deleted, so making them
374 eq? now is debatable. */
375 htab = tyscm_type_map (t_smob->type);
376 t_smob_for_lookup.type = t_smob->type;
377 new_slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
378 gdb_assert (*new_slot == NULL);
379 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot, &t_smob->base);
384 /* Called when OBJFILE is about to be deleted.
385 Make a copy of all types associated with OBJFILE. */
388 save_objfile_types (struct objfile *objfile, void *datum)
390 htab_t htab = (htab_t) datum;
393 if (!gdb_scheme_initialized)
396 copied_types = create_copied_types_hash (objfile);
400 htab_traverse_noresize (htab, tyscm_copy_type_recursive, copied_types);
404 htab_delete (copied_types);
407 /* Administrivia for field smobs. */
409 /* The smob "print" function for <gdb:field>. */
412 tyscm_print_field_smob (SCM self, SCM port, scm_print_state *pstate)
414 field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
416 gdbscm_printf (port, "#<%s ", field_smob_name);
417 scm_write (f_smob->type_scm, port);
418 gdbscm_printf (port, " %d", f_smob->field_num);
419 scm_puts (">", port);
421 scm_remember_upto_here_1 (self);
423 /* Non-zero means success. */
427 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
431 tyscm_make_field_smob (SCM type_scm, int field_num)
433 field_smob *f_smob = (field_smob *)
434 scm_gc_malloc (sizeof (field_smob), field_smob_name);
437 f_smob->type_scm = type_scm;
438 f_smob->field_num = field_num;
439 result = scm_new_smob (field_smob_tag, (scm_t_bits) f_smob);
440 gdbscm_init_gsmob (&f_smob->base);
445 /* Return non-zero if SCM is a <gdb:field> object. */
448 tyscm_is_field (SCM self)
450 return SCM_SMOB_PREDICATE (field_smob_tag, self);
453 /* (field? object) -> boolean */
456 gdbscm_field_p (SCM self)
458 return scm_from_bool (tyscm_is_field (self));
461 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
465 tyscm_scm_from_field (SCM type_scm, int field_num)
467 return tyscm_make_field_smob (type_scm, field_num);
470 /* Returns the <gdb:field> object in SELF.
471 Throws an exception if SELF is not a <gdb:field> object. */
474 tyscm_get_field_arg_unsafe (SCM self, int arg_pos, const char *func_name)
476 SCM_ASSERT_TYPE (tyscm_is_field (self), self, arg_pos, func_name,
482 /* Returns a pointer to the field smob of SELF.
483 Throws an exception if SELF is not a <gdb:field> object. */
486 tyscm_get_field_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
488 SCM f_scm = tyscm_get_field_arg_unsafe (self, arg_pos, func_name);
489 field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (f_scm);
494 /* Returns a pointer to the type struct in F_SMOB
495 (the type the field is in). */
498 tyscm_field_smob_containing_type (field_smob *f_smob)
502 gdb_assert (tyscm_is_type (f_smob->type_scm));
503 t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm);
508 /* Returns a pointer to the field struct of F_SMOB. */
510 static struct field *
511 tyscm_field_smob_to_field (field_smob *f_smob)
513 struct type *type = tyscm_field_smob_containing_type (f_smob);
515 /* This should be non-NULL by construction. */
516 gdb_assert (TYPE_FIELDS (type) != NULL);
518 return &TYPE_FIELD (type, f_smob->field_num);
521 /* Type smob accessors. */
523 /* (type-code <gdb:type>) -> integer
524 Return the code for this type. */
527 gdbscm_type_code (SCM self)
530 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
531 struct type *type = t_smob->type;
533 return scm_from_int (TYPE_CODE (type));
536 /* (type-fields <gdb:type>) -> list
537 Return a list of all fields. Each element is a <gdb:field> object.
538 This also supports arrays, we return a field list of one element,
542 gdbscm_type_fields (SCM self)
545 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
546 struct type *type = t_smob->type;
547 struct type *containing_type;
548 SCM containing_type_scm, result;
551 containing_type = tyscm_get_composite (type);
552 if (containing_type == NULL)
553 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
554 _(not_composite_error));
556 /* If SELF is a typedef or reference, we want the underlying type,
557 which is what tyscm_get_composite returns. */
558 if (containing_type == type)
559 containing_type_scm = self;
561 containing_type_scm = tyscm_scm_from_type (containing_type);
564 for (i = 0; i < TYPE_NFIELDS (containing_type); ++i)
565 result = scm_cons (tyscm_make_field_smob (containing_type_scm, i), result);
567 return scm_reverse_x (result, SCM_EOL);
570 /* (type-tag <gdb:type>) -> string
571 Return the type's tag, or #f. */
574 gdbscm_type_tag (SCM self)
577 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
578 struct type *type = t_smob->type;
579 const char *tagname = nullptr;
581 if (TYPE_CODE (type) == TYPE_CODE_STRUCT
582 || TYPE_CODE (type) == TYPE_CODE_UNION
583 || TYPE_CODE (type) == TYPE_CODE_ENUM)
584 tagname = TYPE_NAME (type);
586 if (tagname == nullptr)
588 return gdbscm_scm_from_c_string (tagname);
591 /* (type-name <gdb:type>) -> string
592 Return the type's name, or #f. */
595 gdbscm_type_name (SCM self)
598 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
599 struct type *type = t_smob->type;
601 if (!TYPE_NAME (type))
603 return gdbscm_scm_from_c_string (TYPE_NAME (type));
606 /* (type-print-name <gdb:type>) -> string
607 Return the print name of type.
608 TODO: template support elided for now. */
611 gdbscm_type_print_name (SCM self)
614 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
615 struct type *type = t_smob->type;
616 std::string thetype = tyscm_type_name (type);
617 SCM result = gdbscm_scm_from_c_string (thetype.c_str ());
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;
634 check_typedef (type);
636 CATCH (except, RETURN_MASK_ALL)
641 /* Ignore exceptions. */
643 return scm_from_long (TYPE_LENGTH (type));
646 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
647 Return the type, stripped of typedefs. */
650 gdbscm_type_strip_typedefs (SCM self)
653 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
654 struct type *type = t_smob->type;
658 type = check_typedef (type);
660 CATCH (except, RETURN_MASK_ALL)
662 GDBSCM_HANDLE_GDB_EXCEPTION (except);
666 return tyscm_scm_from_type (type);
669 /* Strip typedefs and pointers/reference from a type. Then check that
670 it is a struct, union, or enum type. If not, return NULL. */
673 tyscm_get_composite (struct type *type)
680 type = check_typedef (type);
682 CATCH (except, RETURN_MASK_ALL)
684 GDBSCM_HANDLE_GDB_EXCEPTION (except);
688 if (TYPE_CODE (type) != TYPE_CODE_PTR
689 && TYPE_CODE (type) != TYPE_CODE_REF)
691 type = TYPE_TARGET_TYPE (type);
694 /* If this is not a struct, union, or enum type, raise TypeError
696 if (TYPE_CODE (type) != TYPE_CODE_STRUCT
697 && TYPE_CODE (type) != TYPE_CODE_UNION
698 && TYPE_CODE (type) != TYPE_CODE_ENUM)
704 /* Helper for tyscm_array and tyscm_vector. */
707 tyscm_array_1 (SCM self, SCM n1_scm, SCM n2_scm, int is_vector,
708 const char *func_name)
711 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, func_name);
712 struct type *type = t_smob->type;
714 struct type *array = NULL;
716 gdbscm_parse_function_args (func_name, SCM_ARG2, NULL, "l|l",
717 n1_scm, &n1, n2_scm, &n2);
719 if (SCM_UNBNDP (n2_scm))
725 if (n2 < n1 - 1) /* Note: An empty array has n2 == n1 - 1. */
727 gdbscm_out_of_range_error (func_name, SCM_ARG3,
728 scm_cons (scm_from_long (n1),
730 _("Array length must not be negative"));
735 array = lookup_array_range_type (type, n1, n2);
737 make_vector_type (array);
739 CATCH (except, RETURN_MASK_ALL)
741 GDBSCM_HANDLE_GDB_EXCEPTION (except);
745 return tyscm_scm_from_type (array);
748 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
749 The array has indices [low-bound,high-bound].
750 If low-bound is not provided zero is used.
751 Return an array type.
753 IWBN if the one argument version specified a size, not the high bound.
754 It's too easy to pass one argument thinking it is the size of the array.
755 The current semantics are for compatibility with the Python version.
756 Later we can add #:size. */
759 gdbscm_type_array (SCM self, SCM n1, SCM n2)
761 return tyscm_array_1 (self, n1, n2, 0, FUNC_NAME);
764 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
765 The array has indices [low-bound,high-bound].
766 If low-bound is not provided zero is used.
767 Return a vector type.
769 IWBN if the one argument version specified a size, not the high bound.
770 It's too easy to pass one argument thinking it is the size of the array.
771 The current semantics are for compatibility with the Python version.
772 Later we can add #:size. */
775 gdbscm_type_vector (SCM self, SCM n1, SCM n2)
777 return tyscm_array_1 (self, n1, n2, 1, FUNC_NAME);
780 /* (type-pointer <gdb:type>) -> <gdb:type>
781 Return a <gdb:type> object which represents a pointer to SELF. */
784 gdbscm_type_pointer (SCM self)
787 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
788 struct type *type = t_smob->type;
792 type = lookup_pointer_type (type);
794 CATCH (except, RETURN_MASK_ALL)
796 GDBSCM_HANDLE_GDB_EXCEPTION (except);
800 return tyscm_scm_from_type (type);
803 /* (type-range <gdb:type>) -> (low high)
804 Return the range of a type represented by SELF. The return type is
805 a list. The first element is the low bound, and the second element
806 is the high bound. */
809 gdbscm_type_range (SCM self)
812 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
813 struct type *type = t_smob->type;
814 SCM low_scm, high_scm;
815 /* Initialize these to appease GCC warnings. */
816 LONGEST low = 0, high = 0;
818 SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ARRAY
819 || TYPE_CODE (type) == TYPE_CODE_STRING
820 || TYPE_CODE (type) == TYPE_CODE_RANGE,
821 self, SCM_ARG1, FUNC_NAME, _("ranged type"));
823 switch (TYPE_CODE (type))
825 case TYPE_CODE_ARRAY:
826 case TYPE_CODE_STRING:
827 low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type));
828 high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type));
830 case TYPE_CODE_RANGE:
831 low = TYPE_LOW_BOUND (type);
832 high = TYPE_HIGH_BOUND (type);
836 low_scm = gdbscm_scm_from_longest (low);
837 high_scm = gdbscm_scm_from_longest (high);
839 return scm_list_2 (low_scm, high_scm);
842 /* (type-reference <gdb:type>) -> <gdb:type>
843 Return a <gdb:type> object which represents a reference to SELF. */
846 gdbscm_type_reference (SCM self)
849 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
850 struct type *type = t_smob->type;
854 type = lookup_lvalue_reference_type (type);
856 CATCH (except, RETURN_MASK_ALL)
858 GDBSCM_HANDLE_GDB_EXCEPTION (except);
862 return tyscm_scm_from_type (type);
865 /* (type-target <gdb:type>) -> <gdb:type>
866 Return a <gdb:type> object which represents the target type of SELF. */
869 gdbscm_type_target (SCM self)
872 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
873 struct type *type = t_smob->type;
875 SCM_ASSERT (TYPE_TARGET_TYPE (type), self, SCM_ARG1, FUNC_NAME);
877 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type));
880 /* (type-const <gdb:type>) -> <gdb:type>
881 Return a const-qualified type variant. */
884 gdbscm_type_const (SCM self)
887 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
888 struct type *type = t_smob->type;
892 type = make_cv_type (1, 0, type, NULL);
894 CATCH (except, RETURN_MASK_ALL)
896 GDBSCM_HANDLE_GDB_EXCEPTION (except);
900 return tyscm_scm_from_type (type);
903 /* (type-volatile <gdb:type>) -> <gdb:type>
904 Return a volatile-qualified type variant. */
907 gdbscm_type_volatile (SCM self)
910 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
911 struct type *type = t_smob->type;
915 type = make_cv_type (0, 1, type, NULL);
917 CATCH (except, RETURN_MASK_ALL)
919 GDBSCM_HANDLE_GDB_EXCEPTION (except);
923 return tyscm_scm_from_type (type);
926 /* (type-unqualified <gdb:type>) -> <gdb:type>
927 Return an unqualified type variant. */
930 gdbscm_type_unqualified (SCM self)
933 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
934 struct type *type = t_smob->type;
938 type = make_cv_type (0, 0, type, NULL);
940 CATCH (except, RETURN_MASK_ALL)
942 GDBSCM_HANDLE_GDB_EXCEPTION (except);
946 return tyscm_scm_from_type (type);
949 /* Field related accessors of types. */
951 /* (type-num-fields <gdb:type>) -> integer
952 Return number of fields. */
955 gdbscm_type_num_fields (SCM self)
958 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
959 struct type *type = t_smob->type;
961 type = tyscm_get_composite (type);
963 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
964 _(not_composite_error));
966 return scm_from_long (TYPE_NFIELDS (type));
969 /* (type-field <gdb:type> string) -> <gdb:field>
970 Return the <gdb:field> object for the field named by the argument. */
973 gdbscm_type_field (SCM self, SCM field_scm)
976 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
977 struct type *type = t_smob->type;
979 SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
982 /* We want just fields of this type, not of base types, so instead of
983 using lookup_struct_elt_type, portions of that function are
986 type = tyscm_get_composite (type);
988 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
989 _(not_composite_error));
992 gdb::unique_xmalloc_ptr<char> field = gdbscm_scm_to_c_string (field_scm);
994 for (int i = 0; i < TYPE_NFIELDS (type); i++)
996 const char *t_field_name = TYPE_FIELD_NAME (type, i);
998 if (t_field_name && (strcmp_iw (t_field_name, field.get ()) == 0))
1000 field.reset (nullptr);
1001 return tyscm_make_field_smob (self, i);
1006 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, field_scm,
1007 _("Unknown field"));
1010 /* (type-has-field? <gdb:type> string) -> boolean
1011 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1014 gdbscm_type_has_field_p (SCM self, SCM field_scm)
1017 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1018 struct type *type = t_smob->type;
1020 SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
1023 /* We want just fields of this type, not of base types, so instead of
1024 using lookup_struct_elt_type, portions of that function are
1027 type = tyscm_get_composite (type);
1029 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1030 _(not_composite_error));
1033 gdb::unique_xmalloc_ptr<char> field
1034 = gdbscm_scm_to_c_string (field_scm);
1036 for (int i = 0; i < TYPE_NFIELDS (type); i++)
1038 const char *t_field_name = TYPE_FIELD_NAME (type, i);
1040 if (t_field_name && (strcmp_iw (t_field_name, field.get ()) == 0))
1048 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1049 Make a field iterator object. */
1052 gdbscm_make_field_iterator (SCM self)
1055 = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1056 struct type *type = t_smob->type;
1057 struct type *containing_type;
1058 SCM containing_type_scm;
1060 containing_type = tyscm_get_composite (type);
1061 if (containing_type == NULL)
1062 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1063 _(not_composite_error));
1065 /* If SELF is a typedef or reference, we want the underlying type,
1066 which is what tyscm_get_composite returns. */
1067 if (containing_type == type)
1068 containing_type_scm = self;
1070 containing_type_scm = tyscm_scm_from_type (containing_type);
1072 return gdbscm_make_iterator (containing_type_scm, scm_from_int (0),
1073 tyscm_next_field_x_proc);
1076 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1077 Return the next field in the iteration through the list of fields of the
1078 type, or (end-of-iteration).
1079 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1080 This is the next! <gdb:iterator> function, not exported to the user. */
1083 gdbscm_type_next_field_x (SCM self)
1085 iterator_smob *i_smob;
1088 SCM it_scm, result, progress, object;
1091 it_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1092 i_smob = (iterator_smob *) SCM_SMOB_DATA (it_scm);
1093 object = itscm_iterator_smob_object (i_smob);
1094 progress = itscm_iterator_smob_progress (i_smob);
1096 SCM_ASSERT_TYPE (tyscm_is_type (object), object,
1097 SCM_ARG1, FUNC_NAME, type_smob_name);
1098 t_smob = (type_smob *) SCM_SMOB_DATA (object);
1099 type = t_smob->type;
1101 SCM_ASSERT_TYPE (scm_is_signed_integer (progress,
1102 0, TYPE_NFIELDS (type)),
1103 progress, SCM_ARG1, FUNC_NAME, _("integer"));
1104 field = scm_to_int (progress);
1106 if (field < TYPE_NFIELDS (type))
1108 result = tyscm_make_field_smob (object, field);
1109 itscm_set_iterator_smob_progress_x (i_smob, scm_from_int (field + 1));
1113 return gdbscm_end_of_iteration ();
1116 /* Field smob accessors. */
1118 /* (field-name <gdb:field>) -> string
1119 Return the name of this field or #f if there isn't one. */
1122 gdbscm_field_name (SCM self)
1125 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1126 struct field *field = tyscm_field_smob_to_field (f_smob);
1128 if (FIELD_NAME (*field))
1129 return gdbscm_scm_from_c_string (FIELD_NAME (*field));
1133 /* (field-type <gdb:field>) -> <gdb:type>
1134 Return the <gdb:type> object of the field or #f if there isn't one. */
1137 gdbscm_field_type (SCM self)
1140 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1141 struct field *field = tyscm_field_smob_to_field (f_smob);
1143 /* A field can have a NULL type in some situations. */
1144 if (FIELD_TYPE (*field))
1145 return tyscm_scm_from_type (FIELD_TYPE (*field));
1149 /* (field-enumval <gdb:field>) -> integer
1150 For enum values, return its value as an integer. */
1153 gdbscm_field_enumval (SCM self)
1156 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1157 struct field *field = tyscm_field_smob_to_field (f_smob);
1158 struct type *type = tyscm_field_smob_containing_type (f_smob);
1160 SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ENUM,
1161 self, SCM_ARG1, FUNC_NAME, _("enum type"));
1163 return scm_from_long (FIELD_ENUMVAL (*field));
1166 /* (field-bitpos <gdb:field>) -> integer
1167 For bitfields, return its offset in bits. */
1170 gdbscm_field_bitpos (SCM self)
1173 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1174 struct field *field = tyscm_field_smob_to_field (f_smob);
1175 struct type *type = tyscm_field_smob_containing_type (f_smob);
1177 SCM_ASSERT_TYPE (TYPE_CODE (type) != TYPE_CODE_ENUM,
1178 self, SCM_ARG1, FUNC_NAME, _("non-enum type"));
1180 return scm_from_long (FIELD_BITPOS (*field));
1183 /* (field-bitsize <gdb:field>) -> integer
1184 Return the size of the field in bits. */
1187 gdbscm_field_bitsize (SCM self)
1190 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1191 struct field *field = tyscm_field_smob_to_field (f_smob);
1193 return scm_from_long (FIELD_BITPOS (*field));
1196 /* (field-artificial? <gdb:field>) -> boolean
1197 Return #t if field is artificial. */
1200 gdbscm_field_artificial_p (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_bool (FIELD_ARTIFICIAL (*field));
1209 /* (field-baseclass? <gdb:field>) -> boolean
1210 Return #t if field is a baseclass. */
1213 gdbscm_field_baseclass_p (SCM self)
1216 = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
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);