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
);
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
, t_scm
);
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 gdb_assert (objfile
!= NULL
);
369 htab_empty (copied_types
);
370 t_smob
->type
= copy_type_recursive (objfile
, t_smob
->type
, copied_types
);
374 /* Called when OBJFILE is about to be deleted.
375 Make a copy of all types associated with OBJFILE. */
378 save_objfile_types (struct objfile
*objfile
, void *datum
)
383 if (!gdb_scheme_initialized
)
386 copied_types
= create_copied_types_hash (objfile
);
390 htab_traverse_noresize (htab
, tyscm_copy_type_recursive
, copied_types
);
394 htab_delete (copied_types
);
397 /* Administrivia for field smobs. */
399 /* The smob "mark" function for <gdb:field>. */
402 tyscm_mark_field_smob (SCM self
)
404 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
406 scm_gc_mark (f_smob
->type_scm
);
408 return gdbscm_mark_gsmob (&f_smob
->base
);
411 /* The smob "print" function for <gdb:field>. */
414 tyscm_print_field_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
416 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (self
);
418 gdbscm_printf (port
, "#<%s ", field_smob_name
);
419 scm_write (f_smob
->type_scm
, port
);
420 gdbscm_printf (port
, " %d", f_smob
->field_num
);
421 scm_puts (">", port
);
423 scm_remember_upto_here_1 (self
);
425 /* Non-zero means success. */
429 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
433 tyscm_make_field_smob (SCM type_scm
, int field_num
)
435 field_smob
*f_smob
= (field_smob
*)
436 scm_gc_malloc (sizeof (field_smob
), field_smob_name
);
439 f_smob
->type_scm
= type_scm
;
440 f_smob
->field_num
= field_num
;
441 result
= scm_new_smob (field_smob_tag
, (scm_t_bits
) f_smob
);
442 gdbscm_init_gsmob (&f_smob
->base
);
447 /* Return non-zero if SCM is a <gdb:field> object. */
450 tyscm_is_field (SCM self
)
452 return SCM_SMOB_PREDICATE (field_smob_tag
, self
);
455 /* (field? object) -> boolean */
458 gdbscm_field_p (SCM self
)
460 return scm_from_bool (tyscm_is_field (self
));
463 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
467 tyscm_scm_from_field (SCM type_scm
, int field_num
)
469 return tyscm_make_field_smob (type_scm
, field_num
);
472 /* Returns the <gdb:field> object in SELF.
473 Throws an exception if SELF is not a <gdb:field> object. */
476 tyscm_get_field_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
478 SCM_ASSERT_TYPE (tyscm_is_field (self
), self
, arg_pos
, func_name
,
484 /* Returns a pointer to the field smob of SELF.
485 Throws an exception if SELF is not a <gdb:field> object. */
488 tyscm_get_field_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
490 SCM f_scm
= tyscm_get_field_arg_unsafe (self
, arg_pos
, func_name
);
491 field_smob
*f_smob
= (field_smob
*) SCM_SMOB_DATA (f_scm
);
496 /* Returns a pointer to the type struct in F_SMOB
497 (the type the field is in). */
500 tyscm_field_smob_containing_type (field_smob
*f_smob
)
504 gdb_assert (tyscm_is_type (f_smob
->type_scm
));
505 t_smob
= (type_smob
*) SCM_SMOB_DATA (f_smob
->type_scm
);
510 /* Returns a pointer to the field struct of F_SMOB. */
512 static struct field
*
513 tyscm_field_smob_to_field (field_smob
*f_smob
)
515 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
517 /* This should be non-NULL by construction. */
518 gdb_assert (TYPE_FIELDS (type
) != NULL
);
520 return &TYPE_FIELD (type
, f_smob
->field_num
);
523 /* Type smob accessors. */
525 /* (type-code <gdb:type>) -> integer
526 Return the code for this type. */
529 gdbscm_type_code (SCM self
)
532 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
533 struct type
*type
= t_smob
->type
;
535 return scm_from_int (TYPE_CODE (type
));
538 /* (type-fields <gdb:type>) -> list
539 Return a list of all fields. Each element is a <gdb:field> object.
540 This also supports arrays, we return a field list of one element,
544 gdbscm_type_fields (SCM self
)
547 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
548 struct type
*type
= t_smob
->type
;
549 struct type
*containing_type
;
550 SCM containing_type_scm
, result
;
553 containing_type
= tyscm_get_composite (type
);
554 if (containing_type
== NULL
)
555 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
556 _(not_composite_error
));
558 /* If SELF is a typedef or reference, we want the underlying type,
559 which is what tyscm_get_composite returns. */
560 if (containing_type
== type
)
561 containing_type_scm
= self
;
563 containing_type_scm
= tyscm_scm_from_type (containing_type
);
566 for (i
= 0; i
< TYPE_NFIELDS (containing_type
); ++i
)
567 result
= scm_cons (tyscm_make_field_smob (containing_type_scm
, i
), result
);
569 return scm_reverse_x (result
, SCM_EOL
);
572 /* (type-tag <gdb:type>) -> string
573 Return the type's tag, or #f. */
576 gdbscm_type_tag (SCM self
)
579 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
580 struct type
*type
= t_smob
->type
;
582 if (!TYPE_TAG_NAME (type
))
584 return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type
));
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
;
597 if (!TYPE_NAME (type
))
599 return gdbscm_scm_from_c_string (TYPE_NAME (type
));
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
;
613 SCM exception
, result
;
615 thetype
= tyscm_type_name (type
, &exception
);
618 gdbscm_throw (exception
);
620 result
= gdbscm_scm_from_c_string (thetype
);
626 /* (type-sizeof <gdb:type>) -> integer
627 Return the size of the type represented by SELF, in bytes. */
630 gdbscm_type_sizeof (SCM self
)
633 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
634 struct type
*type
= t_smob
->type
;
635 volatile struct gdb_exception except
;
637 TRY_CATCH (except
, RETURN_MASK_ALL
)
639 check_typedef (type
);
641 /* Ignore exceptions. */
643 return scm_from_long (TYPE_LENGTH (type
));
646 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
647 Return the type, stripped of typedefs. */
650 gdbscm_type_strip_typedefs (SCM self
)
653 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
654 struct type
*type
= t_smob
->type
;
655 volatile struct gdb_exception except
;
657 TRY_CATCH (except
, RETURN_MASK_ALL
)
659 type
= check_typedef (type
);
661 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
663 return tyscm_scm_from_type (type
);
666 /* Strip typedefs and pointers/reference from a type. Then check that
667 it is a struct, union, or enum type. If not, return NULL. */
670 tyscm_get_composite (struct type
*type
)
672 volatile struct gdb_exception except
;
676 TRY_CATCH (except
, RETURN_MASK_ALL
)
678 type
= check_typedef (type
);
680 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
682 if (TYPE_CODE (type
) != TYPE_CODE_PTR
683 && TYPE_CODE (type
) != TYPE_CODE_REF
)
685 type
= TYPE_TARGET_TYPE (type
);
688 /* If this is not a struct, union, or enum type, raise TypeError
690 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
691 && TYPE_CODE (type
) != TYPE_CODE_UNION
692 && TYPE_CODE (type
) != TYPE_CODE_ENUM
)
698 /* Helper for tyscm_array and tyscm_vector. */
701 tyscm_array_1 (SCM self
, SCM n1_scm
, SCM n2_scm
, int is_vector
,
702 const char *func_name
)
705 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, func_name
);
706 struct type
*type
= t_smob
->type
;
708 struct type
*array
= NULL
;
709 volatile struct gdb_exception except
;
711 gdbscm_parse_function_args (func_name
, SCM_ARG2
, NULL
, "l|l",
712 n1_scm
, &n1
, n2_scm
, &n2
);
714 if (SCM_UNBNDP (n2_scm
))
722 gdbscm_out_of_range_error (func_name
, SCM_ARG3
,
723 scm_cons (scm_from_long (n1
),
725 _("Array length must not be negative"));
728 TRY_CATCH (except
, RETURN_MASK_ALL
)
730 array
= lookup_array_range_type (type
, n1
, n2
);
732 make_vector_type (array
);
734 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
736 return tyscm_scm_from_type (array
);
739 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
740 The array has indices [low-bound,high-bound].
741 If low-bound is not provided zero is used.
742 Return an array type.
744 IWBN if the one argument version specified a size, not the high bound.
745 It's too easy to pass one argument thinking it is the size of the array.
746 The current semantics are for compatibility with the Python version.
747 Later we can add #:size. */
750 gdbscm_type_array (SCM self
, SCM n1
, SCM n2
)
752 return tyscm_array_1 (self
, n1
, n2
, 0, FUNC_NAME
);
755 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
756 The array has indices [low-bound,high-bound].
757 If low-bound is not provided zero is used.
758 Return a vector type.
760 IWBN if the one argument version specified a size, not the high bound.
761 It's too easy to pass one argument thinking it is the size of the array.
762 The current semantics are for compatibility with the Python version.
763 Later we can add #:size. */
766 gdbscm_type_vector (SCM self
, SCM n1
, SCM n2
)
768 return tyscm_array_1 (self
, n1
, n2
, 1, FUNC_NAME
);
771 /* (type-pointer <gdb:type>) -> <gdb:type>
772 Return a <gdb:type> object which represents a pointer to SELF. */
775 gdbscm_type_pointer (SCM self
)
778 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
779 struct type
*type
= t_smob
->type
;
780 volatile struct gdb_exception except
;
782 TRY_CATCH (except
, RETURN_MASK_ALL
)
784 type
= lookup_pointer_type (type
);
786 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
788 return tyscm_scm_from_type (type
);
791 /* (type-range <gdb:type>) -> (low high)
792 Return the range of a type represented by SELF. The return type is
793 a list. The first element is the low bound, and the second element
794 is the high bound. */
797 gdbscm_type_range (SCM self
)
800 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
801 struct type
*type
= t_smob
->type
;
802 SCM low_scm
, high_scm
;
803 /* Initialize these to appease GCC warnings. */
804 LONGEST low
= 0, high
= 0;
806 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ARRAY
807 || TYPE_CODE (type
) == TYPE_CODE_STRING
808 || TYPE_CODE (type
) == TYPE_CODE_RANGE
,
809 self
, SCM_ARG1
, FUNC_NAME
, _("ranged type"));
811 switch (TYPE_CODE (type
))
813 case TYPE_CODE_ARRAY
:
814 case TYPE_CODE_STRING
:
815 low
= TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
));
816 high
= TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type
));
818 case TYPE_CODE_RANGE
:
819 low
= TYPE_LOW_BOUND (type
);
820 high
= TYPE_HIGH_BOUND (type
);
824 low_scm
= gdbscm_scm_from_longest (low
);
825 high_scm
= gdbscm_scm_from_longest (high
);
827 return scm_list_2 (low_scm
, high_scm
);
830 /* (type-reference <gdb:type>) -> <gdb:type>
831 Return a <gdb:type> object which represents a reference to SELF. */
834 gdbscm_type_reference (SCM self
)
837 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
838 struct type
*type
= t_smob
->type
;
839 volatile struct gdb_exception except
;
841 TRY_CATCH (except
, RETURN_MASK_ALL
)
843 type
= lookup_reference_type (type
);
845 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
847 return tyscm_scm_from_type (type
);
850 /* (type-target <gdb:type>) -> <gdb:type>
851 Return a <gdb:type> object which represents the target type of SELF. */
854 gdbscm_type_target (SCM self
)
857 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
858 struct type
*type
= t_smob
->type
;
860 SCM_ASSERT (TYPE_TARGET_TYPE (type
), self
, SCM_ARG1
, FUNC_NAME
);
862 return tyscm_scm_from_type (TYPE_TARGET_TYPE (type
));
865 /* (type-const <gdb:type>) -> <gdb:type>
866 Return a const-qualified type variant. */
869 gdbscm_type_const (SCM self
)
872 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
873 struct type
*type
= t_smob
->type
;
874 volatile struct gdb_exception except
;
876 TRY_CATCH (except
, RETURN_MASK_ALL
)
878 type
= make_cv_type (1, 0, type
, NULL
);
880 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
882 return tyscm_scm_from_type (type
);
885 /* (type-volatile <gdb:type>) -> <gdb:type>
886 Return a volatile-qualified type variant. */
889 gdbscm_type_volatile (SCM self
)
892 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
893 struct type
*type
= t_smob
->type
;
894 volatile struct gdb_exception except
;
896 TRY_CATCH (except
, RETURN_MASK_ALL
)
898 type
= make_cv_type (0, 1, type
, NULL
);
900 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
902 return tyscm_scm_from_type (type
);
905 /* (type-unqualified <gdb:type>) -> <gdb:type>
906 Return an unqualified type variant. */
909 gdbscm_type_unqualified (SCM self
)
912 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
913 struct type
*type
= t_smob
->type
;
914 volatile struct gdb_exception except
;
916 TRY_CATCH (except
, RETURN_MASK_ALL
)
918 type
= make_cv_type (0, 0, type
, NULL
);
920 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
922 return tyscm_scm_from_type (type
);
925 /* Field related accessors of types. */
927 /* (type-num-fields <gdb:type>) -> integer
928 Return number of fields. */
931 gdbscm_type_num_fields (SCM self
)
934 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
935 struct type
*type
= t_smob
->type
;
937 type
= tyscm_get_composite (type
);
939 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
940 _(not_composite_error
));
942 return scm_from_long (TYPE_NFIELDS (type
));
945 /* (type-field <gdb:type> string) -> <gdb:field>
946 Return the <gdb:field> object for the field named by the argument. */
949 gdbscm_type_field (SCM self
, SCM field_scm
)
952 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
953 struct type
*type
= t_smob
->type
;
956 struct cleanup
*cleanups
;
958 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
961 /* We want just fields of this type, not of base types, so instead of
962 using lookup_struct_elt_type, portions of that function are
965 type
= tyscm_get_composite (type
);
967 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
968 _(not_composite_error
));
970 field
= gdbscm_scm_to_c_string (field_scm
);
971 cleanups
= make_cleanup (xfree
, field
);
973 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
975 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
977 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
979 do_cleanups (cleanups
);
980 return tyscm_make_field_smob (self
, i
);
984 do_cleanups (cleanups
);
986 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, field_scm
,
990 /* (type-has-field? <gdb:type> string) -> boolean
991 Return boolean indicating if type SELF has FIELD_SCM (a string). */
994 gdbscm_type_has_field_p (SCM self
, SCM field_scm
)
997 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
998 struct type
*type
= t_smob
->type
;
1001 struct cleanup
*cleanups
;
1003 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
1006 /* We want just fields of this type, not of base types, so instead of
1007 using lookup_struct_elt_type, portions of that function are
1010 type
= tyscm_get_composite (type
);
1012 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1013 _(not_composite_error
));
1015 field
= gdbscm_scm_to_c_string (field_scm
);
1016 cleanups
= make_cleanup (xfree
, field
);
1018 for (i
= 0; i
< TYPE_NFIELDS (type
); i
++)
1020 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
1022 if (t_field_name
&& (strcmp_iw (t_field_name
, field
) == 0))
1024 do_cleanups (cleanups
);
1029 do_cleanups (cleanups
);
1034 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1035 Make a field iterator object. */
1038 gdbscm_make_field_iterator (SCM self
)
1041 = tyscm_get_type_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1042 struct type
*type
= t_smob
->type
;
1043 struct type
*containing_type
;
1044 SCM containing_type_scm
;
1046 containing_type
= tyscm_get_composite (type
);
1047 if (containing_type
== NULL
)
1048 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1049 _(not_composite_error
));
1051 /* If SELF is a typedef or reference, we want the underlying type,
1052 which is what tyscm_get_composite returns. */
1053 if (containing_type
== type
)
1054 containing_type_scm
= self
;
1056 containing_type_scm
= tyscm_scm_from_type (containing_type
);
1058 return gdbscm_make_iterator (containing_type_scm
, scm_from_int (0),
1059 tyscm_next_field_x_proc
);
1062 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1063 Return the next field in the iteration through the list of fields of the
1064 type, or (end-of-iteration).
1065 SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1066 This is the next! <gdb:iterator> function, not exported to the user. */
1069 gdbscm_type_next_field_x (SCM self
)
1071 iterator_smob
*i_smob
;
1074 SCM it_scm
, result
, progress
, object
;
1077 it_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1078 i_smob
= (iterator_smob
*) SCM_SMOB_DATA (it_scm
);
1079 object
= itscm_iterator_smob_object (i_smob
);
1080 progress
= itscm_iterator_smob_progress (i_smob
);
1082 SCM_ASSERT_TYPE (tyscm_is_type (object
), object
,
1083 SCM_ARG1
, FUNC_NAME
, type_smob_name
);
1084 t_smob
= (type_smob
*) SCM_SMOB_DATA (object
);
1085 type
= t_smob
->type
;
1087 SCM_ASSERT_TYPE (scm_is_signed_integer (progress
,
1088 0, TYPE_NFIELDS (type
)),
1089 progress
, SCM_ARG1
, FUNC_NAME
, _("integer"));
1090 field
= scm_to_int (progress
);
1092 if (field
< TYPE_NFIELDS (type
))
1094 result
= tyscm_make_field_smob (object
, field
);
1095 itscm_set_iterator_smob_progress_x (i_smob
, scm_from_int (field
+ 1));
1099 return gdbscm_end_of_iteration ();
1102 /* Field smob accessors. */
1104 /* (field-name <gdb:field>) -> string
1105 Return the name of this field or #f if there isn't one. */
1108 gdbscm_field_name (SCM self
)
1111 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1112 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1114 if (FIELD_NAME (*field
))
1115 return gdbscm_scm_from_c_string (FIELD_NAME (*field
));
1119 /* (field-type <gdb:field>) -> <gdb:type>
1120 Return the <gdb:type> object of the field or #f if there isn't one. */
1123 gdbscm_field_type (SCM self
)
1126 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1127 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1129 /* A field can have a NULL type in some situations. */
1130 if (FIELD_TYPE (*field
))
1131 return tyscm_scm_from_type (FIELD_TYPE (*field
));
1135 /* (field-enumval <gdb:field>) -> integer
1136 For enum values, return its value as an integer. */
1139 gdbscm_field_enumval (SCM self
)
1142 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1143 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1144 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1146 SCM_ASSERT_TYPE (TYPE_CODE (type
) == TYPE_CODE_ENUM
,
1147 self
, SCM_ARG1
, FUNC_NAME
, _("enum type"));
1149 return scm_from_long (FIELD_ENUMVAL (*field
));
1152 /* (field-bitpos <gdb:field>) -> integer
1153 For bitfields, return its offset in bits. */
1156 gdbscm_field_bitpos (SCM self
)
1159 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1160 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1161 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1163 SCM_ASSERT_TYPE (TYPE_CODE (type
) != TYPE_CODE_ENUM
,
1164 self
, SCM_ARG1
, FUNC_NAME
, _("non-enum type"));
1166 return scm_from_long (FIELD_BITPOS (*field
));
1169 /* (field-bitsize <gdb:field>) -> integer
1170 Return the size of the field in bits. */
1173 gdbscm_field_bitsize (SCM self
)
1176 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1177 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1179 return scm_from_long (FIELD_BITPOS (*field
));
1182 /* (field-artificial? <gdb:field>) -> boolean
1183 Return #t if field is artificial. */
1186 gdbscm_field_artificial_p (SCM self
)
1189 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1190 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1192 return scm_from_bool (FIELD_ARTIFICIAL (*field
));
1195 /* (field-baseclass? <gdb:field>) -> boolean
1196 Return #t if field is a baseclass. */
1199 gdbscm_field_baseclass_p (SCM self
)
1202 = tyscm_get_field_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1203 struct field
*field
= tyscm_field_smob_to_field (f_smob
);
1204 struct type
*type
= tyscm_field_smob_containing_type (f_smob
);
1206 if (TYPE_CODE (type
) == TYPE_CODE_CLASS
)
1207 return scm_from_bool (f_smob
->field_num
< TYPE_N_BASECLASSES (type
));
1211 /* Return the type named TYPE_NAME in BLOCK.
1212 Returns NULL if not found.
1213 This routine does not throw an error. */
1215 static struct type
*
1216 tyscm_lookup_typename (const char *type_name
, const struct block
*block
)
1218 struct type
*type
= NULL
;
1219 volatile struct gdb_exception except
;
1221 TRY_CATCH (except
, RETURN_MASK_ALL
)
1223 if (!strncmp (type_name
, "struct ", 7))
1224 type
= lookup_struct (type_name
+ 7, NULL
);
1225 else if (!strncmp (type_name
, "union ", 6))
1226 type
= lookup_union (type_name
+ 6, NULL
);
1227 else if (!strncmp (type_name
, "enum ", 5))
1228 type
= lookup_enum (type_name
+ 5, NULL
);
1230 type
= lookup_typename (current_language
, get_current_arch (),
1231 type_name
, block
, 0);
1233 if (except
.reason
< 0)
1239 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1240 TODO: legacy template support left out until needed. */
1243 gdbscm_lookup_type (SCM name_scm
, SCM rest
)
1245 SCM keywords
[] = { block_keyword
, SCM_BOOL_F
};
1247 SCM block_scm
= SCM_BOOL_F
;
1248 int block_arg_pos
= -1;
1249 const struct block
*block
= NULL
;
1252 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#O",
1254 rest
, &block_arg_pos
, &block_scm
);
1256 if (block_arg_pos
!= -1)
1260 block
= bkscm_scm_to_block (block_scm
, block_arg_pos
, FUNC_NAME
,
1265 gdbscm_throw (exception
);
1268 type
= tyscm_lookup_typename (name
, block
);
1272 return tyscm_scm_from_type (type
);
1276 /* Initialize the Scheme type code. */
1279 static const scheme_integer_constant type_integer_constants
[] =
1281 #define X(SYM) { #SYM, SYM }
1282 X (TYPE_CODE_BITSTRING
),
1284 X (TYPE_CODE_ARRAY
),
1285 X (TYPE_CODE_STRUCT
),
1286 X (TYPE_CODE_UNION
),
1288 X (TYPE_CODE_FLAGS
),
1294 X (TYPE_CODE_RANGE
),
1295 X (TYPE_CODE_STRING
),
1296 X (TYPE_CODE_ERROR
),
1297 X (TYPE_CODE_METHOD
),
1298 X (TYPE_CODE_METHODPTR
),
1299 X (TYPE_CODE_MEMBERPTR
),
1303 X (TYPE_CODE_COMPLEX
),
1304 X (TYPE_CODE_TYPEDEF
),
1305 X (TYPE_CODE_NAMESPACE
),
1306 X (TYPE_CODE_DECFLOAT
),
1307 X (TYPE_CODE_INTERNAL_FUNCTION
),
1310 END_INTEGER_CONSTANTS
1313 static const scheme_function type_functions
[] =
1315 { "type?", 1, 0, 0, gdbscm_type_p
,
1317 Return #t if the object is a <gdb:type> object." },
1319 { "lookup-type", 1, 0, 1, gdbscm_lookup_type
,
1321 Return the <gdb:type> object representing string or #f if not found.\n\
1322 If block is given then the type is looked for in that block.\n\
1324 Arguments: string [#:block <gdb:block>]" },
1326 { "type-code", 1, 0, 0, gdbscm_type_code
,
1328 Return the code of the type" },
1330 { "type-tag", 1, 0, 0, gdbscm_type_tag
,
1332 Return the tag name of the type, or #f if there isn't one." },
1334 { "type-name", 1, 0, 0, gdbscm_type_name
,
1336 Return the name of the type as a string, or #f if there isn't one." },
1338 { "type-print-name", 1, 0, 0, gdbscm_type_print_name
,
1340 Return the print name of the type as a string." },
1342 { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof
,
1344 Return the size of the type, in bytes." },
1346 { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs
,
1348 Return a type formed by stripping the type of all typedefs." },
1350 { "type-array", 2, 1, 0, gdbscm_type_array
,
1352 Return a type representing an array of objects of the type.\n\
1354 Arguments: <gdb:type> [low-bound] high-bound\n\
1355 If low-bound is not provided zero is used.\n\
1356 N.B. If only the high-bound parameter is specified, it is not\n\
1358 Valid bounds for array indices are [low-bound,high-bound]." },
1360 { "type-vector", 2, 1, 0, gdbscm_type_vector
,
1362 Return a type representing a vector of objects of the type.\n\
1363 Vectors differ from arrays in that if the current language has C-style\n\
1364 arrays, vectors don't decay to a pointer to the first element.\n\
1365 They are first class values.\n\
1367 Arguments: <gdb:type> [low-bound] high-bound\n\
1368 If low-bound is not provided zero is used.\n\
1369 N.B. If only the high-bound parameter is specified, it is not\n\
1371 Valid bounds for array indices are [low-bound,high-bound]." },
1373 { "type-pointer", 1, 0, 0, gdbscm_type_pointer
,
1375 Return a type of pointer to the type." },
1377 { "type-range", 1, 0, 0, gdbscm_type_range
,
1379 Return (low high) representing the range for the type." },
1381 { "type-reference", 1, 0, 0, gdbscm_type_reference
,
1383 Return a type of reference to the type." },
1385 { "type-target", 1, 0, 0, gdbscm_type_target
,
1387 Return the target type of the type." },
1389 { "type-const", 1, 0, 0, gdbscm_type_const
,
1391 Return a const variant of the type." },
1393 { "type-volatile", 1, 0, 0, gdbscm_type_volatile
,
1395 Return a volatile variant of the type." },
1397 { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified
,
1399 Return a variant of the type without const or volatile attributes." },
1401 { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields
,
1403 Return the number of fields of the type." },
1405 { "type-fields", 1, 0, 0, gdbscm_type_fields
,
1407 Return the list of <gdb:field> objects of fields of the type." },
1409 { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator
,
1411 Return a <gdb:iterator> object for iterating over the fields of the type." },
1413 { "type-field", 2, 0, 0, gdbscm_type_field
,
1415 Return the field named by string of the type.\n\
1417 Arguments: <gdb:type> string" },
1419 { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p
,
1421 Return #t if the type has field named string.\n\
1423 Arguments: <gdb:type> string" },
1425 { "field?", 1, 0, 0, gdbscm_field_p
,
1427 Return #t if the object is a <gdb:field> object." },
1429 { "field-name", 1, 0, 0, gdbscm_field_name
,
1431 Return the name of the field." },
1433 { "field-type", 1, 0, 0, gdbscm_field_type
,
1435 Return the type of the field." },
1437 { "field-enumval", 1, 0, 0, gdbscm_field_enumval
,
1439 Return the enum value represented by the field." },
1441 { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos
,
1443 Return the offset in bits of the field in its containing type." },
1445 { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize
,
1447 Return the size of the field in bits." },
1449 { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p
,
1451 Return #t if the field is artificial." },
1453 { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p
,
1455 Return #t if the field is a baseclass." },
1461 gdbscm_initialize_types (void)
1463 type_smob_tag
= gdbscm_make_smob_type (type_smob_name
, sizeof (type_smob
));
1464 scm_set_smob_mark (type_smob_tag
, tyscm_mark_type_smob
);
1465 scm_set_smob_free (type_smob_tag
, tyscm_free_type_smob
);
1466 scm_set_smob_print (type_smob_tag
, tyscm_print_type_smob
);
1467 scm_set_smob_equalp (type_smob_tag
, tyscm_equal_p_type_smob
);
1469 field_smob_tag
= gdbscm_make_smob_type (field_smob_name
,
1470 sizeof (field_smob
));
1471 scm_set_smob_mark (field_smob_tag
, tyscm_mark_field_smob
);
1472 scm_set_smob_print (field_smob_tag
, tyscm_print_field_smob
);
1474 gdbscm_define_integer_constants (type_integer_constants
, 1);
1475 gdbscm_define_functions (type_functions
, 1);
1477 /* This function is "private". */
1478 tyscm_next_field_x_proc
1479 = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1480 gdbscm_type_next_field_x
);
1481 scm_set_procedure_property_x (tyscm_next_field_x_proc
,
1482 gdbscm_documentation_symbol
,
1483 gdbscm_scm_from_c_string ("\
1484 Internal function to assist the type fields iterator."));
1486 block_keyword
= scm_from_latin1_keyword ("block");
1488 /* Register an objfile "free" callback so we can properly copy types
1489 associated with the objfile when it's about to be deleted. */
1490 tyscm_objfile_data_key
1491 = register_objfile_data_with_cleanup (save_objfile_types
, NULL
);
1493 global_types_map
= gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob
,
1494 tyscm_eq_type_smob
);