1 /* Scheme interface to types.
3 Copyright (C) 2008-2014 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"
26 #include "exceptions.h"
32 #include "dwarf2loc.h"
33 #include "typeprint.h"
34 #include "guile-internal.h"
36 /* The <gdb:type> smob.
37 The type is chained with all types associated with its objfile, if any.
38 This lets us copy the underlying struct type when the objfile is
41 typedef struct _type_smob
43 /* This always appears first.
44 eqable_gdb_smob is used so that types are eq?-able.
45 Also, a type object can be associated with an objfile. eqable_gdb_smob
46 lets us track the lifetime of all types associated with an objfile.
47 When an objfile is deleted we need to invalidate the type object. */
50 /* The GDB type structure this smob is wrapping. */
58 /* This always appears first. */
61 /* Backlink to the containing <gdb:type> object. */
64 /* The field number in TYPE_SCM. */
68 static const char type_smob_name
[] = "gdb:type";
69 static const char field_smob_name
[] = "gdb:field";
71 static const char not_composite_error
[] =
72 N_("type is not a structure, union, or enum type");
74 /* The tag Guile knows the type smob by. */
75 static scm_t_bits type_smob_tag
;
77 /* The tag Guile knows the field smob by. */
78 static scm_t_bits field_smob_tag
;
80 /* The "next" procedure for field iterators. */
81 static SCM tyscm_next_field_x_proc
;
83 /* Keywords used in argument passing. */
84 static SCM block_keyword
;
86 static const struct objfile_data
*tyscm_objfile_data_key
;
88 /* Hash table to uniquify global (non-objfile-owned) types. */
89 static htab_t global_types_map
;
91 static struct type
*tyscm_get_composite (struct type
*type
);
93 /* Return the type field of T_SMOB.
94 This exists so that we don't have to export the struct's contents. */
97 tyscm_type_smob_type (type_smob
*t_smob
)
102 /* Return the name of TYPE in expanded form.
103 Space for the result is malloc'd, caller must free.
104 If there's an error computing the name, the result is NULL and the
105 exception is stored in *EXCP. */
108 tyscm_type_name (struct type
*type
, SCM
*excp
)
111 volatile struct gdb_exception except
;
113 TRY_CATCH (except
, RETURN_MASK_ALL
)
115 struct cleanup
*old_chain
;
118 stb
= mem_fileopen ();
119 old_chain
= make_cleanup_ui_file_delete (stb
);
121 LA_PRINT_TYPE (type
, "", stb
, -1, 0, &type_print_raw_options
);
123 name
= ui_file_xstrdup (stb
, NULL
);
124 do_cleanups (old_chain
);
126 if (except
.reason
< 0)
128 *excp
= gdbscm_scm_from_gdb_exception (except
);
135 /* Administrivia for type smobs. */
137 /* Helper function to hash a type_smob. */
140 tyscm_hash_type_smob (const void *p
)
142 const type_smob
*t_smob
= p
;
144 return htab_hash_pointer (t_smob
->type
);
147 /* Helper function to compute equality of type_smobs. */
150 tyscm_eq_type_smob (const void *ap
, const void *bp
)
152 const type_smob
*a
= ap
;
153 const type_smob
*b
= bp
;
155 return (a
->type
== b
->type
159 /* Return the struct type pointer -> SCM mapping table.
160 If type is owned by an objfile, the mapping table is created if necessary.
161 Otherwise, type is not owned by an objfile, and we use
165 tyscm_type_map (struct type
*type
)
167 struct objfile
*objfile
= TYPE_OBJFILE (type
);
171 return global_types_map
;
173 htab
= objfile_data (objfile
, tyscm_objfile_data_key
);
176 htab
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
178 set_objfile_data (objfile
, tyscm_objfile_data_key
, htab
);
184 /* The smob "mark" function for <gdb:type>. */
187 tyscm_mark_type_smob (SCM self
)
192 /* The smob "free" function for <gdb:type>. */
195 tyscm_free_type_smob (SCM self
)
197 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
199 if (t_smob
->type
!= NULL
)
201 htab_t htab
= tyscm_type_map (t_smob
->type
);
203 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
206 /* Not necessary, done to catch bugs. */
212 /* The smob "print" function for <gdb:type>. */
215 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
217 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
219 char *name
= tyscm_type_name (t_smob
->type
, &exception
);
222 gdbscm_throw (exception
);
224 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
225 invoked by write/~S. What to do here may need to evolve.
226 IWBN if we could pass an argument to format that would we could use
227 instead of writingp. */
228 if (pstate
->writingp
)
229 gdbscm_printf (port
, "#<%s ", type_smob_name
);
231 scm_puts (name
, port
);
233 if (pstate
->writingp
)
234 scm_puts (">", port
);
236 scm_remember_upto_here_1 (self
);
238 /* Non-zero means success. */
242 /* The smob "equal?" function for <gdb:type>. */
245 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
247 type_smob
*type1_smob
, *type2_smob
;
248 struct type
*type1
, *type2
;
250 volatile struct gdb_exception except
;
252 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
254 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
256 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
257 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
258 type1
= type1_smob
->type
;
259 type2
= type2_smob
->type
;
261 TRY_CATCH (except
, RETURN_MASK_ALL
)
263 result
= types_deeply_equal (type1
, type2
);
265 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
267 return scm_from_bool (result
);
270 /* Low level routine to create a <gdb:type> object. */
273 tyscm_make_type_smob (void)
275 type_smob
*t_smob
= (type_smob
*)
276 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
279 /* This must be filled in by the caller. */
282 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
283 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
288 /* Return non-zero if SCM is a <gdb:type> object. */
291 tyscm_is_type (SCM self
)
293 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
296 /* (type? object) -> boolean */
299 gdbscm_type_p (SCM self
)
301 return scm_from_bool (tyscm_is_type (self
));
304 /* Return the existing object that encapsulates TYPE, or create a new
305 <gdb:type> object. */
308 tyscm_scm_from_type (struct type
*type
)
311 eqable_gdb_smob
**slot
;
312 type_smob
*t_smob
, t_smob_for_lookup
;
315 /* If we've already created a gsmob for this type, return it.
316 This makes types eq?-able. */
317 htab
= tyscm_type_map (type
);
318 t_smob_for_lookup
.type
= type
;
319 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
321 return (*slot
)->containing_scm
;
323 t_scm
= tyscm_make_type_smob ();
324 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
326 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
331 /* Returns the <gdb:type> object in SELF.
332 Throws an exception if SELF is not a <gdb:type> object. */
335 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
337 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
343 /* Returns a pointer to the type smob of SELF.
344 Throws an exception if SELF is not a <gdb:type> object. */
347 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
349 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
350 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
355 /* Helper function for save_objfile_types to make a deep copy of the type. */
358 tyscm_copy_type_recursive (void **slot
, void *info
)
360 type_smob
*t_smob
= (type_smob
*) *slot
;
361 htab_t copied_types
= info
;
362 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
364 eqable_gdb_smob
**new_slot
;
365 type_smob t_smob_for_lookup
;
367 gdb_assert (objfile
!= NULL
);
369 htab_empty (copied_types
);
370 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
372 /* The eq?-hashtab that the type lived in is going away.
373 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
374 garbage collected we'll assert-fail if the type isn't in the hashtab.
377 Types now live in "arch space", and things like "char" that came from
378 the objfile *could* be considered eq? with the arch "char" type.
379 However, they weren't before the objfile got deleted, so making them
380 eq? now is debatable. */
381 htab
= tyscm_type_map (t_smob
->type
);
382 t_smob_for_lookup
.type
= t_smob
->type
;
383 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
384 gdb_assert (*new_slot
== NULL
);
385 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
390 /* Called when OBJFILE is about to be deleted.
391 Make a copy of all types associated with OBJFILE. */
394 save_objfile_types (struct objfile
*objfile
, void *datum
)
399 if (!gdb_scheme_initialized
)
402 copied_types
= create_copied_types_hash (objfile
);
406 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
410 htab_delete (copied_types
);
413 /* Administrivia for field smobs. */
415 /* The smob "mark" function for <gdb:field>. */
418 tyscm_mark_field_smob (SCM self
)
420 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
422 return f_smob
->type_scm
;
425 /* The smob "print" function for <gdb:field>. */
428 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
430 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
432 gdbscm_printf (port
, "#<%s ", field_smob_name
);
433 scm_write (f_smob
->type_scm
, port
);
434 gdbscm_printf (port
, " %d", f_smob
->field_num
);
435 scm_puts (">", port
);
437 scm_remember_upto_here_1 (self
);
439 /* Non-zero means success. */
443 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
447 tyscm_make_field_smob (SCM type_scm
, int field_num
)
449 field_smob
*f_smob
= (field_smob
*)
450 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
453 f_smob
->type_scm
= type_scm
;
454 f_smob
->field_num
= field_num
;
455 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
456 gdbscm_init_gsmob (&f_smob
->base
);
461 /* Return non-zero if SCM is a <gdb:field> object. */
464 tyscm_is_field (SCM self
)
466 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
469 /* (field? object) -> boolean */
472 gdbscm_field_p (SCM self
)
474 return scm_from_bool (tyscm_is_field (self
));
477 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
481 tyscm_scm_from_field (SCM type_scm
, int field_num
)
483 return tyscm_make_field_smob (type_scm
, field_num
);
486 /* Returns the <gdb:field> object in SELF.
487 Throws an exception if SELF is not a <gdb:field> object. */
490 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
492 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
498 /* Returns a pointer to the field smob of SELF.
499 Throws an exception if SELF is not a <gdb:field> object. */
502 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
504 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
505 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
510 /* Returns a pointer to the type struct in F_SMOB
511 (the type the field is in). */
514 tyscm_field_smob_containing_type (field_smob
*f_smob
)
518 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
519 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
524 /* Returns a pointer to the field struct of F_SMOB. */
526 static struct field
*
527 tyscm_field_smob_to_field (field_smob
*f_smob
)
529 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
531 /* This should be non-NULL by construction. */
532 gdb_assert (TYPE_FIELDS (type
) != NULL
);
534 return &TYPE_FIELD (type
, f_smob
->field_num
);
537 /* Type smob accessors. */
539 /* (type-code <gdb:type>) -> integer
540 Return the code for this type. */
543 gdbscm_type_code (SCM self
)
546 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
547 struct type
*type
= t_smob
->type
;
549 return scm_from_int (TYPE_CODE (type
));
552 /* (type-fields <gdb:type>) -> list
553 Return a list of all fields. Each element is a <gdb:field> object.
554 This also supports arrays, we return a field list of one element,
558 gdbscm_type_fields (SCM self
)
561 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
562 struct type
*type
= t_smob
->type
;
563 struct type
*containing_type
;
564 SCM containing_type_scm
, result
;
567 containing_type
= tyscm_get_composite (type
);
568 if (containing_type
== NULL
)
569 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
570 _(not_composite_error
));
572 /* If SELF is a typedef or reference, we want the underlying type,
573 which is what tyscm_get_composite returns. */
574 if (containing_type
== type
)
575 containing_type_scm
= self
;
577 containing_type_scm
= tyscm_scm_from_type (containing_type
);
580 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
581 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
583 return scm_reverse_x (result
, SCM_EOL
);
586 /* (type-tag <gdb:type>) -> string
587 Return the type's tag, or #f. */
590 gdbscm_type_tag (SCM self
)
593 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
594 struct type
*type
= t_smob
->type
;
596 if (!TYPE_TAG_NAME (type
))
598 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
601 /* (type-name <gdb:type>) -> string
602 Return the type's name, or #f. */
605 gdbscm_type_name (SCM self
)
608 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
609 struct type
*type
= t_smob
->type
;
611 if (!TYPE_NAME (type
))
613 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
616 /* (type-print-name <gdb:type>) -> string
617 Return the print name of type.
618 TODO: template support elided for now. */
621 gdbscm_type_print_name (SCM self
)
624 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
625 struct type
*type
= t_smob
->type
;
627 SCM exception
, result
;
629 thetype
= tyscm_type_name (type
, &exception
);
632 gdbscm_throw (exception
);
634 result
= gdbscm_scm_from_c_string (thetype
);
640 /* (type-sizeof <gdb:type>) -> integer
641 Return the size of the type represented by SELF, in bytes. */
644 gdbscm_type_sizeof (SCM self
)
647 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
648 struct type
*type
= t_smob
->type
;
649 volatile struct gdb_exception except
;
651 TRY_CATCH (except
, RETURN_MASK_ALL
)
653 check_typedef (type
);
655 /* Ignore exceptions. */
657 return scm_from_long (TYPE_LENGTH (type
));
660 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
661 Return the type, stripped of typedefs. */
664 gdbscm_type_strip_typedefs (SCM self
)
667 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
668 struct type
*type
= t_smob
->type
;
669 volatile struct gdb_exception except
;
671 TRY_CATCH (except
, RETURN_MASK_ALL
)
673 type
= check_typedef (type
);
675 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
677 return tyscm_scm_from_type (type
);
680 /* Strip typedefs and pointers/reference from a type. Then check that
681 it is a struct, union, or enum type. If not, return NULL. */
684 tyscm_get_composite (struct type
*type
)
686 volatile struct gdb_exception except
;
690 TRY_CATCH (except
, RETURN_MASK_ALL
)
692 type
= check_typedef (type
);
694 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
696 if (TYPE_CODE (type
) != TYPE_CODE_PTR
697 && TYPE_CODE (type
) != TYPE_CODE_REF
)
699 type
= TYPE_TARGET_TYPE (type
);
702 /* If this is not a struct, union, or enum type, raise TypeError
704 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
705 && TYPE_CODE (type
) != TYPE_CODE_UNION
706 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
712 /* Helper for tyscm_array and tyscm_vector. */
715 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
716 const char *func_name
)
719 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
720 struct type
*type
= t_smob
->type
;
722 struct type
*array
= NULL
;
723 volatile struct gdb_exception except
;
725 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
726 n1_scm
, &n1
, n2_scm
, &n2
);
728 if (SCM_UNBNDP (n2_scm
))
736 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
737 scm_cons (scm_from_long (n1
),
739 _("Array length must not be negative"));
742 TRY_CATCH (except
, RETURN_MASK_ALL
)
744 array
= lookup_array_range_type (type
, n1
, n2
);
746 make_vector_type (array
);
748 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
750 return tyscm_scm_from_type (array
);
753 /* (type-array <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 an array 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_array (SCM self
, SCM n1
, SCM n2
)
766 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
769 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
770 The array has indices [low-bound,high-bound].
771 If low-bound is not provided zero is used.
772 Return a vector type.
774 IWBN if the one argument version specified a size, not the high bound.
775 It's too easy to pass one argument thinking it is the size of the array.
776 The current semantics are for compatibility with the Python version.
777 Later we can add #:size. */
780 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
782 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
785 /* (type-pointer <gdb:type>) -> <gdb:type>
786 Return a <gdb:type> object which represents a pointer to SELF. */
789 gdbscm_type_pointer (SCM self
)
792 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
793 struct type
*type
= t_smob
->type
;
794 volatile struct gdb_exception except
;
796 TRY_CATCH (except
, RETURN_MASK_ALL
)
798 type
= lookup_pointer_type (type
);
800 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
802 return tyscm_scm_from_type (type
);
805 /* (type-range <gdb:type>) -> (low high)
806 Return the range of a type represented by SELF. The return type is
807 a list. The first element is the low bound, and the second element
808 is the high bound. */
811 gdbscm_type_range (SCM self
)
814 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
815 struct type
*type
= t_smob
->type
;
816 SCM low_scm
, high_scm
;
817 /* Initialize these to appease GCC warnings. */
818 LONGEST low
= 0, high
= 0;
820 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
821 || TYPE_CODE (type
) == TYPE_CODE_STRING
822 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
823 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
825 switch (TYPE_CODE (type
))
827 case TYPE_CODE_ARRAY
:
828 case TYPE_CODE_STRING
:
829 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
830 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
832 case TYPE_CODE_RANGE
:
833 low
= TYPE_LOW_BOUND (type
);
834 high
= TYPE_HIGH_BOUND (type
);
838 low_scm
= gdbscm_scm_from_longest (low
);
839 high_scm
= gdbscm_scm_from_longest (high
);
841 return scm_list_2 (low_scm
, high_scm
);
844 /* (type-reference <gdb:type>) -> <gdb:type>
845 Return a <gdb:type> object which represents a reference to SELF. */
848 gdbscm_type_reference (SCM self
)
851 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
852 struct type
*type
= t_smob
->type
;
853 volatile struct gdb_exception except
;
855 TRY_CATCH (except
, RETURN_MASK_ALL
)
857 type
= lookup_reference_type (type
);
859 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
861 return tyscm_scm_from_type (type
);
864 /* (type-target <gdb:type>) -> <gdb:type>
865 Return a <gdb:type> object which represents the target type of SELF. */
868 gdbscm_type_target (SCM self
)
871 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
872 struct type
*type
= t_smob
->type
;
874 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
876 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
879 /* (type-const <gdb:type>) -> <gdb:type>
880 Return a const-qualified type variant. */
883 gdbscm_type_const (SCM self
)
886 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
887 struct type
*type
= t_smob
->type
;
888 volatile struct gdb_exception except
;
890 TRY_CATCH (except
, RETURN_MASK_ALL
)
892 type
= make_cv_type (1, 0, type
, NULL
);
894 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
896 return tyscm_scm_from_type (type
);
899 /* (type-volatile <gdb:type>) -> <gdb:type>
900 Return a volatile-qualified type variant. */
903 gdbscm_type_volatile (SCM self
)
906 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
907 struct type
*type
= t_smob
->type
;
908 volatile struct gdb_exception except
;
910 TRY_CATCH (except
, RETURN_MASK_ALL
)
912 type
= make_cv_type (0, 1, type
, NULL
);
914 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
916 return tyscm_scm_from_type (type
);
919 /* (type-unqualified <gdb:type>) -> <gdb:type>
920 Return an unqualified type variant. */
923 gdbscm_type_unqualified (SCM self
)
926 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
927 struct type
*type
= t_smob
->type
;
928 volatile struct gdb_exception except
;
930 TRY_CATCH (except
, RETURN_MASK_ALL
)
932 type
= make_cv_type (0, 0, type
, NULL
);
934 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
936 return tyscm_scm_from_type (type
);
939 /* Field related accessors of types. */
941 /* (type-num-fields <gdb:type>) -> integer
942 Return number of fields. */
945 gdbscm_type_num_fields (SCM self
)
948 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
949 struct type
*type
= t_smob
->type
;
951 type
= tyscm_get_composite (type
);
953 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
954 _(not_composite_error
));
956 return scm_from_long (TYPE_NFIELDS (type
));
959 /* (type-field <gdb:type> string) -> <gdb:field>
960 Return the <gdb:field> object for the field named by the argument. */
963 gdbscm_type_field (SCM self
, SCM field_scm
)
966 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
967 struct type
*type
= t_smob
->type
;
970 struct cleanup
*cleanups
;
972 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
975 /* We want just fields of this type, not of base types, so instead of
976 using lookup_struct_elt_type, portions of that function are
979 type
= tyscm_get_composite (type
);
981 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
982 _(not_composite_error
));
984 field
= gdbscm_scm_to_c_string (field_scm
);
985 cleanups
= make_cleanup (xfree
, field
);
987 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
989 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
991 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
993 do_cleanups (cleanups
);
994 return tyscm_make_field_smob (self
, i
);
998 do_cleanups (cleanups
);
1000 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1001 _("Unknown field"));
1004 /* (type-has-field? <gdb:type> string) -> boolean
1005 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1008 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1011 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1012 struct type
*type
= t_smob
->type
;
1015 struct cleanup
*cleanups
;
1017 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1020 /* We want just fields of this type, not of base types, so instead of
1021 using lookup_struct_elt_type, portions of that function are
1024 type
= tyscm_get_composite (type
);
1026 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1027 _(not_composite_error
));
1029 field
= gdbscm_scm_to_c_string (field_scm
);
1030 cleanups
= make_cleanup (xfree
, field
);
1032 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1034 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1036 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1038 do_cleanups (cleanups
);
1043 do_cleanups (cleanups
);
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 field
*field
= tyscm_field_smob_to_field (f_smob
);
1218 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1220 if (TYPE_CODE (type
) == TYPE_CODE_CLASS
)
1221 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1225 /* Return the type named TYPE_NAME in BLOCK.
1226 Returns NULL if not found.
1227 This routine does not throw an error. */
1229 static struct type
*
1230 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1232 struct type
*type
= NULL
;
1233 volatile struct gdb_exception except
;
1235 TRY_CATCH (except
, RETURN_MASK_ALL
)
1237 if (!strncmp (type_name
, "struct ", 7))
1238 type
= lookup_struct (type_name
+ 7, NULL
);
1239 else if (!strncmp (type_name
, "union ", 6))
1240 type
= lookup_union (type_name
+ 6, NULL
);
1241 else if (!strncmp (type_name
, "enum ", 5))
1242 type
= lookup_enum (type_name
+ 5, NULL
);
1244 type
= lookup_typename (current_language
, get_current_arch (),
1245 type_name
, block
, 0);
1247 if (except
.reason
< 0)
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, gdbscm_type_p
,
1331 Return #t if the object is a <gdb:type> object." },
1333 { "lookup-type", 1, 0, 1, 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, gdbscm_type_code
,
1342 Return the code of the type" },
1344 { "type-tag", 1, 0, 0, gdbscm_type_tag
,
1346 Return the tag name of the type, or #f if there isn't one." },
1348 { "type-name", 1, 0, 0, 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, gdbscm_type_print_name
,
1354 Return the print name of the type as a string." },
1356 { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof
,
1358 Return the size of the type, in bytes." },
1360 { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs
,
1362 Return a type formed by stripping the type of all typedefs." },
1364 { "type-array", 2, 1, 0, gdbscm_type_array
,
1366 Return a type representing an array of objects of the type.\n\
1368 Arguments: <gdb:type> [low-bound] high-bound\n\
1369 If low-bound is not provided zero is used.\n\
1370 N.B. If only the high-bound parameter is specified, it is not\n\
1372 Valid bounds for array indices are [low-bound,high-bound]." },
1374 { "type-vector", 2, 1, 0, gdbscm_type_vector
,
1376 Return a type representing a vector of objects of the type.\n\
1377 Vectors differ from arrays in that if the current language has C-style\n\
1378 arrays, vectors don't decay to a pointer to the first element.\n\
1379 They are first class values.\n\
1381 Arguments: <gdb:type> [low-bound] high-bound\n\
1382 If low-bound is not provided zero is used.\n\
1383 N.B. If only the high-bound parameter is specified, it is not\n\
1385 Valid bounds for array indices are [low-bound,high-bound]." },
1387 { "type-pointer", 1, 0, 0, gdbscm_type_pointer
,
1389 Return a type of pointer to the type." },
1391 { "type-range", 1, 0, 0, gdbscm_type_range
,
1393 Return (low high) representing the range for the type." },
1395 { "type-reference", 1, 0, 0, gdbscm_type_reference
,
1397 Return a type of reference to the type." },
1399 { "type-target", 1, 0, 0, gdbscm_type_target
,
1401 Return the target type of the type." },
1403 { "type-const", 1, 0, 0, gdbscm_type_const
,
1405 Return a const variant of the type." },
1407 { "type-volatile", 1, 0, 0, gdbscm_type_volatile
,
1409 Return a volatile variant of the type." },
1411 { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified
,
1413 Return a variant of the type without const or volatile attributes." },
1415 { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields
,
1417 Return the number of fields of the type." },
1419 { "type-fields", 1, 0, 0, gdbscm_type_fields
,
1421 Return the list of <gdb:field> objects of fields of the type." },
1423 { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator
,
1425 Return a <gdb:iterator> object for iterating over the fields of the type." },
1427 { "type-field", 2, 0, 0, gdbscm_type_field
,
1429 Return the field named by string of the type.\n\
1431 Arguments: <gdb:type> string" },
1433 { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p
,
1435 Return #t if the type has field named string.\n\
1437 Arguments: <gdb:type> string" },
1439 { "field?", 1, 0, 0, gdbscm_field_p
,
1441 Return #t if the object is a <gdb:field> object." },
1443 { "field-name", 1, 0, 0, gdbscm_field_name
,
1445 Return the name of the field." },
1447 { "field-type", 1, 0, 0, gdbscm_field_type
,
1449 Return the type of the field." },
1451 { "field-enumval", 1, 0, 0, gdbscm_field_enumval
,
1453 Return the enum value represented by the field." },
1455 { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos
,
1457 Return the offset in bits of the field in its containing type." },
1459 { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize
,
1461 Return the size of the field in bits." },
1463 { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p
,
1465 Return #t if the field is artificial." },
1467 { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p
,
1469 Return #t if the field is a baseclass." },
1475 gdbscm_initialize_types (void)
1477 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1478 scm_set_smob_mark (type_smob_tag
, tyscm_mark_type_smob
);
1479 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1480 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1481 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1483 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1484 sizeof (field_smob
));
1485 scm_set_smob_mark (field_smob_tag
, tyscm_mark_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 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
);