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
)
189 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
192 return gdbscm_mark_eqable_gsmob (&t_smob
->base
);
195 /* The smob "free" function for <gdb:type>. */
198 tyscm_free_type_smob (SCM self
)
200 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
202 if (t_smob
->type
!= NULL
)
204 htab_t htab
= tyscm_type_map (t_smob
->type
);
206 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &t_smob
->base
);
209 /* Not necessary, done to catch bugs. */
215 /* The smob "print" function for <gdb:type>. */
218 tyscm_print_type_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
220 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (self
);
222 char *name
= tyscm_type_name (t_smob
->type
, &exception
);
225 gdbscm_throw (exception
);
227 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
228 invoked by write/~S. What to do here may need to evolve.
229 IWBN if we could pass an argument to format that would we could use
230 instead of writingp. */
231 if (pstate
->writingp
)
232 gdbscm_printf (port
, "#<%s ", type_smob_name
);
234 scm_puts (name
, port
);
236 if (pstate
->writingp
)
237 scm_puts (">", port
);
239 scm_remember_upto_here_1 (self
);
241 /* Non-zero means success. */
245 /* The smob "equal?" function for <gdb:type>. */
248 tyscm_equal_p_type_smob (SCM type1_scm
, SCM type2_scm
)
250 type_smob
*type1_smob
, *type2_smob
;
251 struct type
*type1
, *type2
;
253 volatile struct gdb_exception except
;
255 SCM_ASSERT_TYPE (tyscm_is_type (type1_scm
), type1_scm
, SCM_ARG1
, FUNC_NAME
,
257 SCM_ASSERT_TYPE (tyscm_is_type (type2_scm
), type2_scm
, SCM_ARG2
, FUNC_NAME
,
259 type1_smob
= (type_smob
*) SCM_SMOB_DATA (type1_scm
);
260 type2_smob
= (type_smob
*) SCM_SMOB_DATA (type2_scm
);
261 type1
= type1_smob
->type
;
262 type2
= type2_smob
->type
;
264 TRY_CATCH (except
, RETURN_MASK_ALL
)
266 result
= types_deeply_equal (type1
, type2
);
268 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
270 return scm_from_bool (result
);
273 /* Low level routine to create a <gdb:type> object. */
276 tyscm_make_type_smob (void)
278 type_smob
*t_smob
= (type_smob
*)
279 scm_gc_malloc (sizeof (type_smob
), type_smob_name
);
282 /* This must be filled in by the caller. */
285 t_scm
= scm_new_smob (type_smob_tag
, (scm_t_bits
) t_smob
);
286 gdbscm_init_eqable_gsmob (&t_smob
->base
, t_scm
);
291 /* Return non-zero if SCM is a <gdb:type> object. */
294 tyscm_is_type (SCM self
)
296 return SCM_SMOB_PREDICATE (type_smob_tag
, self
);
299 /* (type? object) -> boolean */
302 gdbscm_type_p (SCM self
)
304 return scm_from_bool (tyscm_is_type (self
));
307 /* Return the existing object that encapsulates TYPE, or create a new
308 <gdb:type> object. */
311 tyscm_scm_from_type (struct type
*type
)
314 eqable_gdb_smob
**slot
;
315 type_smob
*t_smob
, t_smob_for_lookup
;
318 /* If we've already created a gsmob for this type, return it.
319 This makes types eq?-able. */
320 htab
= tyscm_type_map (type
);
321 t_smob_for_lookup
.type
= type
;
322 slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
324 return (*slot
)->containing_scm
;
326 t_scm
= tyscm_make_type_smob ();
327 t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
329 gdbscm_fill_eqable_gsmob_ptr_slot (slot
, &t_smob
->base
);
334 /* Returns the <gdb:type> object in SELF.
335 Throws an exception if SELF is not a <gdb:type> object. */
338 tyscm_get_type_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
340 SCM_ASSERT_TYPE (tyscm_is_type (self
), self
, arg_pos
, func_name
,
346 /* Returns a pointer to the type smob of SELF.
347 Throws an exception if SELF is not a <gdb:type> object. */
350 tyscm_get_type_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
352 SCM t_scm
= tyscm_get_type_arg_unsafe (self
, arg_pos
, func_name
);
353 type_smob
*t_smob
= (type_smob
*) SCM_SMOB_DATA (t_scm
);
358 /* Helper function for save_objfile_types to make a deep copy of the type. */
361 tyscm_copy_type_recursive (void **slot
, void *info
)
363 type_smob
*t_smob
= (type_smob
*) *slot
;
364 htab_t copied_types
= info
;
365 struct objfile
*objfile
= TYPE_OBJFILE (t_smob
->type
);
367 eqable_gdb_smob
**new_slot
;
368 type_smob t_smob_for_lookup
;
370 gdb_assert (objfile
!= NULL
);
372 htab_empty (copied_types
);
373 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
375 /* The eq?-hashtab that the type lived in is going away.
376 Add the type to its new eq?-hashtab: Otherwise if/when the type is later
377 garbage collected we'll assert-fail if the type isn't in the hashtab.
380 Types now live in "arch space", and things like "char" that came from
381 the objfile *could* be considered eq? with the arch "char" type.
382 However, they weren't before the objfile got deleted, so making them
383 eq? now is debatable. */
384 htab
= tyscm_type_map (t_smob
->type
);
385 t_smob_for_lookup
.type
= t_smob
->type
;
386 new_slot
= gdbscm_find_eqable_gsmob_ptr_slot (htab
, &t_smob_for_lookup
.base
);
387 gdb_assert (*new_slot
== NULL
);
388 gdbscm_fill_eqable_gsmob_ptr_slot (new_slot
, &t_smob
->base
);
393 /* Called when OBJFILE is about to be deleted.
394 Make a copy of all types associated with OBJFILE. */
397 save_objfile_types (struct objfile
*objfile
, void *datum
)
402 if (!gdb_scheme_initialized
)
405 copied_types
= create_copied_types_hash (objfile
);
409 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
413 htab_delete (copied_types
);
416 /* Administrivia for field smobs. */
418 /* The smob "mark" function for <gdb:field>. */
421 tyscm_mark_field_smob (SCM self
)
423 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
425 scm_gc_mark (f_smob
->type_scm
);
427 return gdbscm_mark_gsmob (&f_smob
->base
);
430 /* The smob "print" function for <gdb:field>. */
433 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
435 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
437 gdbscm_printf (port
, "#<%s ", field_smob_name
);
438 scm_write (f_smob
->type_scm
, port
);
439 gdbscm_printf (port
, " %d", f_smob
->field_num
);
440 scm_puts (">", port
);
442 scm_remember_upto_here_1 (self
);
444 /* Non-zero means success. */
448 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
452 tyscm_make_field_smob (SCM type_scm
, int field_num
)
454 field_smob
*f_smob
= (field_smob
*)
455 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
458 f_smob
->type_scm
= type_scm
;
459 f_smob
->field_num
= field_num
;
460 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
461 gdbscm_init_gsmob (&f_smob
->base
);
466 /* Return non-zero if SCM is a <gdb:field> object. */
469 tyscm_is_field (SCM self
)
471 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
474 /* (field? object) -> boolean */
477 gdbscm_field_p (SCM self
)
479 return scm_from_bool (tyscm_is_field (self
));
482 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
486 tyscm_scm_from_field (SCM type_scm
, int field_num
)
488 return tyscm_make_field_smob (type_scm
, field_num
);
491 /* Returns the <gdb:field> object in SELF.
492 Throws an exception if SELF is not a <gdb:field> object. */
495 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
497 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
503 /* Returns a pointer to the field smob of SELF.
504 Throws an exception if SELF is not a <gdb:field> object. */
507 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
509 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
510 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
515 /* Returns a pointer to the type struct in F_SMOB
516 (the type the field is in). */
519 tyscm_field_smob_containing_type (field_smob
*f_smob
)
523 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
524 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
529 /* Returns a pointer to the field struct of F_SMOB. */
531 static struct field
*
532 tyscm_field_smob_to_field (field_smob
*f_smob
)
534 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
536 /* This should be non-NULL by construction. */
537 gdb_assert (TYPE_FIELDS (type
) != NULL
);
539 return &TYPE_FIELD (type
, f_smob
->field_num
);
542 /* Type smob accessors. */
544 /* (type-code <gdb:type>) -> integer
545 Return the code for this type. */
548 gdbscm_type_code (SCM self
)
551 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
552 struct type
*type
= t_smob
->type
;
554 return scm_from_int (TYPE_CODE (type
));
557 /* (type-fields <gdb:type>) -> list
558 Return a list of all fields. Each element is a <gdb:field> object.
559 This also supports arrays, we return a field list of one element,
563 gdbscm_type_fields (SCM self
)
566 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
567 struct type
*type
= t_smob
->type
;
568 struct type
*containing_type
;
569 SCM containing_type_scm
, result
;
572 containing_type
= tyscm_get_composite (type
);
573 if (containing_type
== NULL
)
574 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
575 _(not_composite_error
));
577 /* If SELF is a typedef or reference, we want the underlying type,
578 which is what tyscm_get_composite returns. */
579 if (containing_type
== type
)
580 containing_type_scm
= self
;
582 containing_type_scm
= tyscm_scm_from_type (containing_type
);
585 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
586 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
588 return scm_reverse_x (result
, SCM_EOL
);
591 /* (type-tag <gdb:type>) -> string
592 Return the type's tag, or #f. */
595 gdbscm_type_tag (SCM self
)
598 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
599 struct type
*type
= t_smob
->type
;
601 if (!TYPE_TAG_NAME (type
))
603 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
606 /* (type-name <gdb:type>) -> string
607 Return the type's name, or #f. */
610 gdbscm_type_name (SCM self
)
613 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
614 struct type
*type
= t_smob
->type
;
616 if (!TYPE_NAME (type
))
618 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
621 /* (type-print-name <gdb:type>) -> string
622 Return the print name of type.
623 TODO: template support elided for now. */
626 gdbscm_type_print_name (SCM self
)
629 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
630 struct type
*type
= t_smob
->type
;
632 SCM exception
, result
;
634 thetype
= tyscm_type_name (type
, &exception
);
637 gdbscm_throw (exception
);
639 result
= gdbscm_scm_from_c_string (thetype
);
645 /* (type-sizeof <gdb:type>) -> integer
646 Return the size of the type represented by SELF, in bytes. */
649 gdbscm_type_sizeof (SCM self
)
652 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
653 struct type
*type
= t_smob
->type
;
654 volatile struct gdb_exception except
;
656 TRY_CATCH (except
, RETURN_MASK_ALL
)
658 check_typedef (type
);
660 /* Ignore exceptions. */
662 return scm_from_long (TYPE_LENGTH (type
));
665 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
666 Return the type, stripped of typedefs. */
669 gdbscm_type_strip_typedefs (SCM self
)
672 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
673 struct type
*type
= t_smob
->type
;
674 volatile struct gdb_exception except
;
676 TRY_CATCH (except
, RETURN_MASK_ALL
)
678 type
= check_typedef (type
);
680 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
682 return tyscm_scm_from_type (type
);
685 /* Strip typedefs and pointers/reference from a type. Then check that
686 it is a struct, union, or enum type. If not, return NULL. */
689 tyscm_get_composite (struct type
*type
)
691 volatile struct gdb_exception except
;
695 TRY_CATCH (except
, RETURN_MASK_ALL
)
697 type
= check_typedef (type
);
699 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
701 if (TYPE_CODE (type
) != TYPE_CODE_PTR
702 && TYPE_CODE (type
) != TYPE_CODE_REF
)
704 type
= TYPE_TARGET_TYPE (type
);
707 /* If this is not a struct, union, or enum type, raise TypeError
709 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
710 && TYPE_CODE (type
) != TYPE_CODE_UNION
711 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
717 /* Helper for tyscm_array and tyscm_vector. */
720 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
721 const char *func_name
)
724 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
725 struct type
*type
= t_smob
->type
;
727 struct type
*array
= NULL
;
728 volatile struct gdb_exception except
;
730 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
731 n1_scm
, &n1
, n2_scm
, &n2
);
733 if (SCM_UNBNDP (n2_scm
))
741 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
742 scm_cons (scm_from_long (n1
),
744 _("Array length must not be negative"));
747 TRY_CATCH (except
, RETURN_MASK_ALL
)
749 array
= lookup_array_range_type (type
, n1
, n2
);
751 make_vector_type (array
);
753 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
755 return tyscm_scm_from_type (array
);
758 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
759 The array has indices [low-bound,high-bound].
760 If low-bound is not provided zero is used.
761 Return an array type.
763 IWBN if the one argument version specified a size, not the high bound.
764 It's too easy to pass one argument thinking it is the size of the array.
765 The current semantics are for compatibility with the Python version.
766 Later we can add #:size. */
769 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
771 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
774 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
775 The array has indices [low-bound,high-bound].
776 If low-bound is not provided zero is used.
777 Return a vector type.
779 IWBN if the one argument version specified a size, not the high bound.
780 It's too easy to pass one argument thinking it is the size of the array.
781 The current semantics are for compatibility with the Python version.
782 Later we can add #:size. */
785 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
787 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
790 /* (type-pointer <gdb:type>) -> <gdb:type>
791 Return a <gdb:type> object which represents a pointer to SELF. */
794 gdbscm_type_pointer (SCM self
)
797 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
798 struct type
*type
= t_smob
->type
;
799 volatile struct gdb_exception except
;
801 TRY_CATCH (except
, RETURN_MASK_ALL
)
803 type
= lookup_pointer_type (type
);
805 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
807 return tyscm_scm_from_type (type
);
810 /* (type-range <gdb:type>) -> (low high)
811 Return the range of a type represented by SELF. The return type is
812 a list. The first element is the low bound, and the second element
813 is the high bound. */
816 gdbscm_type_range (SCM self
)
819 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
820 struct type
*type
= t_smob
->type
;
821 SCM low_scm
, high_scm
;
822 /* Initialize these to appease GCC warnings. */
823 LONGEST low
= 0, high
= 0;
825 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
826 || TYPE_CODE (type
) == TYPE_CODE_STRING
827 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
828 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
830 switch (TYPE_CODE (type
))
832 case TYPE_CODE_ARRAY
:
833 case TYPE_CODE_STRING
:
834 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
835 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
837 case TYPE_CODE_RANGE
:
838 low
= TYPE_LOW_BOUND (type
);
839 high
= TYPE_HIGH_BOUND (type
);
843 low_scm
= gdbscm_scm_from_longest (low
);
844 high_scm
= gdbscm_scm_from_longest (high
);
846 return scm_list_2 (low_scm
, high_scm
);
849 /* (type-reference <gdb:type>) -> <gdb:type>
850 Return a <gdb:type> object which represents a reference to SELF. */
853 gdbscm_type_reference (SCM self
)
856 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
857 struct type
*type
= t_smob
->type
;
858 volatile struct gdb_exception except
;
860 TRY_CATCH (except
, RETURN_MASK_ALL
)
862 type
= lookup_reference_type (type
);
864 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
866 return tyscm_scm_from_type (type
);
869 /* (type-target <gdb:type>) -> <gdb:type>
870 Return a <gdb:type> object which represents the target type of SELF. */
873 gdbscm_type_target (SCM self
)
876 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
877 struct type
*type
= t_smob
->type
;
879 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
881 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
884 /* (type-const <gdb:type>) -> <gdb:type>
885 Return a const-qualified type variant. */
888 gdbscm_type_const (SCM self
)
891 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
892 struct type
*type
= t_smob
->type
;
893 volatile struct gdb_exception except
;
895 TRY_CATCH (except
, RETURN_MASK_ALL
)
897 type
= make_cv_type (1, 0, type
, NULL
);
899 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
901 return tyscm_scm_from_type (type
);
904 /* (type-volatile <gdb:type>) -> <gdb:type>
905 Return a volatile-qualified type variant. */
908 gdbscm_type_volatile (SCM self
)
911 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
912 struct type
*type
= t_smob
->type
;
913 volatile struct gdb_exception except
;
915 TRY_CATCH (except
, RETURN_MASK_ALL
)
917 type
= make_cv_type (0, 1, type
, NULL
);
919 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
921 return tyscm_scm_from_type (type
);
924 /* (type-unqualified <gdb:type>) -> <gdb:type>
925 Return an unqualified type variant. */
928 gdbscm_type_unqualified (SCM self
)
931 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
932 struct type
*type
= t_smob
->type
;
933 volatile struct gdb_exception except
;
935 TRY_CATCH (except
, RETURN_MASK_ALL
)
937 type
= make_cv_type (0, 0, type
, NULL
);
939 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
941 return tyscm_scm_from_type (type
);
944 /* Field related accessors of types. */
946 /* (type-num-fields <gdb:type>) -> integer
947 Return number of fields. */
950 gdbscm_type_num_fields (SCM self
)
953 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
954 struct type
*type
= t_smob
->type
;
956 type
= tyscm_get_composite (type
);
958 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
959 _(not_composite_error
));
961 return scm_from_long (TYPE_NFIELDS (type
));
964 /* (type-field <gdb:type> string) -> <gdb:field>
965 Return the <gdb:field> object for the field named by the argument. */
968 gdbscm_type_field (SCM self
, SCM field_scm
)
971 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
972 struct type
*type
= t_smob
->type
;
975 struct cleanup
*cleanups
;
977 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
980 /* We want just fields of this type, not of base types, so instead of
981 using lookup_struct_elt_type, portions of that function are
984 type
= tyscm_get_composite (type
);
986 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
987 _(not_composite_error
));
989 field
= gdbscm_scm_to_c_string (field_scm
);
990 cleanups
= make_cleanup (xfree
, field
);
992 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
994 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
996 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
998 do_cleanups (cleanups
);
999 return tyscm_make_field_smob (self
, i
);
1003 do_cleanups (cleanups
);
1005 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
1006 _("Unknown field"));
1009 /* (type-has-field? <gdb:type> string) -> boolean
1010 Return boolean indicating if type SELF has FIELD_SCM (a string). */
1013 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
1016 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1017 struct type
*type
= t_smob
->type
;
1020 struct cleanup
*cleanups
;
1022 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1025 /* We want just fields of this type, not of base types, so instead of
1026 using lookup_struct_elt_type, portions of that function are
1029 type
= tyscm_get_composite (type
);
1031 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1032 _(not_composite_error
));
1034 field
= gdbscm_scm_to_c_string (field_scm
);
1035 cleanups
= make_cleanup (xfree
, field
);
1037 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1039 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1041 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1043 do_cleanups (cleanups
);
1048 do_cleanups (cleanups
);
1053 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1054 Make a field iterator object. */
1057 gdbscm_make_field_iterator (SCM self
)
1060 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1061 struct type
*type
= t_smob
->type
;
1062 struct type
*containing_type
;
1063 SCM containing_type_scm
;
1065 containing_type
= tyscm_get_composite (type
);
1066 if (containing_type
== NULL
)
1067 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1068 _(not_composite_error
));
1070 /* If SELF is a typedef or reference, we want the underlying type,
1071 which is what tyscm_get_composite returns. */
1072 if (containing_type
== type
)
1073 containing_type_scm
= self
;
1075 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1077 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1078 tyscm_next_field_x_proc
);
1081 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1082 Return the next field in the iteration through the list of fields of the
1083 type, or (end-of-iteration).
1084 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1085 This is the next! <gdb:iterator> function, not exported to the user. */
1088 gdbscm_type_next_field_x (SCM self
)
1090 iterator_smob
*i_smob
;
1093 SCM it_scm
, result
, progress
, object
;
1096 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1097 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1098 object
= itscm_iterator_smob_object (i_smob
);
1099 progress
= itscm_iterator_smob_progress (i_smob
);
1101 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1102 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1103 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1104 type
= t_smob
->type
;
1106 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1107 0, TYPE_NFIELDS (type
)),
1108 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1109 field
= scm_to_int (progress
);
1111 if (field
< TYPE_NFIELDS (type
))
1113 result
= tyscm_make_field_smob (object
, field
);
1114 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1118 return gdbscm_end_of_iteration ();
1121 /* Field smob accessors. */
1123 /* (field-name <gdb:field>) -> string
1124 Return the name of this field or #f if there isn't one. */
1127 gdbscm_field_name (SCM self
)
1130 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1131 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1133 if (FIELD_NAME (*field
))
1134 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1138 /* (field-type <gdb:field>) -> <gdb:type>
1139 Return the <gdb:type> object of the field or #f if there isn't one. */
1142 gdbscm_field_type (SCM self
)
1145 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1146 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1148 /* A field can have a NULL type in some situations. */
1149 if (FIELD_TYPE (*field
))
1150 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1154 /* (field-enumval <gdb:field>) -> integer
1155 For enum values, return its value as an integer. */
1158 gdbscm_field_enumval (SCM self
)
1161 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1162 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1163 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1165 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1166 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1168 return scm_from_long (FIELD_ENUMVAL (*field
));
1171 /* (field-bitpos <gdb:field>) -> integer
1172 For bitfields, return its offset in bits. */
1175 gdbscm_field_bitpos (SCM self
)
1178 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1179 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1180 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1182 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1183 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1185 return scm_from_long (FIELD_BITPOS (*field
));
1188 /* (field-bitsize <gdb:field>) -> integer
1189 Return the size of the field in bits. */
1192 gdbscm_field_bitsize (SCM self
)
1195 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1196 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1198 return scm_from_long (FIELD_BITPOS (*field
));
1201 /* (field-artificial? <gdb:field>) -> boolean
1202 Return #t if field is artificial. */
1205 gdbscm_field_artificial_p (SCM self
)
1208 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1209 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1211 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1214 /* (field-baseclass? <gdb:field>) -> boolean
1215 Return #t if field is a baseclass. */
1218 gdbscm_field_baseclass_p (SCM self
)
1221 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1222 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1223 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1225 if (TYPE_CODE (type
) == TYPE_CODE_CLASS
)
1226 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1230 /* Return the type named TYPE_NAME in BLOCK.
1231 Returns NULL if not found.
1232 This routine does not throw an error. */
1234 static struct type
*
1235 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1237 struct type
*type
= NULL
;
1238 volatile struct gdb_exception except
;
1240 TRY_CATCH (except
, RETURN_MASK_ALL
)
1242 if (!strncmp (type_name
, "struct ", 7))
1243 type
= lookup_struct (type_name
+ 7, NULL
);
1244 else if (!strncmp (type_name
, "union ", 6))
1245 type
= lookup_union (type_name
+ 6, NULL
);
1246 else if (!strncmp (type_name
, "enum ", 5))
1247 type
= lookup_enum (type_name
+ 5, NULL
);
1249 type
= lookup_typename (current_language
, get_current_arch (),
1250 type_name
, block
, 0);
1252 if (except
.reason
< 0)
1258 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1259 TODO: legacy template support left out until needed. */
1262 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1264 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1266 SCM block_scm
= SCM_BOOL_F
;
1267 int block_arg_pos
= -1;
1268 const struct block
*block
= NULL
;
1271 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1273 rest
, &block_arg_pos
, &block_scm
);
1275 if (block_arg_pos
!= -1)
1279 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1284 gdbscm_throw (exception
);
1287 type
= tyscm_lookup_typename (name
, block
);
1291 return tyscm_scm_from_type (type
);
1295 /* Initialize the Scheme type code. */
1298 static const scheme_integer_constant type_integer_constants
[] =
1300 #define X(SYM) { #SYM, SYM }
1301 X (TYPE_CODE_BITSTRING
),
1303 X (TYPE_CODE_ARRAY
),
1304 X (TYPE_CODE_STRUCT
),
1305 X (TYPE_CODE_UNION
),
1307 X (TYPE_CODE_FLAGS
),
1313 X (TYPE_CODE_RANGE
),
1314 X (TYPE_CODE_STRING
),
1315 X (TYPE_CODE_ERROR
),
1316 X (TYPE_CODE_METHOD
),
1317 X (TYPE_CODE_METHODPTR
),
1318 X (TYPE_CODE_MEMBERPTR
),
1322 X (TYPE_CODE_COMPLEX
),
1323 X (TYPE_CODE_TYPEDEF
),
1324 X (TYPE_CODE_NAMESPACE
),
1325 X (TYPE_CODE_DECFLOAT
),
1326 X (TYPE_CODE_INTERNAL_FUNCTION
),
1329 END_INTEGER_CONSTANTS
1332 static const scheme_function type_functions
[] =
1334 { "type?", 1, 0, 0, gdbscm_type_p
,
1336 Return #t if the object is a <gdb:type> object." },
1338 { "lookup-type", 1, 0, 1, gdbscm_lookup_type
,
1340 Return the <gdb:type> object representing string or #f if not found.\n\
1341 If block is given then the type is looked for in that block.\n\
1343 Arguments: string [#:block <gdb:block>]" },
1345 { "type-code", 1, 0, 0, gdbscm_type_code
,
1347 Return the code of the type" },
1349 { "type-tag", 1, 0, 0, gdbscm_type_tag
,
1351 Return the tag name of the type, or #f if there isn't one." },
1353 { "type-name", 1, 0, 0, gdbscm_type_name
,
1355 Return the name of the type as a string, or #f if there isn't one." },
1357 { "type-print-name", 1, 0, 0, gdbscm_type_print_name
,
1359 Return the print name of the type as a string." },
1361 { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof
,
1363 Return the size of the type, in bytes." },
1365 { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs
,
1367 Return a type formed by stripping the type of all typedefs." },
1369 { "type-array", 2, 1, 0, gdbscm_type_array
,
1371 Return a type representing an array of objects of the type.\n\
1373 Arguments: <gdb:type> [low-bound] high-bound\n\
1374 If low-bound is not provided zero is used.\n\
1375 N.B. If only the high-bound parameter is specified, it is not\n\
1377 Valid bounds for array indices are [low-bound,high-bound]." },
1379 { "type-vector", 2, 1, 0, gdbscm_type_vector
,
1381 Return a type representing a vector of objects of the type.\n\
1382 Vectors differ from arrays in that if the current language has C-style\n\
1383 arrays, vectors don't decay to a pointer to the first element.\n\
1384 They are first class values.\n\
1386 Arguments: <gdb:type> [low-bound] high-bound\n\
1387 If low-bound is not provided zero is used.\n\
1388 N.B. If only the high-bound parameter is specified, it is not\n\
1390 Valid bounds for array indices are [low-bound,high-bound]." },
1392 { "type-pointer", 1, 0, 0, gdbscm_type_pointer
,
1394 Return a type of pointer to the type." },
1396 { "type-range", 1, 0, 0, gdbscm_type_range
,
1398 Return (low high) representing the range for the type." },
1400 { "type-reference", 1, 0, 0, gdbscm_type_reference
,
1402 Return a type of reference to the type." },
1404 { "type-target", 1, 0, 0, gdbscm_type_target
,
1406 Return the target type of the type." },
1408 { "type-const", 1, 0, 0, gdbscm_type_const
,
1410 Return a const variant of the type." },
1412 { "type-volatile", 1, 0, 0, gdbscm_type_volatile
,
1414 Return a volatile variant of the type." },
1416 { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified
,
1418 Return a variant of the type without const or volatile attributes." },
1420 { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields
,
1422 Return the number of fields of the type." },
1424 { "type-fields", 1, 0, 0, gdbscm_type_fields
,
1426 Return the list of <gdb:field> objects of fields of the type." },
1428 { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator
,
1430 Return a <gdb:iterator> object for iterating over the fields of the type." },
1432 { "type-field", 2, 0, 0, gdbscm_type_field
,
1434 Return the field named by string of the type.\n\
1436 Arguments: <gdb:type> string" },
1438 { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p
,
1440 Return #t if the type has field named string.\n\
1442 Arguments: <gdb:type> string" },
1444 { "field?", 1, 0, 0, gdbscm_field_p
,
1446 Return #t if the object is a <gdb:field> object." },
1448 { "field-name", 1, 0, 0, gdbscm_field_name
,
1450 Return the name of the field." },
1452 { "field-type", 1, 0, 0, gdbscm_field_type
,
1454 Return the type of the field." },
1456 { "field-enumval", 1, 0, 0, gdbscm_field_enumval
,
1458 Return the enum value represented by the field." },
1460 { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos
,
1462 Return the offset in bits of the field in its containing type." },
1464 { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize
,
1466 Return the size of the field in bits." },
1468 { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p
,
1470 Return #t if the field is artificial." },
1472 { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p
,
1474 Return #t if the field is a baseclass." },
1480 gdbscm_initialize_types (void)
1482 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1483 scm_set_smob_mark (type_smob_tag
, tyscm_mark_type_smob
);
1484 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1485 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1486 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1488 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1489 sizeof (field_smob
));
1490 scm_set_smob_mark (field_smob_tag
, tyscm_mark_field_smob
);
1491 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1493 gdbscm_define_integer_constants (type_integer_constants
, 1);
1494 gdbscm_define_functions (type_functions
, 1);
1496 /* This function is "private". */
1497 tyscm_next_field_x_proc
1498 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1499 gdbscm_type_next_field_x
);
1500 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1501 gdbscm_documentation_symbol
,
1502 gdbscm_scm_from_c_string ("\
1503 Internal function to assist the type fields iterator."));
1505 block_keyword
= scm_from_latin1_keyword ("block");
1507 /* Register an objfile "free" callback so we can properly copy types
1508 associated with the objfile when it's about to be deleted. */
1509 tyscm_objfile_data_key
1510 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1512 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1513 tyscm_eq_type_smob
);