1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2015 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/>. */
24 #include "gdb_regex.h"
29 #include "expression.h"
30 #include "parser-defs.h"
37 #include "breakpoint.h"
40 #include "gdb_obstack.h"
42 #include "completer.h"
47 #include "dictionary.h"
55 #include "typeprint.h"
59 #include "mi/mi-common.h"
60 #include "arch-utils.h"
61 #include "cli/cli-utils.h"
63 /* Define whether or not the C operator '/' truncates towards zero for
64 differently signed operands (truncation direction is undefined in C).
65 Copied from valarith.c. */
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
71 static struct type
*desc_base_type (struct type
*);
73 static struct type
*desc_bounds_type (struct type
*);
75 static struct value
*desc_bounds (struct value
*);
77 static int fat_pntr_bounds_bitpos (struct type
*);
79 static int fat_pntr_bounds_bitsize (struct type
*);
81 static struct type
*desc_data_target_type (struct type
*);
83 static struct value
*desc_data (struct value
*);
85 static int fat_pntr_data_bitpos (struct type
*);
87 static int fat_pntr_data_bitsize (struct type
*);
89 static struct value
*desc_one_bound (struct value
*, int, int);
91 static int desc_bound_bitpos (struct type
*, int, int);
93 static int desc_bound_bitsize (struct type
*, int, int);
95 static struct type
*desc_index_type (struct type
*, int);
97 static int desc_arity (struct type
*);
99 static int ada_type_match (struct type
*, struct type
*, int);
101 static int ada_args_match (struct symbol
*, struct value
**, int);
103 static int full_match (const char *, const char *);
105 static struct value
*make_array_descriptor (struct type
*, struct value
*);
107 static void ada_add_block_symbols (struct obstack
*,
108 const struct block
*, const char *,
109 domain_enum
, struct objfile
*, int);
111 static int is_nonfunction (struct ada_symbol_info
*, int);
113 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
114 const struct block
*);
116 static int num_defns_collected (struct obstack
*);
118 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
120 static struct value
*resolve_subexp (struct expression
**, int *, int,
123 static void replace_operator_with_call (struct expression
**, int, int, int,
124 struct symbol
*, const struct block
*);
126 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
128 static char *ada_op_name (enum exp_opcode
);
130 static const char *ada_decoded_op_name (enum exp_opcode
);
132 static int numeric_type_p (struct type
*);
134 static int integer_type_p (struct type
*);
136 static int scalar_type_p (struct type
*);
138 static int discrete_type_p (struct type
*);
140 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
145 static struct symbol
*find_old_style_renaming_symbol (const char *,
146 const struct block
*);
148 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
151 static struct value
*evaluate_subexp_type (struct expression
*, int *);
153 static struct type
*ada_find_parallel_type_with_name (struct type
*,
156 static int is_dynamic_field (struct type
*, int);
158 static struct type
*to_fixed_variant_branch_type (struct type
*,
160 CORE_ADDR
, struct value
*);
162 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
164 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
166 static struct type
*to_static_fixed_type (struct type
*);
167 static struct type
*static_unwrap_type (struct type
*type
);
169 static struct value
*unwrap_value (struct value
*);
171 static struct type
*constrained_packed_array_type (struct type
*, long *);
173 static struct type
*decode_constrained_packed_array_type (struct type
*);
175 static long decode_packed_array_bitsize (struct type
*);
177 static struct value
*decode_constrained_packed_array (struct value
*);
179 static int ada_is_packed_array_type (struct type
*);
181 static int ada_is_unconstrained_packed_array_type (struct type
*);
183 static struct value
*value_subscript_packed (struct value
*, int,
186 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int, int);
188 static struct value
*coerce_unspec_val_to_type (struct value
*,
191 static struct value
*get_var_value (char *, char *);
193 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
195 static int equiv_types (struct type
*, struct type
*);
197 static int is_name_suffix (const char *);
199 static int advance_wild_match (const char **, const char *, int);
201 static int wild_match (const char *, const char *);
203 static struct value
*ada_coerce_ref (struct value
*);
205 static LONGEST
pos_atr (struct value
*);
207 static struct value
*value_pos_atr (struct type
*, struct value
*);
209 static struct value
*value_val_atr (struct type
*, struct value
*);
211 static struct symbol
*standard_lookup (const char *, const struct block
*,
214 static struct value
*ada_search_struct_field (char *, struct value
*, int,
217 static struct value
*ada_value_primitive_field (struct value
*, int, int,
220 static int find_struct_field (const char *, struct type
*, int,
221 struct type
**, int *, int *, int *, int *);
223 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
226 static int ada_resolve_function (struct ada_symbol_info
*, int,
227 struct value
**, int, const char *,
230 static int ada_is_direct_array_type (struct type
*);
232 static void ada_language_arch_info (struct gdbarch
*,
233 struct language_arch_info
*);
235 static struct value
*ada_index_struct_field (int, struct value
*, int,
238 static struct value
*assign_aggregate (struct value
*, struct value
*,
242 static void aggregate_assign_from_choices (struct value
*, struct value
*,
244 int *, LONGEST
*, int *,
245 int, LONGEST
, LONGEST
);
247 static void aggregate_assign_positional (struct value
*, struct value
*,
249 int *, LONGEST
*, int *, int,
253 static void aggregate_assign_others (struct value
*, struct value
*,
255 int *, LONGEST
*, int, LONGEST
, LONGEST
);
258 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
261 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
264 static void ada_forward_operator_length (struct expression
*, int, int *,
267 static struct type
*ada_find_any_type (const char *name
);
270 /* The result of a symbol lookup to be stored in our symbol cache. */
274 /* The name used to perform the lookup. */
276 /* The namespace used during the lookup. */
277 domain_enum
namespace;
278 /* The symbol returned by the lookup, or NULL if no matching symbol
281 /* The block where the symbol was found, or NULL if no matching
283 const struct block
*block
;
284 /* A pointer to the next entry with the same hash. */
285 struct cache_entry
*next
;
288 /* The Ada symbol cache, used to store the result of Ada-mode symbol
289 lookups in the course of executing the user's commands.
291 The cache is implemented using a simple, fixed-sized hash.
292 The size is fixed on the grounds that there are not likely to be
293 all that many symbols looked up during any given session, regardless
294 of the size of the symbol table. If we decide to go to a resizable
295 table, let's just use the stuff from libiberty instead. */
297 #define HASH_SIZE 1009
299 struct ada_symbol_cache
301 /* An obstack used to store the entries in our cache. */
302 struct obstack cache_space
;
304 /* The root of the hash table used to implement our symbol cache. */
305 struct cache_entry
*root
[HASH_SIZE
];
308 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
310 /* Maximum-sized dynamic type. */
311 static unsigned int varsize_limit
;
313 /* FIXME: brobecker/2003-09-17: No longer a const because it is
314 returned by a function that does not return a const char *. */
315 static char *ada_completer_word_break_characters
=
317 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
319 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
322 /* The name of the symbol to use to get the name of the main subprogram. */
323 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
324 = "__gnat_ada_main_program_name";
326 /* Limit on the number of warnings to raise per expression evaluation. */
327 static int warning_limit
= 2;
329 /* Number of warning messages issued; reset to 0 by cleanups after
330 expression evaluation. */
331 static int warnings_issued
= 0;
333 static const char *known_runtime_file_name_patterns
[] = {
334 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
337 static const char *known_auxiliary_function_name_patterns
[] = {
338 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
341 /* Space for allocating results of ada_lookup_symbol_list. */
342 static struct obstack symbol_list_obstack
;
344 /* Maintenance-related settings for this module. */
346 static struct cmd_list_element
*maint_set_ada_cmdlist
;
347 static struct cmd_list_element
*maint_show_ada_cmdlist
;
349 /* Implement the "maintenance set ada" (prefix) command. */
352 maint_set_ada_cmd (char *args
, int from_tty
)
354 help_list (maint_set_ada_cmdlist
, "maintenance set ada ", all_commands
,
358 /* Implement the "maintenance show ada" (prefix) command. */
361 maint_show_ada_cmd (char *args
, int from_tty
)
363 cmd_show_list (maint_show_ada_cmdlist
, from_tty
, "");
366 /* The "maintenance ada set/show ignore-descriptive-type" value. */
368 static int ada_ignore_descriptive_types_p
= 0;
370 /* Inferior-specific data. */
372 /* Per-inferior data for this module. */
374 struct ada_inferior_data
376 /* The ada__tags__type_specific_data type, which is used when decoding
377 tagged types. With older versions of GNAT, this type was directly
378 accessible through a component ("tsd") in the object tag. But this
379 is no longer the case, so we cache it for each inferior. */
380 struct type
*tsd_type
;
382 /* The exception_support_info data. This data is used to determine
383 how to implement support for Ada exception catchpoints in a given
385 const struct exception_support_info
*exception_info
;
388 /* Our key to this module's inferior data. */
389 static const struct inferior_data
*ada_inferior_data
;
391 /* A cleanup routine for our inferior data. */
393 ada_inferior_data_cleanup (struct inferior
*inf
, void *arg
)
395 struct ada_inferior_data
*data
;
397 data
= inferior_data (inf
, ada_inferior_data
);
402 /* Return our inferior data for the given inferior (INF).
404 This function always returns a valid pointer to an allocated
405 ada_inferior_data structure. If INF's inferior data has not
406 been previously set, this functions creates a new one with all
407 fields set to zero, sets INF's inferior to it, and then returns
408 a pointer to that newly allocated ada_inferior_data. */
410 static struct ada_inferior_data
*
411 get_ada_inferior_data (struct inferior
*inf
)
413 struct ada_inferior_data
*data
;
415 data
= inferior_data (inf
, ada_inferior_data
);
418 data
= XCNEW (struct ada_inferior_data
);
419 set_inferior_data (inf
, ada_inferior_data
, data
);
425 /* Perform all necessary cleanups regarding our module's inferior data
426 that is required after the inferior INF just exited. */
429 ada_inferior_exit (struct inferior
*inf
)
431 ada_inferior_data_cleanup (inf
, NULL
);
432 set_inferior_data (inf
, ada_inferior_data
, NULL
);
436 /* program-space-specific data. */
438 /* This module's per-program-space data. */
439 struct ada_pspace_data
441 /* The Ada symbol cache. */
442 struct ada_symbol_cache
*sym_cache
;
445 /* Key to our per-program-space data. */
446 static const struct program_space_data
*ada_pspace_data_handle
;
448 /* Return this module's data for the given program space (PSPACE).
449 If not is found, add a zero'ed one now.
451 This function always returns a valid object. */
453 static struct ada_pspace_data
*
454 get_ada_pspace_data (struct program_space
*pspace
)
456 struct ada_pspace_data
*data
;
458 data
= program_space_data (pspace
, ada_pspace_data_handle
);
461 data
= XCNEW (struct ada_pspace_data
);
462 set_program_space_data (pspace
, ada_pspace_data_handle
, data
);
468 /* The cleanup callback for this module's per-program-space data. */
471 ada_pspace_data_cleanup (struct program_space
*pspace
, void *data
)
473 struct ada_pspace_data
*pspace_data
= data
;
475 if (pspace_data
->sym_cache
!= NULL
)
476 ada_free_symbol_cache (pspace_data
->sym_cache
);
482 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
483 all typedef layers have been peeled. Otherwise, return TYPE.
485 Normally, we really expect a typedef type to only have 1 typedef layer.
486 In other words, we really expect the target type of a typedef type to be
487 a non-typedef type. This is particularly true for Ada units, because
488 the language does not have a typedef vs not-typedef distinction.
489 In that respect, the Ada compiler has been trying to eliminate as many
490 typedef definitions in the debugging information, since they generally
491 do not bring any extra information (we still use typedef under certain
492 circumstances related mostly to the GNAT encoding).
494 Unfortunately, we have seen situations where the debugging information
495 generated by the compiler leads to such multiple typedef layers. For
496 instance, consider the following example with stabs:
498 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
499 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
501 This is an error in the debugging information which causes type
502 pck__float_array___XUP to be defined twice, and the second time,
503 it is defined as a typedef of a typedef.
505 This is on the fringe of legality as far as debugging information is
506 concerned, and certainly unexpected. But it is easy to handle these
507 situations correctly, so we can afford to be lenient in this case. */
510 ada_typedef_target_type (struct type
*type
)
512 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
513 type
= TYPE_TARGET_TYPE (type
);
517 /* Given DECODED_NAME a string holding a symbol name in its
518 decoded form (ie using the Ada dotted notation), returns
519 its unqualified name. */
522 ada_unqualified_name (const char *decoded_name
)
526 /* If the decoded name starts with '<', it means that the encoded
527 name does not follow standard naming conventions, and thus that
528 it is not your typical Ada symbol name. Trying to unqualify it
529 is therefore pointless and possibly erroneous. */
530 if (decoded_name
[0] == '<')
533 result
= strrchr (decoded_name
, '.');
535 result
++; /* Skip the dot... */
537 result
= decoded_name
;
542 /* Return a string starting with '<', followed by STR, and '>'.
543 The result is good until the next call. */
546 add_angle_brackets (const char *str
)
548 static char *result
= NULL
;
551 result
= xstrprintf ("<%s>", str
);
556 ada_get_gdb_completer_word_break_characters (void)
558 return ada_completer_word_break_characters
;
561 /* Print an array element index using the Ada syntax. */
564 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
565 const struct value_print_options
*options
)
567 LA_VALUE_PRINT (index_value
, stream
, options
);
568 fprintf_filtered (stream
, " => ");
571 /* Assuming VECT points to an array of *SIZE objects of size
572 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
573 updating *SIZE as necessary and returning the (new) array. */
576 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
578 if (*size
< min_size
)
581 if (*size
< min_size
)
583 vect
= xrealloc (vect
, *size
* element_size
);
588 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
589 suffix of FIELD_NAME beginning "___". */
592 field_name_match (const char *field_name
, const char *target
)
594 int len
= strlen (target
);
597 (strncmp (field_name
, target
, len
) == 0
598 && (field_name
[len
] == '\0'
599 || (strncmp (field_name
+ len
, "___", 3) == 0
600 && strcmp (field_name
+ strlen (field_name
) - 6,
605 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
606 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
607 and return its index. This function also handles fields whose name
608 have ___ suffixes because the compiler sometimes alters their name
609 by adding such a suffix to represent fields with certain constraints.
610 If the field could not be found, return a negative number if
611 MAYBE_MISSING is set. Otherwise raise an error. */
614 ada_get_field_index (const struct type
*type
, const char *field_name
,
618 struct type
*struct_type
= check_typedef ((struct type
*) type
);
620 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
621 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
625 error (_("Unable to find field %s in struct %s. Aborting"),
626 field_name
, TYPE_NAME (struct_type
));
631 /* The length of the prefix of NAME prior to any "___" suffix. */
634 ada_name_prefix_len (const char *name
)
640 const char *p
= strstr (name
, "___");
643 return strlen (name
);
649 /* Return non-zero if SUFFIX is a suffix of STR.
650 Return zero if STR is null. */
653 is_suffix (const char *str
, const char *suffix
)
660 len2
= strlen (suffix
);
661 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
664 /* The contents of value VAL, treated as a value of type TYPE. The
665 result is an lval in memory if VAL is. */
667 static struct value
*
668 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
670 type
= ada_check_typedef (type
);
671 if (value_type (val
) == type
)
675 struct value
*result
;
677 /* Make sure that the object size is not unreasonable before
678 trying to allocate some memory for it. */
679 ada_ensure_varsize_limit (type
);
682 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
683 result
= allocate_value_lazy (type
);
686 result
= allocate_value (type
);
687 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
689 set_value_component_location (result
, val
);
690 set_value_bitsize (result
, value_bitsize (val
));
691 set_value_bitpos (result
, value_bitpos (val
));
692 set_value_address (result
, value_address (val
));
697 static const gdb_byte
*
698 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
703 return valaddr
+ offset
;
707 cond_offset_target (CORE_ADDR address
, long offset
)
712 return address
+ offset
;
715 /* Issue a warning (as for the definition of warning in utils.c, but
716 with exactly one argument rather than ...), unless the limit on the
717 number of warnings has passed during the evaluation of the current
720 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
721 provided by "complaint". */
722 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
725 lim_warning (const char *format
, ...)
729 va_start (args
, format
);
730 warnings_issued
+= 1;
731 if (warnings_issued
<= warning_limit
)
732 vwarning (format
, args
);
737 /* Issue an error if the size of an object of type T is unreasonable,
738 i.e. if it would be a bad idea to allocate a value of this type in
742 ada_ensure_varsize_limit (const struct type
*type
)
744 if (TYPE_LENGTH (type
) > varsize_limit
)
745 error (_("object size is larger than varsize-limit"));
748 /* Maximum value of a SIZE-byte signed integer type. */
750 max_of_size (int size
)
752 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
754 return top_bit
| (top_bit
- 1);
757 /* Minimum value of a SIZE-byte signed integer type. */
759 min_of_size (int size
)
761 return -max_of_size (size
) - 1;
764 /* Maximum value of a SIZE-byte unsigned integer type. */
766 umax_of_size (int size
)
768 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
770 return top_bit
| (top_bit
- 1);
773 /* Maximum value of integral type T, as a signed quantity. */
775 max_of_type (struct type
*t
)
777 if (TYPE_UNSIGNED (t
))
778 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
780 return max_of_size (TYPE_LENGTH (t
));
783 /* Minimum value of integral type T, as a signed quantity. */
785 min_of_type (struct type
*t
)
787 if (TYPE_UNSIGNED (t
))
790 return min_of_size (TYPE_LENGTH (t
));
793 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
795 ada_discrete_type_high_bound (struct type
*type
)
797 type
= resolve_dynamic_type (type
, 0);
798 switch (TYPE_CODE (type
))
800 case TYPE_CODE_RANGE
:
801 return TYPE_HIGH_BOUND (type
);
803 return TYPE_FIELD_ENUMVAL (type
, TYPE_NFIELDS (type
) - 1);
808 return max_of_type (type
);
810 error (_("Unexpected type in ada_discrete_type_high_bound."));
814 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
816 ada_discrete_type_low_bound (struct type
*type
)
818 type
= resolve_dynamic_type (type
, 0);
819 switch (TYPE_CODE (type
))
821 case TYPE_CODE_RANGE
:
822 return TYPE_LOW_BOUND (type
);
824 return TYPE_FIELD_ENUMVAL (type
, 0);
829 return min_of_type (type
);
831 error (_("Unexpected type in ada_discrete_type_low_bound."));
835 /* The identity on non-range types. For range types, the underlying
836 non-range scalar type. */
839 get_base_type (struct type
*type
)
841 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
843 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
845 type
= TYPE_TARGET_TYPE (type
);
850 /* Return a decoded version of the given VALUE. This means returning
851 a value whose type is obtained by applying all the GNAT-specific
852 encondings, making the resulting type a static but standard description
853 of the initial type. */
856 ada_get_decoded_value (struct value
*value
)
858 struct type
*type
= ada_check_typedef (value_type (value
));
860 if (ada_is_array_descriptor_type (type
)
861 || (ada_is_constrained_packed_array_type (type
)
862 && TYPE_CODE (type
) != TYPE_CODE_PTR
))
864 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
) /* array access type. */
865 value
= ada_coerce_to_simple_array_ptr (value
);
867 value
= ada_coerce_to_simple_array (value
);
870 value
= ada_to_fixed_value (value
);
875 /* Same as ada_get_decoded_value, but with the given TYPE.
876 Because there is no associated actual value for this type,
877 the resulting type might be a best-effort approximation in
878 the case of dynamic types. */
881 ada_get_decoded_type (struct type
*type
)
883 type
= to_static_fixed_type (type
);
884 if (ada_is_constrained_packed_array_type (type
))
885 type
= ada_coerce_to_simple_array_type (type
);
891 /* Language Selection */
893 /* If the main program is in Ada, return language_ada, otherwise return LANG
894 (the main program is in Ada iif the adainit symbol is found). */
897 ada_update_initial_language (enum language lang
)
899 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
900 (struct objfile
*) NULL
).minsym
!= NULL
)
906 /* If the main procedure is written in Ada, then return its name.
907 The result is good until the next call. Return NULL if the main
908 procedure doesn't appear to be in Ada. */
913 struct bound_minimal_symbol msym
;
914 static char *main_program_name
= NULL
;
916 /* For Ada, the name of the main procedure is stored in a specific
917 string constant, generated by the binder. Look for that symbol,
918 extract its address, and then read that string. If we didn't find
919 that string, then most probably the main procedure is not written
921 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
923 if (msym
.minsym
!= NULL
)
925 CORE_ADDR main_program_name_addr
;
928 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
929 if (main_program_name_addr
== 0)
930 error (_("Invalid address for Ada main program name."));
932 xfree (main_program_name
);
933 target_read_string (main_program_name_addr
, &main_program_name
,
938 return main_program_name
;
941 /* The main procedure doesn't seem to be in Ada. */
947 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
950 const struct ada_opname_map ada_opname_table
[] = {
951 {"Oadd", "\"+\"", BINOP_ADD
},
952 {"Osubtract", "\"-\"", BINOP_SUB
},
953 {"Omultiply", "\"*\"", BINOP_MUL
},
954 {"Odivide", "\"/\"", BINOP_DIV
},
955 {"Omod", "\"mod\"", BINOP_MOD
},
956 {"Orem", "\"rem\"", BINOP_REM
},
957 {"Oexpon", "\"**\"", BINOP_EXP
},
958 {"Olt", "\"<\"", BINOP_LESS
},
959 {"Ole", "\"<=\"", BINOP_LEQ
},
960 {"Ogt", "\">\"", BINOP_GTR
},
961 {"Oge", "\">=\"", BINOP_GEQ
},
962 {"Oeq", "\"=\"", BINOP_EQUAL
},
963 {"One", "\"/=\"", BINOP_NOTEQUAL
},
964 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
965 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
966 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
967 {"Oconcat", "\"&\"", BINOP_CONCAT
},
968 {"Oabs", "\"abs\"", UNOP_ABS
},
969 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
970 {"Oadd", "\"+\"", UNOP_PLUS
},
971 {"Osubtract", "\"-\"", UNOP_NEG
},
975 /* The "encoded" form of DECODED, according to GNAT conventions.
976 The result is valid until the next call to ada_encode. */
979 ada_encode (const char *decoded
)
981 static char *encoding_buffer
= NULL
;
982 static size_t encoding_buffer_size
= 0;
989 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
990 2 * strlen (decoded
) + 10);
993 for (p
= decoded
; *p
!= '\0'; p
+= 1)
997 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
1002 const struct ada_opname_map
*mapping
;
1004 for (mapping
= ada_opname_table
;
1005 mapping
->encoded
!= NULL
1006 && strncmp (mapping
->decoded
, p
,
1007 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
1009 if (mapping
->encoded
== NULL
)
1010 error (_("invalid Ada operator name: %s"), p
);
1011 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
1012 k
+= strlen (mapping
->encoded
);
1017 encoding_buffer
[k
] = *p
;
1022 encoding_buffer
[k
] = '\0';
1023 return encoding_buffer
;
1026 /* Return NAME folded to lower case, or, if surrounded by single
1027 quotes, unfolded, but with the quotes stripped away. Result good
1031 ada_fold_name (const char *name
)
1033 static char *fold_buffer
= NULL
;
1034 static size_t fold_buffer_size
= 0;
1036 int len
= strlen (name
);
1037 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
1039 if (name
[0] == '\'')
1041 strncpy (fold_buffer
, name
+ 1, len
- 2);
1042 fold_buffer
[len
- 2] = '\000';
1048 for (i
= 0; i
<= len
; i
+= 1)
1049 fold_buffer
[i
] = tolower (name
[i
]);
1055 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1058 is_lower_alphanum (const char c
)
1060 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1063 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1064 This function saves in LEN the length of that same symbol name but
1065 without either of these suffixes:
1071 These are suffixes introduced by the compiler for entities such as
1072 nested subprogram for instance, in order to avoid name clashes.
1073 They do not serve any purpose for the debugger. */
1076 ada_remove_trailing_digits (const char *encoded
, int *len
)
1078 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1082 while (i
> 0 && isdigit (encoded
[i
]))
1084 if (i
>= 0 && encoded
[i
] == '.')
1086 else if (i
>= 0 && encoded
[i
] == '$')
1088 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
1090 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
1095 /* Remove the suffix introduced by the compiler for protected object
1099 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1101 /* Remove trailing N. */
1103 /* Protected entry subprograms are broken into two
1104 separate subprograms: The first one is unprotected, and has
1105 a 'N' suffix; the second is the protected version, and has
1106 the 'P' suffix. The second calls the first one after handling
1107 the protection. Since the P subprograms are internally generated,
1108 we leave these names undecoded, giving the user a clue that this
1109 entity is internal. */
1112 && encoded
[*len
- 1] == 'N'
1113 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1117 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1120 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
1124 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
1127 if (encoded
[i
] != 'X')
1133 if (isalnum (encoded
[i
-1]))
1137 /* If ENCODED follows the GNAT entity encoding conventions, then return
1138 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1139 replaced by ENCODED.
1141 The resulting string is valid until the next call of ada_decode.
1142 If the string is unchanged by decoding, the original string pointer
1146 ada_decode (const char *encoded
)
1153 static char *decoding_buffer
= NULL
;
1154 static size_t decoding_buffer_size
= 0;
1156 /* The name of the Ada main procedure starts with "_ada_".
1157 This prefix is not part of the decoded name, so skip this part
1158 if we see this prefix. */
1159 if (strncmp (encoded
, "_ada_", 5) == 0)
1162 /* If the name starts with '_', then it is not a properly encoded
1163 name, so do not attempt to decode it. Similarly, if the name
1164 starts with '<', the name should not be decoded. */
1165 if (encoded
[0] == '_' || encoded
[0] == '<')
1168 len0
= strlen (encoded
);
1170 ada_remove_trailing_digits (encoded
, &len0
);
1171 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1173 /* Remove the ___X.* suffix if present. Do not forget to verify that
1174 the suffix is located before the current "end" of ENCODED. We want
1175 to avoid re-matching parts of ENCODED that have previously been
1176 marked as discarded (by decrementing LEN0). */
1177 p
= strstr (encoded
, "___");
1178 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1186 /* Remove any trailing TKB suffix. It tells us that this symbol
1187 is for the body of a task, but that information does not actually
1188 appear in the decoded name. */
1190 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
1193 /* Remove any trailing TB suffix. The TB suffix is slightly different
1194 from the TKB suffix because it is used for non-anonymous task
1197 if (len0
> 2 && strncmp (encoded
+ len0
- 2, "TB", 2) == 0)
1200 /* Remove trailing "B" suffixes. */
1201 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1203 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
1206 /* Make decoded big enough for possible expansion by operator name. */
1208 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1209 decoded
= decoding_buffer
;
1211 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1213 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1216 while ((i
>= 0 && isdigit (encoded
[i
]))
1217 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1219 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1221 else if (encoded
[i
] == '$')
1225 /* The first few characters that are not alphabetic are not part
1226 of any encoding we use, so we can copy them over verbatim. */
1228 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1229 decoded
[j
] = encoded
[i
];
1234 /* Is this a symbol function? */
1235 if (at_start_name
&& encoded
[i
] == 'O')
1239 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1241 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1242 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1244 && !isalnum (encoded
[i
+ op_len
]))
1246 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1249 j
+= strlen (ada_opname_table
[k
].decoded
);
1253 if (ada_opname_table
[k
].encoded
!= NULL
)
1258 /* Replace "TK__" with "__", which will eventually be translated
1259 into "." (just below). */
1261 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1264 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1265 be translated into "." (just below). These are internal names
1266 generated for anonymous blocks inside which our symbol is nested. */
1268 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1269 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1270 && isdigit (encoded
[i
+4]))
1274 while (k
< len0
&& isdigit (encoded
[k
]))
1275 k
++; /* Skip any extra digit. */
1277 /* Double-check that the "__B_{DIGITS}+" sequence we found
1278 is indeed followed by "__". */
1279 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1283 /* Remove _E{DIGITS}+[sb] */
1285 /* Just as for protected object subprograms, there are 2 categories
1286 of subprograms created by the compiler for each entry. The first
1287 one implements the actual entry code, and has a suffix following
1288 the convention above; the second one implements the barrier and
1289 uses the same convention as above, except that the 'E' is replaced
1292 Just as above, we do not decode the name of barrier functions
1293 to give the user a clue that the code he is debugging has been
1294 internally generated. */
1296 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1297 && isdigit (encoded
[i
+2]))
1301 while (k
< len0
&& isdigit (encoded
[k
]))
1305 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1308 /* Just as an extra precaution, make sure that if this
1309 suffix is followed by anything else, it is a '_'.
1310 Otherwise, we matched this sequence by accident. */
1312 || (k
< len0
&& encoded
[k
] == '_'))
1317 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1318 the GNAT front-end in protected object subprograms. */
1321 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1323 /* Backtrack a bit up until we reach either the begining of
1324 the encoded name, or "__". Make sure that we only find
1325 digits or lowercase characters. */
1326 const char *ptr
= encoded
+ i
- 1;
1328 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1331 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1335 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1337 /* This is a X[bn]* sequence not separated from the previous
1338 part of the name with a non-alpha-numeric character (in other
1339 words, immediately following an alpha-numeric character), then
1340 verify that it is placed at the end of the encoded name. If
1341 not, then the encoding is not valid and we should abort the
1342 decoding. Otherwise, just skip it, it is used in body-nested
1346 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1350 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1352 /* Replace '__' by '.'. */
1360 /* It's a character part of the decoded name, so just copy it
1362 decoded
[j
] = encoded
[i
];
1367 decoded
[j
] = '\000';
1369 /* Decoded names should never contain any uppercase character.
1370 Double-check this, and abort the decoding if we find one. */
1372 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1373 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1376 if (strcmp (decoded
, encoded
) == 0)
1382 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1383 decoded
= decoding_buffer
;
1384 if (encoded
[0] == '<')
1385 strcpy (decoded
, encoded
);
1387 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1392 /* Table for keeping permanent unique copies of decoded names. Once
1393 allocated, names in this table are never released. While this is a
1394 storage leak, it should not be significant unless there are massive
1395 changes in the set of decoded names in successive versions of a
1396 symbol table loaded during a single session. */
1397 static struct htab
*decoded_names_store
;
1399 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1400 in the language-specific part of GSYMBOL, if it has not been
1401 previously computed. Tries to save the decoded name in the same
1402 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1403 in any case, the decoded symbol has a lifetime at least that of
1405 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1406 const, but nevertheless modified to a semantically equivalent form
1407 when a decoded name is cached in it. */
1410 ada_decode_symbol (const struct general_symbol_info
*arg
)
1412 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1413 const char **resultp
=
1414 &gsymbol
->language_specific
.mangled_lang
.demangled_name
;
1416 if (!gsymbol
->ada_mangled
)
1418 const char *decoded
= ada_decode (gsymbol
->name
);
1419 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1421 gsymbol
->ada_mangled
= 1;
1423 if (obstack
!= NULL
)
1424 *resultp
= obstack_copy0 (obstack
, decoded
, strlen (decoded
));
1427 /* Sometimes, we can't find a corresponding objfile, in
1428 which case, we put the result on the heap. Since we only
1429 decode when needed, we hope this usually does not cause a
1430 significant memory leak (FIXME). */
1432 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1436 *slot
= xstrdup (decoded
);
1445 ada_la_decode (const char *encoded
, int options
)
1447 return xstrdup (ada_decode (encoded
));
1450 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1451 suffixes that encode debugging information or leading _ada_ on
1452 SYM_NAME (see is_name_suffix commentary for the debugging
1453 information that is ignored). If WILD, then NAME need only match a
1454 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1455 either argument is NULL. */
1458 match_name (const char *sym_name
, const char *name
, int wild
)
1460 if (sym_name
== NULL
|| name
== NULL
)
1463 return wild_match (sym_name
, name
) == 0;
1466 int len_name
= strlen (name
);
1468 return (strncmp (sym_name
, name
, len_name
) == 0
1469 && is_name_suffix (sym_name
+ len_name
))
1470 || (strncmp (sym_name
, "_ada_", 5) == 0
1471 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1472 && is_name_suffix (sym_name
+ len_name
+ 5));
1479 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1480 generated by the GNAT compiler to describe the index type used
1481 for each dimension of an array, check whether it follows the latest
1482 known encoding. If not, fix it up to conform to the latest encoding.
1483 Otherwise, do nothing. This function also does nothing if
1484 INDEX_DESC_TYPE is NULL.
1486 The GNAT encoding used to describle the array index type evolved a bit.
1487 Initially, the information would be provided through the name of each
1488 field of the structure type only, while the type of these fields was
1489 described as unspecified and irrelevant. The debugger was then expected
1490 to perform a global type lookup using the name of that field in order
1491 to get access to the full index type description. Because these global
1492 lookups can be very expensive, the encoding was later enhanced to make
1493 the global lookup unnecessary by defining the field type as being
1494 the full index type description.
1496 The purpose of this routine is to allow us to support older versions
1497 of the compiler by detecting the use of the older encoding, and by
1498 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1499 we essentially replace each field's meaningless type by the associated
1503 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1507 if (index_desc_type
== NULL
)
1509 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1511 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1512 to check one field only, no need to check them all). If not, return
1515 If our INDEX_DESC_TYPE was generated using the older encoding,
1516 the field type should be a meaningless integer type whose name
1517 is not equal to the field name. */
1518 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1519 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1520 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1523 /* Fixup each field of INDEX_DESC_TYPE. */
1524 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1526 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1527 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1530 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1534 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1536 static char *bound_name
[] = {
1537 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1538 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1541 /* Maximum number of array dimensions we are prepared to handle. */
1543 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1546 /* The desc_* routines return primitive portions of array descriptors
1549 /* The descriptor or array type, if any, indicated by TYPE; removes
1550 level of indirection, if needed. */
1552 static struct type
*
1553 desc_base_type (struct type
*type
)
1557 type
= ada_check_typedef (type
);
1558 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1559 type
= ada_typedef_target_type (type
);
1562 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1563 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1564 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1569 /* True iff TYPE indicates a "thin" array pointer type. */
1572 is_thin_pntr (struct type
*type
)
1575 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1576 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1579 /* The descriptor type for thin pointer type TYPE. */
1581 static struct type
*
1582 thin_descriptor_type (struct type
*type
)
1584 struct type
*base_type
= desc_base_type (type
);
1586 if (base_type
== NULL
)
1588 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1592 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1594 if (alt_type
== NULL
)
1601 /* A pointer to the array data for thin-pointer value VAL. */
1603 static struct value
*
1604 thin_data_pntr (struct value
*val
)
1606 struct type
*type
= ada_check_typedef (value_type (val
));
1607 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1609 data_type
= lookup_pointer_type (data_type
);
1611 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1612 return value_cast (data_type
, value_copy (val
));
1614 return value_from_longest (data_type
, value_address (val
));
1617 /* True iff TYPE indicates a "thick" array pointer type. */
1620 is_thick_pntr (struct type
*type
)
1622 type
= desc_base_type (type
);
1623 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1624 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1627 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1628 pointer to one, the type of its bounds data; otherwise, NULL. */
1630 static struct type
*
1631 desc_bounds_type (struct type
*type
)
1635 type
= desc_base_type (type
);
1639 else if (is_thin_pntr (type
))
1641 type
= thin_descriptor_type (type
);
1644 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1646 return ada_check_typedef (r
);
1648 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1650 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1652 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1657 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1658 one, a pointer to its bounds data. Otherwise NULL. */
1660 static struct value
*
1661 desc_bounds (struct value
*arr
)
1663 struct type
*type
= ada_check_typedef (value_type (arr
));
1665 if (is_thin_pntr (type
))
1667 struct type
*bounds_type
=
1668 desc_bounds_type (thin_descriptor_type (type
));
1671 if (bounds_type
== NULL
)
1672 error (_("Bad GNAT array descriptor"));
1674 /* NOTE: The following calculation is not really kosher, but
1675 since desc_type is an XVE-encoded type (and shouldn't be),
1676 the correct calculation is a real pain. FIXME (and fix GCC). */
1677 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1678 addr
= value_as_long (arr
);
1680 addr
= value_address (arr
);
1683 value_from_longest (lookup_pointer_type (bounds_type
),
1684 addr
- TYPE_LENGTH (bounds_type
));
1687 else if (is_thick_pntr (type
))
1689 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1690 _("Bad GNAT array descriptor"));
1691 struct type
*p_bounds_type
= value_type (p_bounds
);
1694 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1696 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1698 if (TYPE_STUB (target_type
))
1699 p_bounds
= value_cast (lookup_pointer_type
1700 (ada_check_typedef (target_type
)),
1704 error (_("Bad GNAT array descriptor"));
1712 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1713 position of the field containing the address of the bounds data. */
1716 fat_pntr_bounds_bitpos (struct type
*type
)
1718 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1721 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1722 size of the field containing the address of the bounds data. */
1725 fat_pntr_bounds_bitsize (struct type
*type
)
1727 type
= desc_base_type (type
);
1729 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1730 return TYPE_FIELD_BITSIZE (type
, 1);
1732 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1735 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1736 pointer to one, the type of its array data (a array-with-no-bounds type);
1737 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1740 static struct type
*
1741 desc_data_target_type (struct type
*type
)
1743 type
= desc_base_type (type
);
1745 /* NOTE: The following is bogus; see comment in desc_bounds. */
1746 if (is_thin_pntr (type
))
1747 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1748 else if (is_thick_pntr (type
))
1750 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1753 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1754 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1760 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1763 static struct value
*
1764 desc_data (struct value
*arr
)
1766 struct type
*type
= value_type (arr
);
1768 if (is_thin_pntr (type
))
1769 return thin_data_pntr (arr
);
1770 else if (is_thick_pntr (type
))
1771 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1772 _("Bad GNAT array descriptor"));
1778 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1779 position of the field containing the address of the data. */
1782 fat_pntr_data_bitpos (struct type
*type
)
1784 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1787 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1788 size of the field containing the address of the data. */
1791 fat_pntr_data_bitsize (struct type
*type
)
1793 type
= desc_base_type (type
);
1795 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1796 return TYPE_FIELD_BITSIZE (type
, 0);
1798 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1801 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1802 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1803 bound, if WHICH is 1. The first bound is I=1. */
1805 static struct value
*
1806 desc_one_bound (struct value
*bounds
, int i
, int which
)
1808 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1809 _("Bad GNAT array descriptor bounds"));
1812 /* If BOUNDS is an array-bounds structure type, return the bit position
1813 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1814 bound, if WHICH is 1. The first bound is I=1. */
1817 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1819 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1822 /* If BOUNDS is an array-bounds structure type, return the bit field size
1823 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1824 bound, if WHICH is 1. The first bound is I=1. */
1827 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1829 type
= desc_base_type (type
);
1831 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1832 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1834 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1837 /* If TYPE is the type of an array-bounds structure, the type of its
1838 Ith bound (numbering from 1). Otherwise, NULL. */
1840 static struct type
*
1841 desc_index_type (struct type
*type
, int i
)
1843 type
= desc_base_type (type
);
1845 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1846 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1851 /* The number of index positions in the array-bounds type TYPE.
1852 Return 0 if TYPE is NULL. */
1855 desc_arity (struct type
*type
)
1857 type
= desc_base_type (type
);
1860 return TYPE_NFIELDS (type
) / 2;
1864 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1865 an array descriptor type (representing an unconstrained array
1869 ada_is_direct_array_type (struct type
*type
)
1873 type
= ada_check_typedef (type
);
1874 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1875 || ada_is_array_descriptor_type (type
));
1878 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1882 ada_is_array_type (struct type
*type
)
1885 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1886 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1887 type
= TYPE_TARGET_TYPE (type
);
1888 return ada_is_direct_array_type (type
);
1891 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1894 ada_is_simple_array_type (struct type
*type
)
1898 type
= ada_check_typedef (type
);
1899 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1900 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1901 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1902 == TYPE_CODE_ARRAY
));
1905 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1908 ada_is_array_descriptor_type (struct type
*type
)
1910 struct type
*data_type
= desc_data_target_type (type
);
1914 type
= ada_check_typedef (type
);
1915 return (data_type
!= NULL
1916 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1917 && desc_arity (desc_bounds_type (type
)) > 0);
1920 /* Non-zero iff type is a partially mal-formed GNAT array
1921 descriptor. FIXME: This is to compensate for some problems with
1922 debugging output from GNAT. Re-examine periodically to see if it
1926 ada_is_bogus_array_descriptor (struct type
*type
)
1930 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1931 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1932 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1933 && !ada_is_array_descriptor_type (type
);
1937 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1938 (fat pointer) returns the type of the array data described---specifically,
1939 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1940 in from the descriptor; otherwise, they are left unspecified. If
1941 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1942 returns NULL. The result is simply the type of ARR if ARR is not
1945 ada_type_of_array (struct value
*arr
, int bounds
)
1947 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1948 return decode_constrained_packed_array_type (value_type (arr
));
1950 if (!ada_is_array_descriptor_type (value_type (arr
)))
1951 return value_type (arr
);
1955 struct type
*array_type
=
1956 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1958 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1959 TYPE_FIELD_BITSIZE (array_type
, 0) =
1960 decode_packed_array_bitsize (value_type (arr
));
1966 struct type
*elt_type
;
1968 struct value
*descriptor
;
1970 elt_type
= ada_array_element_type (value_type (arr
), -1);
1971 arity
= ada_array_arity (value_type (arr
));
1973 if (elt_type
== NULL
|| arity
== 0)
1974 return ada_check_typedef (value_type (arr
));
1976 descriptor
= desc_bounds (arr
);
1977 if (value_as_long (descriptor
) == 0)
1981 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1982 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1983 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1984 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1987 create_static_range_type (range_type
, value_type (low
),
1988 longest_to_int (value_as_long (low
)),
1989 longest_to_int (value_as_long (high
)));
1990 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1992 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1994 /* We need to store the element packed bitsize, as well as
1995 recompute the array size, because it was previously
1996 computed based on the unpacked element size. */
1997 LONGEST lo
= value_as_long (low
);
1998 LONGEST hi
= value_as_long (high
);
2000 TYPE_FIELD_BITSIZE (elt_type
, 0) =
2001 decode_packed_array_bitsize (value_type (arr
));
2002 /* If the array has no element, then the size is already
2003 zero, and does not need to be recomputed. */
2007 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
2009 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
2014 return lookup_pointer_type (elt_type
);
2018 /* If ARR does not represent an array, returns ARR unchanged.
2019 Otherwise, returns either a standard GDB array with bounds set
2020 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2021 GDB array. Returns NULL if ARR is a null fat pointer. */
2024 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2026 if (ada_is_array_descriptor_type (value_type (arr
)))
2028 struct type
*arrType
= ada_type_of_array (arr
, 1);
2030 if (arrType
== NULL
)
2032 return value_cast (arrType
, value_copy (desc_data (arr
)));
2034 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2035 return decode_constrained_packed_array (arr
);
2040 /* If ARR does not represent an array, returns ARR unchanged.
2041 Otherwise, returns a standard GDB array describing ARR (which may
2042 be ARR itself if it already is in the proper form). */
2045 ada_coerce_to_simple_array (struct value
*arr
)
2047 if (ada_is_array_descriptor_type (value_type (arr
)))
2049 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2052 error (_("Bounds unavailable for null array pointer."));
2053 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
2054 return value_ind (arrVal
);
2056 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2057 return decode_constrained_packed_array (arr
);
2062 /* If TYPE represents a GNAT array type, return it translated to an
2063 ordinary GDB array type (possibly with BITSIZE fields indicating
2064 packing). For other types, is the identity. */
2067 ada_coerce_to_simple_array_type (struct type
*type
)
2069 if (ada_is_constrained_packed_array_type (type
))
2070 return decode_constrained_packed_array_type (type
);
2072 if (ada_is_array_descriptor_type (type
))
2073 return ada_check_typedef (desc_data_target_type (type
));
2078 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2081 ada_is_packed_array_type (struct type
*type
)
2085 type
= desc_base_type (type
);
2086 type
= ada_check_typedef (type
);
2088 ada_type_name (type
) != NULL
2089 && strstr (ada_type_name (type
), "___XP") != NULL
;
2092 /* Non-zero iff TYPE represents a standard GNAT constrained
2093 packed-array type. */
2096 ada_is_constrained_packed_array_type (struct type
*type
)
2098 return ada_is_packed_array_type (type
)
2099 && !ada_is_array_descriptor_type (type
);
2102 /* Non-zero iff TYPE represents an array descriptor for a
2103 unconstrained packed-array type. */
2106 ada_is_unconstrained_packed_array_type (struct type
*type
)
2108 return ada_is_packed_array_type (type
)
2109 && ada_is_array_descriptor_type (type
);
2112 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2113 return the size of its elements in bits. */
2116 decode_packed_array_bitsize (struct type
*type
)
2118 const char *raw_name
;
2122 /* Access to arrays implemented as fat pointers are encoded as a typedef
2123 of the fat pointer type. We need the name of the fat pointer type
2124 to do the decoding, so strip the typedef layer. */
2125 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
2126 type
= ada_typedef_target_type (type
);
2128 raw_name
= ada_type_name (ada_check_typedef (type
));
2130 raw_name
= ada_type_name (desc_base_type (type
));
2135 tail
= strstr (raw_name
, "___XP");
2136 gdb_assert (tail
!= NULL
);
2138 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2141 (_("could not understand bit size information on packed array"));
2148 /* Given that TYPE is a standard GDB array type with all bounds filled
2149 in, and that the element size of its ultimate scalar constituents
2150 (that is, either its elements, or, if it is an array of arrays, its
2151 elements' elements, etc.) is *ELT_BITS, return an identical type,
2152 but with the bit sizes of its elements (and those of any
2153 constituent arrays) recorded in the BITSIZE components of its
2154 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2157 Note that, for arrays whose index type has an XA encoding where
2158 a bound references a record discriminant, getting that discriminant,
2159 and therefore the actual value of that bound, is not possible
2160 because none of the given parameters gives us access to the record.
2161 This function assumes that it is OK in the context where it is being
2162 used to return an array whose bounds are still dynamic and where
2163 the length is arbitrary. */
2165 static struct type
*
2166 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2168 struct type
*new_elt_type
;
2169 struct type
*new_type
;
2170 struct type
*index_type_desc
;
2171 struct type
*index_type
;
2172 LONGEST low_bound
, high_bound
;
2174 type
= ada_check_typedef (type
);
2175 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2178 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2179 if (index_type_desc
)
2180 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2183 index_type
= TYPE_INDEX_TYPE (type
);
2185 new_type
= alloc_type_copy (type
);
2187 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2189 create_array_type (new_type
, new_elt_type
, index_type
);
2190 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2191 TYPE_NAME (new_type
) = ada_type_name (type
);
2193 if ((TYPE_CODE (check_typedef (index_type
)) == TYPE_CODE_RANGE
2194 && is_dynamic_type (check_typedef (index_type
)))
2195 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2196 low_bound
= high_bound
= 0;
2197 if (high_bound
< low_bound
)
2198 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2201 *elt_bits
*= (high_bound
- low_bound
+ 1);
2202 TYPE_LENGTH (new_type
) =
2203 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2206 TYPE_FIXED_INSTANCE (new_type
) = 1;
2210 /* The array type encoded by TYPE, where
2211 ada_is_constrained_packed_array_type (TYPE). */
2213 static struct type
*
2214 decode_constrained_packed_array_type (struct type
*type
)
2216 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2219 struct type
*shadow_type
;
2223 raw_name
= ada_type_name (desc_base_type (type
));
2228 name
= (char *) alloca (strlen (raw_name
) + 1);
2229 tail
= strstr (raw_name
, "___XP");
2230 type
= desc_base_type (type
);
2232 memcpy (name
, raw_name
, tail
- raw_name
);
2233 name
[tail
- raw_name
] = '\000';
2235 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2237 if (shadow_type
== NULL
)
2239 lim_warning (_("could not find bounds information on packed array"));
2242 CHECK_TYPEDEF (shadow_type
);
2244 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2246 lim_warning (_("could not understand bounds "
2247 "information on packed array"));
2251 bits
= decode_packed_array_bitsize (type
);
2252 return constrained_packed_array_type (shadow_type
, &bits
);
2255 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2256 array, returns a simple array that denotes that array. Its type is a
2257 standard GDB array type except that the BITSIZEs of the array
2258 target types are set to the number of bits in each element, and the
2259 type length is set appropriately. */
2261 static struct value
*
2262 decode_constrained_packed_array (struct value
*arr
)
2266 /* If our value is a pointer, then dereference it. Likewise if
2267 the value is a reference. Make sure that this operation does not
2268 cause the target type to be fixed, as this would indirectly cause
2269 this array to be decoded. The rest of the routine assumes that
2270 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2271 and "value_ind" routines to perform the dereferencing, as opposed
2272 to using "ada_coerce_ref" or "ada_value_ind". */
2273 arr
= coerce_ref (arr
);
2274 if (TYPE_CODE (ada_check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2275 arr
= value_ind (arr
);
2277 type
= decode_constrained_packed_array_type (value_type (arr
));
2280 error (_("can't unpack array"));
2284 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2285 && ada_is_modular_type (value_type (arr
)))
2287 /* This is a (right-justified) modular type representing a packed
2288 array with no wrapper. In order to interpret the value through
2289 the (left-justified) packed array type we just built, we must
2290 first left-justify it. */
2291 int bit_size
, bit_pos
;
2294 mod
= ada_modulus (value_type (arr
)) - 1;
2301 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2302 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2303 bit_pos
/ HOST_CHAR_BIT
,
2304 bit_pos
% HOST_CHAR_BIT
,
2309 return coerce_unspec_val_to_type (arr
, type
);
2313 /* The value of the element of packed array ARR at the ARITY indices
2314 given in IND. ARR must be a simple array. */
2316 static struct value
*
2317 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2320 int bits
, elt_off
, bit_off
;
2321 long elt_total_bit_offset
;
2322 struct type
*elt_type
;
2326 elt_total_bit_offset
= 0;
2327 elt_type
= ada_check_typedef (value_type (arr
));
2328 for (i
= 0; i
< arity
; i
+= 1)
2330 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2331 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2333 (_("attempt to do packed indexing of "
2334 "something other than a packed array"));
2337 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2338 LONGEST lowerbound
, upperbound
;
2341 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2343 lim_warning (_("don't know bounds of array"));
2344 lowerbound
= upperbound
= 0;
2347 idx
= pos_atr (ind
[i
]);
2348 if (idx
< lowerbound
|| idx
> upperbound
)
2349 lim_warning (_("packed array index %ld out of bounds"),
2351 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2352 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2353 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2356 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2357 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2359 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2364 /* Non-zero iff TYPE includes negative integer values. */
2367 has_negatives (struct type
*type
)
2369 switch (TYPE_CODE (type
))
2374 return !TYPE_UNSIGNED (type
);
2375 case TYPE_CODE_RANGE
:
2376 return TYPE_LOW_BOUND (type
) < 0;
2381 /* Create a new value of type TYPE from the contents of OBJ starting
2382 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2383 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2384 assigning through the result will set the field fetched from.
2385 VALADDR is ignored unless OBJ is NULL, in which case,
2386 VALADDR+OFFSET must address the start of storage containing the
2387 packed value. The value returned in this case is never an lval.
2388 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2391 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2392 long offset
, int bit_offset
, int bit_size
,
2396 int src
, /* Index into the source area */
2397 targ
, /* Index into the target area */
2398 srcBitsLeft
, /* Number of source bits left to move */
2399 nsrc
, ntarg
, /* Number of source and target bytes */
2400 unusedLS
, /* Number of bits in next significant
2401 byte of source that are unused */
2402 accumSize
; /* Number of meaningful bits in accum */
2403 unsigned char *bytes
; /* First byte containing data to unpack */
2404 unsigned char *unpacked
;
2405 unsigned long accum
; /* Staging area for bits being transferred */
2407 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2408 /* Transmit bytes from least to most significant; delta is the direction
2409 the indices move. */
2410 int delta
= gdbarch_bits_big_endian (get_type_arch (type
)) ? -1 : 1;
2412 type
= ada_check_typedef (type
);
2416 v
= allocate_value (type
);
2417 bytes
= (unsigned char *) (valaddr
+ offset
);
2419 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2421 v
= value_at (type
, value_address (obj
));
2422 type
= value_type (v
);
2423 bytes
= (unsigned char *) alloca (len
);
2424 read_memory (value_address (v
) + offset
, bytes
, len
);
2428 v
= allocate_value (type
);
2429 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2434 long new_offset
= offset
;
2436 set_value_component_location (v
, obj
);
2437 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2438 set_value_bitsize (v
, bit_size
);
2439 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2442 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2444 set_value_offset (v
, new_offset
);
2446 /* Also set the parent value. This is needed when trying to
2447 assign a new value (in inferior memory). */
2448 set_value_parent (v
, obj
);
2451 set_value_bitsize (v
, bit_size
);
2452 unpacked
= (unsigned char *) value_contents (v
);
2454 srcBitsLeft
= bit_size
;
2456 ntarg
= TYPE_LENGTH (type
);
2460 memset (unpacked
, 0, TYPE_LENGTH (type
));
2463 else if (gdbarch_bits_big_endian (get_type_arch (type
)))
2466 if (has_negatives (type
)
2467 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2471 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2474 switch (TYPE_CODE (type
))
2476 case TYPE_CODE_ARRAY
:
2477 case TYPE_CODE_UNION
:
2478 case TYPE_CODE_STRUCT
:
2479 /* Non-scalar values must be aligned at a byte boundary... */
2481 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2482 /* ... And are placed at the beginning (most-significant) bytes
2484 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2489 targ
= TYPE_LENGTH (type
) - 1;
2495 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2498 unusedLS
= bit_offset
;
2501 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2508 /* Mask for removing bits of the next source byte that are not
2509 part of the value. */
2510 unsigned int unusedMSMask
=
2511 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2513 /* Sign-extend bits for this byte. */
2514 unsigned int signMask
= sign
& ~unusedMSMask
;
2517 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2518 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2519 if (accumSize
>= HOST_CHAR_BIT
)
2521 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2522 accumSize
-= HOST_CHAR_BIT
;
2523 accum
>>= HOST_CHAR_BIT
;
2527 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2534 accum
|= sign
<< accumSize
;
2535 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2536 accumSize
-= HOST_CHAR_BIT
;
2537 accum
>>= HOST_CHAR_BIT
;
2545 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2546 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2549 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2550 int src_offset
, int n
, int bits_big_endian_p
)
2552 unsigned int accum
, mask
;
2553 int accum_bits
, chunk_size
;
2555 target
+= targ_offset
/ HOST_CHAR_BIT
;
2556 targ_offset
%= HOST_CHAR_BIT
;
2557 source
+= src_offset
/ HOST_CHAR_BIT
;
2558 src_offset
%= HOST_CHAR_BIT
;
2559 if (bits_big_endian_p
)
2561 accum
= (unsigned char) *source
;
2563 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2569 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2570 accum_bits
+= HOST_CHAR_BIT
;
2572 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2575 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2576 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2579 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2581 accum_bits
-= chunk_size
;
2588 accum
= (unsigned char) *source
>> src_offset
;
2590 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2594 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2595 accum_bits
+= HOST_CHAR_BIT
;
2597 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2600 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2601 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2603 accum_bits
-= chunk_size
;
2604 accum
>>= chunk_size
;
2611 /* Store the contents of FROMVAL into the location of TOVAL.
2612 Return a new value with the location of TOVAL and contents of
2613 FROMVAL. Handles assignment into packed fields that have
2614 floating-point or non-scalar types. */
2616 static struct value
*
2617 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2619 struct type
*type
= value_type (toval
);
2620 int bits
= value_bitsize (toval
);
2622 toval
= ada_coerce_ref (toval
);
2623 fromval
= ada_coerce_ref (fromval
);
2625 if (ada_is_direct_array_type (value_type (toval
)))
2626 toval
= ada_coerce_to_simple_array (toval
);
2627 if (ada_is_direct_array_type (value_type (fromval
)))
2628 fromval
= ada_coerce_to_simple_array (fromval
);
2630 if (!deprecated_value_modifiable (toval
))
2631 error (_("Left operand of assignment is not a modifiable lvalue."));
2633 if (VALUE_LVAL (toval
) == lval_memory
2635 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2636 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2638 int len
= (value_bitpos (toval
)
2639 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2641 gdb_byte
*buffer
= alloca (len
);
2643 CORE_ADDR to_addr
= value_address (toval
);
2645 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2646 fromval
= value_cast (type
, fromval
);
2648 read_memory (to_addr
, buffer
, len
);
2649 from_size
= value_bitsize (fromval
);
2651 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2652 if (gdbarch_bits_big_endian (get_type_arch (type
)))
2653 move_bits (buffer
, value_bitpos (toval
),
2654 value_contents (fromval
), from_size
- bits
, bits
, 1);
2656 move_bits (buffer
, value_bitpos (toval
),
2657 value_contents (fromval
), 0, bits
, 0);
2658 write_memory_with_notification (to_addr
, buffer
, len
);
2660 val
= value_copy (toval
);
2661 memcpy (value_contents_raw (val
), value_contents (fromval
),
2662 TYPE_LENGTH (type
));
2663 deprecated_set_value_type (val
, type
);
2668 return value_assign (toval
, fromval
);
2672 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2673 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2674 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2675 * COMPONENT, and not the inferior's memory. The current contents
2676 * of COMPONENT are ignored. */
2678 value_assign_to_component (struct value
*container
, struct value
*component
,
2681 LONGEST offset_in_container
=
2682 (LONGEST
) (value_address (component
) - value_address (container
));
2683 int bit_offset_in_container
=
2684 value_bitpos (component
) - value_bitpos (container
);
2687 val
= value_cast (value_type (component
), val
);
2689 if (value_bitsize (component
) == 0)
2690 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2692 bits
= value_bitsize (component
);
2694 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2695 move_bits (value_contents_writeable (container
) + offset_in_container
,
2696 value_bitpos (container
) + bit_offset_in_container
,
2697 value_contents (val
),
2698 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2701 move_bits (value_contents_writeable (container
) + offset_in_container
,
2702 value_bitpos (container
) + bit_offset_in_container
,
2703 value_contents (val
), 0, bits
, 0);
2706 /* The value of the element of array ARR at the ARITY indices given in IND.
2707 ARR may be either a simple array, GNAT array descriptor, or pointer
2711 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2715 struct type
*elt_type
;
2717 elt
= ada_coerce_to_simple_array (arr
);
2719 elt_type
= ada_check_typedef (value_type (elt
));
2720 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2721 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2722 return value_subscript_packed (elt
, arity
, ind
);
2724 for (k
= 0; k
< arity
; k
+= 1)
2726 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2727 error (_("too many subscripts (%d expected)"), k
);
2728 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2733 /* Assuming ARR is a pointer to a GDB array, the value of the element
2734 of *ARR at the ARITY indices given in IND.
2735 Does not read the entire array into memory. */
2737 static struct value
*
2738 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2742 = check_typedef (value_enclosing_type (ada_value_ind (arr
)));
2744 for (k
= 0; k
< arity
; k
+= 1)
2748 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2749 error (_("too many subscripts (%d expected)"), k
);
2750 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2752 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2753 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2754 type
= TYPE_TARGET_TYPE (type
);
2757 return value_ind (arr
);
2760 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2761 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2762 elements starting at index LOW. The lower bound of this array is LOW, as
2764 static struct value
*
2765 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2768 struct type
*type0
= ada_check_typedef (type
);
2769 CORE_ADDR base
= value_as_address (array_ptr
)
2770 + ((low
- ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
)))
2771 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2772 struct type
*index_type
2773 = create_static_range_type (NULL
,
2774 TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
)),
2776 struct type
*slice_type
=
2777 create_array_type (NULL
, TYPE_TARGET_TYPE (type0
), index_type
);
2779 return value_at_lazy (slice_type
, base
);
2783 static struct value
*
2784 ada_value_slice (struct value
*array
, int low
, int high
)
2786 struct type
*type
= ada_check_typedef (value_type (array
));
2787 struct type
*index_type
2788 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2789 struct type
*slice_type
=
2790 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2792 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2795 /* If type is a record type in the form of a standard GNAT array
2796 descriptor, returns the number of dimensions for type. If arr is a
2797 simple array, returns the number of "array of"s that prefix its
2798 type designation. Otherwise, returns 0. */
2801 ada_array_arity (struct type
*type
)
2808 type
= desc_base_type (type
);
2811 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2812 return desc_arity (desc_bounds_type (type
));
2814 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2817 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2823 /* If TYPE is a record type in the form of a standard GNAT array
2824 descriptor or a simple array type, returns the element type for
2825 TYPE after indexing by NINDICES indices, or by all indices if
2826 NINDICES is -1. Otherwise, returns NULL. */
2829 ada_array_element_type (struct type
*type
, int nindices
)
2831 type
= desc_base_type (type
);
2833 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2836 struct type
*p_array_type
;
2838 p_array_type
= desc_data_target_type (type
);
2840 k
= ada_array_arity (type
);
2844 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2845 if (nindices
>= 0 && k
> nindices
)
2847 while (k
> 0 && p_array_type
!= NULL
)
2849 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2852 return p_array_type
;
2854 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2856 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2858 type
= TYPE_TARGET_TYPE (type
);
2867 /* The type of nth index in arrays of given type (n numbering from 1).
2868 Does not examine memory. Throws an error if N is invalid or TYPE
2869 is not an array type. NAME is the name of the Ada attribute being
2870 evaluated ('range, 'first, 'last, or 'length); it is used in building
2871 the error message. */
2873 static struct type
*
2874 ada_index_type (struct type
*type
, int n
, const char *name
)
2876 struct type
*result_type
;
2878 type
= desc_base_type (type
);
2880 if (n
< 0 || n
> ada_array_arity (type
))
2881 error (_("invalid dimension number to '%s"), name
);
2883 if (ada_is_simple_array_type (type
))
2887 for (i
= 1; i
< n
; i
+= 1)
2888 type
= TYPE_TARGET_TYPE (type
);
2889 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2890 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2891 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2892 perhaps stabsread.c would make more sense. */
2893 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2898 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2899 if (result_type
== NULL
)
2900 error (_("attempt to take bound of something that is not an array"));
2906 /* Given that arr is an array type, returns the lower bound of the
2907 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2908 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2909 array-descriptor type. It works for other arrays with bounds supplied
2910 by run-time quantities other than discriminants. */
2913 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2915 struct type
*type
, *index_type_desc
, *index_type
;
2918 gdb_assert (which
== 0 || which
== 1);
2920 if (ada_is_constrained_packed_array_type (arr_type
))
2921 arr_type
= decode_constrained_packed_array_type (arr_type
);
2923 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2924 return (LONGEST
) - which
;
2926 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2927 type
= TYPE_TARGET_TYPE (arr_type
);
2931 if (TYPE_FIXED_INSTANCE (type
))
2933 /* The array has already been fixed, so we do not need to
2934 check the parallel ___XA type again. That encoding has
2935 already been applied, so ignore it now. */
2936 index_type_desc
= NULL
;
2940 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2941 ada_fixup_array_indexes_type (index_type_desc
);
2944 if (index_type_desc
!= NULL
)
2945 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2949 struct type
*elt_type
= check_typedef (type
);
2951 for (i
= 1; i
< n
; i
++)
2952 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2954 index_type
= TYPE_INDEX_TYPE (elt_type
);
2958 (LONGEST
) (which
== 0
2959 ? ada_discrete_type_low_bound (index_type
)
2960 : ada_discrete_type_high_bound (index_type
));
2963 /* Given that arr is an array value, returns the lower bound of the
2964 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2965 WHICH is 1. This routine will also work for arrays with bounds
2966 supplied by run-time quantities other than discriminants. */
2969 ada_array_bound (struct value
*arr
, int n
, int which
)
2971 struct type
*arr_type
;
2973 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2974 arr
= value_ind (arr
);
2975 arr_type
= value_enclosing_type (arr
);
2977 if (ada_is_constrained_packed_array_type (arr_type
))
2978 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2979 else if (ada_is_simple_array_type (arr_type
))
2980 return ada_array_bound_from_type (arr_type
, n
, which
);
2982 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2985 /* Given that arr is an array value, returns the length of the
2986 nth index. This routine will also work for arrays with bounds
2987 supplied by run-time quantities other than discriminants.
2988 Does not work for arrays indexed by enumeration types with representation
2989 clauses at the moment. */
2992 ada_array_length (struct value
*arr
, int n
)
2994 struct type
*arr_type
;
2996 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2997 arr
= value_ind (arr
);
2998 arr_type
= value_enclosing_type (arr
);
3000 if (ada_is_constrained_packed_array_type (arr_type
))
3001 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3003 if (ada_is_simple_array_type (arr_type
))
3004 return (ada_array_bound_from_type (arr_type
, n
, 1)
3005 - ada_array_bound_from_type (arr_type
, n
, 0) + 1);
3007 return (value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1))
3008 - value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0)) + 1);
3011 /* An empty array whose type is that of ARR_TYPE (an array type),
3012 with bounds LOW to LOW-1. */
3014 static struct value
*
3015 empty_array (struct type
*arr_type
, int low
)
3017 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3018 struct type
*index_type
3019 = create_static_range_type
3020 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
, low
- 1);
3021 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3023 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3027 /* Name resolution */
3029 /* The "decoded" name for the user-definable Ada operator corresponding
3033 ada_decoded_op_name (enum exp_opcode op
)
3037 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3039 if (ada_opname_table
[i
].op
== op
)
3040 return ada_opname_table
[i
].decoded
;
3042 error (_("Could not find operator name for opcode"));
3046 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3047 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3048 undefined namespace) and converts operators that are
3049 user-defined into appropriate function calls. If CONTEXT_TYPE is
3050 non-null, it provides a preferred result type [at the moment, only
3051 type void has any effect---causing procedures to be preferred over
3052 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3053 return type is preferred. May change (expand) *EXP. */
3056 resolve (struct expression
**expp
, int void_context_p
)
3058 struct type
*context_type
= NULL
;
3062 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3064 resolve_subexp (expp
, &pc
, 1, context_type
);
3067 /* Resolve the operator of the subexpression beginning at
3068 position *POS of *EXPP. "Resolving" consists of replacing
3069 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3070 with their resolutions, replacing built-in operators with
3071 function calls to user-defined operators, where appropriate, and,
3072 when DEPROCEDURE_P is non-zero, converting function-valued variables
3073 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3074 are as in ada_resolve, above. */
3076 static struct value
*
3077 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
3078 struct type
*context_type
)
3082 struct expression
*exp
; /* Convenience: == *expp. */
3083 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3084 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3085 int nargs
; /* Number of operands. */
3092 /* Pass one: resolve operands, saving their types and updating *pos,
3097 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3098 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3103 resolve_subexp (expp
, pos
, 0, NULL
);
3105 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3110 resolve_subexp (expp
, pos
, 0, NULL
);
3115 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
));
3118 case OP_ATR_MODULUS
:
3128 case TERNOP_IN_RANGE
:
3129 case BINOP_IN_BOUNDS
:
3135 case OP_DISCRETE_RANGE
:
3137 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3146 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
3148 resolve_subexp (expp
, pos
, 1, NULL
);
3150 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
3167 case BINOP_LOGICAL_AND
:
3168 case BINOP_LOGICAL_OR
:
3169 case BINOP_BITWISE_AND
:
3170 case BINOP_BITWISE_IOR
:
3171 case BINOP_BITWISE_XOR
:
3174 case BINOP_NOTEQUAL
:
3181 case BINOP_SUBSCRIPT
:
3189 case UNOP_LOGICAL_NOT
:
3205 case OP_INTERNALVAR
:
3215 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3218 case STRUCTOP_STRUCT
:
3219 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3232 error (_("Unexpected operator during name resolution"));
3235 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
3236 for (i
= 0; i
< nargs
; i
+= 1)
3237 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
3241 /* Pass two: perform any resolution on principal operator. */
3248 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3250 struct ada_symbol_info
*candidates
;
3254 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3255 (exp
->elts
[pc
+ 2].symbol
),
3256 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3259 if (n_candidates
> 1)
3261 /* Types tend to get re-introduced locally, so if there
3262 are any local symbols that are not types, first filter
3265 for (j
= 0; j
< n_candidates
; j
+= 1)
3266 switch (SYMBOL_CLASS (candidates
[j
].sym
))
3271 case LOC_REGPARM_ADDR
:
3279 if (j
< n_candidates
)
3282 while (j
< n_candidates
)
3284 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
3286 candidates
[j
] = candidates
[n_candidates
- 1];
3295 if (n_candidates
== 0)
3296 error (_("No definition found for %s"),
3297 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3298 else if (n_candidates
== 1)
3300 else if (deprocedure_p
3301 && !is_nonfunction (candidates
, n_candidates
))
3303 i
= ada_resolve_function
3304 (candidates
, n_candidates
, NULL
, 0,
3305 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3308 error (_("Could not find a match for %s"),
3309 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3313 printf_filtered (_("Multiple matches for %s\n"),
3314 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3315 user_select_syms (candidates
, n_candidates
, 1);
3319 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3320 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
3321 if (innermost_block
== NULL
3322 || contained_in (candidates
[i
].block
, innermost_block
))
3323 innermost_block
= candidates
[i
].block
;
3327 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3330 replace_operator_with_call (expp
, pc
, 0, 0,
3331 exp
->elts
[pc
+ 2].symbol
,
3332 exp
->elts
[pc
+ 1].block
);
3339 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3340 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3342 struct ada_symbol_info
*candidates
;
3346 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3347 (exp
->elts
[pc
+ 5].symbol
),
3348 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3350 if (n_candidates
== 1)
3354 i
= ada_resolve_function
3355 (candidates
, n_candidates
,
3357 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3360 error (_("Could not find a match for %s"),
3361 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3364 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3365 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
3366 if (innermost_block
== NULL
3367 || contained_in (candidates
[i
].block
, innermost_block
))
3368 innermost_block
= candidates
[i
].block
;
3379 case BINOP_BITWISE_AND
:
3380 case BINOP_BITWISE_IOR
:
3381 case BINOP_BITWISE_XOR
:
3383 case BINOP_NOTEQUAL
:
3391 case UNOP_LOGICAL_NOT
:
3393 if (possible_user_operator_p (op
, argvec
))
3395 struct ada_symbol_info
*candidates
;
3399 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3400 (struct block
*) NULL
, VAR_DOMAIN
,
3402 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3403 ada_decoded_op_name (op
), NULL
);
3407 replace_operator_with_call (expp
, pc
, nargs
, 1,
3408 candidates
[i
].sym
, candidates
[i
].block
);
3419 return evaluate_subexp_type (exp
, pos
);
3422 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3423 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3425 /* The term "match" here is rather loose. The match is heuristic and
3429 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3431 ftype
= ada_check_typedef (ftype
);
3432 atype
= ada_check_typedef (atype
);
3434 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3435 ftype
= TYPE_TARGET_TYPE (ftype
);
3436 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3437 atype
= TYPE_TARGET_TYPE (atype
);
3439 switch (TYPE_CODE (ftype
))
3442 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3444 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3445 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3446 TYPE_TARGET_TYPE (atype
), 0);
3449 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3451 case TYPE_CODE_ENUM
:
3452 case TYPE_CODE_RANGE
:
3453 switch (TYPE_CODE (atype
))
3456 case TYPE_CODE_ENUM
:
3457 case TYPE_CODE_RANGE
:
3463 case TYPE_CODE_ARRAY
:
3464 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3465 || ada_is_array_descriptor_type (atype
));
3467 case TYPE_CODE_STRUCT
:
3468 if (ada_is_array_descriptor_type (ftype
))
3469 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3470 || ada_is_array_descriptor_type (atype
));
3472 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3473 && !ada_is_array_descriptor_type (atype
));
3475 case TYPE_CODE_UNION
:
3477 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3481 /* Return non-zero if the formals of FUNC "sufficiently match" the
3482 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3483 may also be an enumeral, in which case it is treated as a 0-
3484 argument function. */
3487 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3490 struct type
*func_type
= SYMBOL_TYPE (func
);
3492 if (SYMBOL_CLASS (func
) == LOC_CONST
3493 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3494 return (n_actuals
== 0);
3495 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3498 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3501 for (i
= 0; i
< n_actuals
; i
+= 1)
3503 if (actuals
[i
] == NULL
)
3507 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3509 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3511 if (!ada_type_match (ftype
, atype
, 1))
3518 /* False iff function type FUNC_TYPE definitely does not produce a value
3519 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3520 FUNC_TYPE is not a valid function type with a non-null return type
3521 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3524 return_match (struct type
*func_type
, struct type
*context_type
)
3526 struct type
*return_type
;
3528 if (func_type
== NULL
)
3531 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3532 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3534 return_type
= get_base_type (func_type
);
3535 if (return_type
== NULL
)
3538 context_type
= get_base_type (context_type
);
3540 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3541 return context_type
== NULL
|| return_type
== context_type
;
3542 else if (context_type
== NULL
)
3543 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3545 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3549 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3550 function (if any) that matches the types of the NARGS arguments in
3551 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3552 that returns that type, then eliminate matches that don't. If
3553 CONTEXT_TYPE is void and there is at least one match that does not
3554 return void, eliminate all matches that do.
3556 Asks the user if there is more than one match remaining. Returns -1
3557 if there is no such symbol or none is selected. NAME is used
3558 solely for messages. May re-arrange and modify SYMS in
3559 the process; the index returned is for the modified vector. */
3562 ada_resolve_function (struct ada_symbol_info syms
[],
3563 int nsyms
, struct value
**args
, int nargs
,
3564 const char *name
, struct type
*context_type
)
3568 int m
; /* Number of hits */
3571 /* In the first pass of the loop, we only accept functions matching
3572 context_type. If none are found, we add a second pass of the loop
3573 where every function is accepted. */
3574 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3576 for (k
= 0; k
< nsyms
; k
+= 1)
3578 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3580 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3581 && (fallback
|| return_match (type
, context_type
)))
3593 printf_filtered (_("Multiple matches for %s\n"), name
);
3594 user_select_syms (syms
, m
, 1);
3600 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3601 in a listing of choices during disambiguation (see sort_choices, below).
3602 The idea is that overloadings of a subprogram name from the
3603 same package should sort in their source order. We settle for ordering
3604 such symbols by their trailing number (__N or $N). */
3607 encoded_ordered_before (const char *N0
, const char *N1
)
3611 else if (N0
== NULL
)
3617 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3619 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3621 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3622 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3627 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3630 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3632 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3633 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3635 return (strcmp (N0
, N1
) < 0);
3639 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3643 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3647 for (i
= 1; i
< nsyms
; i
+= 1)
3649 struct ada_symbol_info sym
= syms
[i
];
3652 for (j
= i
- 1; j
>= 0; j
-= 1)
3654 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3655 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3657 syms
[j
+ 1] = syms
[j
];
3663 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3664 by asking the user (if necessary), returning the number selected,
3665 and setting the first elements of SYMS items. Error if no symbols
3668 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3669 to be re-integrated one of these days. */
3672 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3675 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3677 int first_choice
= (max_results
== 1) ? 1 : 2;
3678 const char *select_mode
= multiple_symbols_select_mode ();
3680 if (max_results
< 1)
3681 error (_("Request to select 0 symbols!"));
3685 if (select_mode
== multiple_symbols_cancel
)
3687 canceled because the command is ambiguous\n\
3688 See set/show multiple-symbol."));
3690 /* If select_mode is "all", then return all possible symbols.
3691 Only do that if more than one symbol can be selected, of course.
3692 Otherwise, display the menu as usual. */
3693 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3696 printf_unfiltered (_("[0] cancel\n"));
3697 if (max_results
> 1)
3698 printf_unfiltered (_("[1] all\n"));
3700 sort_choices (syms
, nsyms
);
3702 for (i
= 0; i
< nsyms
; i
+= 1)
3704 if (syms
[i
].sym
== NULL
)
3707 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3709 struct symtab_and_line sal
=
3710 find_function_start_sal (syms
[i
].sym
, 1);
3712 if (sal
.symtab
== NULL
)
3713 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3715 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3718 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3719 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3720 symtab_to_filename_for_display (sal
.symtab
),
3727 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3728 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3729 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3730 struct symtab
*symtab
= NULL
;
3732 if (SYMBOL_OBJFILE_OWNED (syms
[i
].sym
))
3733 symtab
= symbol_symtab (syms
[i
].sym
);
3735 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3736 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3738 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3739 symtab_to_filename_for_display (symtab
),
3740 SYMBOL_LINE (syms
[i
].sym
));
3741 else if (is_enumeral
3742 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3744 printf_unfiltered (("[%d] "), i
+ first_choice
);
3745 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3746 gdb_stdout
, -1, 0, &type_print_raw_options
);
3747 printf_unfiltered (_("'(%s) (enumeral)\n"),
3748 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3750 else if (symtab
!= NULL
)
3751 printf_unfiltered (is_enumeral
3752 ? _("[%d] %s in %s (enumeral)\n")
3753 : _("[%d] %s at %s:?\n"),
3755 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3756 symtab_to_filename_for_display (symtab
));
3758 printf_unfiltered (is_enumeral
3759 ? _("[%d] %s (enumeral)\n")
3760 : _("[%d] %s at ?\n"),
3762 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3766 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3769 for (i
= 0; i
< n_chosen
; i
+= 1)
3770 syms
[i
] = syms
[chosen
[i
]];
3775 /* Read and validate a set of numeric choices from the user in the
3776 range 0 .. N_CHOICES-1. Place the results in increasing
3777 order in CHOICES[0 .. N-1], and return N.
3779 The user types choices as a sequence of numbers on one line
3780 separated by blanks, encoding them as follows:
3782 + A choice of 0 means to cancel the selection, throwing an error.
3783 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3784 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3786 The user is not allowed to choose more than MAX_RESULTS values.
3788 ANNOTATION_SUFFIX, if present, is used to annotate the input
3789 prompts (for use with the -f switch). */
3792 get_selections (int *choices
, int n_choices
, int max_results
,
3793 int is_all_choice
, char *annotation_suffix
)
3798 int first_choice
= is_all_choice
? 2 : 1;
3800 prompt
= getenv ("PS2");
3804 args
= command_line_input (prompt
, 0, annotation_suffix
);
3807 error_no_arg (_("one or more choice numbers"));
3811 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3812 order, as given in args. Choices are validated. */
3818 args
= skip_spaces (args
);
3819 if (*args
== '\0' && n_chosen
== 0)
3820 error_no_arg (_("one or more choice numbers"));
3821 else if (*args
== '\0')
3824 choice
= strtol (args
, &args2
, 10);
3825 if (args
== args2
|| choice
< 0
3826 || choice
> n_choices
+ first_choice
- 1)
3827 error (_("Argument must be choice number"));
3831 error (_("cancelled"));
3833 if (choice
< first_choice
)
3835 n_chosen
= n_choices
;
3836 for (j
= 0; j
< n_choices
; j
+= 1)
3840 choice
-= first_choice
;
3842 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3846 if (j
< 0 || choice
!= choices
[j
])
3850 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3851 choices
[k
+ 1] = choices
[k
];
3852 choices
[j
+ 1] = choice
;
3857 if (n_chosen
> max_results
)
3858 error (_("Select no more than %d of the above"), max_results
);
3863 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3864 on the function identified by SYM and BLOCK, and taking NARGS
3865 arguments. Update *EXPP as needed to hold more space. */
3868 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3869 int oplen
, struct symbol
*sym
,
3870 const struct block
*block
)
3872 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3873 symbol, -oplen for operator being replaced). */
3874 struct expression
*newexp
= (struct expression
*)
3875 xzalloc (sizeof (struct expression
)
3876 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3877 struct expression
*exp
= *expp
;
3879 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3880 newexp
->language_defn
= exp
->language_defn
;
3881 newexp
->gdbarch
= exp
->gdbarch
;
3882 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3883 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3884 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3886 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3887 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3889 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3890 newexp
->elts
[pc
+ 4].block
= block
;
3891 newexp
->elts
[pc
+ 5].symbol
= sym
;
3897 /* Type-class predicates */
3899 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3903 numeric_type_p (struct type
*type
)
3909 switch (TYPE_CODE (type
))
3914 case TYPE_CODE_RANGE
:
3915 return (type
== TYPE_TARGET_TYPE (type
)
3916 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3923 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3926 integer_type_p (struct type
*type
)
3932 switch (TYPE_CODE (type
))
3936 case TYPE_CODE_RANGE
:
3937 return (type
== TYPE_TARGET_TYPE (type
)
3938 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3945 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3948 scalar_type_p (struct type
*type
)
3954 switch (TYPE_CODE (type
))
3957 case TYPE_CODE_RANGE
:
3958 case TYPE_CODE_ENUM
:
3967 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3970 discrete_type_p (struct type
*type
)
3976 switch (TYPE_CODE (type
))
3979 case TYPE_CODE_RANGE
:
3980 case TYPE_CODE_ENUM
:
3981 case TYPE_CODE_BOOL
:
3989 /* Returns non-zero if OP with operands in the vector ARGS could be
3990 a user-defined function. Errs on the side of pre-defined operators
3991 (i.e., result 0). */
3994 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3996 struct type
*type0
=
3997 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3998 struct type
*type1
=
3999 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4013 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4017 case BINOP_BITWISE_AND
:
4018 case BINOP_BITWISE_IOR
:
4019 case BINOP_BITWISE_XOR
:
4020 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4023 case BINOP_NOTEQUAL
:
4028 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4031 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4034 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4038 case UNOP_LOGICAL_NOT
:
4040 return (!numeric_type_p (type0
));
4049 1. In the following, we assume that a renaming type's name may
4050 have an ___XD suffix. It would be nice if this went away at some
4052 2. We handle both the (old) purely type-based representation of
4053 renamings and the (new) variable-based encoding. At some point,
4054 it is devoutly to be hoped that the former goes away
4055 (FIXME: hilfinger-2007-07-09).
4056 3. Subprogram renamings are not implemented, although the XRS
4057 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4059 /* If SYM encodes a renaming,
4061 <renaming> renames <renamed entity>,
4063 sets *LEN to the length of the renamed entity's name,
4064 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4065 the string describing the subcomponent selected from the renamed
4066 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4067 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4068 are undefined). Otherwise, returns a value indicating the category
4069 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4070 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4071 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4072 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4073 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4074 may be NULL, in which case they are not assigned.
4076 [Currently, however, GCC does not generate subprogram renamings.] */
4078 enum ada_renaming_category
4079 ada_parse_renaming (struct symbol
*sym
,
4080 const char **renamed_entity
, int *len
,
4081 const char **renaming_expr
)
4083 enum ada_renaming_category kind
;
4088 return ADA_NOT_RENAMING
;
4089 switch (SYMBOL_CLASS (sym
))
4092 return ADA_NOT_RENAMING
;
4094 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
4095 renamed_entity
, len
, renaming_expr
);
4099 case LOC_OPTIMIZED_OUT
:
4100 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
4102 return ADA_NOT_RENAMING
;
4106 kind
= ADA_OBJECT_RENAMING
;
4110 kind
= ADA_EXCEPTION_RENAMING
;
4114 kind
= ADA_PACKAGE_RENAMING
;
4118 kind
= ADA_SUBPROGRAM_RENAMING
;
4122 return ADA_NOT_RENAMING
;
4126 if (renamed_entity
!= NULL
)
4127 *renamed_entity
= info
;
4128 suffix
= strstr (info
, "___XE");
4129 if (suffix
== NULL
|| suffix
== info
)
4130 return ADA_NOT_RENAMING
;
4132 *len
= strlen (info
) - strlen (suffix
);
4134 if (renaming_expr
!= NULL
)
4135 *renaming_expr
= suffix
;
4139 /* Assuming TYPE encodes a renaming according to the old encoding in
4140 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4141 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4142 ADA_NOT_RENAMING otherwise. */
4143 static enum ada_renaming_category
4144 parse_old_style_renaming (struct type
*type
,
4145 const char **renamed_entity
, int *len
,
4146 const char **renaming_expr
)
4148 enum ada_renaming_category kind
;
4153 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
4154 || TYPE_NFIELDS (type
) != 1)
4155 return ADA_NOT_RENAMING
;
4157 name
= type_name_no_tag (type
);
4159 return ADA_NOT_RENAMING
;
4161 name
= strstr (name
, "___XR");
4163 return ADA_NOT_RENAMING
;
4168 kind
= ADA_OBJECT_RENAMING
;
4171 kind
= ADA_EXCEPTION_RENAMING
;
4174 kind
= ADA_PACKAGE_RENAMING
;
4177 kind
= ADA_SUBPROGRAM_RENAMING
;
4180 return ADA_NOT_RENAMING
;
4183 info
= TYPE_FIELD_NAME (type
, 0);
4185 return ADA_NOT_RENAMING
;
4186 if (renamed_entity
!= NULL
)
4187 *renamed_entity
= info
;
4188 suffix
= strstr (info
, "___XE");
4189 if (renaming_expr
!= NULL
)
4190 *renaming_expr
= suffix
+ 5;
4191 if (suffix
== NULL
|| suffix
== info
)
4192 return ADA_NOT_RENAMING
;
4194 *len
= suffix
- info
;
4198 /* Compute the value of the given RENAMING_SYM, which is expected to
4199 be a symbol encoding a renaming expression. BLOCK is the block
4200 used to evaluate the renaming. */
4202 static struct value
*
4203 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4204 const struct block
*block
)
4206 const char *sym_name
;
4207 struct expression
*expr
;
4208 struct value
*value
;
4209 struct cleanup
*old_chain
= NULL
;
4211 sym_name
= SYMBOL_LINKAGE_NAME (renaming_sym
);
4212 expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4213 old_chain
= make_cleanup (free_current_contents
, &expr
);
4214 value
= evaluate_expression (expr
);
4216 do_cleanups (old_chain
);
4221 /* Evaluation: Function Calls */
4223 /* Return an lvalue containing the value VAL. This is the identity on
4224 lvalues, and otherwise has the side-effect of allocating memory
4225 in the inferior where a copy of the value contents is copied. */
4227 static struct value
*
4228 ensure_lval (struct value
*val
)
4230 if (VALUE_LVAL (val
) == not_lval
4231 || VALUE_LVAL (val
) == lval_internalvar
)
4233 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4234 const CORE_ADDR addr
=
4235 value_as_long (value_allocate_space_in_inferior (len
));
4237 set_value_address (val
, addr
);
4238 VALUE_LVAL (val
) = lval_memory
;
4239 write_memory (addr
, value_contents (val
), len
);
4245 /* Return the value ACTUAL, converted to be an appropriate value for a
4246 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4247 allocating any necessary descriptors (fat pointers), or copies of
4248 values not residing in memory, updating it as needed. */
4251 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4253 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4254 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4255 struct type
*formal_target
=
4256 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4257 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4258 struct type
*actual_target
=
4259 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4260 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4262 if (ada_is_array_descriptor_type (formal_target
)
4263 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4264 return make_array_descriptor (formal_type
, actual
);
4265 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4266 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4268 struct value
*result
;
4270 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4271 && ada_is_array_descriptor_type (actual_target
))
4272 result
= desc_data (actual
);
4273 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
4275 if (VALUE_LVAL (actual
) != lval_memory
)
4279 actual_type
= ada_check_typedef (value_type (actual
));
4280 val
= allocate_value (actual_type
);
4281 memcpy ((char *) value_contents_raw (val
),
4282 (char *) value_contents (actual
),
4283 TYPE_LENGTH (actual_type
));
4284 actual
= ensure_lval (val
);
4286 result
= value_addr (actual
);
4290 return value_cast_pointers (formal_type
, result
, 0);
4292 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4293 return ada_value_ind (actual
);
4298 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4299 type TYPE. This is usually an inefficient no-op except on some targets
4300 (such as AVR) where the representation of a pointer and an address
4304 value_pointer (struct value
*value
, struct type
*type
)
4306 struct gdbarch
*gdbarch
= get_type_arch (type
);
4307 unsigned len
= TYPE_LENGTH (type
);
4308 gdb_byte
*buf
= alloca (len
);
4311 addr
= value_address (value
);
4312 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4313 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4318 /* Push a descriptor of type TYPE for array value ARR on the stack at
4319 *SP, updating *SP to reflect the new descriptor. Return either
4320 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4321 to-descriptor type rather than a descriptor type), a struct value *
4322 representing a pointer to this descriptor. */
4324 static struct value
*
4325 make_array_descriptor (struct type
*type
, struct value
*arr
)
4327 struct type
*bounds_type
= desc_bounds_type (type
);
4328 struct type
*desc_type
= desc_base_type (type
);
4329 struct value
*descriptor
= allocate_value (desc_type
);
4330 struct value
*bounds
= allocate_value (bounds_type
);
4333 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4336 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4337 ada_array_bound (arr
, i
, 0),
4338 desc_bound_bitpos (bounds_type
, i
, 0),
4339 desc_bound_bitsize (bounds_type
, i
, 0));
4340 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4341 ada_array_bound (arr
, i
, 1),
4342 desc_bound_bitpos (bounds_type
, i
, 1),
4343 desc_bound_bitsize (bounds_type
, i
, 1));
4346 bounds
= ensure_lval (bounds
);
4348 modify_field (value_type (descriptor
),
4349 value_contents_writeable (descriptor
),
4350 value_pointer (ensure_lval (arr
),
4351 TYPE_FIELD_TYPE (desc_type
, 0)),
4352 fat_pntr_data_bitpos (desc_type
),
4353 fat_pntr_data_bitsize (desc_type
));
4355 modify_field (value_type (descriptor
),
4356 value_contents_writeable (descriptor
),
4357 value_pointer (bounds
,
4358 TYPE_FIELD_TYPE (desc_type
, 1)),
4359 fat_pntr_bounds_bitpos (desc_type
),
4360 fat_pntr_bounds_bitsize (desc_type
));
4362 descriptor
= ensure_lval (descriptor
);
4364 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4365 return value_addr (descriptor
);
4370 /* Symbol Cache Module */
4372 /* Performance measurements made as of 2010-01-15 indicate that
4373 this cache does bring some noticeable improvements. Depending
4374 on the type of entity being printed, the cache can make it as much
4375 as an order of magnitude faster than without it.
4377 The descriptive type DWARF extension has significantly reduced
4378 the need for this cache, at least when DWARF is being used. However,
4379 even in this case, some expensive name-based symbol searches are still
4380 sometimes necessary - to find an XVZ variable, mostly. */
4382 /* Initialize the contents of SYM_CACHE. */
4385 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4387 obstack_init (&sym_cache
->cache_space
);
4388 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4391 /* Free the memory used by SYM_CACHE. */
4394 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4396 obstack_free (&sym_cache
->cache_space
, NULL
);
4400 /* Return the symbol cache associated to the given program space PSPACE.
4401 If not allocated for this PSPACE yet, allocate and initialize one. */
4403 static struct ada_symbol_cache
*
4404 ada_get_symbol_cache (struct program_space
*pspace
)
4406 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4407 struct ada_symbol_cache
*sym_cache
= pspace_data
->sym_cache
;
4409 if (sym_cache
== NULL
)
4411 sym_cache
= XCNEW (struct ada_symbol_cache
);
4412 ada_init_symbol_cache (sym_cache
);
4418 /* Clear all entries from the symbol cache. */
4421 ada_clear_symbol_cache (void)
4423 struct ada_symbol_cache
*sym_cache
4424 = ada_get_symbol_cache (current_program_space
);
4426 obstack_free (&sym_cache
->cache_space
, NULL
);
4427 ada_init_symbol_cache (sym_cache
);
4430 /* Search our cache for an entry matching NAME and NAMESPACE.
4431 Return it if found, or NULL otherwise. */
4433 static struct cache_entry
**
4434 find_entry (const char *name
, domain_enum
namespace)
4436 struct ada_symbol_cache
*sym_cache
4437 = ada_get_symbol_cache (current_program_space
);
4438 int h
= msymbol_hash (name
) % HASH_SIZE
;
4439 struct cache_entry
**e
;
4441 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4443 if (namespace == (*e
)->namespace && strcmp (name
, (*e
)->name
) == 0)
4449 /* Search the symbol cache for an entry matching NAME and NAMESPACE.
4450 Return 1 if found, 0 otherwise.
4452 If an entry was found and SYM is not NULL, set *SYM to the entry's
4453 SYM. Same principle for BLOCK if not NULL. */
4456 lookup_cached_symbol (const char *name
, domain_enum
namespace,
4457 struct symbol
**sym
, const struct block
**block
)
4459 struct cache_entry
**e
= find_entry (name
, namespace);
4466 *block
= (*e
)->block
;
4470 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4471 in domain NAMESPACE, save this result in our symbol cache. */
4474 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
4475 const struct block
*block
)
4477 struct ada_symbol_cache
*sym_cache
4478 = ada_get_symbol_cache (current_program_space
);
4481 struct cache_entry
*e
;
4483 /* Symbols for builtin types don't have a block.
4484 For now don't cache such symbols. */
4485 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4488 /* If the symbol is a local symbol, then do not cache it, as a search
4489 for that symbol depends on the context. To determine whether
4490 the symbol is local or not, we check the block where we found it
4491 against the global and static blocks of its associated symtab. */
4493 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4494 GLOBAL_BLOCK
) != block
4495 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4496 STATIC_BLOCK
) != block
)
4499 h
= msymbol_hash (name
) % HASH_SIZE
;
4500 e
= (struct cache_entry
*) obstack_alloc (&sym_cache
->cache_space
,
4502 e
->next
= sym_cache
->root
[h
];
4503 sym_cache
->root
[h
] = e
;
4504 e
->name
= copy
= obstack_alloc (&sym_cache
->cache_space
, strlen (name
) + 1);
4505 strcpy (copy
, name
);
4507 e
->namespace = namespace;
4513 /* Return nonzero if wild matching should be used when searching for
4514 all symbols matching LOOKUP_NAME.
4516 LOOKUP_NAME is expected to be a symbol name after transformation
4517 for Ada lookups (see ada_name_for_lookup). */
4520 should_use_wild_match (const char *lookup_name
)
4522 return (strstr (lookup_name
, "__") == NULL
);
4525 /* Return the result of a standard (literal, C-like) lookup of NAME in
4526 given DOMAIN, visible from lexical block BLOCK. */
4528 static struct symbol
*
4529 standard_lookup (const char *name
, const struct block
*block
,
4532 /* Initialize it just to avoid a GCC false warning. */
4533 struct symbol
*sym
= NULL
;
4535 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
4537 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
4538 cache_symbol (name
, domain
, sym
, block_found
);
4543 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4544 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4545 since they contend in overloading in the same way. */
4547 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4551 for (i
= 0; i
< n
; i
+= 1)
4552 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4553 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4554 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4560 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4561 struct types. Otherwise, they may not. */
4564 equiv_types (struct type
*type0
, struct type
*type1
)
4568 if (type0
== NULL
|| type1
== NULL
4569 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4571 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4572 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4573 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4574 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4580 /* True iff SYM0 represents the same entity as SYM1, or one that is
4581 no more defined than that of SYM1. */
4584 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4588 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4589 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4592 switch (SYMBOL_CLASS (sym0
))
4598 struct type
*type0
= SYMBOL_TYPE (sym0
);
4599 struct type
*type1
= SYMBOL_TYPE (sym1
);
4600 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4601 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4602 int len0
= strlen (name0
);
4605 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4606 && (equiv_types (type0
, type1
)
4607 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4608 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4611 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4612 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4618 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4619 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4622 add_defn_to_vec (struct obstack
*obstackp
,
4624 const struct block
*block
)
4627 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4629 /* Do not try to complete stub types, as the debugger is probably
4630 already scanning all symbols matching a certain name at the
4631 time when this function is called. Trying to replace the stub
4632 type by its associated full type will cause us to restart a scan
4633 which may lead to an infinite recursion. Instead, the client
4634 collecting the matching symbols will end up collecting several
4635 matches, with at least one of them complete. It can then filter
4636 out the stub ones if needed. */
4638 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4640 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4642 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4644 prevDefns
[i
].sym
= sym
;
4645 prevDefns
[i
].block
= block
;
4651 struct ada_symbol_info info
;
4655 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4659 /* Number of ada_symbol_info structures currently collected in
4660 current vector in *OBSTACKP. */
4663 num_defns_collected (struct obstack
*obstackp
)
4665 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4668 /* Vector of ada_symbol_info structures currently collected in current
4669 vector in *OBSTACKP. If FINISH, close off the vector and return
4670 its final address. */
4672 static struct ada_symbol_info
*
4673 defns_collected (struct obstack
*obstackp
, int finish
)
4676 return obstack_finish (obstackp
);
4678 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4681 /* Return a bound minimal symbol matching NAME according to Ada
4682 decoding rules. Returns an invalid symbol if there is no such
4683 minimal symbol. Names prefixed with "standard__" are handled
4684 specially: "standard__" is first stripped off, and only static and
4685 global symbols are searched. */
4687 struct bound_minimal_symbol
4688 ada_lookup_simple_minsym (const char *name
)
4690 struct bound_minimal_symbol result
;
4691 struct objfile
*objfile
;
4692 struct minimal_symbol
*msymbol
;
4693 const int wild_match_p
= should_use_wild_match (name
);
4695 memset (&result
, 0, sizeof (result
));
4697 /* Special case: If the user specifies a symbol name inside package
4698 Standard, do a non-wild matching of the symbol name without
4699 the "standard__" prefix. This was primarily introduced in order
4700 to allow the user to specifically access the standard exceptions
4701 using, for instance, Standard.Constraint_Error when Constraint_Error
4702 is ambiguous (due to the user defining its own Constraint_Error
4703 entity inside its program). */
4704 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4705 name
+= sizeof ("standard__") - 1;
4707 ALL_MSYMBOLS (objfile
, msymbol
)
4709 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match_p
)
4710 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4712 result
.minsym
= msymbol
;
4713 result
.objfile
= objfile
;
4721 /* For all subprograms that statically enclose the subprogram of the
4722 selected frame, add symbols matching identifier NAME in DOMAIN
4723 and their blocks to the list of data in OBSTACKP, as for
4724 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4725 with a wildcard prefix. */
4728 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4729 const char *name
, domain_enum
namespace,
4734 /* True if TYPE is definitely an artificial type supplied to a symbol
4735 for which no debugging information was given in the symbol file. */
4738 is_nondebugging_type (struct type
*type
)
4740 const char *name
= ada_type_name (type
);
4742 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4745 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4746 that are deemed "identical" for practical purposes.
4748 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4749 types and that their number of enumerals is identical (in other
4750 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4753 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4757 /* The heuristic we use here is fairly conservative. We consider
4758 that 2 enumerate types are identical if they have the same
4759 number of enumerals and that all enumerals have the same
4760 underlying value and name. */
4762 /* All enums in the type should have an identical underlying value. */
4763 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4764 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4767 /* All enumerals should also have the same name (modulo any numerical
4769 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4771 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4772 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4773 int len_1
= strlen (name_1
);
4774 int len_2
= strlen (name_2
);
4776 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4777 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4779 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4780 TYPE_FIELD_NAME (type2
, i
),
4788 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4789 that are deemed "identical" for practical purposes. Sometimes,
4790 enumerals are not strictly identical, but their types are so similar
4791 that they can be considered identical.
4793 For instance, consider the following code:
4795 type Color is (Black, Red, Green, Blue, White);
4796 type RGB_Color is new Color range Red .. Blue;
4798 Type RGB_Color is a subrange of an implicit type which is a copy
4799 of type Color. If we call that implicit type RGB_ColorB ("B" is
4800 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4801 As a result, when an expression references any of the enumeral
4802 by name (Eg. "print green"), the expression is technically
4803 ambiguous and the user should be asked to disambiguate. But
4804 doing so would only hinder the user, since it wouldn't matter
4805 what choice he makes, the outcome would always be the same.
4806 So, for practical purposes, we consider them as the same. */
4809 symbols_are_identical_enums (struct ada_symbol_info
*syms
, int nsyms
)
4813 /* Before performing a thorough comparison check of each type,
4814 we perform a series of inexpensive checks. We expect that these
4815 checks will quickly fail in the vast majority of cases, and thus
4816 help prevent the unnecessary use of a more expensive comparison.
4817 Said comparison also expects us to make some of these checks
4818 (see ada_identical_enum_types_p). */
4820 /* Quick check: All symbols should have an enum type. */
4821 for (i
= 0; i
< nsyms
; i
++)
4822 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
)
4825 /* Quick check: They should all have the same value. */
4826 for (i
= 1; i
< nsyms
; i
++)
4827 if (SYMBOL_VALUE (syms
[i
].sym
) != SYMBOL_VALUE (syms
[0].sym
))
4830 /* Quick check: They should all have the same number of enumerals. */
4831 for (i
= 1; i
< nsyms
; i
++)
4832 if (TYPE_NFIELDS (SYMBOL_TYPE (syms
[i
].sym
))
4833 != TYPE_NFIELDS (SYMBOL_TYPE (syms
[0].sym
)))
4836 /* All the sanity checks passed, so we might have a set of
4837 identical enumeration types. Perform a more complete
4838 comparison of the type of each symbol. */
4839 for (i
= 1; i
< nsyms
; i
++)
4840 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].sym
),
4841 SYMBOL_TYPE (syms
[0].sym
)))
4847 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4848 duplicate other symbols in the list (The only case I know of where
4849 this happens is when object files containing stabs-in-ecoff are
4850 linked with files containing ordinary ecoff debugging symbols (or no
4851 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4852 Returns the number of items in the modified list. */
4855 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4859 /* We should never be called with less than 2 symbols, as there
4860 cannot be any extra symbol in that case. But it's easy to
4861 handle, since we have nothing to do in that case. */
4870 /* If two symbols have the same name and one of them is a stub type,
4871 the get rid of the stub. */
4873 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4874 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4876 for (j
= 0; j
< nsyms
; j
++)
4879 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4880 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4881 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4882 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4887 /* Two symbols with the same name, same class and same address
4888 should be identical. */
4890 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4891 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4892 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4894 for (j
= 0; j
< nsyms
; j
+= 1)
4897 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4898 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4899 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4900 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4901 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4902 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4909 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4910 syms
[j
- 1] = syms
[j
];
4917 /* If all the remaining symbols are identical enumerals, then
4918 just keep the first one and discard the rest.
4920 Unlike what we did previously, we do not discard any entry
4921 unless they are ALL identical. This is because the symbol
4922 comparison is not a strict comparison, but rather a practical
4923 comparison. If all symbols are considered identical, then
4924 we can just go ahead and use the first one and discard the rest.
4925 But if we cannot reduce the list to a single element, we have
4926 to ask the user to disambiguate anyways. And if we have to
4927 present a multiple-choice menu, it's less confusing if the list
4928 isn't missing some choices that were identical and yet distinct. */
4929 if (symbols_are_identical_enums (syms
, nsyms
))
4935 /* Given a type that corresponds to a renaming entity, use the type name
4936 to extract the scope (package name or function name, fully qualified,
4937 and following the GNAT encoding convention) where this renaming has been
4938 defined. The string returned needs to be deallocated after use. */
4941 xget_renaming_scope (struct type
*renaming_type
)
4943 /* The renaming types adhere to the following convention:
4944 <scope>__<rename>___<XR extension>.
4945 So, to extract the scope, we search for the "___XR" extension,
4946 and then backtrack until we find the first "__". */
4948 const char *name
= type_name_no_tag (renaming_type
);
4949 char *suffix
= strstr (name
, "___XR");
4954 /* Now, backtrack a bit until we find the first "__". Start looking
4955 at suffix - 3, as the <rename> part is at least one character long. */
4957 for (last
= suffix
- 3; last
> name
; last
--)
4958 if (last
[0] == '_' && last
[1] == '_')
4961 /* Make a copy of scope and return it. */
4963 scope_len
= last
- name
;
4964 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4966 strncpy (scope
, name
, scope_len
);
4967 scope
[scope_len
] = '\0';
4972 /* Return nonzero if NAME corresponds to a package name. */
4975 is_package_name (const char *name
)
4977 /* Here, We take advantage of the fact that no symbols are generated
4978 for packages, while symbols are generated for each function.
4979 So the condition for NAME represent a package becomes equivalent
4980 to NAME not existing in our list of symbols. There is only one
4981 small complication with library-level functions (see below). */
4985 /* If it is a function that has not been defined at library level,
4986 then we should be able to look it up in the symbols. */
4987 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4990 /* Library-level function names start with "_ada_". See if function
4991 "_ada_" followed by NAME can be found. */
4993 /* Do a quick check that NAME does not contain "__", since library-level
4994 functions names cannot contain "__" in them. */
4995 if (strstr (name
, "__") != NULL
)
4998 fun_name
= xstrprintf ("_ada_%s", name
);
5000 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
5003 /* Return nonzero if SYM corresponds to a renaming entity that is
5004 not visible from FUNCTION_NAME. */
5007 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5010 struct cleanup
*old_chain
;
5012 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5015 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5016 old_chain
= make_cleanup (xfree
, scope
);
5018 /* If the rename has been defined in a package, then it is visible. */
5019 if (is_package_name (scope
))
5021 do_cleanups (old_chain
);
5025 /* Check that the rename is in the current function scope by checking
5026 that its name starts with SCOPE. */
5028 /* If the function name starts with "_ada_", it means that it is
5029 a library-level function. Strip this prefix before doing the
5030 comparison, as the encoding for the renaming does not contain
5032 if (strncmp (function_name
, "_ada_", 5) == 0)
5036 int is_invisible
= strncmp (function_name
, scope
, strlen (scope
)) != 0;
5038 do_cleanups (old_chain
);
5039 return is_invisible
;
5043 /* Remove entries from SYMS that corresponds to a renaming entity that
5044 is not visible from the function associated with CURRENT_BLOCK or
5045 that is superfluous due to the presence of more specific renaming
5046 information. Places surviving symbols in the initial entries of
5047 SYMS and returns the number of surviving symbols.
5050 First, in cases where an object renaming is implemented as a
5051 reference variable, GNAT may produce both the actual reference
5052 variable and the renaming encoding. In this case, we discard the
5055 Second, GNAT emits a type following a specified encoding for each renaming
5056 entity. Unfortunately, STABS currently does not support the definition
5057 of types that are local to a given lexical block, so all renamings types
5058 are emitted at library level. As a consequence, if an application
5059 contains two renaming entities using the same name, and a user tries to
5060 print the value of one of these entities, the result of the ada symbol
5061 lookup will also contain the wrong renaming type.
5063 This function partially covers for this limitation by attempting to
5064 remove from the SYMS list renaming symbols that should be visible
5065 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5066 method with the current information available. The implementation
5067 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5069 - When the user tries to print a rename in a function while there
5070 is another rename entity defined in a package: Normally, the
5071 rename in the function has precedence over the rename in the
5072 package, so the latter should be removed from the list. This is
5073 currently not the case.
5075 - This function will incorrectly remove valid renames if
5076 the CURRENT_BLOCK corresponds to a function which symbol name
5077 has been changed by an "Export" pragma. As a consequence,
5078 the user will be unable to print such rename entities. */
5081 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
5082 int nsyms
, const struct block
*current_block
)
5084 struct symbol
*current_function
;
5085 const char *current_function_name
;
5087 int is_new_style_renaming
;
5089 /* If there is both a renaming foo___XR... encoded as a variable and
5090 a simple variable foo in the same block, discard the latter.
5091 First, zero out such symbols, then compress. */
5092 is_new_style_renaming
= 0;
5093 for (i
= 0; i
< nsyms
; i
+= 1)
5095 struct symbol
*sym
= syms
[i
].sym
;
5096 const struct block
*block
= syms
[i
].block
;
5100 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5102 name
= SYMBOL_LINKAGE_NAME (sym
);
5103 suffix
= strstr (name
, "___XR");
5107 int name_len
= suffix
- name
;
5110 is_new_style_renaming
= 1;
5111 for (j
= 0; j
< nsyms
; j
+= 1)
5112 if (i
!= j
&& syms
[j
].sym
!= NULL
5113 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
5115 && block
== syms
[j
].block
)
5119 if (is_new_style_renaming
)
5123 for (j
= k
= 0; j
< nsyms
; j
+= 1)
5124 if (syms
[j
].sym
!= NULL
)
5132 /* Extract the function name associated to CURRENT_BLOCK.
5133 Abort if unable to do so. */
5135 if (current_block
== NULL
)
5138 current_function
= block_linkage_function (current_block
);
5139 if (current_function
== NULL
)
5142 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
5143 if (current_function_name
== NULL
)
5146 /* Check each of the symbols, and remove it from the list if it is
5147 a type corresponding to a renaming that is out of the scope of
5148 the current block. */
5153 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
5154 == ADA_OBJECT_RENAMING
5155 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
5159 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
5160 syms
[j
- 1] = syms
[j
];
5170 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5171 whose name and domain match NAME and DOMAIN respectively.
5172 If no match was found, then extend the search to "enclosing"
5173 routines (in other words, if we're inside a nested function,
5174 search the symbols defined inside the enclosing functions).
5175 If WILD_MATCH_P is nonzero, perform the naming matching in
5176 "wild" mode (see function "wild_match" for more info).
5178 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5181 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
5182 const struct block
*block
, domain_enum domain
,
5185 int block_depth
= 0;
5187 while (block
!= NULL
)
5190 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
,
5193 /* If we found a non-function match, assume that's the one. */
5194 if (is_nonfunction (defns_collected (obstackp
, 0),
5195 num_defns_collected (obstackp
)))
5198 block
= BLOCK_SUPERBLOCK (block
);
5201 /* If no luck so far, try to find NAME as a local symbol in some lexically
5202 enclosing subprogram. */
5203 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5204 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match_p
);
5207 /* An object of this type is used as the user_data argument when
5208 calling the map_matching_symbols method. */
5212 struct objfile
*objfile
;
5213 struct obstack
*obstackp
;
5214 struct symbol
*arg_sym
;
5218 /* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5219 to a list of symbols. DATA0 is a pointer to a struct match_data *
5220 containing the obstack that collects the symbol list, the file that SYM
5221 must come from, a flag indicating whether a non-argument symbol has
5222 been found in the current block, and the last argument symbol
5223 passed in SYM within the current block (if any). When SYM is null,
5224 marking the end of a block, the argument symbol is added if no
5225 other has been found. */
5228 aux_add_nonlocal_symbols (struct block
*block
, struct symbol
*sym
, void *data0
)
5230 struct match_data
*data
= (struct match_data
*) data0
;
5234 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5235 add_defn_to_vec (data
->obstackp
,
5236 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5238 data
->found_sym
= 0;
5239 data
->arg_sym
= NULL
;
5243 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5245 else if (SYMBOL_IS_ARGUMENT (sym
))
5246 data
->arg_sym
= sym
;
5249 data
->found_sym
= 1;
5250 add_defn_to_vec (data
->obstackp
,
5251 fixup_symbol_section (sym
, data
->objfile
),
5258 /* Implements compare_names, but only applying the comparision using
5259 the given CASING. */
5262 compare_names_with_case (const char *string1
, const char *string2
,
5263 enum case_sensitivity casing
)
5265 while (*string1
!= '\0' && *string2
!= '\0')
5269 if (isspace (*string1
) || isspace (*string2
))
5270 return strcmp_iw_ordered (string1
, string2
);
5272 if (casing
== case_sensitive_off
)
5274 c1
= tolower (*string1
);
5275 c2
= tolower (*string2
);
5292 return strcmp_iw_ordered (string1
, string2
);
5294 if (*string2
== '\0')
5296 if (is_name_suffix (string1
))
5303 if (*string2
== '(')
5304 return strcmp_iw_ordered (string1
, string2
);
5307 if (casing
== case_sensitive_off
)
5308 return tolower (*string1
) - tolower (*string2
);
5310 return *string1
- *string2
;
5315 /* Compare STRING1 to STRING2, with results as for strcmp.
5316 Compatible with strcmp_iw_ordered in that...
5318 strcmp_iw_ordered (STRING1, STRING2) <= 0
5322 compare_names (STRING1, STRING2) <= 0
5324 (they may differ as to what symbols compare equal). */
5327 compare_names (const char *string1
, const char *string2
)
5331 /* Similar to what strcmp_iw_ordered does, we need to perform
5332 a case-insensitive comparison first, and only resort to
5333 a second, case-sensitive, comparison if the first one was
5334 not sufficient to differentiate the two strings. */
5336 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5338 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5343 /* Add to OBSTACKP all non-local symbols whose name and domain match
5344 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5345 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5348 add_nonlocal_symbols (struct obstack
*obstackp
, const char *name
,
5349 domain_enum domain
, int global
,
5352 struct objfile
*objfile
;
5353 struct match_data data
;
5355 memset (&data
, 0, sizeof data
);
5356 data
.obstackp
= obstackp
;
5358 ALL_OBJFILES (objfile
)
5360 data
.objfile
= objfile
;
5363 objfile
->sf
->qf
->map_matching_symbols (objfile
, name
, domain
, global
,
5364 aux_add_nonlocal_symbols
, &data
,
5367 objfile
->sf
->qf
->map_matching_symbols (objfile
, name
, domain
, global
,
5368 aux_add_nonlocal_symbols
, &data
,
5369 full_match
, compare_names
);
5372 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5374 ALL_OBJFILES (objfile
)
5376 char *name1
= alloca (strlen (name
) + sizeof ("_ada_"));
5377 strcpy (name1
, "_ada_");
5378 strcpy (name1
+ sizeof ("_ada_") - 1, name
);
5379 data
.objfile
= objfile
;
5380 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
, domain
,
5382 aux_add_nonlocal_symbols
,
5384 full_match
, compare_names
);
5389 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5390 non-zero, enclosing scope and in global scopes, returning the number of
5392 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5393 indicating the symbols found and the blocks and symbol tables (if
5394 any) in which they were found. This vector is transient---good only to
5395 the next call of ada_lookup_symbol_list.
5397 When full_search is non-zero, any non-function/non-enumeral
5398 symbol match within the nest of blocks whose innermost member is BLOCK0,
5399 is the one match returned (no other matches in that or
5400 enclosing blocks is returned). If there are any matches in or
5401 surrounding BLOCK0, then these alone are returned.
5403 Names prefixed with "standard__" are handled specially: "standard__"
5404 is first stripped off, and only static and global symbols are searched. */
5407 ada_lookup_symbol_list_worker (const char *name0
, const struct block
*block0
,
5408 domain_enum
namespace,
5409 struct ada_symbol_info
**results
,
5413 const struct block
*block
;
5415 const int wild_match_p
= should_use_wild_match (name0
);
5419 obstack_free (&symbol_list_obstack
, NULL
);
5420 obstack_init (&symbol_list_obstack
);
5424 /* Search specified block and its superiors. */
5429 /* Special case: If the user specifies a symbol name inside package
5430 Standard, do a non-wild matching of the symbol name without
5431 the "standard__" prefix. This was primarily introduced in order
5432 to allow the user to specifically access the standard exceptions
5433 using, for instance, Standard.Constraint_Error when Constraint_Error
5434 is ambiguous (due to the user defining its own Constraint_Error
5435 entity inside its program). */
5436 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
5439 name
= name0
+ sizeof ("standard__") - 1;
5442 /* Check the non-global symbols. If we have ANY match, then we're done. */
5448 ada_add_local_symbols (&symbol_list_obstack
, name
, block
,
5449 namespace, wild_match_p
);
5453 /* In the !full_search case we're are being called by
5454 ada_iterate_over_symbols, and we don't want to search
5456 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
5457 namespace, NULL
, wild_match_p
);
5459 if (num_defns_collected (&symbol_list_obstack
) > 0 || !full_search
)
5463 /* No non-global symbols found. Check our cache to see if we have
5464 already performed this search before. If we have, then return
5468 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
5471 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
5475 /* Search symbols from all global blocks. */
5477 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 1,
5480 /* Now add symbols from all per-file blocks if we've gotten no hits
5481 (not strictly correct, but perhaps better than an error). */
5483 if (num_defns_collected (&symbol_list_obstack
) == 0)
5484 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 0,
5488 ndefns
= num_defns_collected (&symbol_list_obstack
);
5489 *results
= defns_collected (&symbol_list_obstack
, 1);
5491 ndefns
= remove_extra_symbols (*results
, ndefns
);
5493 if (ndefns
== 0 && full_search
)
5494 cache_symbol (name0
, namespace, NULL
, NULL
);
5496 if (ndefns
== 1 && full_search
&& cacheIfUnique
)
5497 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
5499 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
5504 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5505 in global scopes, returning the number of matches, and setting *RESULTS
5506 to a vector of (SYM,BLOCK) tuples.
5507 See ada_lookup_symbol_list_worker for further details. */
5510 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
5511 domain_enum domain
, struct ada_symbol_info
**results
)
5513 return ada_lookup_symbol_list_worker (name0
, block0
, domain
, results
, 1);
5516 /* Implementation of the la_iterate_over_symbols method. */
5519 ada_iterate_over_symbols (const struct block
*block
,
5520 const char *name
, domain_enum domain
,
5521 symbol_found_callback_ftype
*callback
,
5525 struct ada_symbol_info
*results
;
5527 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5528 for (i
= 0; i
< ndefs
; ++i
)
5530 if (! (*callback
) (results
[i
].sym
, data
))
5535 /* If NAME is the name of an entity, return a string that should
5536 be used to look that entity up in Ada units. This string should
5537 be deallocated after use using xfree.
5539 NAME can have any form that the "break" or "print" commands might
5540 recognize. In other words, it does not have to be the "natural"
5541 name, or the "encoded" name. */
5544 ada_name_for_lookup (const char *name
)
5547 int nlen
= strlen (name
);
5549 if (name
[0] == '<' && name
[nlen
- 1] == '>')
5551 canon
= xmalloc (nlen
- 1);
5552 memcpy (canon
, name
+ 1, nlen
- 2);
5553 canon
[nlen
- 2] = '\0';
5556 canon
= xstrdup (ada_encode (ada_fold_name (name
)));
5560 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5561 to 1, but choosing the first symbol found if there are multiple
5564 The result is stored in *INFO, which must be non-NULL.
5565 If no match is found, INFO->SYM is set to NULL. */
5568 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5569 domain_enum
namespace,
5570 struct ada_symbol_info
*info
)
5572 struct ada_symbol_info
*candidates
;
5575 gdb_assert (info
!= NULL
);
5576 memset (info
, 0, sizeof (struct ada_symbol_info
));
5578 n_candidates
= ada_lookup_symbol_list (name
, block
, namespace, &candidates
);
5579 if (n_candidates
== 0)
5582 *info
= candidates
[0];
5583 info
->sym
= fixup_symbol_section (info
->sym
, NULL
);
5586 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5587 scope and in global scopes, or NULL if none. NAME is folded and
5588 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5589 choosing the first symbol if there are multiple choices.
5590 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5593 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5594 domain_enum
namespace, int *is_a_field_of_this
)
5596 struct ada_symbol_info info
;
5598 if (is_a_field_of_this
!= NULL
)
5599 *is_a_field_of_this
= 0;
5601 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
5602 block0
, namespace, &info
);
5606 static struct symbol
*
5607 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5609 const struct block
*block
,
5610 const domain_enum domain
)
5614 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
5618 /* If we haven't found a match at this point, try the primitive
5619 types. In other languages, this search is performed before
5620 searching for global symbols in order to short-circuit that
5621 global-symbol search if it happens that the name corresponds
5622 to a primitive type. But we cannot do the same in Ada, because
5623 it is perfectly legitimate for a program to declare a type which
5624 has the same name as a standard type. If looking up a type in
5625 that situation, we have traditionally ignored the primitive type
5626 in favor of user-defined types. This is why, unlike most other
5627 languages, we search the primitive types this late and only after
5628 having searched the global symbols without success. */
5630 if (domain
== VAR_DOMAIN
)
5632 struct gdbarch
*gdbarch
;
5635 gdbarch
= target_gdbarch ();
5637 gdbarch
= block_gdbarch (block
);
5638 sym
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5647 /* True iff STR is a possible encoded suffix of a normal Ada name
5648 that is to be ignored for matching purposes. Suffixes of parallel
5649 names (e.g., XVE) are not included here. Currently, the possible suffixes
5650 are given by any of the regular expressions:
5652 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5653 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5654 TKB [subprogram suffix for task bodies]
5655 _E[0-9]+[bs]$ [protected object entry suffixes]
5656 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5658 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5659 match is performed. This sequence is used to differentiate homonyms,
5660 is an optional part of a valid name suffix. */
5663 is_name_suffix (const char *str
)
5666 const char *matching
;
5667 const int len
= strlen (str
);
5669 /* Skip optional leading __[0-9]+. */
5671 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5674 while (isdigit (str
[0]))
5680 if (str
[0] == '.' || str
[0] == '$')
5683 while (isdigit (matching
[0]))
5685 if (matching
[0] == '\0')
5691 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5694 while (isdigit (matching
[0]))
5696 if (matching
[0] == '\0')
5700 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5702 if (strcmp (str
, "TKB") == 0)
5706 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5707 with a N at the end. Unfortunately, the compiler uses the same
5708 convention for other internal types it creates. So treating
5709 all entity names that end with an "N" as a name suffix causes
5710 some regressions. For instance, consider the case of an enumerated
5711 type. To support the 'Image attribute, it creates an array whose
5713 Having a single character like this as a suffix carrying some
5714 information is a bit risky. Perhaps we should change the encoding
5715 to be something like "_N" instead. In the meantime, do not do
5716 the following check. */
5717 /* Protected Object Subprograms */
5718 if (len
== 1 && str
[0] == 'N')
5723 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5726 while (isdigit (matching
[0]))
5728 if ((matching
[0] == 'b' || matching
[0] == 's')
5729 && matching
[1] == '\0')
5733 /* ??? We should not modify STR directly, as we are doing below. This
5734 is fine in this case, but may become problematic later if we find
5735 that this alternative did not work, and want to try matching
5736 another one from the begining of STR. Since we modified it, we
5737 won't be able to find the begining of the string anymore! */
5741 while (str
[0] != '_' && str
[0] != '\0')
5743 if (str
[0] != 'n' && str
[0] != 'b')
5749 if (str
[0] == '\000')
5754 if (str
[1] != '_' || str
[2] == '\000')
5758 if (strcmp (str
+ 3, "JM") == 0)
5760 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5761 the LJM suffix in favor of the JM one. But we will
5762 still accept LJM as a valid suffix for a reasonable
5763 amount of time, just to allow ourselves to debug programs
5764 compiled using an older version of GNAT. */
5765 if (strcmp (str
+ 3, "LJM") == 0)
5769 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5770 || str
[4] == 'U' || str
[4] == 'P')
5772 if (str
[4] == 'R' && str
[5] != 'T')
5776 if (!isdigit (str
[2]))
5778 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5779 if (!isdigit (str
[k
]) && str
[k
] != '_')
5783 if (str
[0] == '$' && isdigit (str
[1]))
5785 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5786 if (!isdigit (str
[k
]) && str
[k
] != '_')
5793 /* Return non-zero if the string starting at NAME and ending before
5794 NAME_END contains no capital letters. */
5797 is_valid_name_for_wild_match (const char *name0
)
5799 const char *decoded_name
= ada_decode (name0
);
5802 /* If the decoded name starts with an angle bracket, it means that
5803 NAME0 does not follow the GNAT encoding format. It should then
5804 not be allowed as a possible wild match. */
5805 if (decoded_name
[0] == '<')
5808 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5809 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5815 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5816 that could start a simple name. Assumes that *NAMEP points into
5817 the string beginning at NAME0. */
5820 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5822 const char *name
= *namep
;
5832 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5835 if (name
== name0
+ 5 && strncmp (name0
, "_ada", 4) == 0)
5840 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
5841 || name
[2] == target0
))
5849 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5859 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5860 informational suffixes of NAME (i.e., for which is_name_suffix is
5861 true). Assumes that PATN is a lower-cased Ada simple name. */
5864 wild_match (const char *name
, const char *patn
)
5867 const char *name0
= name
;
5871 const char *match
= name
;
5875 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5878 if (*p
== '\0' && is_name_suffix (name
))
5879 return match
!= name0
&& !is_valid_name_for_wild_match (name0
);
5881 if (name
[-1] == '_')
5884 if (!advance_wild_match (&name
, name0
, *patn
))
5889 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5890 informational suffix. */
5893 full_match (const char *sym_name
, const char *search_name
)
5895 return !match_name (sym_name
, search_name
, 0);
5899 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5900 vector *defn_symbols, updating the list of symbols in OBSTACKP
5901 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5902 OBJFILE is the section containing BLOCK. */
5905 ada_add_block_symbols (struct obstack
*obstackp
,
5906 const struct block
*block
, const char *name
,
5907 domain_enum domain
, struct objfile
*objfile
,
5910 struct block_iterator iter
;
5911 int name_len
= strlen (name
);
5912 /* A matching argument symbol, if any. */
5913 struct symbol
*arg_sym
;
5914 /* Set true when we find a matching non-argument symbol. */
5922 for (sym
= block_iter_match_first (block
, name
, wild_match
, &iter
);
5923 sym
!= NULL
; sym
= block_iter_match_next (name
, wild_match
, &iter
))
5925 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5926 SYMBOL_DOMAIN (sym
), domain
)
5927 && wild_match (SYMBOL_LINKAGE_NAME (sym
), name
) == 0)
5929 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5931 else if (SYMBOL_IS_ARGUMENT (sym
))
5936 add_defn_to_vec (obstackp
,
5937 fixup_symbol_section (sym
, objfile
),
5945 for (sym
= block_iter_match_first (block
, name
, full_match
, &iter
);
5946 sym
!= NULL
; sym
= block_iter_match_next (name
, full_match
, &iter
))
5948 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5949 SYMBOL_DOMAIN (sym
), domain
))
5951 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5953 if (SYMBOL_IS_ARGUMENT (sym
))
5958 add_defn_to_vec (obstackp
,
5959 fixup_symbol_section (sym
, objfile
),
5967 if (!found_sym
&& arg_sym
!= NULL
)
5969 add_defn_to_vec (obstackp
,
5970 fixup_symbol_section (arg_sym
, objfile
),
5979 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5981 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5982 SYMBOL_DOMAIN (sym
), domain
))
5986 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5989 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5991 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5996 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5998 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6000 if (SYMBOL_IS_ARGUMENT (sym
))
6005 add_defn_to_vec (obstackp
,
6006 fixup_symbol_section (sym
, objfile
),
6014 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6015 They aren't parameters, right? */
6016 if (!found_sym
&& arg_sym
!= NULL
)
6018 add_defn_to_vec (obstackp
,
6019 fixup_symbol_section (arg_sym
, objfile
),
6026 /* Symbol Completion */
6028 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
6029 name in a form that's appropriate for the completion. The result
6030 does not need to be deallocated, but is only good until the next call.
6032 TEXT_LEN is equal to the length of TEXT.
6033 Perform a wild match if WILD_MATCH_P is set.
6034 ENCODED_P should be set if TEXT represents the start of a symbol name
6035 in its encoded form. */
6038 symbol_completion_match (const char *sym_name
,
6039 const char *text
, int text_len
,
6040 int wild_match_p
, int encoded_p
)
6042 const int verbatim_match
= (text
[0] == '<');
6047 /* Strip the leading angle bracket. */
6052 /* First, test against the fully qualified name of the symbol. */
6054 if (strncmp (sym_name
, text
, text_len
) == 0)
6057 if (match
&& !encoded_p
)
6059 /* One needed check before declaring a positive match is to verify
6060 that iff we are doing a verbatim match, the decoded version
6061 of the symbol name starts with '<'. Otherwise, this symbol name
6062 is not a suitable completion. */
6063 const char *sym_name_copy
= sym_name
;
6064 int has_angle_bracket
;
6066 sym_name
= ada_decode (sym_name
);
6067 has_angle_bracket
= (sym_name
[0] == '<');
6068 match
= (has_angle_bracket
== verbatim_match
);
6069 sym_name
= sym_name_copy
;
6072 if (match
&& !verbatim_match
)
6074 /* When doing non-verbatim match, another check that needs to
6075 be done is to verify that the potentially matching symbol name
6076 does not include capital letters, because the ada-mode would
6077 not be able to understand these symbol names without the
6078 angle bracket notation. */
6081 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6086 /* Second: Try wild matching... */
6088 if (!match
&& wild_match_p
)
6090 /* Since we are doing wild matching, this means that TEXT
6091 may represent an unqualified symbol name. We therefore must
6092 also compare TEXT against the unqualified name of the symbol. */
6093 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
6095 if (strncmp (sym_name
, text
, text_len
) == 0)
6099 /* Finally: If we found a mach, prepare the result to return. */
6105 sym_name
= add_angle_brackets (sym_name
);
6108 sym_name
= ada_decode (sym_name
);
6113 /* A companion function to ada_make_symbol_completion_list().
6114 Check if SYM_NAME represents a symbol which name would be suitable
6115 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6116 it is appended at the end of the given string vector SV.
6118 ORIG_TEXT is the string original string from the user command
6119 that needs to be completed. WORD is the entire command on which
6120 completion should be performed. These two parameters are used to
6121 determine which part of the symbol name should be added to the
6123 if WILD_MATCH_P is set, then wild matching is performed.
6124 ENCODED_P should be set if TEXT represents a symbol name in its
6125 encoded formed (in which case the completion should also be
6129 symbol_completion_add (VEC(char_ptr
) **sv
,
6130 const char *sym_name
,
6131 const char *text
, int text_len
,
6132 const char *orig_text
, const char *word
,
6133 int wild_match_p
, int encoded_p
)
6135 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
6136 wild_match_p
, encoded_p
);
6142 /* We found a match, so add the appropriate completion to the given
6145 if (word
== orig_text
)
6147 completion
= xmalloc (strlen (match
) + 5);
6148 strcpy (completion
, match
);
6150 else if (word
> orig_text
)
6152 /* Return some portion of sym_name. */
6153 completion
= xmalloc (strlen (match
) + 5);
6154 strcpy (completion
, match
+ (word
- orig_text
));
6158 /* Return some of ORIG_TEXT plus sym_name. */
6159 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
6160 strncpy (completion
, word
, orig_text
- word
);
6161 completion
[orig_text
- word
] = '\0';
6162 strcat (completion
, match
);
6165 VEC_safe_push (char_ptr
, *sv
, completion
);
6168 /* An object of this type is passed as the user_data argument to the
6169 expand_symtabs_matching method. */
6170 struct add_partial_datum
6172 VEC(char_ptr
) **completions
;
6181 /* A callback for expand_symtabs_matching. */
6184 ada_complete_symbol_matcher (const char *name
, void *user_data
)
6186 struct add_partial_datum
*data
= user_data
;
6188 return symbol_completion_match (name
, data
->text
, data
->text_len
,
6189 data
->wild_match
, data
->encoded
) != NULL
;
6192 /* Return a list of possible symbol names completing TEXT0. WORD is
6193 the entire command on which completion is made. */
6195 static VEC (char_ptr
) *
6196 ada_make_symbol_completion_list (const char *text0
, const char *word
,
6197 enum type_code code
)
6203 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
6205 struct compunit_symtab
*s
;
6206 struct minimal_symbol
*msymbol
;
6207 struct objfile
*objfile
;
6208 const struct block
*b
, *surrounding_static_block
= 0;
6210 struct block_iterator iter
;
6211 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
6213 gdb_assert (code
== TYPE_CODE_UNDEF
);
6215 if (text0
[0] == '<')
6217 text
= xstrdup (text0
);
6218 make_cleanup (xfree
, text
);
6219 text_len
= strlen (text
);
6225 text
= xstrdup (ada_encode (text0
));
6226 make_cleanup (xfree
, text
);
6227 text_len
= strlen (text
);
6228 for (i
= 0; i
< text_len
; i
++)
6229 text
[i
] = tolower (text
[i
]);
6231 encoded_p
= (strstr (text0
, "__") != NULL
);
6232 /* If the name contains a ".", then the user is entering a fully
6233 qualified entity name, and the match must not be done in wild
6234 mode. Similarly, if the user wants to complete what looks like
6235 an encoded name, the match must not be done in wild mode. */
6236 wild_match_p
= (strchr (text0
, '.') == NULL
&& !encoded_p
);
6239 /* First, look at the partial symtab symbols. */
6241 struct add_partial_datum data
;
6243 data
.completions
= &completions
;
6245 data
.text_len
= text_len
;
6248 data
.wild_match
= wild_match_p
;
6249 data
.encoded
= encoded_p
;
6250 expand_symtabs_matching (NULL
, ada_complete_symbol_matcher
, NULL
,
6254 /* At this point scan through the misc symbol vectors and add each
6255 symbol you find to the list. Eventually we want to ignore
6256 anything that isn't a text symbol (everything else will be
6257 handled by the psymtab code above). */
6259 ALL_MSYMBOLS (objfile
, msymbol
)
6262 symbol_completion_add (&completions
, MSYMBOL_LINKAGE_NAME (msymbol
),
6263 text
, text_len
, text0
, word
, wild_match_p
,
6267 /* Search upwards from currently selected frame (so that we can
6268 complete on local vars. */
6270 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6272 if (!BLOCK_SUPERBLOCK (b
))
6273 surrounding_static_block
= b
; /* For elmin of dups */
6275 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6277 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6278 text
, text_len
, text0
, word
,
6279 wild_match_p
, encoded_p
);
6283 /* Go through the symtabs and check the externs and statics for
6284 symbols which match. */
6286 ALL_COMPUNITS (objfile
, s
)
6289 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6290 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6292 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6293 text
, text_len
, text0
, word
,
6294 wild_match_p
, encoded_p
);
6298 ALL_COMPUNITS (objfile
, s
)
6301 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6302 /* Don't do this block twice. */
6303 if (b
== surrounding_static_block
)
6305 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6307 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6308 text
, text_len
, text0
, word
,
6309 wild_match_p
, encoded_p
);
6313 do_cleanups (old_chain
);
6319 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6320 for tagged types. */
6323 ada_is_dispatch_table_ptr_type (struct type
*type
)
6327 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
6330 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
6334 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6337 /* Return non-zero if TYPE is an interface tag. */
6340 ada_is_interface_tag (struct type
*type
)
6342 const char *name
= TYPE_NAME (type
);
6347 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6350 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6351 to be invisible to users. */
6354 ada_is_ignored_field (struct type
*type
, int field_num
)
6356 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6359 /* Check the name of that field. */
6361 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6363 /* Anonymous field names should not be printed.
6364 brobecker/2007-02-20: I don't think this can actually happen
6365 but we don't want to print the value of annonymous fields anyway. */
6369 /* Normally, fields whose name start with an underscore ("_")
6370 are fields that have been internally generated by the compiler,
6371 and thus should not be printed. The "_parent" field is special,
6372 however: This is a field internally generated by the compiler
6373 for tagged types, and it contains the components inherited from
6374 the parent type. This field should not be printed as is, but
6375 should not be ignored either. */
6376 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
6380 /* If this is the dispatch table of a tagged type or an interface tag,
6382 if (ada_is_tagged_type (type
, 1)
6383 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6384 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6387 /* Not a special field, so it should not be ignored. */
6391 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6392 pointer or reference type whose ultimate target has a tag field. */
6395 ada_is_tagged_type (struct type
*type
, int refok
)
6397 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6400 /* True iff TYPE represents the type of X'Tag */
6403 ada_is_tag_type (struct type
*type
)
6405 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6409 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6411 return (name
!= NULL
6412 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6416 /* The type of the tag on VAL. */
6419 ada_tag_type (struct value
*val
)
6421 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
6424 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6425 retired at Ada 05). */
6428 is_ada95_tag (struct value
*tag
)
6430 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6433 /* The value of the tag on VAL. */
6436 ada_value_tag (struct value
*val
)
6438 return ada_value_struct_elt (val
, "_tag", 0);
6441 /* The value of the tag on the object of type TYPE whose contents are
6442 saved at VALADDR, if it is non-null, or is at memory address
6445 static struct value
*
6446 value_tag_from_contents_and_address (struct type
*type
,
6447 const gdb_byte
*valaddr
,
6450 int tag_byte_offset
;
6451 struct type
*tag_type
;
6453 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6456 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6458 : valaddr
+ tag_byte_offset
);
6459 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6461 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6466 static struct type
*
6467 type_from_tag (struct value
*tag
)
6469 const char *type_name
= ada_tag_name (tag
);
6471 if (type_name
!= NULL
)
6472 return ada_find_any_type (ada_encode (type_name
));
6476 /* Given a value OBJ of a tagged type, return a value of this
6477 type at the base address of the object. The base address, as
6478 defined in Ada.Tags, it is the address of the primary tag of
6479 the object, and therefore where the field values of its full
6480 view can be fetched. */
6483 ada_tag_value_at_base_address (struct value
*obj
)
6485 volatile struct gdb_exception e
;
6487 LONGEST offset_to_top
= 0;
6488 struct type
*ptr_type
, *obj_type
;
6490 CORE_ADDR base_address
;
6492 obj_type
= value_type (obj
);
6494 /* It is the responsability of the caller to deref pointers. */
6496 if (TYPE_CODE (obj_type
) == TYPE_CODE_PTR
6497 || TYPE_CODE (obj_type
) == TYPE_CODE_REF
)
6500 tag
= ada_value_tag (obj
);
6504 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6506 if (is_ada95_tag (tag
))
6509 ptr_type
= builtin_type (target_gdbarch ())->builtin_data_ptr
;
6510 ptr_type
= lookup_pointer_type (ptr_type
);
6511 val
= value_cast (ptr_type
, tag
);
6515 /* It is perfectly possible that an exception be raised while
6516 trying to determine the base address, just like for the tag;
6517 see ada_tag_name for more details. We do not print the error
6518 message for the same reason. */
6520 TRY_CATCH (e
, RETURN_MASK_ERROR
)
6522 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6528 /* If offset is null, nothing to do. */
6530 if (offset_to_top
== 0)
6533 /* -1 is a special case in Ada.Tags; however, what should be done
6534 is not quite clear from the documentation. So do nothing for
6537 if (offset_to_top
== -1)
6540 base_address
= value_address (obj
) - offset_to_top
;
6541 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6543 /* Make sure that we have a proper tag at the new address.
6544 Otherwise, offset_to_top is bogus (which can happen when
6545 the object is not initialized yet). */
6550 obj_type
= type_from_tag (tag
);
6555 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6558 /* Return the "ada__tags__type_specific_data" type. */
6560 static struct type
*
6561 ada_get_tsd_type (struct inferior
*inf
)
6563 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6565 if (data
->tsd_type
== 0)
6566 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6567 return data
->tsd_type
;
6570 /* Return the TSD (type-specific data) associated to the given TAG.
6571 TAG is assumed to be the tag of a tagged-type entity.
6573 May return NULL if we are unable to get the TSD. */
6575 static struct value
*
6576 ada_get_tsd_from_tag (struct value
*tag
)
6581 /* First option: The TSD is simply stored as a field of our TAG.
6582 Only older versions of GNAT would use this format, but we have
6583 to test it first, because there are no visible markers for
6584 the current approach except the absence of that field. */
6586 val
= ada_value_struct_elt (tag
, "tsd", 1);
6590 /* Try the second representation for the dispatch table (in which
6591 there is no explicit 'tsd' field in the referent of the tag pointer,
6592 and instead the tsd pointer is stored just before the dispatch
6595 type
= ada_get_tsd_type (current_inferior());
6598 type
= lookup_pointer_type (lookup_pointer_type (type
));
6599 val
= value_cast (type
, tag
);
6602 return value_ind (value_ptradd (val
, -1));
6605 /* Given the TSD of a tag (type-specific data), return a string
6606 containing the name of the associated type.
6608 The returned value is good until the next call. May return NULL
6609 if we are unable to determine the tag name. */
6612 ada_tag_name_from_tsd (struct value
*tsd
)
6614 static char name
[1024];
6618 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6621 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6622 for (p
= name
; *p
!= '\0'; p
+= 1)
6628 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6631 Return NULL if the TAG is not an Ada tag, or if we were unable to
6632 determine the name of that tag. The result is good until the next
6636 ada_tag_name (struct value
*tag
)
6638 volatile struct gdb_exception e
;
6641 if (!ada_is_tag_type (value_type (tag
)))
6644 /* It is perfectly possible that an exception be raised while trying
6645 to determine the TAG's name, even under normal circumstances:
6646 The associated variable may be uninitialized or corrupted, for
6647 instance. We do not let any exception propagate past this point.
6648 instead we return NULL.
6650 We also do not print the error message either (which often is very
6651 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6652 the caller print a more meaningful message if necessary. */
6653 TRY_CATCH (e
, RETURN_MASK_ERROR
)
6655 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6658 name
= ada_tag_name_from_tsd (tsd
);
6664 /* The parent type of TYPE, or NULL if none. */
6667 ada_parent_type (struct type
*type
)
6671 type
= ada_check_typedef (type
);
6673 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6676 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6677 if (ada_is_parent_field (type
, i
))
6679 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6681 /* If the _parent field is a pointer, then dereference it. */
6682 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
6683 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6684 /* If there is a parallel XVS type, get the actual base type. */
6685 parent_type
= ada_get_base_type (parent_type
);
6687 return ada_check_typedef (parent_type
);
6693 /* True iff field number FIELD_NUM of structure type TYPE contains the
6694 parent-type (inherited) fields of a derived type. Assumes TYPE is
6695 a structure type with at least FIELD_NUM+1 fields. */
6698 ada_is_parent_field (struct type
*type
, int field_num
)
6700 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6702 return (name
!= NULL
6703 && (strncmp (name
, "PARENT", 6) == 0
6704 || strncmp (name
, "_parent", 7) == 0));
6707 /* True iff field number FIELD_NUM of structure type TYPE is a
6708 transparent wrapper field (which should be silently traversed when doing
6709 field selection and flattened when printing). Assumes TYPE is a
6710 structure type with at least FIELD_NUM+1 fields. Such fields are always
6714 ada_is_wrapper_field (struct type
*type
, int field_num
)
6716 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6718 return (name
!= NULL
6719 && (strncmp (name
, "PARENT", 6) == 0
6720 || strcmp (name
, "REP") == 0
6721 || strncmp (name
, "_parent", 7) == 0
6722 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6725 /* True iff field number FIELD_NUM of structure or union type TYPE
6726 is a variant wrapper. Assumes TYPE is a structure type with at least
6727 FIELD_NUM+1 fields. */
6730 ada_is_variant_part (struct type
*type
, int field_num
)
6732 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6734 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6735 || (is_dynamic_field (type
, field_num
)
6736 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6737 == TYPE_CODE_UNION
)));
6740 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6741 whose discriminants are contained in the record type OUTER_TYPE,
6742 returns the type of the controlling discriminant for the variant.
6743 May return NULL if the type could not be found. */
6746 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6748 char *name
= ada_variant_discrim_name (var_type
);
6750 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6753 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6754 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6755 represents a 'when others' clause; otherwise 0. */
6758 ada_is_others_clause (struct type
*type
, int field_num
)
6760 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6762 return (name
!= NULL
&& name
[0] == 'O');
6765 /* Assuming that TYPE0 is the type of the variant part of a record,
6766 returns the name of the discriminant controlling the variant.
6767 The value is valid until the next call to ada_variant_discrim_name. */
6770 ada_variant_discrim_name (struct type
*type0
)
6772 static char *result
= NULL
;
6773 static size_t result_len
= 0;
6776 const char *discrim_end
;
6777 const char *discrim_start
;
6779 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6780 type
= TYPE_TARGET_TYPE (type0
);
6784 name
= ada_type_name (type
);
6786 if (name
== NULL
|| name
[0] == '\000')
6789 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6792 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6795 if (discrim_end
== name
)
6798 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6801 if (discrim_start
== name
+ 1)
6803 if ((discrim_start
> name
+ 3
6804 && strncmp (discrim_start
- 3, "___", 3) == 0)
6805 || discrim_start
[-1] == '.')
6809 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6810 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6811 result
[discrim_end
- discrim_start
] = '\0';
6815 /* Scan STR for a subtype-encoded number, beginning at position K.
6816 Put the position of the character just past the number scanned in
6817 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6818 Return 1 if there was a valid number at the given position, and 0
6819 otherwise. A "subtype-encoded" number consists of the absolute value
6820 in decimal, followed by the letter 'm' to indicate a negative number.
6821 Assumes 0m does not occur. */
6824 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6828 if (!isdigit (str
[k
]))
6831 /* Do it the hard way so as not to make any assumption about
6832 the relationship of unsigned long (%lu scan format code) and
6835 while (isdigit (str
[k
]))
6837 RU
= RU
* 10 + (str
[k
] - '0');
6844 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6850 /* NOTE on the above: Technically, C does not say what the results of
6851 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6852 number representable as a LONGEST (although either would probably work
6853 in most implementations). When RU>0, the locution in the then branch
6854 above is always equivalent to the negative of RU. */
6861 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6862 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6863 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6866 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6868 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6882 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6892 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6893 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6895 if (val
>= L
&& val
<= U
)
6907 /* FIXME: Lots of redundancy below. Try to consolidate. */
6909 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6910 ARG_TYPE, extract and return the value of one of its (non-static)
6911 fields. FIELDNO says which field. Differs from value_primitive_field
6912 only in that it can handle packed values of arbitrary type. */
6914 static struct value
*
6915 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6916 struct type
*arg_type
)
6920 arg_type
= ada_check_typedef (arg_type
);
6921 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6923 /* Handle packed fields. */
6925 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6927 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6928 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6930 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6931 offset
+ bit_pos
/ 8,
6932 bit_pos
% 8, bit_size
, type
);
6935 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6938 /* Find field with name NAME in object of type TYPE. If found,
6939 set the following for each argument that is non-null:
6940 - *FIELD_TYPE_P to the field's type;
6941 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6942 an object of that type;
6943 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6944 - *BIT_SIZE_P to its size in bits if the field is packed, and
6946 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6947 fields up to but not including the desired field, or by the total
6948 number of fields if not found. A NULL value of NAME never
6949 matches; the function just counts visible fields in this case.
6951 Returns 1 if found, 0 otherwise. */
6954 find_struct_field (const char *name
, struct type
*type
, int offset
,
6955 struct type
**field_type_p
,
6956 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6961 type
= ada_check_typedef (type
);
6963 if (field_type_p
!= NULL
)
6964 *field_type_p
= NULL
;
6965 if (byte_offset_p
!= NULL
)
6967 if (bit_offset_p
!= NULL
)
6969 if (bit_size_p
!= NULL
)
6972 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6974 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6975 int fld_offset
= offset
+ bit_pos
/ 8;
6976 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6978 if (t_field_name
== NULL
)
6981 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6983 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6985 if (field_type_p
!= NULL
)
6986 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6987 if (byte_offset_p
!= NULL
)
6988 *byte_offset_p
= fld_offset
;
6989 if (bit_offset_p
!= NULL
)
6990 *bit_offset_p
= bit_pos
% 8;
6991 if (bit_size_p
!= NULL
)
6992 *bit_size_p
= bit_size
;
6995 else if (ada_is_wrapper_field (type
, i
))
6997 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6998 field_type_p
, byte_offset_p
, bit_offset_p
,
6999 bit_size_p
, index_p
))
7002 else if (ada_is_variant_part (type
, i
))
7004 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7007 struct type
*field_type
7008 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7010 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7012 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7014 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7015 field_type_p
, byte_offset_p
,
7016 bit_offset_p
, bit_size_p
, index_p
))
7020 else if (index_p
!= NULL
)
7026 /* Number of user-visible fields in record type TYPE. */
7029 num_visible_fields (struct type
*type
)
7034 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7038 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7039 and search in it assuming it has (class) type TYPE.
7040 If found, return value, else return NULL.
7042 Searches recursively through wrapper fields (e.g., '_parent'). */
7044 static struct value
*
7045 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
7050 type
= ada_check_typedef (type
);
7051 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7053 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7055 if (t_field_name
== NULL
)
7058 else if (field_name_match (t_field_name
, name
))
7059 return ada_value_primitive_field (arg
, offset
, i
, type
);
7061 else if (ada_is_wrapper_field (type
, i
))
7063 struct value
*v
= /* Do not let indent join lines here. */
7064 ada_search_struct_field (name
, arg
,
7065 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7066 TYPE_FIELD_TYPE (type
, i
));
7072 else if (ada_is_variant_part (type
, i
))
7074 /* PNH: Do we ever get here? See find_struct_field. */
7076 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7078 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7080 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7082 struct value
*v
= ada_search_struct_field
/* Force line
7085 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7086 TYPE_FIELD_TYPE (field_type
, j
));
7096 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7097 int, struct type
*);
7100 /* Return field #INDEX in ARG, where the index is that returned by
7101 * find_struct_field through its INDEX_P argument. Adjust the address
7102 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7103 * If found, return value, else return NULL. */
7105 static struct value
*
7106 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7109 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7113 /* Auxiliary function for ada_index_struct_field. Like
7114 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7117 static struct value
*
7118 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7122 type
= ada_check_typedef (type
);
7124 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7126 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7128 else if (ada_is_wrapper_field (type
, i
))
7130 struct value
*v
= /* Do not let indent join lines here. */
7131 ada_index_struct_field_1 (index_p
, arg
,
7132 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7133 TYPE_FIELD_TYPE (type
, i
));
7139 else if (ada_is_variant_part (type
, i
))
7141 /* PNH: Do we ever get here? See ada_search_struct_field,
7142 find_struct_field. */
7143 error (_("Cannot assign this kind of variant record"));
7145 else if (*index_p
== 0)
7146 return ada_value_primitive_field (arg
, offset
, i
, type
);
7153 /* Given ARG, a value of type (pointer or reference to a)*
7154 structure/union, extract the component named NAME from the ultimate
7155 target structure/union and return it as a value with its
7158 The routine searches for NAME among all members of the structure itself
7159 and (recursively) among all members of any wrapper members
7162 If NO_ERR, then simply return NULL in case of error, rather than
7166 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
7168 struct type
*t
, *t1
;
7172 t1
= t
= ada_check_typedef (value_type (arg
));
7173 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7175 t1
= TYPE_TARGET_TYPE (t
);
7178 t1
= ada_check_typedef (t1
);
7179 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7181 arg
= coerce_ref (arg
);
7186 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7188 t1
= TYPE_TARGET_TYPE (t
);
7191 t1
= ada_check_typedef (t1
);
7192 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7194 arg
= value_ind (arg
);
7201 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7205 v
= ada_search_struct_field (name
, arg
, 0, t
);
7208 int bit_offset
, bit_size
, byte_offset
;
7209 struct type
*field_type
;
7212 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7213 address
= value_address (ada_value_ind (arg
));
7215 address
= value_address (ada_coerce_ref (arg
));
7217 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
7218 if (find_struct_field (name
, t1
, 0,
7219 &field_type
, &byte_offset
, &bit_offset
,
7224 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7225 arg
= ada_coerce_ref (arg
);
7227 arg
= ada_value_ind (arg
);
7228 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7229 bit_offset
, bit_size
,
7233 v
= value_at_lazy (field_type
, address
+ byte_offset
);
7237 if (v
!= NULL
|| no_err
)
7240 error (_("There is no member named %s."), name
);
7246 error (_("Attempt to extract a component of "
7247 "a value that is not a record."));
7250 /* Given a type TYPE, look up the type of the component of type named NAME.
7251 If DISPP is non-null, add its byte displacement from the beginning of a
7252 structure (pointed to by a value) of type TYPE to *DISPP (does not
7253 work for packed fields).
7255 Matches any field whose name has NAME as a prefix, possibly
7258 TYPE can be either a struct or union. If REFOK, TYPE may also
7259 be a (pointer or reference)+ to a struct or union, and the
7260 ultimate target type will be searched.
7262 Looks recursively into variant clauses and parent types.
7264 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7265 TYPE is not a type of the right kind. */
7267 static struct type
*
7268 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7269 int noerr
, int *dispp
)
7276 if (refok
&& type
!= NULL
)
7279 type
= ada_check_typedef (type
);
7280 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7281 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7283 type
= TYPE_TARGET_TYPE (type
);
7287 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7288 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7294 target_terminal_ours ();
7295 gdb_flush (gdb_stdout
);
7297 error (_("Type (null) is not a structure or union type"));
7300 /* XXX: type_sprint */
7301 fprintf_unfiltered (gdb_stderr
, _("Type "));
7302 type_print (type
, "", gdb_stderr
, -1);
7303 error (_(" is not a structure or union type"));
7308 type
= to_static_fixed_type (type
);
7310 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7312 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7316 if (t_field_name
== NULL
)
7319 else if (field_name_match (t_field_name
, name
))
7322 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7323 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7326 else if (ada_is_wrapper_field (type
, i
))
7329 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7334 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7339 else if (ada_is_variant_part (type
, i
))
7342 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7345 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7347 /* FIXME pnh 2008/01/26: We check for a field that is
7348 NOT wrapped in a struct, since the compiler sometimes
7349 generates these for unchecked variant types. Revisit
7350 if the compiler changes this practice. */
7351 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7353 if (v_field_name
!= NULL
7354 && field_name_match (v_field_name
, name
))
7355 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
7357 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7364 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7375 target_terminal_ours ();
7376 gdb_flush (gdb_stdout
);
7379 /* XXX: type_sprint */
7380 fprintf_unfiltered (gdb_stderr
, _("Type "));
7381 type_print (type
, "", gdb_stderr
, -1);
7382 error (_(" has no component named <null>"));
7386 /* XXX: type_sprint */
7387 fprintf_unfiltered (gdb_stderr
, _("Type "));
7388 type_print (type
, "", gdb_stderr
, -1);
7389 error (_(" has no component named %s"), name
);
7396 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7397 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7398 represents an unchecked union (that is, the variant part of a
7399 record that is named in an Unchecked_Union pragma). */
7402 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7404 char *discrim_name
= ada_variant_discrim_name (var_type
);
7406 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
7411 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7412 within a value of type OUTER_TYPE that is stored in GDB at
7413 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7414 numbering from 0) is applicable. Returns -1 if none are. */
7417 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7418 const gdb_byte
*outer_valaddr
)
7422 char *discrim_name
= ada_variant_discrim_name (var_type
);
7423 struct value
*outer
;
7424 struct value
*discrim
;
7425 LONGEST discrim_val
;
7427 /* Using plain value_from_contents_and_address here causes problems
7428 because we will end up trying to resolve a type that is currently
7429 being constructed. */
7430 outer
= value_from_contents_and_address_unresolved (outer_type
,
7432 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7433 if (discrim
== NULL
)
7435 discrim_val
= value_as_long (discrim
);
7438 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7440 if (ada_is_others_clause (var_type
, i
))
7442 else if (ada_in_variant (discrim_val
, var_type
, i
))
7446 return others_clause
;
7451 /* Dynamic-Sized Records */
7453 /* Strategy: The type ostensibly attached to a value with dynamic size
7454 (i.e., a size that is not statically recorded in the debugging
7455 data) does not accurately reflect the size or layout of the value.
7456 Our strategy is to convert these values to values with accurate,
7457 conventional types that are constructed on the fly. */
7459 /* There is a subtle and tricky problem here. In general, we cannot
7460 determine the size of dynamic records without its data. However,
7461 the 'struct value' data structure, which GDB uses to represent
7462 quantities in the inferior process (the target), requires the size
7463 of the type at the time of its allocation in order to reserve space
7464 for GDB's internal copy of the data. That's why the
7465 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7466 rather than struct value*s.
7468 However, GDB's internal history variables ($1, $2, etc.) are
7469 struct value*s containing internal copies of the data that are not, in
7470 general, the same as the data at their corresponding addresses in
7471 the target. Fortunately, the types we give to these values are all
7472 conventional, fixed-size types (as per the strategy described
7473 above), so that we don't usually have to perform the
7474 'to_fixed_xxx_type' conversions to look at their values.
7475 Unfortunately, there is one exception: if one of the internal
7476 history variables is an array whose elements are unconstrained
7477 records, then we will need to create distinct fixed types for each
7478 element selected. */
7480 /* The upshot of all of this is that many routines take a (type, host
7481 address, target address) triple as arguments to represent a value.
7482 The host address, if non-null, is supposed to contain an internal
7483 copy of the relevant data; otherwise, the program is to consult the
7484 target at the target address. */
7486 /* Assuming that VAL0 represents a pointer value, the result of
7487 dereferencing it. Differs from value_ind in its treatment of
7488 dynamic-sized types. */
7491 ada_value_ind (struct value
*val0
)
7493 struct value
*val
= value_ind (val0
);
7495 if (ada_is_tagged_type (value_type (val
), 0))
7496 val
= ada_tag_value_at_base_address (val
);
7498 return ada_to_fixed_value (val
);
7501 /* The value resulting from dereferencing any "reference to"
7502 qualifiers on VAL0. */
7504 static struct value
*
7505 ada_coerce_ref (struct value
*val0
)
7507 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
7509 struct value
*val
= val0
;
7511 val
= coerce_ref (val
);
7513 if (ada_is_tagged_type (value_type (val
), 0))
7514 val
= ada_tag_value_at_base_address (val
);
7516 return ada_to_fixed_value (val
);
7522 /* Return OFF rounded upward if necessary to a multiple of
7523 ALIGNMENT (a power of 2). */
7526 align_value (unsigned int off
, unsigned int alignment
)
7528 return (off
+ alignment
- 1) & ~(alignment
- 1);
7531 /* Return the bit alignment required for field #F of template type TYPE. */
7534 field_alignment (struct type
*type
, int f
)
7536 const char *name
= TYPE_FIELD_NAME (type
, f
);
7540 /* The field name should never be null, unless the debugging information
7541 is somehow malformed. In this case, we assume the field does not
7542 require any alignment. */
7546 len
= strlen (name
);
7548 if (!isdigit (name
[len
- 1]))
7551 if (isdigit (name
[len
- 2]))
7552 align_offset
= len
- 2;
7554 align_offset
= len
- 1;
7556 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7557 return TARGET_CHAR_BIT
;
7559 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7562 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7564 static struct symbol
*
7565 ada_find_any_type_symbol (const char *name
)
7569 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7570 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7573 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7577 /* Find a type named NAME. Ignores ambiguity. This routine will look
7578 solely for types defined by debug info, it will not search the GDB
7581 static struct type
*
7582 ada_find_any_type (const char *name
)
7584 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7587 return SYMBOL_TYPE (sym
);
7592 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7593 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7594 symbol, in which case it is returned. Otherwise, this looks for
7595 symbols whose name is that of NAME_SYM suffixed with "___XR".
7596 Return symbol if found, and NULL otherwise. */
7599 ada_find_renaming_symbol (struct symbol
*name_sym
, const struct block
*block
)
7601 const char *name
= SYMBOL_LINKAGE_NAME (name_sym
);
7604 if (strstr (name
, "___XR") != NULL
)
7607 sym
= find_old_style_renaming_symbol (name
, block
);
7612 /* Not right yet. FIXME pnh 7/20/2007. */
7613 sym
= ada_find_any_type_symbol (name
);
7614 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
7620 static struct symbol
*
7621 find_old_style_renaming_symbol (const char *name
, const struct block
*block
)
7623 const struct symbol
*function_sym
= block_linkage_function (block
);
7626 if (function_sym
!= NULL
)
7628 /* If the symbol is defined inside a function, NAME is not fully
7629 qualified. This means we need to prepend the function name
7630 as well as adding the ``___XR'' suffix to build the name of
7631 the associated renaming symbol. */
7632 const char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7633 /* Function names sometimes contain suffixes used
7634 for instance to qualify nested subprograms. When building
7635 the XR type name, we need to make sure that this suffix is
7636 not included. So do not include any suffix in the function
7637 name length below. */
7638 int function_name_len
= ada_name_prefix_len (function_name
);
7639 const int rename_len
= function_name_len
+ 2 /* "__" */
7640 + strlen (name
) + 6 /* "___XR\0" */ ;
7642 /* Strip the suffix if necessary. */
7643 ada_remove_trailing_digits (function_name
, &function_name_len
);
7644 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
7645 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
7647 /* Library-level functions are a special case, as GNAT adds
7648 a ``_ada_'' prefix to the function name to avoid namespace
7649 pollution. However, the renaming symbols themselves do not
7650 have this prefix, so we need to skip this prefix if present. */
7651 if (function_name_len
> 5 /* "_ada_" */
7652 && strstr (function_name
, "_ada_") == function_name
)
7655 function_name_len
-= 5;
7658 rename
= (char *) alloca (rename_len
* sizeof (char));
7659 strncpy (rename
, function_name
, function_name_len
);
7660 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
7665 const int rename_len
= strlen (name
) + 6;
7667 rename
= (char *) alloca (rename_len
* sizeof (char));
7668 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
7671 return ada_find_any_type_symbol (rename
);
7674 /* Because of GNAT encoding conventions, several GDB symbols may match a
7675 given type name. If the type denoted by TYPE0 is to be preferred to
7676 that of TYPE1 for purposes of type printing, return non-zero;
7677 otherwise return 0. */
7680 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7684 else if (type0
== NULL
)
7686 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7688 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7690 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7692 else if (ada_is_constrained_packed_array_type (type0
))
7694 else if (ada_is_array_descriptor_type (type0
)
7695 && !ada_is_array_descriptor_type (type1
))
7699 const char *type0_name
= type_name_no_tag (type0
);
7700 const char *type1_name
= type_name_no_tag (type1
);
7702 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7703 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7709 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7710 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7713 ada_type_name (struct type
*type
)
7717 else if (TYPE_NAME (type
) != NULL
)
7718 return TYPE_NAME (type
);
7720 return TYPE_TAG_NAME (type
);
7723 /* Search the list of "descriptive" types associated to TYPE for a type
7724 whose name is NAME. */
7726 static struct type
*
7727 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7729 struct type
*result
;
7731 if (ada_ignore_descriptive_types_p
)
7734 /* If there no descriptive-type info, then there is no parallel type
7736 if (!HAVE_GNAT_AUX_INFO (type
))
7739 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7740 while (result
!= NULL
)
7742 const char *result_name
= ada_type_name (result
);
7744 if (result_name
== NULL
)
7746 warning (_("unexpected null name on descriptive type"));
7750 /* If the names match, stop. */
7751 if (strcmp (result_name
, name
) == 0)
7754 /* Otherwise, look at the next item on the list, if any. */
7755 if (HAVE_GNAT_AUX_INFO (result
))
7756 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7761 /* If we didn't find a match, see whether this is a packed array. With
7762 older compilers, the descriptive type information is either absent or
7763 irrelevant when it comes to packed arrays so the above lookup fails.
7764 Fall back to using a parallel lookup by name in this case. */
7765 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7766 return ada_find_any_type (name
);
7771 /* Find a parallel type to TYPE with the specified NAME, using the
7772 descriptive type taken from the debugging information, if available,
7773 and otherwise using the (slower) name-based method. */
7775 static struct type
*
7776 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7778 struct type
*result
= NULL
;
7780 if (HAVE_GNAT_AUX_INFO (type
))
7781 result
= find_parallel_type_by_descriptive_type (type
, name
);
7783 result
= ada_find_any_type (name
);
7788 /* Same as above, but specify the name of the parallel type by appending
7789 SUFFIX to the name of TYPE. */
7792 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7795 const char *typename
= ada_type_name (type
);
7798 if (typename
== NULL
)
7801 len
= strlen (typename
);
7803 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7805 strcpy (name
, typename
);
7806 strcpy (name
+ len
, suffix
);
7808 return ada_find_parallel_type_with_name (type
, name
);
7811 /* If TYPE is a variable-size record type, return the corresponding template
7812 type describing its fields. Otherwise, return NULL. */
7814 static struct type
*
7815 dynamic_template_type (struct type
*type
)
7817 type
= ada_check_typedef (type
);
7819 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7820 || ada_type_name (type
) == NULL
)
7824 int len
= strlen (ada_type_name (type
));
7826 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7829 return ada_find_parallel_type (type
, "___XVE");
7833 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7834 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7837 is_dynamic_field (struct type
*templ_type
, int field_num
)
7839 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7842 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7843 && strstr (name
, "___XVL") != NULL
;
7846 /* The index of the variant field of TYPE, or -1 if TYPE does not
7847 represent a variant record type. */
7850 variant_field_index (struct type
*type
)
7854 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7857 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7859 if (ada_is_variant_part (type
, f
))
7865 /* A record type with no fields. */
7867 static struct type
*
7868 empty_record (struct type
*template)
7870 struct type
*type
= alloc_type_copy (template);
7872 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7873 TYPE_NFIELDS (type
) = 0;
7874 TYPE_FIELDS (type
) = NULL
;
7875 INIT_CPLUS_SPECIFIC (type
);
7876 TYPE_NAME (type
) = "<empty>";
7877 TYPE_TAG_NAME (type
) = NULL
;
7878 TYPE_LENGTH (type
) = 0;
7882 /* An ordinary record type (with fixed-length fields) that describes
7883 the value of type TYPE at VALADDR or ADDRESS (see comments at
7884 the beginning of this section) VAL according to GNAT conventions.
7885 DVAL0 should describe the (portion of a) record that contains any
7886 necessary discriminants. It should be NULL if value_type (VAL) is
7887 an outer-level type (i.e., as opposed to a branch of a variant.) A
7888 variant field (unless unchecked) is replaced by a particular branch
7891 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7892 length are not statically known are discarded. As a consequence,
7893 VALADDR, ADDRESS and DVAL0 are ignored.
7895 NOTE: Limitations: For now, we assume that dynamic fields and
7896 variants occupy whole numbers of bytes. However, they need not be
7900 ada_template_to_fixed_record_type_1 (struct type
*type
,
7901 const gdb_byte
*valaddr
,
7902 CORE_ADDR address
, struct value
*dval0
,
7903 int keep_dynamic_fields
)
7905 struct value
*mark
= value_mark ();
7908 int nfields
, bit_len
;
7914 /* Compute the number of fields in this record type that are going
7915 to be processed: unless keep_dynamic_fields, this includes only
7916 fields whose position and length are static will be processed. */
7917 if (keep_dynamic_fields
)
7918 nfields
= TYPE_NFIELDS (type
);
7922 while (nfields
< TYPE_NFIELDS (type
)
7923 && !ada_is_variant_part (type
, nfields
)
7924 && !is_dynamic_field (type
, nfields
))
7928 rtype
= alloc_type_copy (type
);
7929 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7930 INIT_CPLUS_SPECIFIC (rtype
);
7931 TYPE_NFIELDS (rtype
) = nfields
;
7932 TYPE_FIELDS (rtype
) = (struct field
*)
7933 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7934 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7935 TYPE_NAME (rtype
) = ada_type_name (type
);
7936 TYPE_TAG_NAME (rtype
) = NULL
;
7937 TYPE_FIXED_INSTANCE (rtype
) = 1;
7943 for (f
= 0; f
< nfields
; f
+= 1)
7945 off
= align_value (off
, field_alignment (type
, f
))
7946 + TYPE_FIELD_BITPOS (type
, f
);
7947 SET_FIELD_BITPOS (TYPE_FIELD (rtype
, f
), off
);
7948 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7950 if (ada_is_variant_part (type
, f
))
7955 else if (is_dynamic_field (type
, f
))
7957 const gdb_byte
*field_valaddr
= valaddr
;
7958 CORE_ADDR field_address
= address
;
7959 struct type
*field_type
=
7960 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
7964 /* rtype's length is computed based on the run-time
7965 value of discriminants. If the discriminants are not
7966 initialized, the type size may be completely bogus and
7967 GDB may fail to allocate a value for it. So check the
7968 size first before creating the value. */
7969 ada_ensure_varsize_limit (rtype
);
7970 /* Using plain value_from_contents_and_address here
7971 causes problems because we will end up trying to
7972 resolve a type that is currently being
7974 dval
= value_from_contents_and_address_unresolved (rtype
,
7977 rtype
= value_type (dval
);
7982 /* If the type referenced by this field is an aligner type, we need
7983 to unwrap that aligner type, because its size might not be set.
7984 Keeping the aligner type would cause us to compute the wrong
7985 size for this field, impacting the offset of the all the fields
7986 that follow this one. */
7987 if (ada_is_aligner_type (field_type
))
7989 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7991 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7992 field_address
= cond_offset_target (field_address
, field_offset
);
7993 field_type
= ada_aligned_type (field_type
);
7996 field_valaddr
= cond_offset_host (field_valaddr
,
7997 off
/ TARGET_CHAR_BIT
);
7998 field_address
= cond_offset_target (field_address
,
7999 off
/ TARGET_CHAR_BIT
);
8001 /* Get the fixed type of the field. Note that, in this case,
8002 we do not want to get the real type out of the tag: if
8003 the current field is the parent part of a tagged record,
8004 we will get the tag of the object. Clearly wrong: the real
8005 type of the parent is not the real type of the child. We
8006 would end up in an infinite loop. */
8007 field_type
= ada_get_base_type (field_type
);
8008 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8009 field_address
, dval
, 0);
8010 /* If the field size is already larger than the maximum
8011 object size, then the record itself will necessarily
8012 be larger than the maximum object size. We need to make
8013 this check now, because the size might be so ridiculously
8014 large (due to an uninitialized variable in the inferior)
8015 that it would cause an overflow when adding it to the
8017 ada_ensure_varsize_limit (field_type
);
8019 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
8020 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8021 /* The multiplication can potentially overflow. But because
8022 the field length has been size-checked just above, and
8023 assuming that the maximum size is a reasonable value,
8024 an overflow should not happen in practice. So rather than
8025 adding overflow recovery code to this already complex code,
8026 we just assume that it's not going to happen. */
8028 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
8032 /* Note: If this field's type is a typedef, it is important
8033 to preserve the typedef layer.
8035 Otherwise, we might be transforming a typedef to a fat
8036 pointer (encoding a pointer to an unconstrained array),
8037 into a basic fat pointer (encoding an unconstrained
8038 array). As both types are implemented using the same
8039 structure, the typedef is the only clue which allows us
8040 to distinguish between the two options. Stripping it
8041 would prevent us from printing this field appropriately. */
8042 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
8043 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8044 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8046 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8049 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
8051 /* We need to be careful of typedefs when computing
8052 the length of our field. If this is a typedef,
8053 get the length of the target type, not the length
8055 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
8056 field_type
= ada_typedef_target_type (field_type
);
8059 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8062 if (off
+ fld_bit_len
> bit_len
)
8063 bit_len
= off
+ fld_bit_len
;
8065 TYPE_LENGTH (rtype
) =
8066 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8069 /* We handle the variant part, if any, at the end because of certain
8070 odd cases in which it is re-ordered so as NOT to be the last field of
8071 the record. This can happen in the presence of representation
8073 if (variant_field
>= 0)
8075 struct type
*branch_type
;
8077 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8081 /* Using plain value_from_contents_and_address here causes
8082 problems because we will end up trying to resolve a type
8083 that is currently being constructed. */
8084 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8086 rtype
= value_type (dval
);
8092 to_fixed_variant_branch_type
8093 (TYPE_FIELD_TYPE (type
, variant_field
),
8094 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8095 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8096 if (branch_type
== NULL
)
8098 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
8099 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8100 TYPE_NFIELDS (rtype
) -= 1;
8104 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8105 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8107 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8109 if (off
+ fld_bit_len
> bit_len
)
8110 bit_len
= off
+ fld_bit_len
;
8111 TYPE_LENGTH (rtype
) =
8112 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8116 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8117 should contain the alignment of that record, which should be a strictly
8118 positive value. If null or negative, then something is wrong, most
8119 probably in the debug info. In that case, we don't round up the size
8120 of the resulting type. If this record is not part of another structure,
8121 the current RTYPE length might be good enough for our purposes. */
8122 if (TYPE_LENGTH (type
) <= 0)
8124 if (TYPE_NAME (rtype
))
8125 warning (_("Invalid type size for `%s' detected: %d."),
8126 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
8128 warning (_("Invalid type size for <unnamed> detected: %d."),
8129 TYPE_LENGTH (type
));
8133 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
8134 TYPE_LENGTH (type
));
8137 value_free_to_mark (mark
);
8138 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8139 error (_("record type with dynamic size is larger than varsize-limit"));
8143 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8146 static struct type
*
8147 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8148 CORE_ADDR address
, struct value
*dval0
)
8150 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8154 /* An ordinary record type in which ___XVL-convention fields and
8155 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8156 static approximations, containing all possible fields. Uses
8157 no runtime values. Useless for use in values, but that's OK,
8158 since the results are used only for type determinations. Works on both
8159 structs and unions. Representation note: to save space, we memorize
8160 the result of this function in the TYPE_TARGET_TYPE of the
8163 static struct type
*
8164 template_to_static_fixed_type (struct type
*type0
)
8170 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8171 return TYPE_TARGET_TYPE (type0
);
8173 nfields
= TYPE_NFIELDS (type0
);
8176 for (f
= 0; f
< nfields
; f
+= 1)
8178 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
8179 struct type
*new_type
;
8181 if (is_dynamic_field (type0
, f
))
8182 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8184 new_type
= static_unwrap_type (field_type
);
8185 if (type
== type0
&& new_type
!= field_type
)
8187 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8188 TYPE_CODE (type
) = TYPE_CODE (type0
);
8189 INIT_CPLUS_SPECIFIC (type
);
8190 TYPE_NFIELDS (type
) = nfields
;
8191 TYPE_FIELDS (type
) = (struct field
*)
8192 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
8193 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
8194 sizeof (struct field
) * nfields
);
8195 TYPE_NAME (type
) = ada_type_name (type0
);
8196 TYPE_TAG_NAME (type
) = NULL
;
8197 TYPE_FIXED_INSTANCE (type
) = 1;
8198 TYPE_LENGTH (type
) = 0;
8200 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8201 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8206 /* Given an object of type TYPE whose contents are at VALADDR and
8207 whose address in memory is ADDRESS, returns a revision of TYPE,
8208 which should be a non-dynamic-sized record, in which the variant
8209 part, if any, is replaced with the appropriate branch. Looks
8210 for discriminant values in DVAL0, which can be NULL if the record
8211 contains the necessary discriminant values. */
8213 static struct type
*
8214 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8215 CORE_ADDR address
, struct value
*dval0
)
8217 struct value
*mark
= value_mark ();
8220 struct type
*branch_type
;
8221 int nfields
= TYPE_NFIELDS (type
);
8222 int variant_field
= variant_field_index (type
);
8224 if (variant_field
== -1)
8229 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8230 type
= value_type (dval
);
8235 rtype
= alloc_type_copy (type
);
8236 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8237 INIT_CPLUS_SPECIFIC (rtype
);
8238 TYPE_NFIELDS (rtype
) = nfields
;
8239 TYPE_FIELDS (rtype
) =
8240 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8241 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
8242 sizeof (struct field
) * nfields
);
8243 TYPE_NAME (rtype
) = ada_type_name (type
);
8244 TYPE_TAG_NAME (rtype
) = NULL
;
8245 TYPE_FIXED_INSTANCE (rtype
) = 1;
8246 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8248 branch_type
= to_fixed_variant_branch_type
8249 (TYPE_FIELD_TYPE (type
, variant_field
),
8250 cond_offset_host (valaddr
,
8251 TYPE_FIELD_BITPOS (type
, variant_field
)
8253 cond_offset_target (address
,
8254 TYPE_FIELD_BITPOS (type
, variant_field
)
8255 / TARGET_CHAR_BIT
), dval
);
8256 if (branch_type
== NULL
)
8260 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8261 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8262 TYPE_NFIELDS (rtype
) -= 1;
8266 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8267 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8268 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8269 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8271 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8273 value_free_to_mark (mark
);
8277 /* An ordinary record type (with fixed-length fields) that describes
8278 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8279 beginning of this section]. Any necessary discriminants' values
8280 should be in DVAL, a record value; it may be NULL if the object
8281 at ADDR itself contains any necessary discriminant values.
8282 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8283 values from the record are needed. Except in the case that DVAL,
8284 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8285 unchecked) is replaced by a particular branch of the variant.
8287 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8288 is questionable and may be removed. It can arise during the
8289 processing of an unconstrained-array-of-record type where all the
8290 variant branches have exactly the same size. This is because in
8291 such cases, the compiler does not bother to use the XVS convention
8292 when encoding the record. I am currently dubious of this
8293 shortcut and suspect the compiler should be altered. FIXME. */
8295 static struct type
*
8296 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8297 CORE_ADDR address
, struct value
*dval
)
8299 struct type
*templ_type
;
8301 if (TYPE_FIXED_INSTANCE (type0
))
8304 templ_type
= dynamic_template_type (type0
);
8306 if (templ_type
!= NULL
)
8307 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8308 else if (variant_field_index (type0
) >= 0)
8310 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8312 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8317 TYPE_FIXED_INSTANCE (type0
) = 1;
8323 /* An ordinary record type (with fixed-length fields) that describes
8324 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8325 union type. Any necessary discriminants' values should be in DVAL,
8326 a record value. That is, this routine selects the appropriate
8327 branch of the union at ADDR according to the discriminant value
8328 indicated in the union's type name. Returns VAR_TYPE0 itself if
8329 it represents a variant subject to a pragma Unchecked_Union. */
8331 static struct type
*
8332 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8333 CORE_ADDR address
, struct value
*dval
)
8336 struct type
*templ_type
;
8337 struct type
*var_type
;
8339 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8340 var_type
= TYPE_TARGET_TYPE (var_type0
);
8342 var_type
= var_type0
;
8344 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8346 if (templ_type
!= NULL
)
8347 var_type
= templ_type
;
8349 if (is_unchecked_variant (var_type
, value_type (dval
)))
8352 ada_which_variant_applies (var_type
,
8353 value_type (dval
), value_contents (dval
));
8356 return empty_record (var_type
);
8357 else if (is_dynamic_field (var_type
, which
))
8358 return to_fixed_record_type
8359 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8360 valaddr
, address
, dval
);
8361 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8363 to_fixed_record_type
8364 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8366 return TYPE_FIELD_TYPE (var_type
, which
);
8369 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8370 ENCODING_TYPE, a type following the GNAT conventions for discrete
8371 type encodings, only carries redundant information. */
8374 ada_is_redundant_range_encoding (struct type
*range_type
,
8375 struct type
*encoding_type
)
8377 struct type
*fixed_range_type
;
8382 gdb_assert (TYPE_CODE (range_type
) == TYPE_CODE_RANGE
);
8384 if (TYPE_CODE (get_base_type (range_type
))
8385 != TYPE_CODE (get_base_type (encoding_type
)))
8387 /* The compiler probably used a simple base type to describe
8388 the range type instead of the range's actual base type,
8389 expecting us to get the real base type from the encoding
8390 anyway. In this situation, the encoding cannot be ignored
8395 if (is_dynamic_type (range_type
))
8398 if (TYPE_NAME (encoding_type
) == NULL
)
8401 bounds_str
= strstr (TYPE_NAME (encoding_type
), "___XDLU_");
8402 if (bounds_str
== NULL
)
8405 n
= 8; /* Skip "___XDLU_". */
8406 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8408 if (TYPE_LOW_BOUND (range_type
) != lo
)
8411 n
+= 2; /* Skip the "__" separator between the two bounds. */
8412 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8414 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8420 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8421 a type following the GNAT encoding for describing array type
8422 indices, only carries redundant information. */
8425 ada_is_redundant_index_type_desc (struct type
*array_type
,
8426 struct type
*desc_type
)
8428 struct type
*this_layer
= check_typedef (array_type
);
8431 for (i
= 0; i
< TYPE_NFIELDS (desc_type
); i
++)
8433 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer
),
8434 TYPE_FIELD_TYPE (desc_type
, i
)))
8436 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8442 /* Assuming that TYPE0 is an array type describing the type of a value
8443 at ADDR, and that DVAL describes a record containing any
8444 discriminants used in TYPE0, returns a type for the value that
8445 contains no dynamic components (that is, no components whose sizes
8446 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8447 true, gives an error message if the resulting type's size is over
8450 static struct type
*
8451 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8454 struct type
*index_type_desc
;
8455 struct type
*result
;
8456 int constrained_packed_array_p
;
8458 type0
= ada_check_typedef (type0
);
8459 if (TYPE_FIXED_INSTANCE (type0
))
8462 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8463 if (constrained_packed_array_p
)
8464 type0
= decode_constrained_packed_array_type (type0
);
8466 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
8467 ada_fixup_array_indexes_type (index_type_desc
);
8468 if (index_type_desc
!= NULL
8469 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8471 /* Ignore this ___XA parallel type, as it does not bring any
8472 useful information. This allows us to avoid creating fixed
8473 versions of the array's index types, which would be identical
8474 to the original ones. This, in turn, can also help avoid
8475 the creation of fixed versions of the array itself. */
8476 index_type_desc
= NULL
;
8479 if (index_type_desc
== NULL
)
8481 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8483 /* NOTE: elt_type---the fixed version of elt_type0---should never
8484 depend on the contents of the array in properly constructed
8486 /* Create a fixed version of the array element type.
8487 We're not providing the address of an element here,
8488 and thus the actual object value cannot be inspected to do
8489 the conversion. This should not be a problem, since arrays of
8490 unconstrained objects are not allowed. In particular, all
8491 the elements of an array of a tagged type should all be of
8492 the same type specified in the debugging info. No need to
8493 consult the object tag. */
8494 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8496 /* Make sure we always create a new array type when dealing with
8497 packed array types, since we're going to fix-up the array
8498 type length and element bitsize a little further down. */
8499 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8502 result
= create_array_type (alloc_type_copy (type0
),
8503 elt_type
, TYPE_INDEX_TYPE (type0
));
8508 struct type
*elt_type0
;
8511 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8512 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8514 /* NOTE: result---the fixed version of elt_type0---should never
8515 depend on the contents of the array in properly constructed
8517 /* Create a fixed version of the array element type.
8518 We're not providing the address of an element here,
8519 and thus the actual object value cannot be inspected to do
8520 the conversion. This should not be a problem, since arrays of
8521 unconstrained objects are not allowed. In particular, all
8522 the elements of an array of a tagged type should all be of
8523 the same type specified in the debugging info. No need to
8524 consult the object tag. */
8526 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8529 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8531 struct type
*range_type
=
8532 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8534 result
= create_array_type (alloc_type_copy (elt_type0
),
8535 result
, range_type
);
8536 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8538 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8539 error (_("array type with dynamic size is larger than varsize-limit"));
8542 /* We want to preserve the type name. This can be useful when
8543 trying to get the type name of a value that has already been
8544 printed (for instance, if the user did "print VAR; whatis $". */
8545 TYPE_NAME (result
) = TYPE_NAME (type0
);
8547 if (constrained_packed_array_p
)
8549 /* So far, the resulting type has been created as if the original
8550 type was a regular (non-packed) array type. As a result, the
8551 bitsize of the array elements needs to be set again, and the array
8552 length needs to be recomputed based on that bitsize. */
8553 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8554 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8556 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8557 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8558 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8559 TYPE_LENGTH (result
)++;
8562 TYPE_FIXED_INSTANCE (result
) = 1;
8567 /* A standard type (containing no dynamically sized components)
8568 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8569 DVAL describes a record containing any discriminants used in TYPE0,
8570 and may be NULL if there are none, or if the object of type TYPE at
8571 ADDRESS or in VALADDR contains these discriminants.
8573 If CHECK_TAG is not null, in the case of tagged types, this function
8574 attempts to locate the object's tag and use it to compute the actual
8575 type. However, when ADDRESS is null, we cannot use it to determine the
8576 location of the tag, and therefore compute the tagged type's actual type.
8577 So we return the tagged type without consulting the tag. */
8579 static struct type
*
8580 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8581 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8583 type
= ada_check_typedef (type
);
8584 switch (TYPE_CODE (type
))
8588 case TYPE_CODE_STRUCT
:
8590 struct type
*static_type
= to_static_fixed_type (type
);
8591 struct type
*fixed_record_type
=
8592 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8594 /* If STATIC_TYPE is a tagged type and we know the object's address,
8595 then we can determine its tag, and compute the object's actual
8596 type from there. Note that we have to use the fixed record
8597 type (the parent part of the record may have dynamic fields
8598 and the way the location of _tag is expressed may depend on
8601 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8604 value_tag_from_contents_and_address
8608 struct type
*real_type
= type_from_tag (tag
);
8610 value_from_contents_and_address (fixed_record_type
,
8613 fixed_record_type
= value_type (obj
);
8614 if (real_type
!= NULL
)
8615 return to_fixed_record_type
8617 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8620 /* Check to see if there is a parallel ___XVZ variable.
8621 If there is, then it provides the actual size of our type. */
8622 else if (ada_type_name (fixed_record_type
) != NULL
)
8624 const char *name
= ada_type_name (fixed_record_type
);
8625 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8629 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8630 size
= get_int_var_value (xvz_name
, &xvz_found
);
8631 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8633 fixed_record_type
= copy_type (fixed_record_type
);
8634 TYPE_LENGTH (fixed_record_type
) = size
;
8636 /* The FIXED_RECORD_TYPE may have be a stub. We have
8637 observed this when the debugging info is STABS, and
8638 apparently it is something that is hard to fix.
8640 In practice, we don't need the actual type definition
8641 at all, because the presence of the XVZ variable allows us
8642 to assume that there must be a XVS type as well, which we
8643 should be able to use later, when we need the actual type
8646 In the meantime, pretend that the "fixed" type we are
8647 returning is NOT a stub, because this can cause trouble
8648 when using this type to create new types targeting it.
8649 Indeed, the associated creation routines often check
8650 whether the target type is a stub and will try to replace
8651 it, thus using a type with the wrong size. This, in turn,
8652 might cause the new type to have the wrong size too.
8653 Consider the case of an array, for instance, where the size
8654 of the array is computed from the number of elements in
8655 our array multiplied by the size of its element. */
8656 TYPE_STUB (fixed_record_type
) = 0;
8659 return fixed_record_type
;
8661 case TYPE_CODE_ARRAY
:
8662 return to_fixed_array_type (type
, dval
, 1);
8663 case TYPE_CODE_UNION
:
8667 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8671 /* The same as ada_to_fixed_type_1, except that it preserves the type
8672 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8674 The typedef layer needs be preserved in order to differentiate between
8675 arrays and array pointers when both types are implemented using the same
8676 fat pointer. In the array pointer case, the pointer is encoded as
8677 a typedef of the pointer type. For instance, considering:
8679 type String_Access is access String;
8680 S1 : String_Access := null;
8682 To the debugger, S1 is defined as a typedef of type String. But
8683 to the user, it is a pointer. So if the user tries to print S1,
8684 we should not dereference the array, but print the array address
8687 If we didn't preserve the typedef layer, we would lose the fact that
8688 the type is to be presented as a pointer (needs de-reference before
8689 being printed). And we would also use the source-level type name. */
8692 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8693 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8696 struct type
*fixed_type
=
8697 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8699 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8700 then preserve the typedef layer.
8702 Implementation note: We can only check the main-type portion of
8703 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8704 from TYPE now returns a type that has the same instance flags
8705 as TYPE. For instance, if TYPE is a "typedef const", and its
8706 target type is a "struct", then the typedef elimination will return
8707 a "const" version of the target type. See check_typedef for more
8708 details about how the typedef layer elimination is done.
8710 brobecker/2010-11-19: It seems to me that the only case where it is
8711 useful to preserve the typedef layer is when dealing with fat pointers.
8712 Perhaps, we could add a check for that and preserve the typedef layer
8713 only in that situation. But this seems unecessary so far, probably
8714 because we call check_typedef/ada_check_typedef pretty much everywhere.
8716 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
8717 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8718 == TYPE_MAIN_TYPE (fixed_type
)))
8724 /* A standard (static-sized) type corresponding as well as possible to
8725 TYPE0, but based on no runtime data. */
8727 static struct type
*
8728 to_static_fixed_type (struct type
*type0
)
8735 if (TYPE_FIXED_INSTANCE (type0
))
8738 type0
= ada_check_typedef (type0
);
8740 switch (TYPE_CODE (type0
))
8744 case TYPE_CODE_STRUCT
:
8745 type
= dynamic_template_type (type0
);
8747 return template_to_static_fixed_type (type
);
8749 return template_to_static_fixed_type (type0
);
8750 case TYPE_CODE_UNION
:
8751 type
= ada_find_parallel_type (type0
, "___XVU");
8753 return template_to_static_fixed_type (type
);
8755 return template_to_static_fixed_type (type0
);
8759 /* A static approximation of TYPE with all type wrappers removed. */
8761 static struct type
*
8762 static_unwrap_type (struct type
*type
)
8764 if (ada_is_aligner_type (type
))
8766 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
8767 if (ada_type_name (type1
) == NULL
)
8768 TYPE_NAME (type1
) = ada_type_name (type
);
8770 return static_unwrap_type (type1
);
8774 struct type
*raw_real_type
= ada_get_base_type (type
);
8776 if (raw_real_type
== type
)
8779 return to_static_fixed_type (raw_real_type
);
8783 /* In some cases, incomplete and private types require
8784 cross-references that are not resolved as records (for example,
8786 type FooP is access Foo;
8788 type Foo is array ...;
8789 ). In these cases, since there is no mechanism for producing
8790 cross-references to such types, we instead substitute for FooP a
8791 stub enumeration type that is nowhere resolved, and whose tag is
8792 the name of the actual type. Call these types "non-record stubs". */
8794 /* A type equivalent to TYPE that is not a non-record stub, if one
8795 exists, otherwise TYPE. */
8798 ada_check_typedef (struct type
*type
)
8803 /* If our type is a typedef type of a fat pointer, then we're done.
8804 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8805 what allows us to distinguish between fat pointers that represent
8806 array types, and fat pointers that represent array access types
8807 (in both cases, the compiler implements them as fat pointers). */
8808 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
8809 && is_thick_pntr (ada_typedef_target_type (type
)))
8812 CHECK_TYPEDEF (type
);
8813 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8814 || !TYPE_STUB (type
)
8815 || TYPE_TAG_NAME (type
) == NULL
)
8819 const char *name
= TYPE_TAG_NAME (type
);
8820 struct type
*type1
= ada_find_any_type (name
);
8825 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8826 stubs pointing to arrays, as we don't create symbols for array
8827 types, only for the typedef-to-array types). If that's the case,
8828 strip the typedef layer. */
8829 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
8830 type1
= ada_check_typedef (type1
);
8836 /* A value representing the data at VALADDR/ADDRESS as described by
8837 type TYPE0, but with a standard (static-sized) type that correctly
8838 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8839 type, then return VAL0 [this feature is simply to avoid redundant
8840 creation of struct values]. */
8842 static struct value
*
8843 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8846 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8848 if (type
== type0
&& val0
!= NULL
)
8851 return value_from_contents_and_address (type
, 0, address
);
8854 /* A value representing VAL, but with a standard (static-sized) type
8855 that correctly describes it. Does not necessarily create a new
8859 ada_to_fixed_value (struct value
*val
)
8861 val
= unwrap_value (val
);
8862 val
= ada_to_fixed_value_create (value_type (val
),
8863 value_address (val
),
8871 /* Table mapping attribute numbers to names.
8872 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8874 static const char *attribute_names
[] = {
8892 ada_attribute_name (enum exp_opcode n
)
8894 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8895 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8897 return attribute_names
[0];
8900 /* Evaluate the 'POS attribute applied to ARG. */
8903 pos_atr (struct value
*arg
)
8905 struct value
*val
= coerce_ref (arg
);
8906 struct type
*type
= value_type (val
);
8908 if (!discrete_type_p (type
))
8909 error (_("'POS only defined on discrete types"));
8911 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8914 LONGEST v
= value_as_long (val
);
8916 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8918 if (v
== TYPE_FIELD_ENUMVAL (type
, i
))
8921 error (_("enumeration value is invalid: can't find 'POS"));
8924 return value_as_long (val
);
8927 static struct value
*
8928 value_pos_atr (struct type
*type
, struct value
*arg
)
8930 return value_from_longest (type
, pos_atr (arg
));
8933 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8935 static struct value
*
8936 value_val_atr (struct type
*type
, struct value
*arg
)
8938 if (!discrete_type_p (type
))
8939 error (_("'VAL only defined on discrete types"));
8940 if (!integer_type_p (value_type (arg
)))
8941 error (_("'VAL requires integral argument"));
8943 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8945 long pos
= value_as_long (arg
);
8947 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8948 error (_("argument to 'VAL out of range"));
8949 return value_from_longest (type
, TYPE_FIELD_ENUMVAL (type
, pos
));
8952 return value_from_longest (type
, value_as_long (arg
));
8958 /* True if TYPE appears to be an Ada character type.
8959 [At the moment, this is true only for Character and Wide_Character;
8960 It is a heuristic test that could stand improvement]. */
8963 ada_is_character_type (struct type
*type
)
8967 /* If the type code says it's a character, then assume it really is,
8968 and don't check any further. */
8969 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
8972 /* Otherwise, assume it's a character type iff it is a discrete type
8973 with a known character type name. */
8974 name
= ada_type_name (type
);
8975 return (name
!= NULL
8976 && (TYPE_CODE (type
) == TYPE_CODE_INT
8977 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8978 && (strcmp (name
, "character") == 0
8979 || strcmp (name
, "wide_character") == 0
8980 || strcmp (name
, "wide_wide_character") == 0
8981 || strcmp (name
, "unsigned char") == 0));
8984 /* True if TYPE appears to be an Ada string type. */
8987 ada_is_string_type (struct type
*type
)
8989 type
= ada_check_typedef (type
);
8991 && TYPE_CODE (type
) != TYPE_CODE_PTR
8992 && (ada_is_simple_array_type (type
)
8993 || ada_is_array_descriptor_type (type
))
8994 && ada_array_arity (type
) == 1)
8996 struct type
*elttype
= ada_array_element_type (type
, 1);
8998 return ada_is_character_type (elttype
);
9004 /* The compiler sometimes provides a parallel XVS type for a given
9005 PAD type. Normally, it is safe to follow the PAD type directly,
9006 but older versions of the compiler have a bug that causes the offset
9007 of its "F" field to be wrong. Following that field in that case
9008 would lead to incorrect results, but this can be worked around
9009 by ignoring the PAD type and using the associated XVS type instead.
9011 Set to True if the debugger should trust the contents of PAD types.
9012 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9013 static int trust_pad_over_xvs
= 1;
9015 /* True if TYPE is a struct type introduced by the compiler to force the
9016 alignment of a value. Such types have a single field with a
9017 distinctive name. */
9020 ada_is_aligner_type (struct type
*type
)
9022 type
= ada_check_typedef (type
);
9024 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9027 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
9028 && TYPE_NFIELDS (type
) == 1
9029 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9032 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9033 the parallel type. */
9036 ada_get_base_type (struct type
*raw_type
)
9038 struct type
*real_type_namer
;
9039 struct type
*raw_real_type
;
9041 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
9044 if (ada_is_aligner_type (raw_type
))
9045 /* The encoding specifies that we should always use the aligner type.
9046 So, even if this aligner type has an associated XVS type, we should
9049 According to the compiler gurus, an XVS type parallel to an aligner
9050 type may exist because of a stabs limitation. In stabs, aligner
9051 types are empty because the field has a variable-sized type, and
9052 thus cannot actually be used as an aligner type. As a result,
9053 we need the associated parallel XVS type to decode the type.
9054 Since the policy in the compiler is to not change the internal
9055 representation based on the debugging info format, we sometimes
9056 end up having a redundant XVS type parallel to the aligner type. */
9059 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9060 if (real_type_namer
== NULL
9061 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
9062 || TYPE_NFIELDS (real_type_namer
) != 1)
9065 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
9067 /* This is an older encoding form where the base type needs to be
9068 looked up by name. We prefer the newer enconding because it is
9070 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9071 if (raw_real_type
== NULL
)
9074 return raw_real_type
;
9077 /* The field in our XVS type is a reference to the base type. */
9078 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
9081 /* The type of value designated by TYPE, with all aligners removed. */
9084 ada_aligned_type (struct type
*type
)
9086 if (ada_is_aligner_type (type
))
9087 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
9089 return ada_get_base_type (type
);
9093 /* The address of the aligned value in an object at address VALADDR
9094 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9097 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9099 if (ada_is_aligner_type (type
))
9100 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
9102 TYPE_FIELD_BITPOS (type
,
9103 0) / TARGET_CHAR_BIT
);
9110 /* The printed representation of an enumeration literal with encoded
9111 name NAME. The value is good to the next call of ada_enum_name. */
9113 ada_enum_name (const char *name
)
9115 static char *result
;
9116 static size_t result_len
= 0;
9119 /* First, unqualify the enumeration name:
9120 1. Search for the last '.' character. If we find one, then skip
9121 all the preceding characters, the unqualified name starts
9122 right after that dot.
9123 2. Otherwise, we may be debugging on a target where the compiler
9124 translates dots into "__". Search forward for double underscores,
9125 but stop searching when we hit an overloading suffix, which is
9126 of the form "__" followed by digits. */
9128 tmp
= strrchr (name
, '.');
9133 while ((tmp
= strstr (name
, "__")) != NULL
)
9135 if (isdigit (tmp
[2]))
9146 if (name
[1] == 'U' || name
[1] == 'W')
9148 if (sscanf (name
+ 2, "%x", &v
) != 1)
9154 GROW_VECT (result
, result_len
, 16);
9155 if (isascii (v
) && isprint (v
))
9156 xsnprintf (result
, result_len
, "'%c'", v
);
9157 else if (name
[1] == 'U')
9158 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9160 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9166 tmp
= strstr (name
, "__");
9168 tmp
= strstr (name
, "$");
9171 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9172 strncpy (result
, name
, tmp
- name
);
9173 result
[tmp
- name
] = '\0';
9181 /* Evaluate the subexpression of EXP starting at *POS as for
9182 evaluate_type, updating *POS to point just past the evaluated
9185 static struct value
*
9186 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9188 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9191 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9194 static struct value
*
9195 unwrap_value (struct value
*val
)
9197 struct type
*type
= ada_check_typedef (value_type (val
));
9199 if (ada_is_aligner_type (type
))
9201 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9202 struct type
*val_type
= ada_check_typedef (value_type (v
));
9204 if (ada_type_name (val_type
) == NULL
)
9205 TYPE_NAME (val_type
) = ada_type_name (type
);
9207 return unwrap_value (v
);
9211 struct type
*raw_real_type
=
9212 ada_check_typedef (ada_get_base_type (type
));
9214 /* If there is no parallel XVS or XVE type, then the value is
9215 already unwrapped. Return it without further modification. */
9216 if ((type
== raw_real_type
)
9217 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9221 coerce_unspec_val_to_type
9222 (val
, ada_to_fixed_type (raw_real_type
, 0,
9223 value_address (val
),
9228 static struct value
*
9229 cast_to_fixed (struct type
*type
, struct value
*arg
)
9233 if (type
== value_type (arg
))
9235 else if (ada_is_fixed_point_type (value_type (arg
)))
9236 val
= ada_float_to_fixed (type
,
9237 ada_fixed_to_float (value_type (arg
),
9238 value_as_long (arg
)));
9241 DOUBLEST argd
= value_as_double (arg
);
9243 val
= ada_float_to_fixed (type
, argd
);
9246 return value_from_longest (type
, val
);
9249 static struct value
*
9250 cast_from_fixed (struct type
*type
, struct value
*arg
)
9252 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
9253 value_as_long (arg
));
9255 return value_from_double (type
, val
);
9258 /* Given two array types T1 and T2, return nonzero iff both arrays
9259 contain the same number of elements. */
9262 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9264 LONGEST lo1
, hi1
, lo2
, hi2
;
9266 /* Get the array bounds in order to verify that the size of
9267 the two arrays match. */
9268 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9269 || !get_array_bounds (t2
, &lo2
, &hi2
))
9270 error (_("unable to determine array bounds"));
9272 /* To make things easier for size comparison, normalize a bit
9273 the case of empty arrays by making sure that the difference
9274 between upper bound and lower bound is always -1. */
9280 return (hi1
- lo1
== hi2
- lo2
);
9283 /* Assuming that VAL is an array of integrals, and TYPE represents
9284 an array with the same number of elements, but with wider integral
9285 elements, return an array "casted" to TYPE. In practice, this
9286 means that the returned array is built by casting each element
9287 of the original array into TYPE's (wider) element type. */
9289 static struct value
*
9290 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9292 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9297 /* Verify that both val and type are arrays of scalars, and
9298 that the size of val's elements is smaller than the size
9299 of type's element. */
9300 gdb_assert (TYPE_CODE (type
) == TYPE_CODE_ARRAY
);
9301 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9302 gdb_assert (TYPE_CODE (value_type (val
)) == TYPE_CODE_ARRAY
);
9303 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9304 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9305 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9307 if (!get_array_bounds (type
, &lo
, &hi
))
9308 error (_("unable to determine array bounds"));
9310 res
= allocate_value (type
);
9312 /* Promote each array element. */
9313 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9315 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9317 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9318 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9324 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9325 return the converted value. */
9327 static struct value
*
9328 coerce_for_assign (struct type
*type
, struct value
*val
)
9330 struct type
*type2
= value_type (val
);
9335 type2
= ada_check_typedef (type2
);
9336 type
= ada_check_typedef (type
);
9338 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
9339 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9341 val
= ada_value_ind (val
);
9342 type2
= value_type (val
);
9345 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
9346 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9348 if (!ada_same_array_size_p (type
, type2
))
9349 error (_("cannot assign arrays of different length"));
9351 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9352 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9353 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9354 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9356 /* Allow implicit promotion of the array elements to
9358 return ada_promote_array_of_integrals (type
, val
);
9361 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9362 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9363 error (_("Incompatible types in assignment"));
9364 deprecated_set_value_type (val
, type
);
9369 static struct value
*
9370 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9373 struct type
*type1
, *type2
;
9376 arg1
= coerce_ref (arg1
);
9377 arg2
= coerce_ref (arg2
);
9378 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9379 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9381 if (TYPE_CODE (type1
) != TYPE_CODE_INT
9382 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
9383 return value_binop (arg1
, arg2
, op
);
9392 return value_binop (arg1
, arg2
, op
);
9395 v2
= value_as_long (arg2
);
9397 error (_("second operand of %s must not be zero."), op_string (op
));
9399 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9400 return value_binop (arg1
, arg2
, op
);
9402 v1
= value_as_long (arg1
);
9407 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9408 v
+= v
> 0 ? -1 : 1;
9416 /* Should not reach this point. */
9420 val
= allocate_value (type1
);
9421 store_unsigned_integer (value_contents_raw (val
),
9422 TYPE_LENGTH (value_type (val
)),
9423 gdbarch_byte_order (get_type_arch (type1
)), v
);
9428 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9430 if (ada_is_direct_array_type (value_type (arg1
))
9431 || ada_is_direct_array_type (value_type (arg2
)))
9433 /* Automatically dereference any array reference before
9434 we attempt to perform the comparison. */
9435 arg1
= ada_coerce_ref (arg1
);
9436 arg2
= ada_coerce_ref (arg2
);
9438 arg1
= ada_coerce_to_simple_array (arg1
);
9439 arg2
= ada_coerce_to_simple_array (arg2
);
9440 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
9441 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
9442 error (_("Attempt to compare array with non-array"));
9443 /* FIXME: The following works only for types whose
9444 representations use all bits (no padding or undefined bits)
9445 and do not have user-defined equality. */
9447 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
9448 && memcmp (value_contents (arg1
), value_contents (arg2
),
9449 TYPE_LENGTH (value_type (arg1
))) == 0;
9451 return value_equal (arg1
, arg2
);
9454 /* Total number of component associations in the aggregate starting at
9455 index PC in EXP. Assumes that index PC is the start of an
9459 num_component_specs (struct expression
*exp
, int pc
)
9463 m
= exp
->elts
[pc
+ 1].longconst
;
9466 for (i
= 0; i
< m
; i
+= 1)
9468 switch (exp
->elts
[pc
].opcode
)
9474 n
+= exp
->elts
[pc
+ 1].longconst
;
9477 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9482 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9483 component of LHS (a simple array or a record), updating *POS past
9484 the expression, assuming that LHS is contained in CONTAINER. Does
9485 not modify the inferior's memory, nor does it modify LHS (unless
9486 LHS == CONTAINER). */
9489 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9490 struct expression
*exp
, int *pos
)
9492 struct value
*mark
= value_mark ();
9495 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
9497 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9498 struct value
*index_val
= value_from_longest (index_type
, index
);
9500 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9504 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9505 elt
= ada_to_fixed_value (elt
);
9508 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9509 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9511 value_assign_to_component (container
, elt
,
9512 ada_evaluate_subexp (NULL
, exp
, pos
,
9515 value_free_to_mark (mark
);
9518 /* Assuming that LHS represents an lvalue having a record or array
9519 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9520 of that aggregate's value to LHS, advancing *POS past the
9521 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9522 lvalue containing LHS (possibly LHS itself). Does not modify
9523 the inferior's memory, nor does it modify the contents of
9524 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9526 static struct value
*
9527 assign_aggregate (struct value
*container
,
9528 struct value
*lhs
, struct expression
*exp
,
9529 int *pos
, enum noside noside
)
9531 struct type
*lhs_type
;
9532 int n
= exp
->elts
[*pos
+1].longconst
;
9533 LONGEST low_index
, high_index
;
9536 int max_indices
, num_indices
;
9540 if (noside
!= EVAL_NORMAL
)
9542 for (i
= 0; i
< n
; i
+= 1)
9543 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9547 container
= ada_coerce_ref (container
);
9548 if (ada_is_direct_array_type (value_type (container
)))
9549 container
= ada_coerce_to_simple_array (container
);
9550 lhs
= ada_coerce_ref (lhs
);
9551 if (!deprecated_value_modifiable (lhs
))
9552 error (_("Left operand of assignment is not a modifiable lvalue."));
9554 lhs_type
= value_type (lhs
);
9555 if (ada_is_direct_array_type (lhs_type
))
9557 lhs
= ada_coerce_to_simple_array (lhs
);
9558 lhs_type
= value_type (lhs
);
9559 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9560 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9562 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
9565 high_index
= num_visible_fields (lhs_type
) - 1;
9568 error (_("Left-hand side must be array or record."));
9570 num_specs
= num_component_specs (exp
, *pos
- 3);
9571 max_indices
= 4 * num_specs
+ 4;
9572 indices
= alloca (max_indices
* sizeof (indices
[0]));
9573 indices
[0] = indices
[1] = low_index
- 1;
9574 indices
[2] = indices
[3] = high_index
+ 1;
9577 for (i
= 0; i
< n
; i
+= 1)
9579 switch (exp
->elts
[*pos
].opcode
)
9582 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9583 &num_indices
, max_indices
,
9584 low_index
, high_index
);
9587 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9588 &num_indices
, max_indices
,
9589 low_index
, high_index
);
9593 error (_("Misplaced 'others' clause"));
9594 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9595 num_indices
, low_index
, high_index
);
9598 error (_("Internal error: bad aggregate clause"));
9605 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9606 construct at *POS, updating *POS past the construct, given that
9607 the positions are relative to lower bound LOW, where HIGH is the
9608 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9609 updating *NUM_INDICES as needed. CONTAINER is as for
9610 assign_aggregate. */
9612 aggregate_assign_positional (struct value
*container
,
9613 struct value
*lhs
, struct expression
*exp
,
9614 int *pos
, LONGEST
*indices
, int *num_indices
,
9615 int max_indices
, LONGEST low
, LONGEST high
)
9617 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9619 if (ind
- 1 == high
)
9620 warning (_("Extra components in aggregate ignored."));
9623 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9625 assign_component (container
, lhs
, ind
, exp
, pos
);
9628 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9631 /* Assign into the components of LHS indexed by the OP_CHOICES
9632 construct at *POS, updating *POS past the construct, given that
9633 the allowable indices are LOW..HIGH. Record the indices assigned
9634 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9635 needed. CONTAINER is as for assign_aggregate. */
9637 aggregate_assign_from_choices (struct value
*container
,
9638 struct value
*lhs
, struct expression
*exp
,
9639 int *pos
, LONGEST
*indices
, int *num_indices
,
9640 int max_indices
, LONGEST low
, LONGEST high
)
9643 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9644 int choice_pos
, expr_pc
;
9645 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9647 choice_pos
= *pos
+= 3;
9649 for (j
= 0; j
< n_choices
; j
+= 1)
9650 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9652 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9654 for (j
= 0; j
< n_choices
; j
+= 1)
9656 LONGEST lower
, upper
;
9657 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9659 if (op
== OP_DISCRETE_RANGE
)
9662 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9664 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9669 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9681 name
= &exp
->elts
[choice_pos
+ 2].string
;
9684 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
9687 error (_("Invalid record component association."));
9689 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9691 if (! find_struct_field (name
, value_type (lhs
), 0,
9692 NULL
, NULL
, NULL
, NULL
, &ind
))
9693 error (_("Unknown component name: %s."), name
);
9694 lower
= upper
= ind
;
9697 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9698 error (_("Index in component association out of bounds."));
9700 add_component_interval (lower
, upper
, indices
, num_indices
,
9702 while (lower
<= upper
)
9707 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9713 /* Assign the value of the expression in the OP_OTHERS construct in
9714 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9715 have not been previously assigned. The index intervals already assigned
9716 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9717 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9719 aggregate_assign_others (struct value
*container
,
9720 struct value
*lhs
, struct expression
*exp
,
9721 int *pos
, LONGEST
*indices
, int num_indices
,
9722 LONGEST low
, LONGEST high
)
9725 int expr_pc
= *pos
+ 1;
9727 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9731 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9736 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9739 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9742 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9743 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9744 modifying *SIZE as needed. It is an error if *SIZE exceeds
9745 MAX_SIZE. The resulting intervals do not overlap. */
9747 add_component_interval (LONGEST low
, LONGEST high
,
9748 LONGEST
* indices
, int *size
, int max_size
)
9752 for (i
= 0; i
< *size
; i
+= 2) {
9753 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9757 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9758 if (high
< indices
[kh
])
9760 if (low
< indices
[i
])
9762 indices
[i
+ 1] = indices
[kh
- 1];
9763 if (high
> indices
[i
+ 1])
9764 indices
[i
+ 1] = high
;
9765 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9766 *size
-= kh
- i
- 2;
9769 else if (high
< indices
[i
])
9773 if (*size
== max_size
)
9774 error (_("Internal error: miscounted aggregate components."));
9776 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9777 indices
[j
] = indices
[j
- 2];
9779 indices
[i
+ 1] = high
;
9782 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9785 static struct value
*
9786 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
9788 if (type
== ada_check_typedef (value_type (arg2
)))
9791 if (ada_is_fixed_point_type (type
))
9792 return (cast_to_fixed (type
, arg2
));
9794 if (ada_is_fixed_point_type (value_type (arg2
)))
9795 return cast_from_fixed (type
, arg2
);
9797 return value_cast (type
, arg2
);
9800 /* Evaluating Ada expressions, and printing their result.
9801 ------------------------------------------------------
9806 We usually evaluate an Ada expression in order to print its value.
9807 We also evaluate an expression in order to print its type, which
9808 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9809 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9810 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9811 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9814 Evaluating expressions is a little more complicated for Ada entities
9815 than it is for entities in languages such as C. The main reason for
9816 this is that Ada provides types whose definition might be dynamic.
9817 One example of such types is variant records. Or another example
9818 would be an array whose bounds can only be known at run time.
9820 The following description is a general guide as to what should be
9821 done (and what should NOT be done) in order to evaluate an expression
9822 involving such types, and when. This does not cover how the semantic
9823 information is encoded by GNAT as this is covered separatly. For the
9824 document used as the reference for the GNAT encoding, see exp_dbug.ads
9825 in the GNAT sources.
9827 Ideally, we should embed each part of this description next to its
9828 associated code. Unfortunately, the amount of code is so vast right
9829 now that it's hard to see whether the code handling a particular
9830 situation might be duplicated or not. One day, when the code is
9831 cleaned up, this guide might become redundant with the comments
9832 inserted in the code, and we might want to remove it.
9834 2. ``Fixing'' an Entity, the Simple Case:
9835 -----------------------------------------
9837 When evaluating Ada expressions, the tricky issue is that they may
9838 reference entities whose type contents and size are not statically
9839 known. Consider for instance a variant record:
9841 type Rec (Empty : Boolean := True) is record
9844 when False => Value : Integer;
9847 Yes : Rec := (Empty => False, Value => 1);
9848 No : Rec := (empty => True);
9850 The size and contents of that record depends on the value of the
9851 descriminant (Rec.Empty). At this point, neither the debugging
9852 information nor the associated type structure in GDB are able to
9853 express such dynamic types. So what the debugger does is to create
9854 "fixed" versions of the type that applies to the specific object.
9855 We also informally refer to this opperation as "fixing" an object,
9856 which means creating its associated fixed type.
9858 Example: when printing the value of variable "Yes" above, its fixed
9859 type would look like this:
9866 On the other hand, if we printed the value of "No", its fixed type
9873 Things become a little more complicated when trying to fix an entity
9874 with a dynamic type that directly contains another dynamic type,
9875 such as an array of variant records, for instance. There are
9876 two possible cases: Arrays, and records.
9878 3. ``Fixing'' Arrays:
9879 ---------------------
9881 The type structure in GDB describes an array in terms of its bounds,
9882 and the type of its elements. By design, all elements in the array
9883 have the same type and we cannot represent an array of variant elements
9884 using the current type structure in GDB. When fixing an array,
9885 we cannot fix the array element, as we would potentially need one
9886 fixed type per element of the array. As a result, the best we can do
9887 when fixing an array is to produce an array whose bounds and size
9888 are correct (allowing us to read it from memory), but without having
9889 touched its element type. Fixing each element will be done later,
9890 when (if) necessary.
9892 Arrays are a little simpler to handle than records, because the same
9893 amount of memory is allocated for each element of the array, even if
9894 the amount of space actually used by each element differs from element
9895 to element. Consider for instance the following array of type Rec:
9897 type Rec_Array is array (1 .. 2) of Rec;
9899 The actual amount of memory occupied by each element might be different
9900 from element to element, depending on the value of their discriminant.
9901 But the amount of space reserved for each element in the array remains
9902 fixed regardless. So we simply need to compute that size using
9903 the debugging information available, from which we can then determine
9904 the array size (we multiply the number of elements of the array by
9905 the size of each element).
9907 The simplest case is when we have an array of a constrained element
9908 type. For instance, consider the following type declarations:
9910 type Bounded_String (Max_Size : Integer) is
9912 Buffer : String (1 .. Max_Size);
9914 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9916 In this case, the compiler describes the array as an array of
9917 variable-size elements (identified by its XVS suffix) for which
9918 the size can be read in the parallel XVZ variable.
9920 In the case of an array of an unconstrained element type, the compiler
9921 wraps the array element inside a private PAD type. This type should not
9922 be shown to the user, and must be "unwrap"'ed before printing. Note
9923 that we also use the adjective "aligner" in our code to designate
9924 these wrapper types.
9926 In some cases, the size allocated for each element is statically
9927 known. In that case, the PAD type already has the correct size,
9928 and the array element should remain unfixed.
9930 But there are cases when this size is not statically known.
9931 For instance, assuming that "Five" is an integer variable:
9933 type Dynamic is array (1 .. Five) of Integer;
9934 type Wrapper (Has_Length : Boolean := False) is record
9937 when True => Length : Integer;
9941 type Wrapper_Array is array (1 .. 2) of Wrapper;
9943 Hello : Wrapper_Array := (others => (Has_Length => True,
9944 Data => (others => 17),
9948 The debugging info would describe variable Hello as being an
9949 array of a PAD type. The size of that PAD type is not statically
9950 known, but can be determined using a parallel XVZ variable.
9951 In that case, a copy of the PAD type with the correct size should
9952 be used for the fixed array.
9954 3. ``Fixing'' record type objects:
9955 ----------------------------------
9957 Things are slightly different from arrays in the case of dynamic
9958 record types. In this case, in order to compute the associated
9959 fixed type, we need to determine the size and offset of each of
9960 its components. This, in turn, requires us to compute the fixed
9961 type of each of these components.
9963 Consider for instance the example:
9965 type Bounded_String (Max_Size : Natural) is record
9966 Str : String (1 .. Max_Size);
9969 My_String : Bounded_String (Max_Size => 10);
9971 In that case, the position of field "Length" depends on the size
9972 of field Str, which itself depends on the value of the Max_Size
9973 discriminant. In order to fix the type of variable My_String,
9974 we need to fix the type of field Str. Therefore, fixing a variant
9975 record requires us to fix each of its components.
9977 However, if a component does not have a dynamic size, the component
9978 should not be fixed. In particular, fields that use a PAD type
9979 should not fixed. Here is an example where this might happen
9980 (assuming type Rec above):
9982 type Container (Big : Boolean) is record
9986 when True => Another : Integer;
9990 My_Container : Container := (Big => False,
9991 First => (Empty => True),
9994 In that example, the compiler creates a PAD type for component First,
9995 whose size is constant, and then positions the component After just
9996 right after it. The offset of component After is therefore constant
9999 The debugger computes the position of each field based on an algorithm
10000 that uses, among other things, the actual position and size of the field
10001 preceding it. Let's now imagine that the user is trying to print
10002 the value of My_Container. If the type fixing was recursive, we would
10003 end up computing the offset of field After based on the size of the
10004 fixed version of field First. And since in our example First has
10005 only one actual field, the size of the fixed type is actually smaller
10006 than the amount of space allocated to that field, and thus we would
10007 compute the wrong offset of field After.
10009 To make things more complicated, we need to watch out for dynamic
10010 components of variant records (identified by the ___XVL suffix in
10011 the component name). Even if the target type is a PAD type, the size
10012 of that type might not be statically known. So the PAD type needs
10013 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10014 we might end up with the wrong size for our component. This can be
10015 observed with the following type declarations:
10017 type Octal is new Integer range 0 .. 7;
10018 type Octal_Array is array (Positive range <>) of Octal;
10019 pragma Pack (Octal_Array);
10021 type Octal_Buffer (Size : Positive) is record
10022 Buffer : Octal_Array (1 .. Size);
10026 In that case, Buffer is a PAD type whose size is unset and needs
10027 to be computed by fixing the unwrapped type.
10029 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10030 ----------------------------------------------------------
10032 Lastly, when should the sub-elements of an entity that remained unfixed
10033 thus far, be actually fixed?
10035 The answer is: Only when referencing that element. For instance
10036 when selecting one component of a record, this specific component
10037 should be fixed at that point in time. Or when printing the value
10038 of a record, each component should be fixed before its value gets
10039 printed. Similarly for arrays, the element of the array should be
10040 fixed when printing each element of the array, or when extracting
10041 one element out of that array. On the other hand, fixing should
10042 not be performed on the elements when taking a slice of an array!
10044 Note that one of the side-effects of miscomputing the offset and
10045 size of each field is that we end up also miscomputing the size
10046 of the containing type. This can have adverse results when computing
10047 the value of an entity. GDB fetches the value of an entity based
10048 on the size of its type, and thus a wrong size causes GDB to fetch
10049 the wrong amount of memory. In the case where the computed size is
10050 too small, GDB fetches too little data to print the value of our
10051 entiry. Results in this case as unpredicatble, as we usually read
10052 past the buffer containing the data =:-o. */
10054 /* Implement the evaluate_exp routine in the exp_descriptor structure
10055 for the Ada language. */
10057 static struct value
*
10058 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10059 int *pos
, enum noside noside
)
10061 enum exp_opcode op
;
10065 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10068 struct value
**argvec
;
10072 op
= exp
->elts
[pc
].opcode
;
10078 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10080 if (noside
== EVAL_NORMAL
)
10081 arg1
= unwrap_value (arg1
);
10083 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10084 then we need to perform the conversion manually, because
10085 evaluate_subexp_standard doesn't do it. This conversion is
10086 necessary in Ada because the different kinds of float/fixed
10087 types in Ada have different representations.
10089 Similarly, we need to perform the conversion from OP_LONG
10091 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
10092 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
10098 struct value
*result
;
10101 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10102 /* The result type will have code OP_STRING, bashed there from
10103 OP_ARRAY. Bash it back. */
10104 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
10105 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
10111 type
= exp
->elts
[pc
+ 1].type
;
10112 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
10113 if (noside
== EVAL_SKIP
)
10115 arg1
= ada_value_cast (type
, arg1
, noside
);
10120 type
= exp
->elts
[pc
+ 1].type
;
10121 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10124 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10125 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10127 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10128 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10130 return ada_value_assign (arg1
, arg1
);
10132 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10133 except if the lhs of our assignment is a convenience variable.
10134 In the case of assigning to a convenience variable, the lhs
10135 should be exactly the result of the evaluation of the rhs. */
10136 type
= value_type (arg1
);
10137 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10139 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10140 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10142 if (ada_is_fixed_point_type (value_type (arg1
)))
10143 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10144 else if (ada_is_fixed_point_type (value_type (arg2
)))
10146 (_("Fixed-point values must be assigned to fixed-point variables"));
10148 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10149 return ada_value_assign (arg1
, arg2
);
10152 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10153 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10154 if (noside
== EVAL_SKIP
)
10156 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10157 return (value_from_longest
10158 (value_type (arg1
),
10159 value_as_long (arg1
) + value_as_long (arg2
)));
10160 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10161 return (value_from_longest
10162 (value_type (arg2
),
10163 value_as_long (arg1
) + value_as_long (arg2
)));
10164 if ((ada_is_fixed_point_type (value_type (arg1
))
10165 || ada_is_fixed_point_type (value_type (arg2
)))
10166 && value_type (arg1
) != value_type (arg2
))
10167 error (_("Operands of fixed-point addition must have the same type"));
10168 /* Do the addition, and cast the result to the type of the first
10169 argument. We cannot cast the result to a reference type, so if
10170 ARG1 is a reference type, find its underlying type. */
10171 type
= value_type (arg1
);
10172 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10173 type
= TYPE_TARGET_TYPE (type
);
10174 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10175 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10178 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10179 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10180 if (noside
== EVAL_SKIP
)
10182 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10183 return (value_from_longest
10184 (value_type (arg1
),
10185 value_as_long (arg1
) - value_as_long (arg2
)));
10186 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10187 return (value_from_longest
10188 (value_type (arg2
),
10189 value_as_long (arg1
) - value_as_long (arg2
)));
10190 if ((ada_is_fixed_point_type (value_type (arg1
))
10191 || ada_is_fixed_point_type (value_type (arg2
)))
10192 && value_type (arg1
) != value_type (arg2
))
10193 error (_("Operands of fixed-point subtraction "
10194 "must have the same type"));
10195 /* Do the substraction, and cast the result to the type of the first
10196 argument. We cannot cast the result to a reference type, so if
10197 ARG1 is a reference type, find its underlying type. */
10198 type
= value_type (arg1
);
10199 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10200 type
= TYPE_TARGET_TYPE (type
);
10201 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10202 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10208 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10209 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10210 if (noside
== EVAL_SKIP
)
10212 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10214 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10215 return value_zero (value_type (arg1
), not_lval
);
10219 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10220 if (ada_is_fixed_point_type (value_type (arg1
)))
10221 arg1
= cast_from_fixed (type
, arg1
);
10222 if (ada_is_fixed_point_type (value_type (arg2
)))
10223 arg2
= cast_from_fixed (type
, arg2
);
10224 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10225 return ada_value_binop (arg1
, arg2
, op
);
10229 case BINOP_NOTEQUAL
:
10230 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10231 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10232 if (noside
== EVAL_SKIP
)
10234 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10238 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10239 tem
= ada_value_equal (arg1
, arg2
);
10241 if (op
== BINOP_NOTEQUAL
)
10243 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10244 return value_from_longest (type
, (LONGEST
) tem
);
10247 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10248 if (noside
== EVAL_SKIP
)
10250 else if (ada_is_fixed_point_type (value_type (arg1
)))
10251 return value_cast (value_type (arg1
), value_neg (arg1
));
10254 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10255 return value_neg (arg1
);
10258 case BINOP_LOGICAL_AND
:
10259 case BINOP_LOGICAL_OR
:
10260 case UNOP_LOGICAL_NOT
:
10265 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10266 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10267 return value_cast (type
, val
);
10270 case BINOP_BITWISE_AND
:
10271 case BINOP_BITWISE_IOR
:
10272 case BINOP_BITWISE_XOR
:
10276 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10278 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10280 return value_cast (value_type (arg1
), val
);
10286 if (noside
== EVAL_SKIP
)
10292 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10293 /* Only encountered when an unresolved symbol occurs in a
10294 context other than a function call, in which case, it is
10296 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10297 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
10299 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10301 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10302 /* Check to see if this is a tagged type. We also need to handle
10303 the case where the type is a reference to a tagged type, but
10304 we have to be careful to exclude pointers to tagged types.
10305 The latter should be shown as usual (as a pointer), whereas
10306 a reference should mostly be transparent to the user. */
10307 if (ada_is_tagged_type (type
, 0)
10308 || (TYPE_CODE (type
) == TYPE_CODE_REF
10309 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10311 /* Tagged types are a little special in the fact that the real
10312 type is dynamic and can only be determined by inspecting the
10313 object's tag. This means that we need to get the object's
10314 value first (EVAL_NORMAL) and then extract the actual object
10317 Note that we cannot skip the final step where we extract
10318 the object type from its tag, because the EVAL_NORMAL phase
10319 results in dynamic components being resolved into fixed ones.
10320 This can cause problems when trying to print the type
10321 description of tagged types whose parent has a dynamic size:
10322 We use the type name of the "_parent" component in order
10323 to print the name of the ancestor type in the type description.
10324 If that component had a dynamic size, the resolution into
10325 a fixed type would result in the loss of that type name,
10326 thus preventing us from printing the name of the ancestor
10327 type in the type description. */
10328 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10330 if (TYPE_CODE (type
) != TYPE_CODE_REF
)
10332 struct type
*actual_type
;
10334 actual_type
= type_from_tag (ada_value_tag (arg1
));
10335 if (actual_type
== NULL
)
10336 /* If, for some reason, we were unable to determine
10337 the actual type from the tag, then use the static
10338 approximation that we just computed as a fallback.
10339 This can happen if the debugging information is
10340 incomplete, for instance. */
10341 actual_type
= type
;
10342 return value_zero (actual_type
, not_lval
);
10346 /* In the case of a ref, ada_coerce_ref takes care
10347 of determining the actual type. But the evaluation
10348 should return a ref as it should be valid to ask
10349 for its address; so rebuild a ref after coerce. */
10350 arg1
= ada_coerce_ref (arg1
);
10351 return value_ref (arg1
);
10355 /* Records and unions for which GNAT encodings have been
10356 generated need to be statically fixed as well.
10357 Otherwise, non-static fixing produces a type where
10358 all dynamic properties are removed, which prevents "ptype"
10359 from being able to completely describe the type.
10360 For instance, a case statement in a variant record would be
10361 replaced by the relevant components based on the actual
10362 value of the discriminants. */
10363 if ((TYPE_CODE (type
) == TYPE_CODE_STRUCT
10364 && dynamic_template_type (type
) != NULL
)
10365 || (TYPE_CODE (type
) == TYPE_CODE_UNION
10366 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10369 return value_zero (to_static_fixed_type (type
), not_lval
);
10373 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10374 return ada_to_fixed_value (arg1
);
10379 /* Allocate arg vector, including space for the function to be
10380 called in argvec[0] and a terminating NULL. */
10381 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10383 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
10385 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10386 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10387 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10388 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
10391 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10392 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10395 if (noside
== EVAL_SKIP
)
10399 if (ada_is_constrained_packed_array_type
10400 (desc_base_type (value_type (argvec
[0]))))
10401 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10402 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10403 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10404 /* This is a packed array that has already been fixed, and
10405 therefore already coerced to a simple array. Nothing further
10408 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
10409 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10410 && VALUE_LVAL (argvec
[0]) == lval_memory
))
10411 argvec
[0] = value_addr (argvec
[0]);
10413 type
= ada_check_typedef (value_type (argvec
[0]));
10415 /* Ada allows us to implicitly dereference arrays when subscripting
10416 them. So, if this is an array typedef (encoding use for array
10417 access types encoded as fat pointers), strip it now. */
10418 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
10419 type
= ada_typedef_target_type (type
);
10421 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
10423 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
10425 case TYPE_CODE_FUNC
:
10426 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10428 case TYPE_CODE_ARRAY
:
10430 case TYPE_CODE_STRUCT
:
10431 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10432 argvec
[0] = ada_value_ind (argvec
[0]);
10433 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10436 error (_("cannot subscript or call something of type `%s'"),
10437 ada_type_name (value_type (argvec
[0])));
10442 switch (TYPE_CODE (type
))
10444 case TYPE_CODE_FUNC
:
10445 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10447 struct type
*rtype
= TYPE_TARGET_TYPE (type
);
10449 if (TYPE_GNU_IFUNC (type
))
10450 return allocate_value (TYPE_TARGET_TYPE (rtype
));
10451 return allocate_value (rtype
);
10453 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
10454 case TYPE_CODE_INTERNAL_FUNCTION
:
10455 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10456 /* We don't know anything about what the internal
10457 function might return, but we have to return
10459 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10462 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10463 argvec
[0], nargs
, argvec
+ 1);
10465 case TYPE_CODE_STRUCT
:
10469 arity
= ada_array_arity (type
);
10470 type
= ada_array_element_type (type
, nargs
);
10472 error (_("cannot subscript or call a record"));
10473 if (arity
!= nargs
)
10474 error (_("wrong number of subscripts; expecting %d"), arity
);
10475 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10476 return value_zero (ada_aligned_type (type
), lval_memory
);
10478 unwrap_value (ada_value_subscript
10479 (argvec
[0], nargs
, argvec
+ 1));
10481 case TYPE_CODE_ARRAY
:
10482 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10484 type
= ada_array_element_type (type
, nargs
);
10486 error (_("element type of array unknown"));
10488 return value_zero (ada_aligned_type (type
), lval_memory
);
10491 unwrap_value (ada_value_subscript
10492 (ada_coerce_to_simple_array (argvec
[0]),
10493 nargs
, argvec
+ 1));
10494 case TYPE_CODE_PTR
: /* Pointer to array */
10495 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10497 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10498 type
= ada_array_element_type (type
, nargs
);
10500 error (_("element type of array unknown"));
10502 return value_zero (ada_aligned_type (type
), lval_memory
);
10505 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10506 nargs
, argvec
+ 1));
10509 error (_("Attempt to index or call something other than an "
10510 "array or function"));
10515 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10516 struct value
*low_bound_val
=
10517 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10518 struct value
*high_bound_val
=
10519 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10521 LONGEST high_bound
;
10523 low_bound_val
= coerce_ref (low_bound_val
);
10524 high_bound_val
= coerce_ref (high_bound_val
);
10525 low_bound
= pos_atr (low_bound_val
);
10526 high_bound
= pos_atr (high_bound_val
);
10528 if (noside
== EVAL_SKIP
)
10531 /* If this is a reference to an aligner type, then remove all
10533 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10534 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10535 TYPE_TARGET_TYPE (value_type (array
)) =
10536 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10538 if (ada_is_constrained_packed_array_type (value_type (array
)))
10539 error (_("cannot slice a packed array"));
10541 /* If this is a reference to an array or an array lvalue,
10542 convert to a pointer. */
10543 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10544 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
10545 && VALUE_LVAL (array
) == lval_memory
))
10546 array
= value_addr (array
);
10548 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10549 && ada_is_array_descriptor_type (ada_check_typedef
10550 (value_type (array
))))
10551 return empty_array (ada_type_of_array (array
, 0), low_bound
);
10553 array
= ada_coerce_to_simple_array_ptr (array
);
10555 /* If we have more than one level of pointer indirection,
10556 dereference the value until we get only one level. */
10557 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
10558 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
10560 array
= value_ind (array
);
10562 /* Make sure we really do have an array type before going further,
10563 to avoid a SEGV when trying to get the index type or the target
10564 type later down the road if the debug info generated by
10565 the compiler is incorrect or incomplete. */
10566 if (!ada_is_simple_array_type (value_type (array
)))
10567 error (_("cannot take slice of non-array"));
10569 if (TYPE_CODE (ada_check_typedef (value_type (array
)))
10572 struct type
*type0
= ada_check_typedef (value_type (array
));
10574 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10575 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
);
10578 struct type
*arr_type0
=
10579 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10581 return ada_value_slice_from_ptr (array
, arr_type0
,
10582 longest_to_int (low_bound
),
10583 longest_to_int (high_bound
));
10586 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10588 else if (high_bound
< low_bound
)
10589 return empty_array (value_type (array
), low_bound
);
10591 return ada_value_slice (array
, longest_to_int (low_bound
),
10592 longest_to_int (high_bound
));
10595 case UNOP_IN_RANGE
:
10597 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10598 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10600 if (noside
== EVAL_SKIP
)
10603 switch (TYPE_CODE (type
))
10606 lim_warning (_("Membership test incompletely implemented; "
10607 "always returns true"));
10608 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10609 return value_from_longest (type
, (LONGEST
) 1);
10611 case TYPE_CODE_RANGE
:
10612 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10613 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10614 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10615 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10616 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10618 value_from_longest (type
,
10619 (value_less (arg1
, arg3
)
10620 || value_equal (arg1
, arg3
))
10621 && (value_less (arg2
, arg1
)
10622 || value_equal (arg2
, arg1
)));
10625 case BINOP_IN_BOUNDS
:
10627 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10628 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10630 if (noside
== EVAL_SKIP
)
10633 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10635 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10636 return value_zero (type
, not_lval
);
10639 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10641 type
= ada_index_type (value_type (arg2
), tem
, "range");
10643 type
= value_type (arg1
);
10645 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10646 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10648 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10649 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10650 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10652 value_from_longest (type
,
10653 (value_less (arg1
, arg3
)
10654 || value_equal (arg1
, arg3
))
10655 && (value_less (arg2
, arg1
)
10656 || value_equal (arg2
, arg1
)));
10658 case TERNOP_IN_RANGE
:
10659 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10660 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10661 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10663 if (noside
== EVAL_SKIP
)
10666 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10667 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10668 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10670 value_from_longest (type
,
10671 (value_less (arg1
, arg3
)
10672 || value_equal (arg1
, arg3
))
10673 && (value_less (arg2
, arg1
)
10674 || value_equal (arg2
, arg1
)));
10678 case OP_ATR_LENGTH
:
10680 struct type
*type_arg
;
10682 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10684 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10686 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10690 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10694 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10695 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10696 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10699 if (noside
== EVAL_SKIP
)
10702 if (type_arg
== NULL
)
10704 arg1
= ada_coerce_ref (arg1
);
10706 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10707 arg1
= ada_coerce_to_simple_array (arg1
);
10709 if (op
== OP_ATR_LENGTH
)
10710 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10713 type
= ada_index_type (value_type (arg1
), tem
,
10714 ada_attribute_name (op
));
10716 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10719 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10720 return allocate_value (type
);
10724 default: /* Should never happen. */
10725 error (_("unexpected attribute encountered"));
10727 return value_from_longest
10728 (type
, ada_array_bound (arg1
, tem
, 0));
10730 return value_from_longest
10731 (type
, ada_array_bound (arg1
, tem
, 1));
10732 case OP_ATR_LENGTH
:
10733 return value_from_longest
10734 (type
, ada_array_length (arg1
, tem
));
10737 else if (discrete_type_p (type_arg
))
10739 struct type
*range_type
;
10740 const char *name
= ada_type_name (type_arg
);
10743 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
10744 range_type
= to_fixed_range_type (type_arg
, NULL
);
10745 if (range_type
== NULL
)
10746 range_type
= type_arg
;
10750 error (_("unexpected attribute encountered"));
10752 return value_from_longest
10753 (range_type
, ada_discrete_type_low_bound (range_type
));
10755 return value_from_longest
10756 (range_type
, ada_discrete_type_high_bound (range_type
));
10757 case OP_ATR_LENGTH
:
10758 error (_("the 'length attribute applies only to array types"));
10761 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
10762 error (_("unimplemented type attribute"));
10767 if (ada_is_constrained_packed_array_type (type_arg
))
10768 type_arg
= decode_constrained_packed_array_type (type_arg
);
10770 if (op
== OP_ATR_LENGTH
)
10771 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10774 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10776 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10779 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10780 return allocate_value (type
);
10785 error (_("unexpected attribute encountered"));
10787 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10788 return value_from_longest (type
, low
);
10790 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10791 return value_from_longest (type
, high
);
10792 case OP_ATR_LENGTH
:
10793 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10794 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10795 return value_from_longest (type
, high
- low
+ 1);
10801 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10802 if (noside
== EVAL_SKIP
)
10805 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10806 return value_zero (ada_tag_type (arg1
), not_lval
);
10808 return ada_value_tag (arg1
);
10812 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10813 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10814 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10815 if (noside
== EVAL_SKIP
)
10817 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10818 return value_zero (value_type (arg1
), not_lval
);
10821 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10822 return value_binop (arg1
, arg2
,
10823 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10826 case OP_ATR_MODULUS
:
10828 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10830 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10831 if (noside
== EVAL_SKIP
)
10834 if (!ada_is_modular_type (type_arg
))
10835 error (_("'modulus must be applied to modular type"));
10837 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10838 ada_modulus (type_arg
));
10843 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10844 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10845 if (noside
== EVAL_SKIP
)
10847 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10848 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10849 return value_zero (type
, not_lval
);
10851 return value_pos_atr (type
, arg1
);
10854 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10855 type
= value_type (arg1
);
10857 /* If the argument is a reference, then dereference its type, since
10858 the user is really asking for the size of the actual object,
10859 not the size of the pointer. */
10860 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
10861 type
= TYPE_TARGET_TYPE (type
);
10863 if (noside
== EVAL_SKIP
)
10865 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10866 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10868 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10869 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10872 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10873 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10874 type
= exp
->elts
[pc
+ 2].type
;
10875 if (noside
== EVAL_SKIP
)
10877 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10878 return value_zero (type
, not_lval
);
10880 return value_val_atr (type
, arg1
);
10883 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10884 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10885 if (noside
== EVAL_SKIP
)
10887 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10888 return value_zero (value_type (arg1
), not_lval
);
10891 /* For integer exponentiation operations,
10892 only promote the first argument. */
10893 if (is_integral_type (value_type (arg2
)))
10894 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10896 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10898 return value_binop (arg1
, arg2
, op
);
10902 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10903 if (noside
== EVAL_SKIP
)
10909 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10910 if (noside
== EVAL_SKIP
)
10912 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10913 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10914 return value_neg (arg1
);
10919 preeval_pos
= *pos
;
10920 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10921 if (noside
== EVAL_SKIP
)
10923 type
= ada_check_typedef (value_type (arg1
));
10924 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10926 if (ada_is_array_descriptor_type (type
))
10927 /* GDB allows dereferencing GNAT array descriptors. */
10929 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10931 if (arrType
== NULL
)
10932 error (_("Attempt to dereference null array pointer."));
10933 return value_at_lazy (arrType
, 0);
10935 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
10936 || TYPE_CODE (type
) == TYPE_CODE_REF
10937 /* In C you can dereference an array to get the 1st elt. */
10938 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
10940 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10941 only be determined by inspecting the object's tag.
10942 This means that we need to evaluate completely the
10943 expression in order to get its type. */
10945 if ((TYPE_CODE (type
) == TYPE_CODE_REF
10946 || TYPE_CODE (type
) == TYPE_CODE_PTR
)
10947 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10949 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
10951 type
= value_type (ada_value_ind (arg1
));
10955 type
= to_static_fixed_type
10957 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10959 ada_ensure_varsize_limit (type
);
10960 return value_zero (type
, lval_memory
);
10962 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
10964 /* GDB allows dereferencing an int. */
10965 if (expect_type
== NULL
)
10966 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10971 to_static_fixed_type (ada_aligned_type (expect_type
));
10972 return value_zero (expect_type
, lval_memory
);
10976 error (_("Attempt to take contents of a non-pointer value."));
10978 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10979 type
= ada_check_typedef (value_type (arg1
));
10981 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
10982 /* GDB allows dereferencing an int. If we were given
10983 the expect_type, then use that as the target type.
10984 Otherwise, assume that the target type is an int. */
10986 if (expect_type
!= NULL
)
10987 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
10990 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
10991 (CORE_ADDR
) value_as_address (arg1
));
10994 if (ada_is_array_descriptor_type (type
))
10995 /* GDB allows dereferencing GNAT array descriptors. */
10996 return ada_coerce_to_simple_array (arg1
);
10998 return ada_value_ind (arg1
);
11000 case STRUCTOP_STRUCT
:
11001 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11002 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11003 preeval_pos
= *pos
;
11004 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11005 if (noside
== EVAL_SKIP
)
11007 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11009 struct type
*type1
= value_type (arg1
);
11011 if (ada_is_tagged_type (type1
, 1))
11013 type
= ada_lookup_struct_elt_type (type1
,
11014 &exp
->elts
[pc
+ 2].string
,
11017 /* If the field is not found, check if it exists in the
11018 extension of this object's type. This means that we
11019 need to evaluate completely the expression. */
11023 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11025 arg1
= ada_value_struct_elt (arg1
,
11026 &exp
->elts
[pc
+ 2].string
,
11028 arg1
= unwrap_value (arg1
);
11029 type
= value_type (ada_to_fixed_value (arg1
));
11034 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11037 return value_zero (ada_aligned_type (type
), lval_memory
);
11040 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11041 arg1
= unwrap_value (arg1
);
11042 return ada_to_fixed_value (arg1
);
11045 /* The value is not supposed to be used. This is here to make it
11046 easier to accommodate expressions that contain types. */
11048 if (noside
== EVAL_SKIP
)
11050 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11051 return allocate_value (exp
->elts
[pc
+ 1].type
);
11053 error (_("Attempt to use a type name as an expression"));
11058 case OP_DISCRETE_RANGE
:
11059 case OP_POSITIONAL
:
11061 if (noside
== EVAL_NORMAL
)
11065 error (_("Undefined name, ambiguous name, or renaming used in "
11066 "component association: %s."), &exp
->elts
[pc
+2].string
);
11068 error (_("Aggregates only allowed on the right of an assignment"));
11070 internal_error (__FILE__
, __LINE__
,
11071 _("aggregate apparently mangled"));
11074 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11076 for (tem
= 0; tem
< nargs
; tem
+= 1)
11077 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11082 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
11088 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11089 type name that encodes the 'small and 'delta information.
11090 Otherwise, return NULL. */
11092 static const char *
11093 fixed_type_info (struct type
*type
)
11095 const char *name
= ada_type_name (type
);
11096 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
11098 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11100 const char *tail
= strstr (name
, "___XF_");
11107 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11108 return fixed_type_info (TYPE_TARGET_TYPE (type
));
11113 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11116 ada_is_fixed_point_type (struct type
*type
)
11118 return fixed_type_info (type
) != NULL
;
11121 /* Return non-zero iff TYPE represents a System.Address type. */
11124 ada_is_system_address_type (struct type
*type
)
11126 return (TYPE_NAME (type
)
11127 && strcmp (TYPE_NAME (type
), "system__address") == 0);
11130 /* Assuming that TYPE is the representation of an Ada fixed-point
11131 type, return its delta, or -1 if the type is malformed and the
11132 delta cannot be determined. */
11135 ada_delta (struct type
*type
)
11137 const char *encoding
= fixed_type_info (type
);
11140 /* Strictly speaking, num and den are encoded as integer. However,
11141 they may not fit into a long, and they will have to be converted
11142 to DOUBLEST anyway. So scan them as DOUBLEST. */
11143 if (sscanf (encoding
, "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
11150 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11151 factor ('SMALL value) associated with the type. */
11154 scaling_factor (struct type
*type
)
11156 const char *encoding
= fixed_type_info (type
);
11157 DOUBLEST num0
, den0
, num1
, den1
;
11160 /* Strictly speaking, num's and den's are encoded as integer. However,
11161 they may not fit into a long, and they will have to be converted
11162 to DOUBLEST anyway. So scan them as DOUBLEST. */
11163 n
= sscanf (encoding
,
11164 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
11165 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
11166 &num0
, &den0
, &num1
, &den1
);
11171 return num1
/ den1
;
11173 return num0
/ den0
;
11177 /* Assuming that X is the representation of a value of fixed-point
11178 type TYPE, return its floating-point equivalent. */
11181 ada_fixed_to_float (struct type
*type
, LONGEST x
)
11183 return (DOUBLEST
) x
*scaling_factor (type
);
11186 /* The representation of a fixed-point value of type TYPE
11187 corresponding to the value X. */
11190 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
11192 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
11199 /* Scan STR beginning at position K for a discriminant name, and
11200 return the value of that discriminant field of DVAL in *PX. If
11201 PNEW_K is not null, put the position of the character beyond the
11202 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11203 not alter *PX and *PNEW_K if unsuccessful. */
11206 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11209 static char *bound_buffer
= NULL
;
11210 static size_t bound_buffer_len
= 0;
11213 struct value
*bound_val
;
11215 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11218 pend
= strstr (str
+ k
, "__");
11222 k
+= strlen (bound
);
11226 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
11227 bound
= bound_buffer
;
11228 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
11229 bound
[pend
- (str
+ k
)] = '\0';
11233 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11234 if (bound_val
== NULL
)
11237 *px
= value_as_long (bound_val
);
11238 if (pnew_k
!= NULL
)
11243 /* Value of variable named NAME in the current environment. If
11244 no such variable found, then if ERR_MSG is null, returns 0, and
11245 otherwise causes an error with message ERR_MSG. */
11247 static struct value
*
11248 get_var_value (char *name
, char *err_msg
)
11250 struct ada_symbol_info
*syms
;
11253 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
11258 if (err_msg
== NULL
)
11261 error (("%s"), err_msg
);
11264 return value_of_variable (syms
[0].sym
, syms
[0].block
);
11267 /* Value of integer variable named NAME in the current environment. If
11268 no such variable found, returns 0, and sets *FLAG to 0. If
11269 successful, sets *FLAG to 1. */
11272 get_int_var_value (char *name
, int *flag
)
11274 struct value
*var_val
= get_var_value (name
, 0);
11286 return value_as_long (var_val
);
11291 /* Return a range type whose base type is that of the range type named
11292 NAME in the current environment, and whose bounds are calculated
11293 from NAME according to the GNAT range encoding conventions.
11294 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11295 corresponding range type from debug information; fall back to using it
11296 if symbol lookup fails. If a new type must be created, allocate it
11297 like ORIG_TYPE was. The bounds information, in general, is encoded
11298 in NAME, the base type given in the named range type. */
11300 static struct type
*
11301 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11304 struct type
*base_type
;
11305 char *subtype_info
;
11307 gdb_assert (raw_type
!= NULL
);
11308 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
11310 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
11311 base_type
= TYPE_TARGET_TYPE (raw_type
);
11313 base_type
= raw_type
;
11315 name
= TYPE_NAME (raw_type
);
11316 subtype_info
= strstr (name
, "___XD");
11317 if (subtype_info
== NULL
)
11319 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11320 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11322 if (L
< INT_MIN
|| U
> INT_MAX
)
11325 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11330 static char *name_buf
= NULL
;
11331 static size_t name_len
= 0;
11332 int prefix_len
= subtype_info
- name
;
11338 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11339 strncpy (name_buf
, name
, prefix_len
);
11340 name_buf
[prefix_len
] = '\0';
11343 bounds_str
= strchr (subtype_info
, '_');
11346 if (*subtype_info
== 'L')
11348 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11349 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11351 if (bounds_str
[n
] == '_')
11353 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11361 strcpy (name_buf
+ prefix_len
, "___L");
11362 L
= get_int_var_value (name_buf
, &ok
);
11365 lim_warning (_("Unknown lower bound, using 1."));
11370 if (*subtype_info
== 'U')
11372 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11373 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11380 strcpy (name_buf
+ prefix_len
, "___U");
11381 U
= get_int_var_value (name_buf
, &ok
);
11384 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11389 type
= create_static_range_type (alloc_type_copy (raw_type
),
11391 TYPE_NAME (type
) = name
;
11396 /* True iff NAME is the name of a range type. */
11399 ada_is_range_type_name (const char *name
)
11401 return (name
!= NULL
&& strstr (name
, "___XD"));
11405 /* Modular types */
11407 /* True iff TYPE is an Ada modular type. */
11410 ada_is_modular_type (struct type
*type
)
11412 struct type
*subranged_type
= get_base_type (type
);
11414 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
11415 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
11416 && TYPE_UNSIGNED (subranged_type
));
11419 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11422 ada_modulus (struct type
*type
)
11424 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11428 /* Ada exception catchpoint support:
11429 ---------------------------------
11431 We support 3 kinds of exception catchpoints:
11432 . catchpoints on Ada exceptions
11433 . catchpoints on unhandled Ada exceptions
11434 . catchpoints on failed assertions
11436 Exceptions raised during failed assertions, or unhandled exceptions
11437 could perfectly be caught with the general catchpoint on Ada exceptions.
11438 However, we can easily differentiate these two special cases, and having
11439 the option to distinguish these two cases from the rest can be useful
11440 to zero-in on certain situations.
11442 Exception catchpoints are a specialized form of breakpoint,
11443 since they rely on inserting breakpoints inside known routines
11444 of the GNAT runtime. The implementation therefore uses a standard
11445 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11448 Support in the runtime for exception catchpoints have been changed
11449 a few times already, and these changes affect the implementation
11450 of these catchpoints. In order to be able to support several
11451 variants of the runtime, we use a sniffer that will determine
11452 the runtime variant used by the program being debugged. */
11454 /* Ada's standard exceptions.
11456 The Ada 83 standard also defined Numeric_Error. But there so many
11457 situations where it was unclear from the Ada 83 Reference Manual
11458 (RM) whether Constraint_Error or Numeric_Error should be raised,
11459 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11460 Interpretation saying that anytime the RM says that Numeric_Error
11461 should be raised, the implementation may raise Constraint_Error.
11462 Ada 95 went one step further and pretty much removed Numeric_Error
11463 from the list of standard exceptions (it made it a renaming of
11464 Constraint_Error, to help preserve compatibility when compiling
11465 an Ada83 compiler). As such, we do not include Numeric_Error from
11466 this list of standard exceptions. */
11468 static char *standard_exc
[] = {
11469 "constraint_error",
11475 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11477 /* A structure that describes how to support exception catchpoints
11478 for a given executable. */
11480 struct exception_support_info
11482 /* The name of the symbol to break on in order to insert
11483 a catchpoint on exceptions. */
11484 const char *catch_exception_sym
;
11486 /* The name of the symbol to break on in order to insert
11487 a catchpoint on unhandled exceptions. */
11488 const char *catch_exception_unhandled_sym
;
11490 /* The name of the symbol to break on in order to insert
11491 a catchpoint on failed assertions. */
11492 const char *catch_assert_sym
;
11494 /* Assuming that the inferior just triggered an unhandled exception
11495 catchpoint, this function is responsible for returning the address
11496 in inferior memory where the name of that exception is stored.
11497 Return zero if the address could not be computed. */
11498 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11501 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11502 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11504 /* The following exception support info structure describes how to
11505 implement exception catchpoints with the latest version of the
11506 Ada runtime (as of 2007-03-06). */
11508 static const struct exception_support_info default_exception_support_info
=
11510 "__gnat_debug_raise_exception", /* catch_exception_sym */
11511 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11512 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11513 ada_unhandled_exception_name_addr
11516 /* The following exception support info structure describes how to
11517 implement exception catchpoints with a slightly older version
11518 of the Ada runtime. */
11520 static const struct exception_support_info exception_support_info_fallback
=
11522 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11523 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11524 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11525 ada_unhandled_exception_name_addr_from_raise
11528 /* Return nonzero if we can detect the exception support routines
11529 described in EINFO.
11531 This function errors out if an abnormal situation is detected
11532 (for instance, if we find the exception support routines, but
11533 that support is found to be incomplete). */
11536 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11538 struct symbol
*sym
;
11540 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11541 that should be compiled with debugging information. As a result, we
11542 expect to find that symbol in the symtabs. */
11544 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11547 /* Perhaps we did not find our symbol because the Ada runtime was
11548 compiled without debugging info, or simply stripped of it.
11549 It happens on some GNU/Linux distributions for instance, where
11550 users have to install a separate debug package in order to get
11551 the runtime's debugging info. In that situation, let the user
11552 know why we cannot insert an Ada exception catchpoint.
11554 Note: Just for the purpose of inserting our Ada exception
11555 catchpoint, we could rely purely on the associated minimal symbol.
11556 But we would be operating in degraded mode anyway, since we are
11557 still lacking the debugging info needed later on to extract
11558 the name of the exception being raised (this name is printed in
11559 the catchpoint message, and is also used when trying to catch
11560 a specific exception). We do not handle this case for now. */
11561 struct bound_minimal_symbol msym
11562 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11564 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11565 error (_("Your Ada runtime appears to be missing some debugging "
11566 "information.\nCannot insert Ada exception catchpoint "
11567 "in this configuration."));
11572 /* Make sure that the symbol we found corresponds to a function. */
11574 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11575 error (_("Symbol \"%s\" is not a function (class = %d)"),
11576 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
11581 /* Inspect the Ada runtime and determine which exception info structure
11582 should be used to provide support for exception catchpoints.
11584 This function will always set the per-inferior exception_info,
11585 or raise an error. */
11588 ada_exception_support_info_sniffer (void)
11590 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11592 /* If the exception info is already known, then no need to recompute it. */
11593 if (data
->exception_info
!= NULL
)
11596 /* Check the latest (default) exception support info. */
11597 if (ada_has_this_exception_support (&default_exception_support_info
))
11599 data
->exception_info
= &default_exception_support_info
;
11603 /* Try our fallback exception suport info. */
11604 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11606 data
->exception_info
= &exception_support_info_fallback
;
11610 /* Sometimes, it is normal for us to not be able to find the routine
11611 we are looking for. This happens when the program is linked with
11612 the shared version of the GNAT runtime, and the program has not been
11613 started yet. Inform the user of these two possible causes if
11616 if (ada_update_initial_language (language_unknown
) != language_ada
)
11617 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11619 /* If the symbol does not exist, then check that the program is
11620 already started, to make sure that shared libraries have been
11621 loaded. If it is not started, this may mean that the symbol is
11622 in a shared library. */
11624 if (ptid_get_pid (inferior_ptid
) == 0)
11625 error (_("Unable to insert catchpoint. Try to start the program first."));
11627 /* At this point, we know that we are debugging an Ada program and
11628 that the inferior has been started, but we still are not able to
11629 find the run-time symbols. That can mean that we are in
11630 configurable run time mode, or that a-except as been optimized
11631 out by the linker... In any case, at this point it is not worth
11632 supporting this feature. */
11634 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11637 /* True iff FRAME is very likely to be that of a function that is
11638 part of the runtime system. This is all very heuristic, but is
11639 intended to be used as advice as to what frames are uninteresting
11643 is_known_support_routine (struct frame_info
*frame
)
11645 struct symtab_and_line sal
;
11647 enum language func_lang
;
11649 const char *fullname
;
11651 /* If this code does not have any debugging information (no symtab),
11652 This cannot be any user code. */
11654 find_frame_sal (frame
, &sal
);
11655 if (sal
.symtab
== NULL
)
11658 /* If there is a symtab, but the associated source file cannot be
11659 located, then assume this is not user code: Selecting a frame
11660 for which we cannot display the code would not be very helpful
11661 for the user. This should also take care of case such as VxWorks
11662 where the kernel has some debugging info provided for a few units. */
11664 fullname
= symtab_to_fullname (sal
.symtab
);
11665 if (access (fullname
, R_OK
) != 0)
11668 /* Check the unit filename againt the Ada runtime file naming.
11669 We also check the name of the objfile against the name of some
11670 known system libraries that sometimes come with debugging info
11673 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11675 re_comp (known_runtime_file_name_patterns
[i
]);
11676 if (re_exec (lbasename (sal
.symtab
->filename
)))
11678 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11679 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11683 /* Check whether the function is a GNAT-generated entity. */
11685 find_frame_funname (frame
, &func_name
, &func_lang
, NULL
);
11686 if (func_name
== NULL
)
11689 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11691 re_comp (known_auxiliary_function_name_patterns
[i
]);
11692 if (re_exec (func_name
))
11703 /* Find the first frame that contains debugging information and that is not
11704 part of the Ada run-time, starting from FI and moving upward. */
11707 ada_find_printable_frame (struct frame_info
*fi
)
11709 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11711 if (!is_known_support_routine (fi
))
11720 /* Assuming that the inferior just triggered an unhandled exception
11721 catchpoint, return the address in inferior memory where the name
11722 of the exception is stored.
11724 Return zero if the address could not be computed. */
11727 ada_unhandled_exception_name_addr (void)
11729 return parse_and_eval_address ("e.full_name");
11732 /* Same as ada_unhandled_exception_name_addr, except that this function
11733 should be used when the inferior uses an older version of the runtime,
11734 where the exception name needs to be extracted from a specific frame
11735 several frames up in the callstack. */
11738 ada_unhandled_exception_name_addr_from_raise (void)
11741 struct frame_info
*fi
;
11742 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11743 struct cleanup
*old_chain
;
11745 /* To determine the name of this exception, we need to select
11746 the frame corresponding to RAISE_SYM_NAME. This frame is
11747 at least 3 levels up, so we simply skip the first 3 frames
11748 without checking the name of their associated function. */
11749 fi
= get_current_frame ();
11750 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11752 fi
= get_prev_frame (fi
);
11754 old_chain
= make_cleanup (null_cleanup
, NULL
);
11758 enum language func_lang
;
11760 find_frame_funname (fi
, &func_name
, &func_lang
, NULL
);
11761 if (func_name
!= NULL
)
11763 make_cleanup (xfree
, func_name
);
11765 if (strcmp (func_name
,
11766 data
->exception_info
->catch_exception_sym
) == 0)
11767 break; /* We found the frame we were looking for... */
11768 fi
= get_prev_frame (fi
);
11771 do_cleanups (old_chain
);
11777 return parse_and_eval_address ("id.full_name");
11780 /* Assuming the inferior just triggered an Ada exception catchpoint
11781 (of any type), return the address in inferior memory where the name
11782 of the exception is stored, if applicable.
11784 Return zero if the address could not be computed, or if not relevant. */
11787 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11788 struct breakpoint
*b
)
11790 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11794 case ada_catch_exception
:
11795 return (parse_and_eval_address ("e.full_name"));
11798 case ada_catch_exception_unhandled
:
11799 return data
->exception_info
->unhandled_exception_name_addr ();
11802 case ada_catch_assert
:
11803 return 0; /* Exception name is not relevant in this case. */
11807 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11811 return 0; /* Should never be reached. */
11814 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11815 any error that ada_exception_name_addr_1 might cause to be thrown.
11816 When an error is intercepted, a warning with the error message is printed,
11817 and zero is returned. */
11820 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11821 struct breakpoint
*b
)
11823 volatile struct gdb_exception e
;
11824 CORE_ADDR result
= 0;
11826 TRY_CATCH (e
, RETURN_MASK_ERROR
)
11828 result
= ada_exception_name_addr_1 (ex
, b
);
11833 warning (_("failed to get exception name: %s"), e
.message
);
11840 static char *ada_exception_catchpoint_cond_string (const char *excep_string
);
11842 /* Ada catchpoints.
11844 In the case of catchpoints on Ada exceptions, the catchpoint will
11845 stop the target on every exception the program throws. When a user
11846 specifies the name of a specific exception, we translate this
11847 request into a condition expression (in text form), and then parse
11848 it into an expression stored in each of the catchpoint's locations.
11849 We then use this condition to check whether the exception that was
11850 raised is the one the user is interested in. If not, then the
11851 target is resumed again. We store the name of the requested
11852 exception, in order to be able to re-set the condition expression
11853 when symbols change. */
11855 /* An instance of this type is used to represent an Ada catchpoint
11856 breakpoint location. It includes a "struct bp_location" as a kind
11857 of base class; users downcast to "struct bp_location *" when
11860 struct ada_catchpoint_location
11862 /* The base class. */
11863 struct bp_location base
;
11865 /* The condition that checks whether the exception that was raised
11866 is the specific exception the user specified on catchpoint
11868 struct expression
*excep_cond_expr
;
11871 /* Implement the DTOR method in the bp_location_ops structure for all
11872 Ada exception catchpoint kinds. */
11875 ada_catchpoint_location_dtor (struct bp_location
*bl
)
11877 struct ada_catchpoint_location
*al
= (struct ada_catchpoint_location
*) bl
;
11879 xfree (al
->excep_cond_expr
);
11882 /* The vtable to be used in Ada catchpoint locations. */
11884 static const struct bp_location_ops ada_catchpoint_location_ops
=
11886 ada_catchpoint_location_dtor
11889 /* An instance of this type is used to represent an Ada catchpoint.
11890 It includes a "struct breakpoint" as a kind of base class; users
11891 downcast to "struct breakpoint *" when needed. */
11893 struct ada_catchpoint
11895 /* The base class. */
11896 struct breakpoint base
;
11898 /* The name of the specific exception the user specified. */
11899 char *excep_string
;
11902 /* Parse the exception condition string in the context of each of the
11903 catchpoint's locations, and store them for later evaluation. */
11906 create_excep_cond_exprs (struct ada_catchpoint
*c
)
11908 struct cleanup
*old_chain
;
11909 struct bp_location
*bl
;
11912 /* Nothing to do if there's no specific exception to catch. */
11913 if (c
->excep_string
== NULL
)
11916 /* Same if there are no locations... */
11917 if (c
->base
.loc
== NULL
)
11920 /* Compute the condition expression in text form, from the specific
11921 expection we want to catch. */
11922 cond_string
= ada_exception_catchpoint_cond_string (c
->excep_string
);
11923 old_chain
= make_cleanup (xfree
, cond_string
);
11925 /* Iterate over all the catchpoint's locations, and parse an
11926 expression for each. */
11927 for (bl
= c
->base
.loc
; bl
!= NULL
; bl
= bl
->next
)
11929 struct ada_catchpoint_location
*ada_loc
11930 = (struct ada_catchpoint_location
*) bl
;
11931 struct expression
*exp
= NULL
;
11933 if (!bl
->shlib_disabled
)
11935 volatile struct gdb_exception e
;
11939 TRY_CATCH (e
, RETURN_MASK_ERROR
)
11941 exp
= parse_exp_1 (&s
, bl
->address
,
11942 block_for_pc (bl
->address
), 0);
11946 warning (_("failed to reevaluate internal exception condition "
11947 "for catchpoint %d: %s"),
11948 c
->base
.number
, e
.message
);
11949 /* There is a bug in GCC on sparc-solaris when building with
11950 optimization which causes EXP to change unexpectedly
11951 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11952 The problem should be fixed starting with GCC 4.9.
11953 In the meantime, work around it by forcing EXP back
11959 ada_loc
->excep_cond_expr
= exp
;
11962 do_cleanups (old_chain
);
11965 /* Implement the DTOR method in the breakpoint_ops structure for all
11966 exception catchpoint kinds. */
11969 dtor_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
11971 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11973 xfree (c
->excep_string
);
11975 bkpt_breakpoint_ops
.dtor (b
);
11978 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11979 structure for all exception catchpoint kinds. */
11981 static struct bp_location
*
11982 allocate_location_exception (enum ada_exception_catchpoint_kind ex
,
11983 struct breakpoint
*self
)
11985 struct ada_catchpoint_location
*loc
;
11987 loc
= XNEW (struct ada_catchpoint_location
);
11988 init_bp_location (&loc
->base
, &ada_catchpoint_location_ops
, self
);
11989 loc
->excep_cond_expr
= NULL
;
11993 /* Implement the RE_SET method in the breakpoint_ops structure for all
11994 exception catchpoint kinds. */
11997 re_set_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
11999 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12001 /* Call the base class's method. This updates the catchpoint's
12003 bkpt_breakpoint_ops
.re_set (b
);
12005 /* Reparse the exception conditional expressions. One for each
12007 create_excep_cond_exprs (c
);
12010 /* Returns true if we should stop for this breakpoint hit. If the
12011 user specified a specific exception, we only want to cause a stop
12012 if the program thrown that exception. */
12015 should_stop_exception (const struct bp_location
*bl
)
12017 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12018 const struct ada_catchpoint_location
*ada_loc
12019 = (const struct ada_catchpoint_location
*) bl
;
12020 volatile struct gdb_exception ex
;
12023 /* With no specific exception, should always stop. */
12024 if (c
->excep_string
== NULL
)
12027 if (ada_loc
->excep_cond_expr
== NULL
)
12029 /* We will have a NULL expression if back when we were creating
12030 the expressions, this location's had failed to parse. */
12035 TRY_CATCH (ex
, RETURN_MASK_ALL
)
12037 struct value
*mark
;
12039 mark
= value_mark ();
12040 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
));
12041 value_free_to_mark (mark
);
12044 exception_fprintf (gdb_stderr
, ex
,
12045 _("Error in testing exception condition:\n"));
12049 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12050 for all exception catchpoint kinds. */
12053 check_status_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12055 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12058 /* Implement the PRINT_IT method in the breakpoint_ops structure
12059 for all exception catchpoint kinds. */
12061 static enum print_stop_action
12062 print_it_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12064 struct ui_out
*uiout
= current_uiout
;
12065 struct breakpoint
*b
= bs
->breakpoint_at
;
12067 annotate_catchpoint (b
->number
);
12069 if (ui_out_is_mi_like_p (uiout
))
12071 ui_out_field_string (uiout
, "reason",
12072 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12073 ui_out_field_string (uiout
, "disp", bpdisp_text (b
->disposition
));
12076 ui_out_text (uiout
,
12077 b
->disposition
== disp_del
? "\nTemporary catchpoint "
12078 : "\nCatchpoint ");
12079 ui_out_field_int (uiout
, "bkptno", b
->number
);
12080 ui_out_text (uiout
, ", ");
12084 case ada_catch_exception
:
12085 case ada_catch_exception_unhandled
:
12087 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
12088 char exception_name
[256];
12092 read_memory (addr
, (gdb_byte
*) exception_name
,
12093 sizeof (exception_name
) - 1);
12094 exception_name
[sizeof (exception_name
) - 1] = '\0';
12098 /* For some reason, we were unable to read the exception
12099 name. This could happen if the Runtime was compiled
12100 without debugging info, for instance. In that case,
12101 just replace the exception name by the generic string
12102 "exception" - it will read as "an exception" in the
12103 notification we are about to print. */
12104 memcpy (exception_name
, "exception", sizeof ("exception"));
12106 /* In the case of unhandled exception breakpoints, we print
12107 the exception name as "unhandled EXCEPTION_NAME", to make
12108 it clearer to the user which kind of catchpoint just got
12109 hit. We used ui_out_text to make sure that this extra
12110 info does not pollute the exception name in the MI case. */
12111 if (ex
== ada_catch_exception_unhandled
)
12112 ui_out_text (uiout
, "unhandled ");
12113 ui_out_field_string (uiout
, "exception-name", exception_name
);
12116 case ada_catch_assert
:
12117 /* In this case, the name of the exception is not really
12118 important. Just print "failed assertion" to make it clearer
12119 that his program just hit an assertion-failure catchpoint.
12120 We used ui_out_text because this info does not belong in
12122 ui_out_text (uiout
, "failed assertion");
12125 ui_out_text (uiout
, " at ");
12126 ada_find_printable_frame (get_current_frame ());
12128 return PRINT_SRC_AND_LOC
;
12131 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12132 for all exception catchpoint kinds. */
12135 print_one_exception (enum ada_exception_catchpoint_kind ex
,
12136 struct breakpoint
*b
, struct bp_location
**last_loc
)
12138 struct ui_out
*uiout
= current_uiout
;
12139 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12140 struct value_print_options opts
;
12142 get_user_print_options (&opts
);
12143 if (opts
.addressprint
)
12145 annotate_field (4);
12146 ui_out_field_core_addr (uiout
, "addr", b
->loc
->gdbarch
, b
->loc
->address
);
12149 annotate_field (5);
12150 *last_loc
= b
->loc
;
12153 case ada_catch_exception
:
12154 if (c
->excep_string
!= NULL
)
12156 char *msg
= xstrprintf (_("`%s' Ada exception"), c
->excep_string
);
12158 ui_out_field_string (uiout
, "what", msg
);
12162 ui_out_field_string (uiout
, "what", "all Ada exceptions");
12166 case ada_catch_exception_unhandled
:
12167 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
12170 case ada_catch_assert
:
12171 ui_out_field_string (uiout
, "what", "failed Ada assertions");
12175 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12180 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12181 for all exception catchpoint kinds. */
12184 print_mention_exception (enum ada_exception_catchpoint_kind ex
,
12185 struct breakpoint
*b
)
12187 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12188 struct ui_out
*uiout
= current_uiout
;
12190 ui_out_text (uiout
, b
->disposition
== disp_del
? _("Temporary catchpoint ")
12191 : _("Catchpoint "));
12192 ui_out_field_int (uiout
, "bkptno", b
->number
);
12193 ui_out_text (uiout
, ": ");
12197 case ada_catch_exception
:
12198 if (c
->excep_string
!= NULL
)
12200 char *info
= xstrprintf (_("`%s' Ada exception"), c
->excep_string
);
12201 struct cleanup
*old_chain
= make_cleanup (xfree
, info
);
12203 ui_out_text (uiout
, info
);
12204 do_cleanups (old_chain
);
12207 ui_out_text (uiout
, _("all Ada exceptions"));
12210 case ada_catch_exception_unhandled
:
12211 ui_out_text (uiout
, _("unhandled Ada exceptions"));
12214 case ada_catch_assert
:
12215 ui_out_text (uiout
, _("failed Ada assertions"));
12219 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12224 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12225 for all exception catchpoint kinds. */
12228 print_recreate_exception (enum ada_exception_catchpoint_kind ex
,
12229 struct breakpoint
*b
, struct ui_file
*fp
)
12231 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12235 case ada_catch_exception
:
12236 fprintf_filtered (fp
, "catch exception");
12237 if (c
->excep_string
!= NULL
)
12238 fprintf_filtered (fp
, " %s", c
->excep_string
);
12241 case ada_catch_exception_unhandled
:
12242 fprintf_filtered (fp
, "catch exception unhandled");
12245 case ada_catch_assert
:
12246 fprintf_filtered (fp
, "catch assert");
12250 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12252 print_recreate_thread (b
, fp
);
12255 /* Virtual table for "catch exception" breakpoints. */
12258 dtor_catch_exception (struct breakpoint
*b
)
12260 dtor_exception (ada_catch_exception
, b
);
12263 static struct bp_location
*
12264 allocate_location_catch_exception (struct breakpoint
*self
)
12266 return allocate_location_exception (ada_catch_exception
, self
);
12270 re_set_catch_exception (struct breakpoint
*b
)
12272 re_set_exception (ada_catch_exception
, b
);
12276 check_status_catch_exception (bpstat bs
)
12278 check_status_exception (ada_catch_exception
, bs
);
12281 static enum print_stop_action
12282 print_it_catch_exception (bpstat bs
)
12284 return print_it_exception (ada_catch_exception
, bs
);
12288 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12290 print_one_exception (ada_catch_exception
, b
, last_loc
);
12294 print_mention_catch_exception (struct breakpoint
*b
)
12296 print_mention_exception (ada_catch_exception
, b
);
12300 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12302 print_recreate_exception (ada_catch_exception
, b
, fp
);
12305 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12307 /* Virtual table for "catch exception unhandled" breakpoints. */
12310 dtor_catch_exception_unhandled (struct breakpoint
*b
)
12312 dtor_exception (ada_catch_exception_unhandled
, b
);
12315 static struct bp_location
*
12316 allocate_location_catch_exception_unhandled (struct breakpoint
*self
)
12318 return allocate_location_exception (ada_catch_exception_unhandled
, self
);
12322 re_set_catch_exception_unhandled (struct breakpoint
*b
)
12324 re_set_exception (ada_catch_exception_unhandled
, b
);
12328 check_status_catch_exception_unhandled (bpstat bs
)
12330 check_status_exception (ada_catch_exception_unhandled
, bs
);
12333 static enum print_stop_action
12334 print_it_catch_exception_unhandled (bpstat bs
)
12336 return print_it_exception (ada_catch_exception_unhandled
, bs
);
12340 print_one_catch_exception_unhandled (struct breakpoint
*b
,
12341 struct bp_location
**last_loc
)
12343 print_one_exception (ada_catch_exception_unhandled
, b
, last_loc
);
12347 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
12349 print_mention_exception (ada_catch_exception_unhandled
, b
);
12353 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
12354 struct ui_file
*fp
)
12356 print_recreate_exception (ada_catch_exception_unhandled
, b
, fp
);
12359 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12361 /* Virtual table for "catch assert" breakpoints. */
12364 dtor_catch_assert (struct breakpoint
*b
)
12366 dtor_exception (ada_catch_assert
, b
);
12369 static struct bp_location
*
12370 allocate_location_catch_assert (struct breakpoint
*self
)
12372 return allocate_location_exception (ada_catch_assert
, self
);
12376 re_set_catch_assert (struct breakpoint
*b
)
12378 re_set_exception (ada_catch_assert
, b
);
12382 check_status_catch_assert (bpstat bs
)
12384 check_status_exception (ada_catch_assert
, bs
);
12387 static enum print_stop_action
12388 print_it_catch_assert (bpstat bs
)
12390 return print_it_exception (ada_catch_assert
, bs
);
12394 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
12396 print_one_exception (ada_catch_assert
, b
, last_loc
);
12400 print_mention_catch_assert (struct breakpoint
*b
)
12402 print_mention_exception (ada_catch_assert
, b
);
12406 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
12408 print_recreate_exception (ada_catch_assert
, b
, fp
);
12411 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12413 /* Return a newly allocated copy of the first space-separated token
12414 in ARGSP, and then adjust ARGSP to point immediately after that
12417 Return NULL if ARGPS does not contain any more tokens. */
12420 ada_get_next_arg (char **argsp
)
12422 char *args
= *argsp
;
12426 args
= skip_spaces (args
);
12427 if (args
[0] == '\0')
12428 return NULL
; /* No more arguments. */
12430 /* Find the end of the current argument. */
12432 end
= skip_to_space (args
);
12434 /* Adjust ARGSP to point to the start of the next argument. */
12438 /* Make a copy of the current argument and return it. */
12440 result
= xmalloc (end
- args
+ 1);
12441 strncpy (result
, args
, end
- args
);
12442 result
[end
- args
] = '\0';
12447 /* Split the arguments specified in a "catch exception" command.
12448 Set EX to the appropriate catchpoint type.
12449 Set EXCEP_STRING to the name of the specific exception if
12450 specified by the user.
12451 If a condition is found at the end of the arguments, the condition
12452 expression is stored in COND_STRING (memory must be deallocated
12453 after use). Otherwise COND_STRING is set to NULL. */
12456 catch_ada_exception_command_split (char *args
,
12457 enum ada_exception_catchpoint_kind
*ex
,
12458 char **excep_string
,
12459 char **cond_string
)
12461 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
12462 char *exception_name
;
12465 exception_name
= ada_get_next_arg (&args
);
12466 if (exception_name
!= NULL
&& strcmp (exception_name
, "if") == 0)
12468 /* This is not an exception name; this is the start of a condition
12469 expression for a catchpoint on all exceptions. So, "un-get"
12470 this token, and set exception_name to NULL. */
12471 xfree (exception_name
);
12472 exception_name
= NULL
;
12475 make_cleanup (xfree
, exception_name
);
12477 /* Check to see if we have a condition. */
12479 args
= skip_spaces (args
);
12480 if (strncmp (args
, "if", 2) == 0
12481 && (isspace (args
[2]) || args
[2] == '\0'))
12484 args
= skip_spaces (args
);
12486 if (args
[0] == '\0')
12487 error (_("Condition missing after `if' keyword"));
12488 cond
= xstrdup (args
);
12489 make_cleanup (xfree
, cond
);
12491 args
+= strlen (args
);
12494 /* Check that we do not have any more arguments. Anything else
12497 if (args
[0] != '\0')
12498 error (_("Junk at end of expression"));
12500 discard_cleanups (old_chain
);
12502 if (exception_name
== NULL
)
12504 /* Catch all exceptions. */
12505 *ex
= ada_catch_exception
;
12506 *excep_string
= NULL
;
12508 else if (strcmp (exception_name
, "unhandled") == 0)
12510 /* Catch unhandled exceptions. */
12511 *ex
= ada_catch_exception_unhandled
;
12512 *excep_string
= NULL
;
12516 /* Catch a specific exception. */
12517 *ex
= ada_catch_exception
;
12518 *excep_string
= exception_name
;
12520 *cond_string
= cond
;
12523 /* Return the name of the symbol on which we should break in order to
12524 implement a catchpoint of the EX kind. */
12526 static const char *
12527 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12529 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12531 gdb_assert (data
->exception_info
!= NULL
);
12535 case ada_catch_exception
:
12536 return (data
->exception_info
->catch_exception_sym
);
12538 case ada_catch_exception_unhandled
:
12539 return (data
->exception_info
->catch_exception_unhandled_sym
);
12541 case ada_catch_assert
:
12542 return (data
->exception_info
->catch_assert_sym
);
12545 internal_error (__FILE__
, __LINE__
,
12546 _("unexpected catchpoint kind (%d)"), ex
);
12550 /* Return the breakpoint ops "virtual table" used for catchpoints
12553 static const struct breakpoint_ops
*
12554 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12558 case ada_catch_exception
:
12559 return (&catch_exception_breakpoint_ops
);
12561 case ada_catch_exception_unhandled
:
12562 return (&catch_exception_unhandled_breakpoint_ops
);
12564 case ada_catch_assert
:
12565 return (&catch_assert_breakpoint_ops
);
12568 internal_error (__FILE__
, __LINE__
,
12569 _("unexpected catchpoint kind (%d)"), ex
);
12573 /* Return the condition that will be used to match the current exception
12574 being raised with the exception that the user wants to catch. This
12575 assumes that this condition is used when the inferior just triggered
12576 an exception catchpoint.
12578 The string returned is a newly allocated string that needs to be
12579 deallocated later. */
12582 ada_exception_catchpoint_cond_string (const char *excep_string
)
12586 /* The standard exceptions are a special case. They are defined in
12587 runtime units that have been compiled without debugging info; if
12588 EXCEP_STRING is the not-fully-qualified name of a standard
12589 exception (e.g. "constraint_error") then, during the evaluation
12590 of the condition expression, the symbol lookup on this name would
12591 *not* return this standard exception. The catchpoint condition
12592 may then be set only on user-defined exceptions which have the
12593 same not-fully-qualified name (e.g. my_package.constraint_error).
12595 To avoid this unexcepted behavior, these standard exceptions are
12596 systematically prefixed by "standard". This means that "catch
12597 exception constraint_error" is rewritten into "catch exception
12598 standard.constraint_error".
12600 If an exception named contraint_error is defined in another package of
12601 the inferior program, then the only way to specify this exception as a
12602 breakpoint condition is to use its fully-qualified named:
12603 e.g. my_package.constraint_error. */
12605 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12607 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12609 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
12613 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string
);
12616 /* Return the symtab_and_line that should be used to insert an exception
12617 catchpoint of the TYPE kind.
12619 EXCEP_STRING should contain the name of a specific exception that
12620 the catchpoint should catch, or NULL otherwise.
12622 ADDR_STRING returns the name of the function where the real
12623 breakpoint that implements the catchpoints is set, depending on the
12624 type of catchpoint we need to create. */
12626 static struct symtab_and_line
12627 ada_exception_sal (enum ada_exception_catchpoint_kind ex
, char *excep_string
,
12628 char **addr_string
, const struct breakpoint_ops
**ops
)
12630 const char *sym_name
;
12631 struct symbol
*sym
;
12633 /* First, find out which exception support info to use. */
12634 ada_exception_support_info_sniffer ();
12636 /* Then lookup the function on which we will break in order to catch
12637 the Ada exceptions requested by the user. */
12638 sym_name
= ada_exception_sym_name (ex
);
12639 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12641 /* We can assume that SYM is not NULL at this stage. If the symbol
12642 did not exist, ada_exception_support_info_sniffer would have
12643 raised an exception.
12645 Also, ada_exception_support_info_sniffer should have already
12646 verified that SYM is a function symbol. */
12647 gdb_assert (sym
!= NULL
);
12648 gdb_assert (SYMBOL_CLASS (sym
) == LOC_BLOCK
);
12650 /* Set ADDR_STRING. */
12651 *addr_string
= xstrdup (sym_name
);
12654 *ops
= ada_exception_breakpoint_ops (ex
);
12656 return find_function_start_sal (sym
, 1);
12659 /* Create an Ada exception catchpoint.
12661 EX_KIND is the kind of exception catchpoint to be created.
12663 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12664 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12665 of the exception to which this catchpoint applies. When not NULL,
12666 the string must be allocated on the heap, and its deallocation
12667 is no longer the responsibility of the caller.
12669 COND_STRING, if not NULL, is the catchpoint condition. This string
12670 must be allocated on the heap, and its deallocation is no longer
12671 the responsibility of the caller.
12673 TEMPFLAG, if nonzero, means that the underlying breakpoint
12674 should be temporary.
12676 FROM_TTY is the usual argument passed to all commands implementations. */
12679 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12680 enum ada_exception_catchpoint_kind ex_kind
,
12681 char *excep_string
,
12687 struct ada_catchpoint
*c
;
12688 char *addr_string
= NULL
;
12689 const struct breakpoint_ops
*ops
= NULL
;
12690 struct symtab_and_line sal
12691 = ada_exception_sal (ex_kind
, excep_string
, &addr_string
, &ops
);
12693 c
= XNEW (struct ada_catchpoint
);
12694 init_ada_exception_breakpoint (&c
->base
, gdbarch
, sal
, addr_string
,
12695 ops
, tempflag
, disabled
, from_tty
);
12696 c
->excep_string
= excep_string
;
12697 create_excep_cond_exprs (c
);
12698 if (cond_string
!= NULL
)
12699 set_breakpoint_condition (&c
->base
, cond_string
, from_tty
);
12700 install_breakpoint (0, &c
->base
, 1);
12703 /* Implement the "catch exception" command. */
12706 catch_ada_exception_command (char *arg
, int from_tty
,
12707 struct cmd_list_element
*command
)
12709 struct gdbarch
*gdbarch
= get_current_arch ();
12711 enum ada_exception_catchpoint_kind ex_kind
;
12712 char *excep_string
= NULL
;
12713 char *cond_string
= NULL
;
12715 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12719 catch_ada_exception_command_split (arg
, &ex_kind
, &excep_string
,
12721 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12722 excep_string
, cond_string
,
12723 tempflag
, 1 /* enabled */,
12727 /* Split the arguments specified in a "catch assert" command.
12729 ARGS contains the command's arguments (or the empty string if
12730 no arguments were passed).
12732 If ARGS contains a condition, set COND_STRING to that condition
12733 (the memory needs to be deallocated after use). */
12736 catch_ada_assert_command_split (char *args
, char **cond_string
)
12738 args
= skip_spaces (args
);
12740 /* Check whether a condition was provided. */
12741 if (strncmp (args
, "if", 2) == 0
12742 && (isspace (args
[2]) || args
[2] == '\0'))
12745 args
= skip_spaces (args
);
12746 if (args
[0] == '\0')
12747 error (_("condition missing after `if' keyword"));
12748 *cond_string
= xstrdup (args
);
12751 /* Otherwise, there should be no other argument at the end of
12753 else if (args
[0] != '\0')
12754 error (_("Junk at end of arguments."));
12757 /* Implement the "catch assert" command. */
12760 catch_assert_command (char *arg
, int from_tty
,
12761 struct cmd_list_element
*command
)
12763 struct gdbarch
*gdbarch
= get_current_arch ();
12765 char *cond_string
= NULL
;
12767 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12771 catch_ada_assert_command_split (arg
, &cond_string
);
12772 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12774 tempflag
, 1 /* enabled */,
12778 /* Return non-zero if the symbol SYM is an Ada exception object. */
12781 ada_is_exception_sym (struct symbol
*sym
)
12783 const char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
12785 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12786 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12787 && SYMBOL_CLASS (sym
) != LOC_CONST
12788 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12789 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12792 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12793 Ada exception object. This matches all exceptions except the ones
12794 defined by the Ada language. */
12797 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12801 if (!ada_is_exception_sym (sym
))
12804 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12805 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), standard_exc
[i
]) == 0)
12806 return 0; /* A standard exception. */
12808 /* Numeric_Error is also a standard exception, so exclude it.
12809 See the STANDARD_EXC description for more details as to why
12810 this exception is not listed in that array. */
12811 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), "numeric_error") == 0)
12817 /* A helper function for qsort, comparing two struct ada_exc_info
12820 The comparison is determined first by exception name, and then
12821 by exception address. */
12824 compare_ada_exception_info (const void *a
, const void *b
)
12826 const struct ada_exc_info
*exc_a
= (struct ada_exc_info
*) a
;
12827 const struct ada_exc_info
*exc_b
= (struct ada_exc_info
*) b
;
12830 result
= strcmp (exc_a
->name
, exc_b
->name
);
12834 if (exc_a
->addr
< exc_b
->addr
)
12836 if (exc_a
->addr
> exc_b
->addr
)
12842 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12843 routine, but keeping the first SKIP elements untouched.
12845 All duplicates are also removed. */
12848 sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info
) **exceptions
,
12851 struct ada_exc_info
*to_sort
12852 = VEC_address (ada_exc_info
, *exceptions
) + skip
;
12854 = VEC_length (ada_exc_info
, *exceptions
) - skip
;
12857 qsort (to_sort
, to_sort_len
, sizeof (struct ada_exc_info
),
12858 compare_ada_exception_info
);
12860 for (i
= 1, j
= 1; i
< to_sort_len
; i
++)
12861 if (compare_ada_exception_info (&to_sort
[i
], &to_sort
[j
- 1]) != 0)
12862 to_sort
[j
++] = to_sort
[i
];
12864 VEC_truncate(ada_exc_info
, *exceptions
, skip
+ to_sort_len
);
12867 /* A function intended as the "name_matcher" callback in the struct
12868 quick_symbol_functions' expand_symtabs_matching method.
12870 SEARCH_NAME is the symbol's search name.
12872 If USER_DATA is not NULL, it is a pointer to a regext_t object
12873 used to match the symbol (by natural name). Otherwise, when USER_DATA
12874 is null, no filtering is performed, and all symbols are a positive
12878 ada_exc_search_name_matches (const char *search_name
, void *user_data
)
12880 regex_t
*preg
= user_data
;
12885 /* In Ada, the symbol "search name" is a linkage name, whereas
12886 the regular expression used to do the matching refers to
12887 the natural name. So match against the decoded name. */
12888 return (regexec (preg
, ada_decode (search_name
), 0, NULL
, 0) == 0);
12891 /* Add all exceptions defined by the Ada standard whose name match
12892 a regular expression.
12894 If PREG is not NULL, then this regexp_t object is used to
12895 perform the symbol name matching. Otherwise, no name-based
12896 filtering is performed.
12898 EXCEPTIONS is a vector of exceptions to which matching exceptions
12902 ada_add_standard_exceptions (regex_t
*preg
, VEC(ada_exc_info
) **exceptions
)
12906 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12909 || regexec (preg
, standard_exc
[i
], 0, NULL
, 0) == 0)
12911 struct bound_minimal_symbol msymbol
12912 = ada_lookup_simple_minsym (standard_exc
[i
]);
12914 if (msymbol
.minsym
!= NULL
)
12916 struct ada_exc_info info
12917 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12919 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
12925 /* Add all Ada exceptions defined locally and accessible from the given
12928 If PREG is not NULL, then this regexp_t object is used to
12929 perform the symbol name matching. Otherwise, no name-based
12930 filtering is performed.
12932 EXCEPTIONS is a vector of exceptions to which matching exceptions
12936 ada_add_exceptions_from_frame (regex_t
*preg
, struct frame_info
*frame
,
12937 VEC(ada_exc_info
) **exceptions
)
12939 const struct block
*block
= get_frame_block (frame
, 0);
12943 struct block_iterator iter
;
12944 struct symbol
*sym
;
12946 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12948 switch (SYMBOL_CLASS (sym
))
12955 if (ada_is_exception_sym (sym
))
12957 struct ada_exc_info info
= {SYMBOL_PRINT_NAME (sym
),
12958 SYMBOL_VALUE_ADDRESS (sym
)};
12960 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
12964 if (BLOCK_FUNCTION (block
) != NULL
)
12966 block
= BLOCK_SUPERBLOCK (block
);
12970 /* Add all exceptions defined globally whose name name match
12971 a regular expression, excluding standard exceptions.
12973 The reason we exclude standard exceptions is that they need
12974 to be handled separately: Standard exceptions are defined inside
12975 a runtime unit which is normally not compiled with debugging info,
12976 and thus usually do not show up in our symbol search. However,
12977 if the unit was in fact built with debugging info, we need to
12978 exclude them because they would duplicate the entry we found
12979 during the special loop that specifically searches for those
12980 standard exceptions.
12982 If PREG is not NULL, then this regexp_t object is used to
12983 perform the symbol name matching. Otherwise, no name-based
12984 filtering is performed.
12986 EXCEPTIONS is a vector of exceptions to which matching exceptions
12990 ada_add_global_exceptions (regex_t
*preg
, VEC(ada_exc_info
) **exceptions
)
12992 struct objfile
*objfile
;
12993 struct compunit_symtab
*s
;
12995 expand_symtabs_matching (NULL
, ada_exc_search_name_matches
, NULL
,
12996 VARIABLES_DOMAIN
, preg
);
12998 ALL_COMPUNITS (objfile
, s
)
13000 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13003 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13005 struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13006 struct block_iterator iter
;
13007 struct symbol
*sym
;
13009 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13010 if (ada_is_non_standard_exception_sym (sym
)
13012 || regexec (preg
, SYMBOL_NATURAL_NAME (sym
),
13015 struct ada_exc_info info
13016 = {SYMBOL_PRINT_NAME (sym
), SYMBOL_VALUE_ADDRESS (sym
)};
13018 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
13024 /* Implements ada_exceptions_list with the regular expression passed
13025 as a regex_t, rather than a string.
13027 If not NULL, PREG is used to filter out exceptions whose names
13028 do not match. Otherwise, all exceptions are listed. */
13030 static VEC(ada_exc_info
) *
13031 ada_exceptions_list_1 (regex_t
*preg
)
13033 VEC(ada_exc_info
) *result
= NULL
;
13034 struct cleanup
*old_chain
13035 = make_cleanup (VEC_cleanup (ada_exc_info
), &result
);
13038 /* First, list the known standard exceptions. These exceptions
13039 need to be handled separately, as they are usually defined in
13040 runtime units that have been compiled without debugging info. */
13042 ada_add_standard_exceptions (preg
, &result
);
13044 /* Next, find all exceptions whose scope is local and accessible
13045 from the currently selected frame. */
13047 if (has_stack_frames ())
13049 prev_len
= VEC_length (ada_exc_info
, result
);
13050 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13052 if (VEC_length (ada_exc_info
, result
) > prev_len
)
13053 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13056 /* Add all exceptions whose scope is global. */
13058 prev_len
= VEC_length (ada_exc_info
, result
);
13059 ada_add_global_exceptions (preg
, &result
);
13060 if (VEC_length (ada_exc_info
, result
) > prev_len
)
13061 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13063 discard_cleanups (old_chain
);
13067 /* Return a vector of ada_exc_info.
13069 If REGEXP is NULL, all exceptions are included in the result.
13070 Otherwise, it should contain a valid regular expression,
13071 and only the exceptions whose names match that regular expression
13072 are included in the result.
13074 The exceptions are sorted in the following order:
13075 - Standard exceptions (defined by the Ada language), in
13076 alphabetical order;
13077 - Exceptions only visible from the current frame, in
13078 alphabetical order;
13079 - Exceptions whose scope is global, in alphabetical order. */
13081 VEC(ada_exc_info
) *
13082 ada_exceptions_list (const char *regexp
)
13084 VEC(ada_exc_info
) *result
= NULL
;
13085 struct cleanup
*old_chain
= NULL
;
13088 if (regexp
!= NULL
)
13089 old_chain
= compile_rx_or_error (®
, regexp
,
13090 _("invalid regular expression"));
13092 result
= ada_exceptions_list_1 (regexp
!= NULL
? ®
: NULL
);
13094 if (old_chain
!= NULL
)
13095 do_cleanups (old_chain
);
13099 /* Implement the "info exceptions" command. */
13102 info_exceptions_command (char *regexp
, int from_tty
)
13104 VEC(ada_exc_info
) *exceptions
;
13105 struct cleanup
*cleanup
;
13106 struct gdbarch
*gdbarch
= get_current_arch ();
13108 struct ada_exc_info
*info
;
13110 exceptions
= ada_exceptions_list (regexp
);
13111 cleanup
= make_cleanup (VEC_cleanup (ada_exc_info
), &exceptions
);
13113 if (regexp
!= NULL
)
13115 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13117 printf_filtered (_("All defined Ada exceptions:\n"));
13119 for (ix
= 0; VEC_iterate(ada_exc_info
, exceptions
, ix
, info
); ix
++)
13120 printf_filtered ("%s: %s\n", info
->name
, paddress (gdbarch
, info
->addr
));
13122 do_cleanups (cleanup
);
13126 /* Information about operators given special treatment in functions
13128 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13130 #define ADA_OPERATORS \
13131 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13132 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13133 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13134 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13135 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13136 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13137 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13138 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13139 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13140 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13141 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13142 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13143 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13144 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13145 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13146 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13147 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13148 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13149 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13152 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13155 switch (exp
->elts
[pc
- 1].opcode
)
13158 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13161 #define OP_DEFN(op, len, args, binop) \
13162 case op: *oplenp = len; *argsp = args; break;
13168 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13173 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13178 /* Implementation of the exp_descriptor method operator_check. */
13181 ada_operator_check (struct expression
*exp
, int pos
,
13182 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13185 const union exp_element
*const elts
= exp
->elts
;
13186 struct type
*type
= NULL
;
13188 switch (elts
[pos
].opcode
)
13190 case UNOP_IN_RANGE
:
13192 type
= elts
[pos
+ 1].type
;
13196 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13199 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13201 if (type
&& TYPE_OBJFILE (type
)
13202 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13209 ada_op_name (enum exp_opcode opcode
)
13214 return op_name_standard (opcode
);
13216 #define OP_DEFN(op, len, args, binop) case op: return #op;
13221 return "OP_AGGREGATE";
13223 return "OP_CHOICES";
13229 /* As for operator_length, but assumes PC is pointing at the first
13230 element of the operator, and gives meaningful results only for the
13231 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13234 ada_forward_operator_length (struct expression
*exp
, int pc
,
13235 int *oplenp
, int *argsp
)
13237 switch (exp
->elts
[pc
].opcode
)
13240 *oplenp
= *argsp
= 0;
13243 #define OP_DEFN(op, len, args, binop) \
13244 case op: *oplenp = len; *argsp = args; break;
13250 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13255 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13261 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13263 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13271 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13273 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13278 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13282 /* Ada attributes ('Foo). */
13285 case OP_ATR_LENGTH
:
13289 case OP_ATR_MODULUS
:
13296 case UNOP_IN_RANGE
:
13298 /* XXX: gdb_sprint_host_address, type_sprint */
13299 fprintf_filtered (stream
, _("Type @"));
13300 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13301 fprintf_filtered (stream
, " (");
13302 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13303 fprintf_filtered (stream
, ")");
13305 case BINOP_IN_BOUNDS
:
13306 fprintf_filtered (stream
, " (%d)",
13307 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13309 case TERNOP_IN_RANGE
:
13314 case OP_DISCRETE_RANGE
:
13315 case OP_POSITIONAL
:
13322 char *name
= &exp
->elts
[elt
+ 2].string
;
13323 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13325 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13330 return dump_subexp_body_standard (exp
, stream
, elt
);
13334 for (i
= 0; i
< nargs
; i
+= 1)
13335 elt
= dump_subexp (exp
, stream
, elt
);
13340 /* The Ada extension of print_subexp (q.v.). */
13343 ada_print_subexp (struct expression
*exp
, int *pos
,
13344 struct ui_file
*stream
, enum precedence prec
)
13346 int oplen
, nargs
, i
;
13348 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13350 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13357 print_subexp_standard (exp
, pos
, stream
, prec
);
13361 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
13364 case BINOP_IN_BOUNDS
:
13365 /* XXX: sprint_subexp */
13366 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13367 fputs_filtered (" in ", stream
);
13368 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13369 fputs_filtered ("'range", stream
);
13370 if (exp
->elts
[pc
+ 1].longconst
> 1)
13371 fprintf_filtered (stream
, "(%ld)",
13372 (long) exp
->elts
[pc
+ 1].longconst
);
13375 case TERNOP_IN_RANGE
:
13376 if (prec
>= PREC_EQUAL
)
13377 fputs_filtered ("(", stream
);
13378 /* XXX: sprint_subexp */
13379 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13380 fputs_filtered (" in ", stream
);
13381 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13382 fputs_filtered (" .. ", stream
);
13383 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13384 if (prec
>= PREC_EQUAL
)
13385 fputs_filtered (")", stream
);
13390 case OP_ATR_LENGTH
:
13394 case OP_ATR_MODULUS
:
13399 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13401 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
13402 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13403 &type_print_raw_options
);
13407 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13408 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13413 for (tem
= 1; tem
< nargs
; tem
+= 1)
13415 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13416 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13418 fputs_filtered (")", stream
);
13423 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13424 fputs_filtered ("'(", stream
);
13425 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13426 fputs_filtered (")", stream
);
13429 case UNOP_IN_RANGE
:
13430 /* XXX: sprint_subexp */
13431 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13432 fputs_filtered (" in ", stream
);
13433 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13434 &type_print_raw_options
);
13437 case OP_DISCRETE_RANGE
:
13438 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13439 fputs_filtered ("..", stream
);
13440 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13444 fputs_filtered ("others => ", stream
);
13445 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13449 for (i
= 0; i
< nargs
-1; i
+= 1)
13452 fputs_filtered ("|", stream
);
13453 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13455 fputs_filtered (" => ", stream
);
13456 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13459 case OP_POSITIONAL
:
13460 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13464 fputs_filtered ("(", stream
);
13465 for (i
= 0; i
< nargs
; i
+= 1)
13468 fputs_filtered (", ", stream
);
13469 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13471 fputs_filtered (")", stream
);
13476 /* Table mapping opcodes into strings for printing operators
13477 and precedences of the operators. */
13479 static const struct op_print ada_op_print_tab
[] = {
13480 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13481 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13482 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13483 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13484 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13485 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13486 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13487 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13488 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13489 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13490 {">", BINOP_GTR
, PREC_ORDER
, 0},
13491 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13492 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13493 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13494 {"+", BINOP_ADD
, PREC_ADD
, 0},
13495 {"-", BINOP_SUB
, PREC_ADD
, 0},
13496 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13497 {"*", BINOP_MUL
, PREC_MUL
, 0},
13498 {"/", BINOP_DIV
, PREC_MUL
, 0},
13499 {"rem", BINOP_REM
, PREC_MUL
, 0},
13500 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13501 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13502 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13503 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13504 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13505 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13506 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13507 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13508 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13509 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13510 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13514 enum ada_primitive_types
{
13515 ada_primitive_type_int
,
13516 ada_primitive_type_long
,
13517 ada_primitive_type_short
,
13518 ada_primitive_type_char
,
13519 ada_primitive_type_float
,
13520 ada_primitive_type_double
,
13521 ada_primitive_type_void
,
13522 ada_primitive_type_long_long
,
13523 ada_primitive_type_long_double
,
13524 ada_primitive_type_natural
,
13525 ada_primitive_type_positive
,
13526 ada_primitive_type_system_address
,
13527 nr_ada_primitive_types
13531 ada_language_arch_info (struct gdbarch
*gdbarch
,
13532 struct language_arch_info
*lai
)
13534 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13536 lai
->primitive_type_vector
13537 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13540 lai
->primitive_type_vector
[ada_primitive_type_int
]
13541 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13543 lai
->primitive_type_vector
[ada_primitive_type_long
]
13544 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13545 0, "long_integer");
13546 lai
->primitive_type_vector
[ada_primitive_type_short
]
13547 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13548 0, "short_integer");
13549 lai
->string_char_type
13550 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13551 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13552 lai
->primitive_type_vector
[ada_primitive_type_float
]
13553 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13555 lai
->primitive_type_vector
[ada_primitive_type_double
]
13556 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13557 "long_float", NULL
);
13558 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13559 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13560 0, "long_long_integer");
13561 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13562 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13563 "long_long_float", NULL
);
13564 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13565 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13567 lai
->primitive_type_vector
[ada_primitive_type_positive
]
13568 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13570 lai
->primitive_type_vector
[ada_primitive_type_void
]
13571 = builtin
->builtin_void
;
13573 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13574 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, 1, "void"));
13575 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
13576 = "system__address";
13578 lai
->bool_type_symbol
= NULL
;
13579 lai
->bool_type_default
= builtin
->builtin_bool
;
13582 /* Language vector */
13584 /* Not really used, but needed in the ada_language_defn. */
13587 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13589 ada_emit_char (c
, type
, stream
, quoter
, 1);
13593 parse (struct parser_state
*ps
)
13595 warnings_issued
= 0;
13596 return ada_parse (ps
);
13599 static const struct exp_descriptor ada_exp_descriptor
= {
13601 ada_operator_length
,
13602 ada_operator_check
,
13604 ada_dump_subexp_body
,
13605 ada_evaluate_subexp
13608 /* Implement the "la_get_symbol_name_cmp" language_defn method
13611 static symbol_name_cmp_ftype
13612 ada_get_symbol_name_cmp (const char *lookup_name
)
13614 if (should_use_wild_match (lookup_name
))
13617 return compare_names
;
13620 /* Implement the "la_read_var_value" language_defn method for Ada. */
13622 static struct value
*
13623 ada_read_var_value (struct symbol
*var
, struct frame_info
*frame
)
13625 const struct block
*frame_block
= NULL
;
13626 struct symbol
*renaming_sym
= NULL
;
13628 /* The only case where default_read_var_value is not sufficient
13629 is when VAR is a renaming... */
13631 frame_block
= get_frame_block (frame
, NULL
);
13633 renaming_sym
= ada_find_renaming_symbol (var
, frame_block
);
13634 if (renaming_sym
!= NULL
)
13635 return ada_read_renaming_var_value (renaming_sym
, frame_block
);
13637 /* This is a typical case where we expect the default_read_var_value
13638 function to work. */
13639 return default_read_var_value (var
, frame
);
13642 const struct language_defn ada_language_defn
= {
13643 "ada", /* Language name */
13647 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13648 that's not quite what this means. */
13650 macro_expansion_no
,
13651 &ada_exp_descriptor
,
13655 ada_printchar
, /* Print a character constant */
13656 ada_printstr
, /* Function to print string constant */
13657 emit_char
, /* Function to print single char (not used) */
13658 ada_print_type
, /* Print a type using appropriate syntax */
13659 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13660 ada_val_print
, /* Print a value using appropriate syntax */
13661 ada_value_print
, /* Print a top-level value */
13662 ada_read_var_value
, /* la_read_var_value */
13663 NULL
, /* Language specific skip_trampoline */
13664 NULL
, /* name_of_this */
13665 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13666 basic_lookup_transparent_type
, /* lookup_transparent_type */
13667 ada_la_decode
, /* Language specific symbol demangler */
13668 NULL
, /* Language specific
13669 class_name_from_physname */
13670 ada_op_print_tab
, /* expression operators for printing */
13671 0, /* c-style arrays */
13672 1, /* String lower bound */
13673 ada_get_gdb_completer_word_break_characters
,
13674 ada_make_symbol_completion_list
,
13675 ada_language_arch_info
,
13676 ada_print_array_index
,
13677 default_pass_by_reference
,
13679 ada_get_symbol_name_cmp
, /* la_get_symbol_name_cmp */
13680 ada_iterate_over_symbols
,
13687 /* Provide a prototype to silence -Wmissing-prototypes. */
13688 extern initialize_file_ftype _initialize_ada_language
;
13690 /* Command-list for the "set/show ada" prefix command. */
13691 static struct cmd_list_element
*set_ada_list
;
13692 static struct cmd_list_element
*show_ada_list
;
13694 /* Implement the "set ada" prefix command. */
13697 set_ada_command (char *arg
, int from_tty
)
13699 printf_unfiltered (_(\
13700 "\"set ada\" must be followed by the name of a setting.\n"));
13701 help_list (set_ada_list
, "set ada ", all_commands
, gdb_stdout
);
13704 /* Implement the "show ada" prefix command. */
13707 show_ada_command (char *args
, int from_tty
)
13709 cmd_show_list (show_ada_list
, from_tty
, "");
13713 initialize_ada_catchpoint_ops (void)
13715 struct breakpoint_ops
*ops
;
13717 initialize_breakpoint_ops ();
13719 ops
= &catch_exception_breakpoint_ops
;
13720 *ops
= bkpt_breakpoint_ops
;
13721 ops
->dtor
= dtor_catch_exception
;
13722 ops
->allocate_location
= allocate_location_catch_exception
;
13723 ops
->re_set
= re_set_catch_exception
;
13724 ops
->check_status
= check_status_catch_exception
;
13725 ops
->print_it
= print_it_catch_exception
;
13726 ops
->print_one
= print_one_catch_exception
;
13727 ops
->print_mention
= print_mention_catch_exception
;
13728 ops
->print_recreate
= print_recreate_catch_exception
;
13730 ops
= &catch_exception_unhandled_breakpoint_ops
;
13731 *ops
= bkpt_breakpoint_ops
;
13732 ops
->dtor
= dtor_catch_exception_unhandled
;
13733 ops
->allocate_location
= allocate_location_catch_exception_unhandled
;
13734 ops
->re_set
= re_set_catch_exception_unhandled
;
13735 ops
->check_status
= check_status_catch_exception_unhandled
;
13736 ops
->print_it
= print_it_catch_exception_unhandled
;
13737 ops
->print_one
= print_one_catch_exception_unhandled
;
13738 ops
->print_mention
= print_mention_catch_exception_unhandled
;
13739 ops
->print_recreate
= print_recreate_catch_exception_unhandled
;
13741 ops
= &catch_assert_breakpoint_ops
;
13742 *ops
= bkpt_breakpoint_ops
;
13743 ops
->dtor
= dtor_catch_assert
;
13744 ops
->allocate_location
= allocate_location_catch_assert
;
13745 ops
->re_set
= re_set_catch_assert
;
13746 ops
->check_status
= check_status_catch_assert
;
13747 ops
->print_it
= print_it_catch_assert
;
13748 ops
->print_one
= print_one_catch_assert
;
13749 ops
->print_mention
= print_mention_catch_assert
;
13750 ops
->print_recreate
= print_recreate_catch_assert
;
13753 /* This module's 'new_objfile' observer. */
13756 ada_new_objfile_observer (struct objfile
*objfile
)
13758 ada_clear_symbol_cache ();
13761 /* This module's 'free_objfile' observer. */
13764 ada_free_objfile_observer (struct objfile
*objfile
)
13766 ada_clear_symbol_cache ();
13770 _initialize_ada_language (void)
13772 add_language (&ada_language_defn
);
13774 initialize_ada_catchpoint_ops ();
13776 add_prefix_cmd ("ada", no_class
, set_ada_command
,
13777 _("Prefix command for changing Ada-specfic settings"),
13778 &set_ada_list
, "set ada ", 0, &setlist
);
13780 add_prefix_cmd ("ada", no_class
, show_ada_command
,
13781 _("Generic command for showing Ada-specific settings."),
13782 &show_ada_list
, "show ada ", 0, &showlist
);
13784 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
13785 &trust_pad_over_xvs
, _("\
13786 Enable or disable an optimization trusting PAD types over XVS types"), _("\
13787 Show whether an optimization trusting PAD types over XVS types is activated"),
13789 This is related to the encoding used by the GNAT compiler. The debugger\n\
13790 should normally trust the contents of PAD types, but certain older versions\n\
13791 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13792 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13793 work around this bug. It is always safe to turn this option \"off\", but\n\
13794 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13795 this option to \"off\" unless necessary."),
13796 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
13798 add_catch_command ("exception", _("\
13799 Catch Ada exceptions, when raised.\n\
13800 With an argument, catch only exceptions with the given name."),
13801 catch_ada_exception_command
,
13805 add_catch_command ("assert", _("\
13806 Catch failed Ada assertions, when raised.\n\
13807 With an argument, catch only exceptions with the given name."),
13808 catch_assert_command
,
13813 varsize_limit
= 65536;
13815 add_info ("exceptions", info_exceptions_command
,
13817 List all Ada exception names.\n\
13818 If a regular expression is passed as an argument, only those matching\n\
13819 the regular expression are listed."));
13821 add_prefix_cmd ("ada", class_maintenance
, maint_set_ada_cmd
,
13822 _("Set Ada maintenance-related variables."),
13823 &maint_set_ada_cmdlist
, "maintenance set ada ",
13824 0/*allow-unknown*/, &maintenance_set_cmdlist
);
13826 add_prefix_cmd ("ada", class_maintenance
, maint_show_ada_cmd
,
13827 _("Show Ada maintenance-related variables"),
13828 &maint_show_ada_cmdlist
, "maintenance show ada ",
13829 0/*allow-unknown*/, &maintenance_show_cmdlist
);
13831 add_setshow_boolean_cmd
13832 ("ignore-descriptive-types", class_maintenance
,
13833 &ada_ignore_descriptive_types_p
,
13834 _("Set whether descriptive types generated by GNAT should be ignored."),
13835 _("Show whether descriptive types generated by GNAT should be ignored."),
13837 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13838 DWARF attribute."),
13839 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
13841 obstack_init (&symbol_list_obstack
);
13843 decoded_names_store
= htab_create_alloc
13844 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
13845 NULL
, xcalloc
, xfree
);
13847 /* The ada-lang observers. */
13848 observer_attach_new_objfile (ada_new_objfile_observer
);
13849 observer_attach_free_objfile (ada_free_objfile_observer
);
13850 observer_attach_inferior_exit (ada_inferior_exit
);
13852 /* Setup various context-specific data. */
13854 = register_inferior_data_with_cleanup (NULL
, ada_inferior_data_cleanup
);
13855 ada_pspace_data_handle
13856 = register_program_space_data_with_cleanup (NULL
, ada_pspace_data_cleanup
);