1 /* Scheme interface to types.
3 Copyright (C) 2008-2020 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"
30 #include "dwarf2/loc.h"
31 #include "typeprint.h"
32 #include "guile-internal.h"
34 /* The <gdb:type> smob.
35 The type is chained with all types associated with its objfile, if any.
36 This lets us copy the underlying struct type when the objfile is
38 The typedef for this struct is in guile-internal.h. */
42 /* This always appears first.
43 eqable_gdb_smob is used so that types are eq?-able.
44 Also, a type object can be associated with an objfile. eqable_gdb_smob
45 lets us track the lifetime of all types associated with an objfile.
46 When an objfile is deleted we need to invalidate the type object. */
49 /* The GDB type structure this smob is wrapping. */
57 /* This always appears first. */
60 /* Backlink to the containing <gdb:type> object. */
63 /* The field number in TYPE_SCM. */
67 static const char type_smob_name
[] = "gdb:type";
68 static const char field_smob_name
[] = "gdb:field";
70 static const char not_composite_error
[] =
71 N_("type is not a structure, union, or enum type");
73 /* The tag Guile knows the type smob by. */
74 static scm_t_bits type_smob_tag
;
76 /* The tag Guile knows the field smob by. */
77 static scm_t_bits field_smob_tag
;
79 /* The "next" procedure for field iterators. */
80 static SCM tyscm_next_field_x_proc
;
82 /* Keywords used in argument passing. */
83 static SCM block_keyword
;
85 static const struct objfile_data
*tyscm_objfile_data_key
;
87 /* Hash table to uniquify global (non-objfile-owned) types. */
88 static htab_t global_types_map
;
90 static struct type
*tyscm_get_composite (struct type
*type
);
92 /* Return the type field of T_SMOB.
93 This exists so that we don't have to export the struct's contents. */
96 tyscm_type_smob_type (type_smob
*t_smob
)
101 /* Return the name of TYPE in expanded form. If there's an error
102 computing the name, throws the gdb exception with scm_throw. */
105 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 (const gdb_exception
&except
)
117 excp
= gdbscm_scm_from_gdb_exception (unpack (except
));
123 /* Administrivia for type smobs. */
125 /* Helper function to hash a type_smob. */
128 tyscm_hash_type_smob (const void *p
)
130 const type_smob
*t_smob
= (const type_smob
*) p
;
132 return htab_hash_pointer (t_smob
->type
);
135 /* Helper function to compute equality of type_smobs. */
138 tyscm_eq_type_smob (const void *ap
, const void *bp
)
140 const type_smob
*a
= (const type_smob
*) ap
;
141 const type_smob
*b
= (const type_smob
*) bp
;
143 return (a
->type
== b
->type
147 /* Return the struct type pointer -> SCM mapping table.
148 If type is owned by an objfile, the mapping table is created if necessary.
149 Otherwise, type is not owned by an objfile, and we use
153 tyscm_type_map (struct type
*type
)
155 struct objfile
*objfile
= TYPE_OBJFILE (type
);
159 return global_types_map
;
161 htab
= (htab_t
) objfile_data (objfile
, tyscm_objfile_data_key
);
164 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
166 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
172 /* The smob "free" function for <gdb:type>. */
175 tyscm_free_type_smob (SCM self
)
177 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
179 if (t_smob
->type
!= NULL
)
181 htab_t htab
= tyscm_type_map (t_smob
->type
);
183 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
186 /* Not necessary, done to catch bugs. */
192 /* The smob "print" function for <gdb:type>. */
195 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
197 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
198 std::string name
= tyscm_type_name (t_smob
->type
);
200 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
201 invoked by write/~S. What to do here may need to evolve.
202 IWBN if we could pass an argument to format that would we could use
203 instead of writingp. */
204 if (pstate
->writingp
)
205 gdbscm_printf (port
, "#<%s ", type_smob_name
);
207 scm_puts (name
.c_str (), port
);
209 if (pstate
->writingp
)
210 scm_puts (">", port
);
212 scm_remember_upto_here_1 (self
);
214 /* Non-zero means success. */
218 /* The smob "equal?" function for <gdb:type>. */
221 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
223 type_smob
*type1_smob
, *type2_smob
;
224 struct type
*type1
, *type2
;
227 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
229 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
231 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
232 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
233 type1
= type1_smob
->type
;
234 type2
= type2_smob
->type
;
236 gdbscm_gdb_exception exc
{};
239 result
= types_deeply_equal (type1
, type2
);
241 catch (const gdb_exception
&except
)
243 exc
= unpack (except
);
246 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
247 return scm_from_bool (result
);
250 /* Low level routine to create a <gdb:type> object. */
253 tyscm_make_type_smob (void)
255 type_smob
*t_smob
= (type_smob
*)
256 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
259 /* This must be filled in by the caller. */
262 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
263 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
268 /* Return non-zero if SCM is a <gdb:type> object. */
271 tyscm_is_type (SCM self
)
273 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
276 /* (type? object) -> boolean */
279 gdbscm_type_p (SCM self
)
281 return scm_from_bool (tyscm_is_type (self
));
284 /* Return the existing object that encapsulates TYPE, or create a new
285 <gdb:type> object. */
288 tyscm_scm_from_type (struct type
*type
)
291 eqable_gdb_smob
**slot
;
292 type_smob
*t_smob
, t_smob_for_lookup
;
295 /* If we've already created a gsmob for this type, return it.
296 This makes types eq?-able. */
297 htab
= tyscm_type_map (type
);
298 t_smob_for_lookup
.type
= type
;
299 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
301 return (*slot
)->containing_scm
;
303 t_scm
= tyscm_make_type_smob ();
304 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
306 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
311 /* Returns the <gdb:type> object in SELF.
312 Throws an exception if SELF is not a <gdb:type> object. */
315 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
317 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
323 /* Returns a pointer to the type smob of SELF.
324 Throws an exception if SELF is not a <gdb:type> object. */
327 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
329 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
330 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
335 /* Return the type field of T_SCM, an object of type <gdb:type>.
336 This exists so that we don't have to export the struct's contents. */
339 tyscm_scm_to_type (SCM t_scm
)
343 gdb_assert (tyscm_is_type (t_scm
));
344 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
348 /* Helper function for save_objfile_types to make a deep copy of the type. */
351 tyscm_copy_type_recursive (void **slot
, void *info
)
353 type_smob
*t_smob
= (type_smob
*) *slot
;
354 htab_t copied_types
= (htab_t
) info
;
355 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
357 eqable_gdb_smob
**new_slot
;
358 type_smob t_smob_for_lookup
;
360 gdb_assert (objfile
!= NULL
);
362 htab_empty (copied_types
);
363 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
365 /* The eq?-hashtab that the type lived in is going away.
366 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
367 garbage collected we'll assert-fail if the type isn't in the hashtab.
370 Types now live in "arch space", and things like "char" that came from
371 the objfile *could* be considered eq? with the arch "char" type.
372 However, they weren't before the objfile got deleted, so making them
373 eq? now is debatable. */
374 htab
= tyscm_type_map (t_smob
->type
);
375 t_smob_for_lookup
.type
= t_smob
->type
;
376 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
377 gdb_assert (*new_slot
== NULL
);
378 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
383 /* Called when OBJFILE is about to be deleted.
384 Make a copy of all types associated with OBJFILE. */
387 save_objfile_types (struct objfile
*objfile
, void *datum
)
389 htab_t htab
= (htab_t
) datum
;
391 if (!gdb_scheme_initialized
)
394 htab_up copied_types
= create_copied_types_hash (objfile
);
398 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
.get ());
403 /* Administrivia for field smobs. */
405 /* The smob "print" function for <gdb:field>. */
408 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
410 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
412 gdbscm_printf (port
, "#<%s ", field_smob_name
);
413 scm_write (f_smob
->type_scm
, port
);
414 gdbscm_printf (port
, " %d", f_smob
->field_num
);
415 scm_puts (">", port
);
417 scm_remember_upto_here_1 (self
);
419 /* Non-zero means success. */
423 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
427 tyscm_make_field_smob (SCM type_scm
, int field_num
)
429 field_smob
*f_smob
= (field_smob
*)
430 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
433 f_smob
->type_scm
= type_scm
;
434 f_smob
->field_num
= field_num
;
435 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
436 gdbscm_init_gsmob (&f_smob
->base
);
441 /* Return non-zero if SCM is a <gdb:field> object. */
444 tyscm_is_field (SCM self
)
446 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
449 /* (field? object) -> boolean */
452 gdbscm_field_p (SCM self
)
454 return scm_from_bool (tyscm_is_field (self
));
457 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
461 tyscm_scm_from_field (SCM type_scm
, int field_num
)
463 return tyscm_make_field_smob (type_scm
, field_num
);
466 /* Returns the <gdb:field> object in SELF.
467 Throws an exception if SELF is not a <gdb:field> object. */
470 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
472 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
478 /* Returns a pointer to the field smob of SELF.
479 Throws an exception if SELF is not a <gdb:field> object. */
482 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
484 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
485 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
490 /* Returns a pointer to the type struct in F_SMOB
491 (the type the field is in). */
494 tyscm_field_smob_containing_type (field_smob
*f_smob
)
498 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
499 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
504 /* Returns a pointer to the field struct of F_SMOB. */
506 static struct field
*
507 tyscm_field_smob_to_field (field_smob
*f_smob
)
509 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
511 /* This should be non-NULL by construction. */
512 gdb_assert (type
->fields () != NULL
);
514 return &type
->field (f_smob
->field_num
);
517 /* Type smob accessors. */
519 /* (type-code <gdb:type>) -> integer
520 Return the code for this type. */
523 gdbscm_type_code (SCM self
)
526 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
527 struct type
*type
= t_smob
->type
;
529 return scm_from_int (type
->code ());
532 /* (type-fields <gdb:type>) -> list
533 Return a list of all fields. Each element is a <gdb:field> object.
534 This also supports arrays, we return a field list of one element,
538 gdbscm_type_fields (SCM self
)
541 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
542 struct type
*type
= t_smob
->type
;
543 struct type
*containing_type
;
544 SCM containing_type_scm
, result
;
547 containing_type
= tyscm_get_composite (type
);
548 if (containing_type
== NULL
)
549 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
550 _(not_composite_error
));
552 /* If SELF is a typedef or reference, we want the underlying type,
553 which is what tyscm_get_composite returns. */
554 if (containing_type
== type
)
555 containing_type_scm
= self
;
557 containing_type_scm
= tyscm_scm_from_type (containing_type
);
560 for (i
= 0; i
< containing_type
->num_fields (); ++i
)
561 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
563 return scm_reverse_x (result
, SCM_EOL
);
566 /* (type-tag <gdb:type>) -> string
567 Return the type's tag, or #f. */
570 gdbscm_type_tag (SCM self
)
573 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
574 struct type
*type
= t_smob
->type
;
575 const char *tagname
= nullptr;
577 if (type
->code () == TYPE_CODE_STRUCT
578 || type
->code () == TYPE_CODE_UNION
579 || type
->code () == TYPE_CODE_ENUM
)
580 tagname
= type
->name ();
582 if (tagname
== nullptr)
584 return gdbscm_scm_from_c_string (tagname
);
587 /* (type-name <gdb:type>) -> string
588 Return the type's name, or #f. */
591 gdbscm_type_name (SCM self
)
594 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
595 struct type
*type
= t_smob
->type
;
599 return gdbscm_scm_from_c_string (type
->name ());
602 /* (type-print-name <gdb:type>) -> string
603 Return the print name of type.
604 TODO: template support elided for now. */
607 gdbscm_type_print_name (SCM self
)
610 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
611 struct type
*type
= t_smob
->type
;
612 std::string thetype
= tyscm_type_name (type
);
613 SCM result
= gdbscm_scm_from_c_string (thetype
.c_str ());
618 /* (type-sizeof <gdb:type>) -> integer
619 Return the size of the type represented by SELF, in bytes. */
622 gdbscm_type_sizeof (SCM self
)
625 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
626 struct type
*type
= t_smob
->type
;
630 check_typedef (type
);
632 catch (const gdb_exception
&except
)
636 /* Ignore exceptions. */
638 return scm_from_long (TYPE_LENGTH (type
));
641 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
642 Return the type, stripped of typedefs. */
645 gdbscm_type_strip_typedefs (SCM self
)
648 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
649 struct type
*type
= t_smob
->type
;
651 gdbscm_gdb_exception exc
{};
654 type
= check_typedef (type
);
656 catch (const gdb_exception
&except
)
658 exc
= unpack (except
);
661 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
662 return tyscm_scm_from_type (type
);
665 /* Strip typedefs and pointers/reference from a type. Then check that
666 it is a struct, union, or enum type. If not, return NULL. */
669 tyscm_get_composite (struct type
*type
)
674 gdbscm_gdb_exception exc
{};
677 type
= check_typedef (type
);
679 catch (const gdb_exception
&except
)
681 exc
= unpack (except
);
684 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
685 if (type
->code () != TYPE_CODE_PTR
686 && type
->code () != TYPE_CODE_REF
)
688 type
= TYPE_TARGET_TYPE (type
);
691 /* If this is not a struct, union, or enum type, raise TypeError
693 if (type
->code () != TYPE_CODE_STRUCT
694 && type
->code () != TYPE_CODE_UNION
695 && type
->code () != TYPE_CODE_ENUM
)
701 /* Helper for tyscm_array and tyscm_vector. */
704 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
705 const char *func_name
)
708 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
709 struct type
*type
= t_smob
->type
;
711 struct type
*array
= NULL
;
713 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
714 n1_scm
, &n1
, n2_scm
, &n2
);
716 if (SCM_UNBNDP (n2_scm
))
722 if (n2
< n1
- 1) /* Note: An empty array has n2 == n1 - 1. */
724 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
725 scm_cons (scm_from_long (n1
),
727 _("Array length must not be negative"));
730 gdbscm_gdb_exception exc
{};
733 array
= lookup_array_range_type (type
, n1
, n2
);
735 make_vector_type (array
);
737 catch (const gdb_exception
&except
)
739 exc
= unpack (except
);
742 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
743 return tyscm_scm_from_type (array
);
746 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
747 The array has indices [low-bound,high-bound].
748 If low-bound is not provided zero is used.
749 Return an array type.
751 IWBN if the one argument version specified a size, not the high bound.
752 It's too easy to pass one argument thinking it is the size of the array.
753 The current semantics are for compatibility with the Python version.
754 Later we can add #:size. */
757 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
759 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
762 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
763 The array has indices [low-bound,high-bound].
764 If low-bound is not provided zero is used.
765 Return a vector type.
767 IWBN if the one argument version specified a size, not the high bound.
768 It's too easy to pass one argument thinking it is the size of the array.
769 The current semantics are for compatibility with the Python version.
770 Later we can add #:size. */
773 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
775 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
778 /* (type-pointer <gdb:type>) -> <gdb:type>
779 Return a <gdb:type> object which represents a pointer to SELF. */
782 gdbscm_type_pointer (SCM self
)
785 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
786 struct type
*type
= t_smob
->type
;
788 gdbscm_gdb_exception exc
{};
791 type
= lookup_pointer_type (type
);
793 catch (const gdb_exception
&except
)
795 exc
= unpack (except
);
798 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
799 return tyscm_scm_from_type (type
);
802 /* (type-range <gdb:type>) -> (low high)
803 Return the range of a type represented by SELF. The return type is
804 a list. The first element is the low bound, and the second element
805 is the high bound. */
808 gdbscm_type_range (SCM self
)
811 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
812 struct type
*type
= t_smob
->type
;
813 SCM low_scm
, high_scm
;
814 /* Initialize these to appease GCC warnings. */
815 LONGEST low
= 0, high
= 0;
817 SCM_ASSERT_TYPE (type
->code () == TYPE_CODE_ARRAY
818 || type
->code () == TYPE_CODE_STRING
819 || type
->code () == TYPE_CODE_RANGE
,
820 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
822 switch (type
->code ())
824 case TYPE_CODE_ARRAY
:
825 case TYPE_CODE_STRING
:
826 case TYPE_CODE_RANGE
:
827 low
= type
->bounds ()->low
.const_val ();
828 high
= type
->bounds ()->high
.const_val ();
832 low_scm
= gdbscm_scm_from_longest (low
);
833 high_scm
= gdbscm_scm_from_longest (high
);
835 return scm_list_2 (low_scm
, high_scm
);
838 /* (type-reference <gdb:type>) -> <gdb:type>
839 Return a <gdb:type> object which represents a reference to SELF. */
842 gdbscm_type_reference (SCM self
)
845 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
846 struct type
*type
= t_smob
->type
;
848 gdbscm_gdb_exception exc
{};
851 type
= lookup_lvalue_reference_type (type
);
853 catch (const gdb_exception
&except
)
855 exc
= unpack (except
);
858 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
859 return tyscm_scm_from_type (type
);
862 /* (type-target <gdb:type>) -> <gdb:type>
863 Return a <gdb:type> object which represents the target type of SELF. */
866 gdbscm_type_target (SCM self
)
869 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
870 struct type
*type
= t_smob
->type
;
872 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
874 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
877 /* (type-const <gdb:type>) -> <gdb:type>
878 Return a const-qualified type variant. */
881 gdbscm_type_const (SCM self
)
884 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
885 struct type
*type
= t_smob
->type
;
887 gdbscm_gdb_exception exc
{};
890 type
= make_cv_type (1, 0, type
, NULL
);
892 catch (const gdb_exception
&except
)
894 exc
= unpack (except
);
897 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
898 return tyscm_scm_from_type (type
);
901 /* (type-volatile <gdb:type>) -> <gdb:type>
902 Return a volatile-qualified type variant. */
905 gdbscm_type_volatile (SCM self
)
908 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
909 struct type
*type
= t_smob
->type
;
911 gdbscm_gdb_exception exc
{};
914 type
= make_cv_type (0, 1, type
, NULL
);
916 catch (const gdb_exception
&except
)
918 exc
= unpack (except
);
921 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
922 return tyscm_scm_from_type (type
);
925 /* (type-unqualified <gdb:type>) -> <gdb:type>
926 Return an unqualified type variant. */
929 gdbscm_type_unqualified (SCM self
)
932 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
933 struct type
*type
= t_smob
->type
;
935 gdbscm_gdb_exception exc
{};
938 type
= make_cv_type (0, 0, type
, NULL
);
940 catch (const gdb_exception
&except
)
942 exc
= unpack (except
);
945 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
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
->num_fields ());
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
->num_fields (); 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
->num_fields (); 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
->num_fields ()),
1103 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1104 field
= scm_to_int (progress
);
1106 if (field
< type
->num_fields ())
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. */
1145 return tyscm_scm_from_type (field
->type ());
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_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_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_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
,
1243 type_name
, block
, 0);
1245 catch (const gdb_exception
&except
)
1253 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1254 TODO: legacy template support left out until needed. */
1257 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1259 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1261 SCM block_scm
= SCM_BOOL_F
;
1262 int block_arg_pos
= -1;
1263 const struct block
*block
= NULL
;
1266 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1268 rest
, &block_arg_pos
, &block_scm
);
1270 if (block_arg_pos
!= -1)
1274 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1279 gdbscm_throw (exception
);
1282 type
= tyscm_lookup_typename (name
, block
);
1286 return tyscm_scm_from_type (type
);
1290 /* Initialize the Scheme type code. */
1293 static const scheme_integer_constant type_integer_constants
[] =
1295 #define X(SYM) { #SYM, SYM }
1296 X (TYPE_CODE_BITSTRING
),
1298 X (TYPE_CODE_ARRAY
),
1299 X (TYPE_CODE_STRUCT
),
1300 X (TYPE_CODE_UNION
),
1302 X (TYPE_CODE_FLAGS
),
1308 X (TYPE_CODE_RANGE
),
1309 X (TYPE_CODE_STRING
),
1310 X (TYPE_CODE_ERROR
),
1311 X (TYPE_CODE_METHOD
),
1312 X (TYPE_CODE_METHODPTR
),
1313 X (TYPE_CODE_MEMBERPTR
),
1317 X (TYPE_CODE_COMPLEX
),
1318 X (TYPE_CODE_TYPEDEF
),
1319 X (TYPE_CODE_NAMESPACE
),
1320 X (TYPE_CODE_DECFLOAT
),
1321 X (TYPE_CODE_INTERNAL_FUNCTION
),
1324 END_INTEGER_CONSTANTS
1327 static const scheme_function type_functions
[] =
1329 { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p
),
1331 Return #t if the object is a <gdb:type> object." },
1333 { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type
),
1335 Return the <gdb:type> object representing string or #f if not found.\n\
1336 If block is given then the type is looked for in that block.\n\
1338 Arguments: string [#:block <gdb:block>]" },
1340 { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code
),
1342 Return the code of the type" },
1344 { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag
),
1346 Return the tag name of the type, or #f if there isn't one." },
1348 { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name
),
1350 Return the name of the type as a string, or #f if there isn't one." },
1352 { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name
),
1354 Return the print name of the type as a string." },
1356 { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof
),
1358 Return the size of the type, in bytes." },
1360 { "type-strip-typedefs", 1, 0, 0,
1361 as_a_scm_t_subr (gdbscm_type_strip_typedefs
),
1363 Return a type formed by stripping the type of all typedefs." },
1365 { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array
),
1367 Return a type representing an array of objects of the type.\n\
1369 Arguments: <gdb:type> [low-bound] high-bound\n\
1370 If low-bound is not provided zero is used.\n\
1371 N.B. If only the high-bound parameter is specified, it is not\n\
1373 Valid bounds for array indices are [low-bound,high-bound]." },
1375 { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector
),
1377 Return a type representing a vector of objects of the type.\n\
1378 Vectors differ from arrays in that if the current language has C-style\n\
1379 arrays, vectors don't decay to a pointer to the first element.\n\
1380 They are first class values.\n\
1382 Arguments: <gdb:type> [low-bound] high-bound\n\
1383 If low-bound is not provided zero is used.\n\
1384 N.B. If only the high-bound parameter is specified, it is not\n\
1386 Valid bounds for array indices are [low-bound,high-bound]." },
1388 { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer
),
1390 Return a type of pointer to the type." },
1392 { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range
),
1394 Return (low high) representing the range for the type." },
1396 { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference
),
1398 Return a type of reference to the type." },
1400 { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target
),
1402 Return the target type of the type." },
1404 { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const
),
1406 Return a const variant of the type." },
1408 { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile
),
1410 Return a volatile variant of the type." },
1412 { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified
),
1414 Return a variant of the type without const or volatile attributes." },
1416 { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields
),
1418 Return the number of fields of the type." },
1420 { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields
),
1422 Return the list of <gdb:field> objects of fields of the type." },
1424 { "make-field-iterator", 1, 0, 0,
1425 as_a_scm_t_subr (gdbscm_make_field_iterator
),
1427 Return a <gdb:iterator> object for iterating over the fields of the type." },
1429 { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field
),
1431 Return the field named by string of the type.\n\
1433 Arguments: <gdb:type> string" },
1435 { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p
),
1437 Return #t if the type has field named string.\n\
1439 Arguments: <gdb:type> string" },
1441 { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p
),
1443 Return #t if the object is a <gdb:field> object." },
1445 { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name
),
1447 Return the name of the field." },
1449 { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type
),
1451 Return the type of the field." },
1453 { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval
),
1455 Return the enum value represented by the field." },
1457 { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos
),
1459 Return the offset in bits of the field in its containing type." },
1461 { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize
),
1463 Return the size of the field in bits." },
1465 { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p
),
1467 Return #t if the field is artificial." },
1469 { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p
),
1471 Return #t if the field is a baseclass." },
1477 gdbscm_initialize_types (void)
1479 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1480 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1481 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1482 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1484 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1485 sizeof (field_smob
));
1486 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1488 gdbscm_define_integer_constants (type_integer_constants
, 1);
1489 gdbscm_define_functions (type_functions
, 1);
1491 /* This function is "private". */
1492 tyscm_next_field_x_proc
1493 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1494 as_a_scm_t_subr (gdbscm_type_next_field_x
));
1495 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1496 gdbscm_documentation_symbol
,
1497 gdbscm_scm_from_c_string ("\
1498 Internal function to assist the type fields iterator."));
1500 block_keyword
= scm_from_latin1_keyword ("block");
1502 /* Register an objfile "free" callback so we can properly copy types
1503 associated with the objfile when it's about to be deleted. */
1504 tyscm_objfile_data_key
1505 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1507 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1508 tyscm_eq_type_smob
);