1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2019 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"
51 #include "observable.h"
52 #include "common/vec.h"
54 #include "common/gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/byte-vector.h"
68 /* Define whether or not the C operator '/' truncates towards zero for
69 differently signed operands (truncation direction is undefined in C).
70 Copied from valarith.c. */
72 #ifndef TRUNCATION_TOWARDS_ZERO
73 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
76 static struct type
*desc_base_type (struct type
*);
78 static struct type
*desc_bounds_type (struct type
*);
80 static struct value
*desc_bounds (struct value
*);
82 static int fat_pntr_bounds_bitpos (struct type
*);
84 static int fat_pntr_bounds_bitsize (struct type
*);
86 static struct type
*desc_data_target_type (struct type
*);
88 static struct value
*desc_data (struct value
*);
90 static int fat_pntr_data_bitpos (struct type
*);
92 static int fat_pntr_data_bitsize (struct type
*);
94 static struct value
*desc_one_bound (struct value
*, int, int);
96 static int desc_bound_bitpos (struct type
*, int, int);
98 static int desc_bound_bitsize (struct type
*, int, int);
100 static struct type
*desc_index_type (struct type
*, int);
102 static int desc_arity (struct type
*);
104 static int ada_type_match (struct type
*, struct type
*, int);
106 static int ada_args_match (struct symbol
*, struct value
**, int);
108 static struct value
*make_array_descriptor (struct type
*, struct value
*);
110 static void ada_add_block_symbols (struct obstack
*,
111 const struct block
*,
112 const lookup_name_info
&lookup_name
,
113 domain_enum
, struct objfile
*);
115 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
116 const lookup_name_info
&lookup_name
,
117 domain_enum
, int, int *);
119 static int is_nonfunction (struct block_symbol
*, int);
121 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
122 const struct block
*);
124 static int num_defns_collected (struct obstack
*);
126 static struct block_symbol
*defns_collected (struct obstack
*, int);
128 static struct value
*resolve_subexp (expression_up
*, int *, int,
130 innermost_block_tracker
*);
132 static void replace_operator_with_call (expression_up
*, int, int, int,
133 struct symbol
*, const struct block
*);
135 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
137 static const char *ada_op_name (enum exp_opcode
);
139 static const char *ada_decoded_op_name (enum exp_opcode
);
141 static int numeric_type_p (struct type
*);
143 static int integer_type_p (struct type
*);
145 static int scalar_type_p (struct type
*);
147 static int discrete_type_p (struct type
*);
149 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
152 static struct value
*evaluate_subexp_type (struct expression
*, int *);
154 static struct type
*ada_find_parallel_type_with_name (struct type
*,
157 static int is_dynamic_field (struct type
*, int);
159 static struct type
*to_fixed_variant_branch_type (struct type
*,
161 CORE_ADDR
, struct value
*);
163 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
165 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
167 static struct type
*to_static_fixed_type (struct type
*);
168 static struct type
*static_unwrap_type (struct type
*type
);
170 static struct value
*unwrap_value (struct value
*);
172 static struct type
*constrained_packed_array_type (struct type
*, long *);
174 static struct type
*decode_constrained_packed_array_type (struct type
*);
176 static long decode_packed_array_bitsize (struct type
*);
178 static struct value
*decode_constrained_packed_array (struct value
*);
180 static int ada_is_packed_array_type (struct type
*);
182 static int ada_is_unconstrained_packed_array_type (struct type
*);
184 static struct value
*value_subscript_packed (struct value
*, int,
187 static struct value
*coerce_unspec_val_to_type (struct value
*,
190 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
192 static int equiv_types (struct type
*, struct type
*);
194 static int is_name_suffix (const char *);
196 static int advance_wild_match (const char **, const char *, int);
198 static bool wild_match (const char *name
, const char *patn
);
200 static struct value
*ada_coerce_ref (struct value
*);
202 static LONGEST
pos_atr (struct value
*);
204 static struct value
*value_pos_atr (struct type
*, struct value
*);
206 static struct value
*value_val_atr (struct type
*, struct value
*);
208 static struct symbol
*standard_lookup (const char *, const struct block
*,
211 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
214 static struct value
*ada_value_primitive_field (struct value
*, int, int,
217 static int find_struct_field (const char *, struct type
*, int,
218 struct type
**, int *, int *, int *, int *);
220 static int ada_resolve_function (struct block_symbol
*, int,
221 struct value
**, int, const char *,
224 static int ada_is_direct_array_type (struct type
*);
226 static void ada_language_arch_info (struct gdbarch
*,
227 struct language_arch_info
*);
229 static struct value
*ada_index_struct_field (int, struct value
*, int,
232 static struct value
*assign_aggregate (struct value
*, struct value
*,
236 static void aggregate_assign_from_choices (struct value
*, struct value
*,
238 int *, LONGEST
*, int *,
239 int, LONGEST
, LONGEST
);
241 static void aggregate_assign_positional (struct value
*, struct value
*,
243 int *, LONGEST
*, int *, int,
247 static void aggregate_assign_others (struct value
*, struct value
*,
249 int *, LONGEST
*, int, LONGEST
, LONGEST
);
252 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
255 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
258 static void ada_forward_operator_length (struct expression
*, int, int *,
261 static struct type
*ada_find_any_type (const char *name
);
263 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
264 (const lookup_name_info
&lookup_name
);
268 /* The result of a symbol lookup to be stored in our symbol cache. */
272 /* The name used to perform the lookup. */
274 /* The namespace used during the lookup. */
276 /* The symbol returned by the lookup, or NULL if no matching symbol
279 /* The block where the symbol was found, or NULL if no matching
281 const struct block
*block
;
282 /* A pointer to the next entry with the same hash. */
283 struct cache_entry
*next
;
286 /* The Ada symbol cache, used to store the result of Ada-mode symbol
287 lookups in the course of executing the user's commands.
289 The cache is implemented using a simple, fixed-sized hash.
290 The size is fixed on the grounds that there are not likely to be
291 all that many symbols looked up during any given session, regardless
292 of the size of the symbol table. If we decide to go to a resizable
293 table, let's just use the stuff from libiberty instead. */
295 #define HASH_SIZE 1009
297 struct ada_symbol_cache
299 /* An obstack used to store the entries in our cache. */
300 struct obstack cache_space
;
302 /* The root of the hash table used to implement our symbol cache. */
303 struct cache_entry
*root
[HASH_SIZE
];
306 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
308 /* Maximum-sized dynamic type. */
309 static unsigned int varsize_limit
;
311 static const char ada_completer_word_break_characters
[] =
313 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
315 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
318 /* The name of the symbol to use to get the name of the main subprogram. */
319 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
320 = "__gnat_ada_main_program_name";
322 /* Limit on the number of warnings to raise per expression evaluation. */
323 static int warning_limit
= 2;
325 /* Number of warning messages issued; reset to 0 by cleanups after
326 expression evaluation. */
327 static int warnings_issued
= 0;
329 static const char *known_runtime_file_name_patterns
[] = {
330 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
333 static const char *known_auxiliary_function_name_patterns
[] = {
334 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
337 /* Maintenance-related settings for this module. */
339 static struct cmd_list_element
*maint_set_ada_cmdlist
;
340 static struct cmd_list_element
*maint_show_ada_cmdlist
;
342 /* Implement the "maintenance set ada" (prefix) command. */
345 maint_set_ada_cmd (const char *args
, int from_tty
)
347 help_list (maint_set_ada_cmdlist
, "maintenance set ada ", all_commands
,
351 /* Implement the "maintenance show ada" (prefix) command. */
354 maint_show_ada_cmd (const char *args
, int from_tty
)
356 cmd_show_list (maint_show_ada_cmdlist
, from_tty
, "");
359 /* The "maintenance ada set/show ignore-descriptive-type" value. */
361 static int ada_ignore_descriptive_types_p
= 0;
363 /* Inferior-specific data. */
365 /* Per-inferior data for this module. */
367 struct ada_inferior_data
369 /* The ada__tags__type_specific_data type, which is used when decoding
370 tagged types. With older versions of GNAT, this type was directly
371 accessible through a component ("tsd") in the object tag. But this
372 is no longer the case, so we cache it for each inferior. */
373 struct type
*tsd_type
= nullptr;
375 /* The exception_support_info data. This data is used to determine
376 how to implement support for Ada exception catchpoints in a given
378 const struct exception_support_info
*exception_info
= nullptr;
381 /* Our key to this module's inferior data. */
382 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
384 /* Return our inferior data for the given inferior (INF).
386 This function always returns a valid pointer to an allocated
387 ada_inferior_data structure. If INF's inferior data has not
388 been previously set, this functions creates a new one with all
389 fields set to zero, sets INF's inferior to it, and then returns
390 a pointer to that newly allocated ada_inferior_data. */
392 static struct ada_inferior_data
*
393 get_ada_inferior_data (struct inferior
*inf
)
395 struct ada_inferior_data
*data
;
397 data
= ada_inferior_data
.get (inf
);
399 data
= ada_inferior_data
.emplace (inf
);
404 /* Perform all necessary cleanups regarding our module's inferior data
405 that is required after the inferior INF just exited. */
408 ada_inferior_exit (struct inferior
*inf
)
410 ada_inferior_data
.clear (inf
);
414 /* program-space-specific data. */
416 /* This module's per-program-space data. */
417 struct ada_pspace_data
421 if (sym_cache
!= NULL
)
422 ada_free_symbol_cache (sym_cache
);
425 /* The Ada symbol cache. */
426 struct ada_symbol_cache
*sym_cache
= nullptr;
429 /* Key to our per-program-space data. */
430 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
432 /* Return this module's data for the given program space (PSPACE).
433 If not is found, add a zero'ed one now.
435 This function always returns a valid object. */
437 static struct ada_pspace_data
*
438 get_ada_pspace_data (struct program_space
*pspace
)
440 struct ada_pspace_data
*data
;
442 data
= ada_pspace_data_handle
.get (pspace
);
444 data
= ada_pspace_data_handle
.emplace (pspace
);
451 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
452 all typedef layers have been peeled. Otherwise, return TYPE.
454 Normally, we really expect a typedef type to only have 1 typedef layer.
455 In other words, we really expect the target type of a typedef type to be
456 a non-typedef type. This is particularly true for Ada units, because
457 the language does not have a typedef vs not-typedef distinction.
458 In that respect, the Ada compiler has been trying to eliminate as many
459 typedef definitions in the debugging information, since they generally
460 do not bring any extra information (we still use typedef under certain
461 circumstances related mostly to the GNAT encoding).
463 Unfortunately, we have seen situations where the debugging information
464 generated by the compiler leads to such multiple typedef layers. For
465 instance, consider the following example with stabs:
467 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
468 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
470 This is an error in the debugging information which causes type
471 pck__float_array___XUP to be defined twice, and the second time,
472 it is defined as a typedef of a typedef.
474 This is on the fringe of legality as far as debugging information is
475 concerned, and certainly unexpected. But it is easy to handle these
476 situations correctly, so we can afford to be lenient in this case. */
479 ada_typedef_target_type (struct type
*type
)
481 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
482 type
= TYPE_TARGET_TYPE (type
);
486 /* Given DECODED_NAME a string holding a symbol name in its
487 decoded form (ie using the Ada dotted notation), returns
488 its unqualified name. */
491 ada_unqualified_name (const char *decoded_name
)
495 /* If the decoded name starts with '<', it means that the encoded
496 name does not follow standard naming conventions, and thus that
497 it is not your typical Ada symbol name. Trying to unqualify it
498 is therefore pointless and possibly erroneous. */
499 if (decoded_name
[0] == '<')
502 result
= strrchr (decoded_name
, '.');
504 result
++; /* Skip the dot... */
506 result
= decoded_name
;
511 /* Return a string starting with '<', followed by STR, and '>'. */
514 add_angle_brackets (const char *str
)
516 return string_printf ("<%s>", str
);
520 ada_get_gdb_completer_word_break_characters (void)
522 return ada_completer_word_break_characters
;
525 /* Print an array element index using the Ada syntax. */
528 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
529 const struct value_print_options
*options
)
531 LA_VALUE_PRINT (index_value
, stream
, options
);
532 fprintf_filtered (stream
, " => ");
535 /* la_watch_location_expression for Ada. */
537 gdb::unique_xmalloc_ptr
<char>
538 ada_watch_location_expression (struct type
*type
, CORE_ADDR addr
)
540 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
541 std::string name
= type_to_string (type
);
542 return gdb::unique_xmalloc_ptr
<char>
543 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
546 /* Assuming VECT points to an array of *SIZE objects of size
547 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
548 updating *SIZE as necessary and returning the (new) array. */
551 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
553 if (*size
< min_size
)
556 if (*size
< min_size
)
558 vect
= xrealloc (vect
, *size
* element_size
);
563 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
564 suffix of FIELD_NAME beginning "___". */
567 field_name_match (const char *field_name
, const char *target
)
569 int len
= strlen (target
);
572 (strncmp (field_name
, target
, len
) == 0
573 && (field_name
[len
] == '\0'
574 || (startswith (field_name
+ len
, "___")
575 && strcmp (field_name
+ strlen (field_name
) - 6,
580 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
581 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
582 and return its index. This function also handles fields whose name
583 have ___ suffixes because the compiler sometimes alters their name
584 by adding such a suffix to represent fields with certain constraints.
585 If the field could not be found, return a negative number if
586 MAYBE_MISSING is set. Otherwise raise an error. */
589 ada_get_field_index (const struct type
*type
, const char *field_name
,
593 struct type
*struct_type
= check_typedef ((struct type
*) type
);
595 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
596 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
600 error (_("Unable to find field %s in struct %s. Aborting"),
601 field_name
, TYPE_NAME (struct_type
));
606 /* The length of the prefix of NAME prior to any "___" suffix. */
609 ada_name_prefix_len (const char *name
)
615 const char *p
= strstr (name
, "___");
618 return strlen (name
);
624 /* Return non-zero if SUFFIX is a suffix of STR.
625 Return zero if STR is null. */
628 is_suffix (const char *str
, const char *suffix
)
635 len2
= strlen (suffix
);
636 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
639 /* The contents of value VAL, treated as a value of type TYPE. The
640 result is an lval in memory if VAL is. */
642 static struct value
*
643 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
645 type
= ada_check_typedef (type
);
646 if (value_type (val
) == type
)
650 struct value
*result
;
652 /* Make sure that the object size is not unreasonable before
653 trying to allocate some memory for it. */
654 ada_ensure_varsize_limit (type
);
657 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
658 result
= allocate_value_lazy (type
);
661 result
= allocate_value (type
);
662 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
664 set_value_component_location (result
, val
);
665 set_value_bitsize (result
, value_bitsize (val
));
666 set_value_bitpos (result
, value_bitpos (val
));
667 if (VALUE_LVAL (result
) == lval_memory
)
668 set_value_address (result
, value_address (val
));
673 static const gdb_byte
*
674 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
679 return valaddr
+ offset
;
683 cond_offset_target (CORE_ADDR address
, long offset
)
688 return address
+ offset
;
691 /* Issue a warning (as for the definition of warning in utils.c, but
692 with exactly one argument rather than ...), unless the limit on the
693 number of warnings has passed during the evaluation of the current
696 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
697 provided by "complaint". */
698 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
701 lim_warning (const char *format
, ...)
705 va_start (args
, format
);
706 warnings_issued
+= 1;
707 if (warnings_issued
<= warning_limit
)
708 vwarning (format
, args
);
713 /* Issue an error if the size of an object of type T is unreasonable,
714 i.e. if it would be a bad idea to allocate a value of this type in
718 ada_ensure_varsize_limit (const struct type
*type
)
720 if (TYPE_LENGTH (type
) > varsize_limit
)
721 error (_("object size is larger than varsize-limit"));
724 /* Maximum value of a SIZE-byte signed integer type. */
726 max_of_size (int size
)
728 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
730 return top_bit
| (top_bit
- 1);
733 /* Minimum value of a SIZE-byte signed integer type. */
735 min_of_size (int size
)
737 return -max_of_size (size
) - 1;
740 /* Maximum value of a SIZE-byte unsigned integer type. */
742 umax_of_size (int size
)
744 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
746 return top_bit
| (top_bit
- 1);
749 /* Maximum value of integral type T, as a signed quantity. */
751 max_of_type (struct type
*t
)
753 if (TYPE_UNSIGNED (t
))
754 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
756 return max_of_size (TYPE_LENGTH (t
));
759 /* Minimum value of integral type T, as a signed quantity. */
761 min_of_type (struct type
*t
)
763 if (TYPE_UNSIGNED (t
))
766 return min_of_size (TYPE_LENGTH (t
));
769 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
771 ada_discrete_type_high_bound (struct type
*type
)
773 type
= resolve_dynamic_type (type
, NULL
, 0);
774 switch (TYPE_CODE (type
))
776 case TYPE_CODE_RANGE
:
777 return TYPE_HIGH_BOUND (type
);
779 return TYPE_FIELD_ENUMVAL (type
, TYPE_NFIELDS (type
) - 1);
784 return max_of_type (type
);
786 error (_("Unexpected type in ada_discrete_type_high_bound."));
790 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
792 ada_discrete_type_low_bound (struct type
*type
)
794 type
= resolve_dynamic_type (type
, NULL
, 0);
795 switch (TYPE_CODE (type
))
797 case TYPE_CODE_RANGE
:
798 return TYPE_LOW_BOUND (type
);
800 return TYPE_FIELD_ENUMVAL (type
, 0);
805 return min_of_type (type
);
807 error (_("Unexpected type in ada_discrete_type_low_bound."));
811 /* The identity on non-range types. For range types, the underlying
812 non-range scalar type. */
815 get_base_type (struct type
*type
)
817 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
819 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
821 type
= TYPE_TARGET_TYPE (type
);
826 /* Return a decoded version of the given VALUE. This means returning
827 a value whose type is obtained by applying all the GNAT-specific
828 encondings, making the resulting type a static but standard description
829 of the initial type. */
832 ada_get_decoded_value (struct value
*value
)
834 struct type
*type
= ada_check_typedef (value_type (value
));
836 if (ada_is_array_descriptor_type (type
)
837 || (ada_is_constrained_packed_array_type (type
)
838 && TYPE_CODE (type
) != TYPE_CODE_PTR
))
840 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
) /* array access type. */
841 value
= ada_coerce_to_simple_array_ptr (value
);
843 value
= ada_coerce_to_simple_array (value
);
846 value
= ada_to_fixed_value (value
);
851 /* Same as ada_get_decoded_value, but with the given TYPE.
852 Because there is no associated actual value for this type,
853 the resulting type might be a best-effort approximation in
854 the case of dynamic types. */
857 ada_get_decoded_type (struct type
*type
)
859 type
= to_static_fixed_type (type
);
860 if (ada_is_constrained_packed_array_type (type
))
861 type
= ada_coerce_to_simple_array_type (type
);
867 /* Language Selection */
869 /* If the main program is in Ada, return language_ada, otherwise return LANG
870 (the main program is in Ada iif the adainit symbol is found). */
873 ada_update_initial_language (enum language lang
)
875 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
876 (struct objfile
*) NULL
).minsym
!= NULL
)
882 /* If the main procedure is written in Ada, then return its name.
883 The result is good until the next call. Return NULL if the main
884 procedure doesn't appear to be in Ada. */
889 struct bound_minimal_symbol msym
;
890 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
892 /* For Ada, the name of the main procedure is stored in a specific
893 string constant, generated by the binder. Look for that symbol,
894 extract its address, and then read that string. If we didn't find
895 that string, then most probably the main procedure is not written
897 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
899 if (msym
.minsym
!= NULL
)
901 CORE_ADDR main_program_name_addr
;
904 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
905 if (main_program_name_addr
== 0)
906 error (_("Invalid address for Ada main program name."));
908 target_read_string (main_program_name_addr
, &main_program_name
,
913 return main_program_name
.get ();
916 /* The main procedure doesn't seem to be in Ada. */
922 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
925 const struct ada_opname_map ada_opname_table
[] = {
926 {"Oadd", "\"+\"", BINOP_ADD
},
927 {"Osubtract", "\"-\"", BINOP_SUB
},
928 {"Omultiply", "\"*\"", BINOP_MUL
},
929 {"Odivide", "\"/\"", BINOP_DIV
},
930 {"Omod", "\"mod\"", BINOP_MOD
},
931 {"Orem", "\"rem\"", BINOP_REM
},
932 {"Oexpon", "\"**\"", BINOP_EXP
},
933 {"Olt", "\"<\"", BINOP_LESS
},
934 {"Ole", "\"<=\"", BINOP_LEQ
},
935 {"Ogt", "\">\"", BINOP_GTR
},
936 {"Oge", "\">=\"", BINOP_GEQ
},
937 {"Oeq", "\"=\"", BINOP_EQUAL
},
938 {"One", "\"/=\"", BINOP_NOTEQUAL
},
939 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
940 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
941 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
942 {"Oconcat", "\"&\"", BINOP_CONCAT
},
943 {"Oabs", "\"abs\"", UNOP_ABS
},
944 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
945 {"Oadd", "\"+\"", UNOP_PLUS
},
946 {"Osubtract", "\"-\"", UNOP_NEG
},
950 /* The "encoded" form of DECODED, according to GNAT conventions. The
951 result is valid until the next call to ada_encode. If
952 THROW_ERRORS, throw an error if invalid operator name is found.
953 Otherwise, return NULL in that case. */
956 ada_encode_1 (const char *decoded
, bool throw_errors
)
958 static char *encoding_buffer
= NULL
;
959 static size_t encoding_buffer_size
= 0;
966 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
967 2 * strlen (decoded
) + 10);
970 for (p
= decoded
; *p
!= '\0'; p
+= 1)
974 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
979 const struct ada_opname_map
*mapping
;
981 for (mapping
= ada_opname_table
;
982 mapping
->encoded
!= NULL
983 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
985 if (mapping
->encoded
== NULL
)
988 error (_("invalid Ada operator name: %s"), p
);
992 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
993 k
+= strlen (mapping
->encoded
);
998 encoding_buffer
[k
] = *p
;
1003 encoding_buffer
[k
] = '\0';
1004 return encoding_buffer
;
1007 /* The "encoded" form of DECODED, according to GNAT conventions.
1008 The result is valid until the next call to ada_encode. */
1011 ada_encode (const char *decoded
)
1013 return ada_encode_1 (decoded
, true);
1016 /* Return NAME folded to lower case, or, if surrounded by single
1017 quotes, unfolded, but with the quotes stripped away. Result good
1021 ada_fold_name (const char *name
)
1023 static char *fold_buffer
= NULL
;
1024 static size_t fold_buffer_size
= 0;
1026 int len
= strlen (name
);
1027 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
1029 if (name
[0] == '\'')
1031 strncpy (fold_buffer
, name
+ 1, len
- 2);
1032 fold_buffer
[len
- 2] = '\000';
1038 for (i
= 0; i
<= len
; i
+= 1)
1039 fold_buffer
[i
] = tolower (name
[i
]);
1045 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1048 is_lower_alphanum (const char c
)
1050 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1053 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1054 This function saves in LEN the length of that same symbol name but
1055 without either of these suffixes:
1061 These are suffixes introduced by the compiler for entities such as
1062 nested subprogram for instance, in order to avoid name clashes.
1063 They do not serve any purpose for the debugger. */
1066 ada_remove_trailing_digits (const char *encoded
, int *len
)
1068 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1072 while (i
> 0 && isdigit (encoded
[i
]))
1074 if (i
>= 0 && encoded
[i
] == '.')
1076 else if (i
>= 0 && encoded
[i
] == '$')
1078 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1080 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1085 /* Remove the suffix introduced by the compiler for protected object
1089 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1091 /* Remove trailing N. */
1093 /* Protected entry subprograms are broken into two
1094 separate subprograms: The first one is unprotected, and has
1095 a 'N' suffix; the second is the protected version, and has
1096 the 'P' suffix. The second calls the first one after handling
1097 the protection. Since the P subprograms are internally generated,
1098 we leave these names undecoded, giving the user a clue that this
1099 entity is internal. */
1102 && encoded
[*len
- 1] == 'N'
1103 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1107 /* If ENCODED follows the GNAT entity encoding conventions, then return
1108 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1109 replaced by ENCODED.
1111 The resulting string is valid until the next call of ada_decode.
1112 If the string is unchanged by decoding, the original string pointer
1116 ada_decode (const char *encoded
)
1123 static char *decoding_buffer
= NULL
;
1124 static size_t decoding_buffer_size
= 0;
1126 /* With function descriptors on PPC64, the value of a symbol named
1127 ".FN", if it exists, is the entry point of the function "FN". */
1128 if (encoded
[0] == '.')
1131 /* The name of the Ada main procedure starts with "_ada_".
1132 This prefix is not part of the decoded name, so skip this part
1133 if we see this prefix. */
1134 if (startswith (encoded
, "_ada_"))
1137 /* If the name starts with '_', then it is not a properly encoded
1138 name, so do not attempt to decode it. Similarly, if the name
1139 starts with '<', the name should not be decoded. */
1140 if (encoded
[0] == '_' || encoded
[0] == '<')
1143 len0
= strlen (encoded
);
1145 ada_remove_trailing_digits (encoded
, &len0
);
1146 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1148 /* Remove the ___X.* suffix if present. Do not forget to verify that
1149 the suffix is located before the current "end" of ENCODED. We want
1150 to avoid re-matching parts of ENCODED that have previously been
1151 marked as discarded (by decrementing LEN0). */
1152 p
= strstr (encoded
, "___");
1153 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1161 /* Remove any trailing TKB suffix. It tells us that this symbol
1162 is for the body of a task, but that information does not actually
1163 appear in the decoded name. */
1165 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1168 /* Remove any trailing TB suffix. The TB suffix is slightly different
1169 from the TKB suffix because it is used for non-anonymous task
1172 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1175 /* Remove trailing "B" suffixes. */
1176 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1178 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1181 /* Make decoded big enough for possible expansion by operator name. */
1183 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1184 decoded
= decoding_buffer
;
1186 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1188 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1191 while ((i
>= 0 && isdigit (encoded
[i
]))
1192 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1194 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1196 else if (encoded
[i
] == '$')
1200 /* The first few characters that are not alphabetic are not part
1201 of any encoding we use, so we can copy them over verbatim. */
1203 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1204 decoded
[j
] = encoded
[i
];
1209 /* Is this a symbol function? */
1210 if (at_start_name
&& encoded
[i
] == 'O')
1214 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1216 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1217 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1219 && !isalnum (encoded
[i
+ op_len
]))
1221 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1224 j
+= strlen (ada_opname_table
[k
].decoded
);
1228 if (ada_opname_table
[k
].encoded
!= NULL
)
1233 /* Replace "TK__" with "__", which will eventually be translated
1234 into "." (just below). */
1236 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1239 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1240 be translated into "." (just below). These are internal names
1241 generated for anonymous blocks inside which our symbol is nested. */
1243 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1244 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1245 && isdigit (encoded
[i
+4]))
1249 while (k
< len0
&& isdigit (encoded
[k
]))
1250 k
++; /* Skip any extra digit. */
1252 /* Double-check that the "__B_{DIGITS}+" sequence we found
1253 is indeed followed by "__". */
1254 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1258 /* Remove _E{DIGITS}+[sb] */
1260 /* Just as for protected object subprograms, there are 2 categories
1261 of subprograms created by the compiler for each entry. The first
1262 one implements the actual entry code, and has a suffix following
1263 the convention above; the second one implements the barrier and
1264 uses the same convention as above, except that the 'E' is replaced
1267 Just as above, we do not decode the name of barrier functions
1268 to give the user a clue that the code he is debugging has been
1269 internally generated. */
1271 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1272 && isdigit (encoded
[i
+2]))
1276 while (k
< len0
&& isdigit (encoded
[k
]))
1280 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1283 /* Just as an extra precaution, make sure that if this
1284 suffix is followed by anything else, it is a '_'.
1285 Otherwise, we matched this sequence by accident. */
1287 || (k
< len0
&& encoded
[k
] == '_'))
1292 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1293 the GNAT front-end in protected object subprograms. */
1296 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1298 /* Backtrack a bit up until we reach either the begining of
1299 the encoded name, or "__". Make sure that we only find
1300 digits or lowercase characters. */
1301 const char *ptr
= encoded
+ i
- 1;
1303 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1306 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1310 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1312 /* This is a X[bn]* sequence not separated from the previous
1313 part of the name with a non-alpha-numeric character (in other
1314 words, immediately following an alpha-numeric character), then
1315 verify that it is placed at the end of the encoded name. If
1316 not, then the encoding is not valid and we should abort the
1317 decoding. Otherwise, just skip it, it is used in body-nested
1321 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1325 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1327 /* Replace '__' by '.'. */
1335 /* It's a character part of the decoded name, so just copy it
1337 decoded
[j
] = encoded
[i
];
1342 decoded
[j
] = '\000';
1344 /* Decoded names should never contain any uppercase character.
1345 Double-check this, and abort the decoding if we find one. */
1347 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1348 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1351 if (strcmp (decoded
, encoded
) == 0)
1357 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1358 decoded
= decoding_buffer
;
1359 if (encoded
[0] == '<')
1360 strcpy (decoded
, encoded
);
1362 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1367 /* Table for keeping permanent unique copies of decoded names. Once
1368 allocated, names in this table are never released. While this is a
1369 storage leak, it should not be significant unless there are massive
1370 changes in the set of decoded names in successive versions of a
1371 symbol table loaded during a single session. */
1372 static struct htab
*decoded_names_store
;
1374 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1375 in the language-specific part of GSYMBOL, if it has not been
1376 previously computed. Tries to save the decoded name in the same
1377 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1378 in any case, the decoded symbol has a lifetime at least that of
1380 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1381 const, but nevertheless modified to a semantically equivalent form
1382 when a decoded name is cached in it. */
1385 ada_decode_symbol (const struct general_symbol_info
*arg
)
1387 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1388 const char **resultp
=
1389 &gsymbol
->language_specific
.demangled_name
;
1391 if (!gsymbol
->ada_mangled
)
1393 const char *decoded
= ada_decode (gsymbol
->name
);
1394 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1396 gsymbol
->ada_mangled
= 1;
1398 if (obstack
!= NULL
)
1400 = (const char *) obstack_copy0 (obstack
, decoded
, strlen (decoded
));
1403 /* Sometimes, we can't find a corresponding objfile, in
1404 which case, we put the result on the heap. Since we only
1405 decode when needed, we hope this usually does not cause a
1406 significant memory leak (FIXME). */
1408 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1412 *slot
= xstrdup (decoded
);
1421 ada_la_decode (const char *encoded
, int options
)
1423 return xstrdup (ada_decode (encoded
));
1426 /* Implement la_sniff_from_mangled_name for Ada. */
1429 ada_sniff_from_mangled_name (const char *mangled
, char **out
)
1431 const char *demangled
= ada_decode (mangled
);
1435 if (demangled
!= mangled
&& demangled
!= NULL
&& demangled
[0] != '<')
1437 /* Set the gsymbol language to Ada, but still return 0.
1438 Two reasons for that:
1440 1. For Ada, we prefer computing the symbol's decoded name
1441 on the fly rather than pre-compute it, in order to save
1442 memory (Ada projects are typically very large).
1444 2. There are some areas in the definition of the GNAT
1445 encoding where, with a bit of bad luck, we might be able
1446 to decode a non-Ada symbol, generating an incorrect
1447 demangled name (Eg: names ending with "TB" for instance
1448 are identified as task bodies and so stripped from
1449 the decoded name returned).
1451 Returning 1, here, but not setting *DEMANGLED, helps us get a
1452 little bit of the best of both worlds. Because we're last,
1453 we should not affect any of the other languages that were
1454 able to demangle the symbol before us; we get to correctly
1455 tag Ada symbols as such; and even if we incorrectly tagged a
1456 non-Ada symbol, which should be rare, any routing through the
1457 Ada language should be transparent (Ada tries to behave much
1458 like C/C++ with non-Ada symbols). */
1469 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1470 generated by the GNAT compiler to describe the index type used
1471 for each dimension of an array, check whether it follows the latest
1472 known encoding. If not, fix it up to conform to the latest encoding.
1473 Otherwise, do nothing. This function also does nothing if
1474 INDEX_DESC_TYPE is NULL.
1476 The GNAT encoding used to describle the array index type evolved a bit.
1477 Initially, the information would be provided through the name of each
1478 field of the structure type only, while the type of these fields was
1479 described as unspecified and irrelevant. The debugger was then expected
1480 to perform a global type lookup using the name of that field in order
1481 to get access to the full index type description. Because these global
1482 lookups can be very expensive, the encoding was later enhanced to make
1483 the global lookup unnecessary by defining the field type as being
1484 the full index type description.
1486 The purpose of this routine is to allow us to support older versions
1487 of the compiler by detecting the use of the older encoding, and by
1488 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1489 we essentially replace each field's meaningless type by the associated
1493 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1497 if (index_desc_type
== NULL
)
1499 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1501 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1502 to check one field only, no need to check them all). If not, return
1505 If our INDEX_DESC_TYPE was generated using the older encoding,
1506 the field type should be a meaningless integer type whose name
1507 is not equal to the field name. */
1508 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1509 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1510 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1513 /* Fixup each field of INDEX_DESC_TYPE. */
1514 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1516 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1517 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1520 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1524 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1526 static const char *bound_name
[] = {
1527 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1528 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1531 /* Maximum number of array dimensions we are prepared to handle. */
1533 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1536 /* The desc_* routines return primitive portions of array descriptors
1539 /* The descriptor or array type, if any, indicated by TYPE; removes
1540 level of indirection, if needed. */
1542 static struct type
*
1543 desc_base_type (struct type
*type
)
1547 type
= ada_check_typedef (type
);
1548 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1549 type
= ada_typedef_target_type (type
);
1552 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1553 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1554 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1559 /* True iff TYPE indicates a "thin" array pointer type. */
1562 is_thin_pntr (struct type
*type
)
1565 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1566 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1569 /* The descriptor type for thin pointer type TYPE. */
1571 static struct type
*
1572 thin_descriptor_type (struct type
*type
)
1574 struct type
*base_type
= desc_base_type (type
);
1576 if (base_type
== NULL
)
1578 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1582 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1584 if (alt_type
== NULL
)
1591 /* A pointer to the array data for thin-pointer value VAL. */
1593 static struct value
*
1594 thin_data_pntr (struct value
*val
)
1596 struct type
*type
= ada_check_typedef (value_type (val
));
1597 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1599 data_type
= lookup_pointer_type (data_type
);
1601 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1602 return value_cast (data_type
, value_copy (val
));
1604 return value_from_longest (data_type
, value_address (val
));
1607 /* True iff TYPE indicates a "thick" array pointer type. */
1610 is_thick_pntr (struct type
*type
)
1612 type
= desc_base_type (type
);
1613 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1614 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1617 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1618 pointer to one, the type of its bounds data; otherwise, NULL. */
1620 static struct type
*
1621 desc_bounds_type (struct type
*type
)
1625 type
= desc_base_type (type
);
1629 else if (is_thin_pntr (type
))
1631 type
= thin_descriptor_type (type
);
1634 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1636 return ada_check_typedef (r
);
1638 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1640 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1642 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1647 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1648 one, a pointer to its bounds data. Otherwise NULL. */
1650 static struct value
*
1651 desc_bounds (struct value
*arr
)
1653 struct type
*type
= ada_check_typedef (value_type (arr
));
1655 if (is_thin_pntr (type
))
1657 struct type
*bounds_type
=
1658 desc_bounds_type (thin_descriptor_type (type
));
1661 if (bounds_type
== NULL
)
1662 error (_("Bad GNAT array descriptor"));
1664 /* NOTE: The following calculation is not really kosher, but
1665 since desc_type is an XVE-encoded type (and shouldn't be),
1666 the correct calculation is a real pain. FIXME (and fix GCC). */
1667 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1668 addr
= value_as_long (arr
);
1670 addr
= value_address (arr
);
1673 value_from_longest (lookup_pointer_type (bounds_type
),
1674 addr
- TYPE_LENGTH (bounds_type
));
1677 else if (is_thick_pntr (type
))
1679 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1680 _("Bad GNAT array descriptor"));
1681 struct type
*p_bounds_type
= value_type (p_bounds
);
1684 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1686 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1688 if (TYPE_STUB (target_type
))
1689 p_bounds
= value_cast (lookup_pointer_type
1690 (ada_check_typedef (target_type
)),
1694 error (_("Bad GNAT array descriptor"));
1702 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1703 position of the field containing the address of the bounds data. */
1706 fat_pntr_bounds_bitpos (struct type
*type
)
1708 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1711 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1712 size of the field containing the address of the bounds data. */
1715 fat_pntr_bounds_bitsize (struct type
*type
)
1717 type
= desc_base_type (type
);
1719 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1720 return TYPE_FIELD_BITSIZE (type
, 1);
1722 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1725 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1726 pointer to one, the type of its array data (a array-with-no-bounds type);
1727 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1730 static struct type
*
1731 desc_data_target_type (struct type
*type
)
1733 type
= desc_base_type (type
);
1735 /* NOTE: The following is bogus; see comment in desc_bounds. */
1736 if (is_thin_pntr (type
))
1737 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1738 else if (is_thick_pntr (type
))
1740 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1743 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1744 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1750 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1753 static struct value
*
1754 desc_data (struct value
*arr
)
1756 struct type
*type
= value_type (arr
);
1758 if (is_thin_pntr (type
))
1759 return thin_data_pntr (arr
);
1760 else if (is_thick_pntr (type
))
1761 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1762 _("Bad GNAT array descriptor"));
1768 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1769 position of the field containing the address of the data. */
1772 fat_pntr_data_bitpos (struct type
*type
)
1774 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1777 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1778 size of the field containing the address of the data. */
1781 fat_pntr_data_bitsize (struct type
*type
)
1783 type
= desc_base_type (type
);
1785 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1786 return TYPE_FIELD_BITSIZE (type
, 0);
1788 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1791 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1792 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1793 bound, if WHICH is 1. The first bound is I=1. */
1795 static struct value
*
1796 desc_one_bound (struct value
*bounds
, int i
, int which
)
1798 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1799 _("Bad GNAT array descriptor bounds"));
1802 /* If BOUNDS is an array-bounds structure type, return the bit position
1803 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1804 bound, if WHICH is 1. The first bound is I=1. */
1807 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1809 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1812 /* If BOUNDS is an array-bounds structure type, return the bit field size
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_bitsize (struct type
*type
, int i
, int which
)
1819 type
= desc_base_type (type
);
1821 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1822 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1824 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1827 /* If TYPE is the type of an array-bounds structure, the type of its
1828 Ith bound (numbering from 1). Otherwise, NULL. */
1830 static struct type
*
1831 desc_index_type (struct type
*type
, int i
)
1833 type
= desc_base_type (type
);
1835 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1836 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1841 /* The number of index positions in the array-bounds type TYPE.
1842 Return 0 if TYPE is NULL. */
1845 desc_arity (struct type
*type
)
1847 type
= desc_base_type (type
);
1850 return TYPE_NFIELDS (type
) / 2;
1854 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1855 an array descriptor type (representing an unconstrained array
1859 ada_is_direct_array_type (struct type
*type
)
1863 type
= ada_check_typedef (type
);
1864 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1865 || ada_is_array_descriptor_type (type
));
1868 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1872 ada_is_array_type (struct type
*type
)
1875 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1876 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1877 type
= TYPE_TARGET_TYPE (type
);
1878 return ada_is_direct_array_type (type
);
1881 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1884 ada_is_simple_array_type (struct type
*type
)
1888 type
= ada_check_typedef (type
);
1889 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1890 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1891 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1892 == TYPE_CODE_ARRAY
));
1895 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1898 ada_is_array_descriptor_type (struct type
*type
)
1900 struct type
*data_type
= desc_data_target_type (type
);
1904 type
= ada_check_typedef (type
);
1905 return (data_type
!= NULL
1906 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1907 && desc_arity (desc_bounds_type (type
)) > 0);
1910 /* Non-zero iff type is a partially mal-formed GNAT array
1911 descriptor. FIXME: This is to compensate for some problems with
1912 debugging output from GNAT. Re-examine periodically to see if it
1916 ada_is_bogus_array_descriptor (struct type
*type
)
1920 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1921 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1922 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1923 && !ada_is_array_descriptor_type (type
);
1927 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1928 (fat pointer) returns the type of the array data described---specifically,
1929 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1930 in from the descriptor; otherwise, they are left unspecified. If
1931 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1932 returns NULL. The result is simply the type of ARR if ARR is not
1935 ada_type_of_array (struct value
*arr
, int bounds
)
1937 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1938 return decode_constrained_packed_array_type (value_type (arr
));
1940 if (!ada_is_array_descriptor_type (value_type (arr
)))
1941 return value_type (arr
);
1945 struct type
*array_type
=
1946 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1948 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1949 TYPE_FIELD_BITSIZE (array_type
, 0) =
1950 decode_packed_array_bitsize (value_type (arr
));
1956 struct type
*elt_type
;
1958 struct value
*descriptor
;
1960 elt_type
= ada_array_element_type (value_type (arr
), -1);
1961 arity
= ada_array_arity (value_type (arr
));
1963 if (elt_type
== NULL
|| arity
== 0)
1964 return ada_check_typedef (value_type (arr
));
1966 descriptor
= desc_bounds (arr
);
1967 if (value_as_long (descriptor
) == 0)
1971 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1972 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1973 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1974 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1977 create_static_range_type (range_type
, value_type (low
),
1978 longest_to_int (value_as_long (low
)),
1979 longest_to_int (value_as_long (high
)));
1980 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1982 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1984 /* We need to store the element packed bitsize, as well as
1985 recompute the array size, because it was previously
1986 computed based on the unpacked element size. */
1987 LONGEST lo
= value_as_long (low
);
1988 LONGEST hi
= value_as_long (high
);
1990 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1991 decode_packed_array_bitsize (value_type (arr
));
1992 /* If the array has no element, then the size is already
1993 zero, and does not need to be recomputed. */
1997 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1999 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
2004 return lookup_pointer_type (elt_type
);
2008 /* If ARR does not represent an array, returns ARR unchanged.
2009 Otherwise, returns either a standard GDB array with bounds set
2010 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2011 GDB array. Returns NULL if ARR is a null fat pointer. */
2014 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2016 if (ada_is_array_descriptor_type (value_type (arr
)))
2018 struct type
*arrType
= ada_type_of_array (arr
, 1);
2020 if (arrType
== NULL
)
2022 return value_cast (arrType
, value_copy (desc_data (arr
)));
2024 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2025 return decode_constrained_packed_array (arr
);
2030 /* If ARR does not represent an array, returns ARR unchanged.
2031 Otherwise, returns a standard GDB array describing ARR (which may
2032 be ARR itself if it already is in the proper form). */
2035 ada_coerce_to_simple_array (struct value
*arr
)
2037 if (ada_is_array_descriptor_type (value_type (arr
)))
2039 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2042 error (_("Bounds unavailable for null array pointer."));
2043 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
2044 return value_ind (arrVal
);
2046 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2047 return decode_constrained_packed_array (arr
);
2052 /* If TYPE represents a GNAT array type, return it translated to an
2053 ordinary GDB array type (possibly with BITSIZE fields indicating
2054 packing). For other types, is the identity. */
2057 ada_coerce_to_simple_array_type (struct type
*type
)
2059 if (ada_is_constrained_packed_array_type (type
))
2060 return decode_constrained_packed_array_type (type
);
2062 if (ada_is_array_descriptor_type (type
))
2063 return ada_check_typedef (desc_data_target_type (type
));
2068 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2071 ada_is_packed_array_type (struct type
*type
)
2075 type
= desc_base_type (type
);
2076 type
= ada_check_typedef (type
);
2078 ada_type_name (type
) != NULL
2079 && strstr (ada_type_name (type
), "___XP") != NULL
;
2082 /* Non-zero iff TYPE represents a standard GNAT constrained
2083 packed-array type. */
2086 ada_is_constrained_packed_array_type (struct type
*type
)
2088 return ada_is_packed_array_type (type
)
2089 && !ada_is_array_descriptor_type (type
);
2092 /* Non-zero iff TYPE represents an array descriptor for a
2093 unconstrained packed-array type. */
2096 ada_is_unconstrained_packed_array_type (struct type
*type
)
2098 return ada_is_packed_array_type (type
)
2099 && ada_is_array_descriptor_type (type
);
2102 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2103 return the size of its elements in bits. */
2106 decode_packed_array_bitsize (struct type
*type
)
2108 const char *raw_name
;
2112 /* Access to arrays implemented as fat pointers are encoded as a typedef
2113 of the fat pointer type. We need the name of the fat pointer type
2114 to do the decoding, so strip the typedef layer. */
2115 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
2116 type
= ada_typedef_target_type (type
);
2118 raw_name
= ada_type_name (ada_check_typedef (type
));
2120 raw_name
= ada_type_name (desc_base_type (type
));
2125 tail
= strstr (raw_name
, "___XP");
2126 gdb_assert (tail
!= NULL
);
2128 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2131 (_("could not understand bit size information on packed array"));
2138 /* Given that TYPE is a standard GDB array type with all bounds filled
2139 in, and that the element size of its ultimate scalar constituents
2140 (that is, either its elements, or, if it is an array of arrays, its
2141 elements' elements, etc.) is *ELT_BITS, return an identical type,
2142 but with the bit sizes of its elements (and those of any
2143 constituent arrays) recorded in the BITSIZE components of its
2144 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2147 Note that, for arrays whose index type has an XA encoding where
2148 a bound references a record discriminant, getting that discriminant,
2149 and therefore the actual value of that bound, is not possible
2150 because none of the given parameters gives us access to the record.
2151 This function assumes that it is OK in the context where it is being
2152 used to return an array whose bounds are still dynamic and where
2153 the length is arbitrary. */
2155 static struct type
*
2156 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2158 struct type
*new_elt_type
;
2159 struct type
*new_type
;
2160 struct type
*index_type_desc
;
2161 struct type
*index_type
;
2162 LONGEST low_bound
, high_bound
;
2164 type
= ada_check_typedef (type
);
2165 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2168 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2169 if (index_type_desc
)
2170 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2173 index_type
= TYPE_INDEX_TYPE (type
);
2175 new_type
= alloc_type_copy (type
);
2177 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2179 create_array_type (new_type
, new_elt_type
, index_type
);
2180 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2181 TYPE_NAME (new_type
) = ada_type_name (type
);
2183 if ((TYPE_CODE (check_typedef (index_type
)) == TYPE_CODE_RANGE
2184 && is_dynamic_type (check_typedef (index_type
)))
2185 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2186 low_bound
= high_bound
= 0;
2187 if (high_bound
< low_bound
)
2188 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2191 *elt_bits
*= (high_bound
- low_bound
+ 1);
2192 TYPE_LENGTH (new_type
) =
2193 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2196 TYPE_FIXED_INSTANCE (new_type
) = 1;
2200 /* The array type encoded by TYPE, where
2201 ada_is_constrained_packed_array_type (TYPE). */
2203 static struct type
*
2204 decode_constrained_packed_array_type (struct type
*type
)
2206 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2209 struct type
*shadow_type
;
2213 raw_name
= ada_type_name (desc_base_type (type
));
2218 name
= (char *) alloca (strlen (raw_name
) + 1);
2219 tail
= strstr (raw_name
, "___XP");
2220 type
= desc_base_type (type
);
2222 memcpy (name
, raw_name
, tail
- raw_name
);
2223 name
[tail
- raw_name
] = '\000';
2225 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2227 if (shadow_type
== NULL
)
2229 lim_warning (_("could not find bounds information on packed array"));
2232 shadow_type
= check_typedef (shadow_type
);
2234 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2236 lim_warning (_("could not understand bounds "
2237 "information on packed array"));
2241 bits
= decode_packed_array_bitsize (type
);
2242 return constrained_packed_array_type (shadow_type
, &bits
);
2245 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2246 array, returns a simple array that denotes that array. Its type is a
2247 standard GDB array type except that the BITSIZEs of the array
2248 target types are set to the number of bits in each element, and the
2249 type length is set appropriately. */
2251 static struct value
*
2252 decode_constrained_packed_array (struct value
*arr
)
2256 /* If our value is a pointer, then dereference it. Likewise if
2257 the value is a reference. Make sure that this operation does not
2258 cause the target type to be fixed, as this would indirectly cause
2259 this array to be decoded. The rest of the routine assumes that
2260 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2261 and "value_ind" routines to perform the dereferencing, as opposed
2262 to using "ada_coerce_ref" or "ada_value_ind". */
2263 arr
= coerce_ref (arr
);
2264 if (TYPE_CODE (ada_check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2265 arr
= value_ind (arr
);
2267 type
= decode_constrained_packed_array_type (value_type (arr
));
2270 error (_("can't unpack array"));
2274 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2275 && ada_is_modular_type (value_type (arr
)))
2277 /* This is a (right-justified) modular type representing a packed
2278 array with no wrapper. In order to interpret the value through
2279 the (left-justified) packed array type we just built, we must
2280 first left-justify it. */
2281 int bit_size
, bit_pos
;
2284 mod
= ada_modulus (value_type (arr
)) - 1;
2291 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2292 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2293 bit_pos
/ HOST_CHAR_BIT
,
2294 bit_pos
% HOST_CHAR_BIT
,
2299 return coerce_unspec_val_to_type (arr
, type
);
2303 /* The value of the element of packed array ARR at the ARITY indices
2304 given in IND. ARR must be a simple array. */
2306 static struct value
*
2307 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2310 int bits
, elt_off
, bit_off
;
2311 long elt_total_bit_offset
;
2312 struct type
*elt_type
;
2316 elt_total_bit_offset
= 0;
2317 elt_type
= ada_check_typedef (value_type (arr
));
2318 for (i
= 0; i
< arity
; i
+= 1)
2320 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2321 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2323 (_("attempt to do packed indexing of "
2324 "something other than a packed array"));
2327 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2328 LONGEST lowerbound
, upperbound
;
2331 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2333 lim_warning (_("don't know bounds of array"));
2334 lowerbound
= upperbound
= 0;
2337 idx
= pos_atr (ind
[i
]);
2338 if (idx
< lowerbound
|| idx
> upperbound
)
2339 lim_warning (_("packed array index %ld out of bounds"),
2341 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2342 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2343 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2346 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2347 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2349 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2354 /* Non-zero iff TYPE includes negative integer values. */
2357 has_negatives (struct type
*type
)
2359 switch (TYPE_CODE (type
))
2364 return !TYPE_UNSIGNED (type
);
2365 case TYPE_CODE_RANGE
:
2366 return TYPE_LOW_BOUND (type
) < 0;
2370 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2371 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2372 the unpacked buffer.
2374 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2375 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2377 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2380 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2382 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2385 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2386 gdb_byte
*unpacked
, int unpacked_len
,
2387 int is_big_endian
, int is_signed_type
,
2390 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2391 int src_idx
; /* Index into the source area */
2392 int src_bytes_left
; /* Number of source bytes left to process. */
2393 int srcBitsLeft
; /* Number of source bits left to move */
2394 int unusedLS
; /* Number of bits in next significant
2395 byte of source that are unused */
2397 int unpacked_idx
; /* Index into the unpacked buffer */
2398 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2400 unsigned long accum
; /* Staging area for bits being transferred */
2401 int accumSize
; /* Number of meaningful bits in accum */
2404 /* Transmit bytes from least to most significant; delta is the direction
2405 the indices move. */
2406 int delta
= is_big_endian
? -1 : 1;
2408 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2410 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2411 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2412 bit_size
, unpacked_len
);
2414 srcBitsLeft
= bit_size
;
2415 src_bytes_left
= src_len
;
2416 unpacked_bytes_left
= unpacked_len
;
2421 src_idx
= src_len
- 1;
2423 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2427 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2433 unpacked_idx
= unpacked_len
- 1;
2437 /* Non-scalar values must be aligned at a byte boundary... */
2439 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2440 /* ... And are placed at the beginning (most-significant) bytes
2442 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2443 unpacked_bytes_left
= unpacked_idx
+ 1;
2448 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2450 src_idx
= unpacked_idx
= 0;
2451 unusedLS
= bit_offset
;
2454 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2459 while (src_bytes_left
> 0)
2461 /* Mask for removing bits of the next source byte that are not
2462 part of the value. */
2463 unsigned int unusedMSMask
=
2464 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2466 /* Sign-extend bits for this byte. */
2467 unsigned int signMask
= sign
& ~unusedMSMask
;
2470 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2471 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2472 if (accumSize
>= HOST_CHAR_BIT
)
2474 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2475 accumSize
-= HOST_CHAR_BIT
;
2476 accum
>>= HOST_CHAR_BIT
;
2477 unpacked_bytes_left
-= 1;
2478 unpacked_idx
+= delta
;
2480 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2482 src_bytes_left
-= 1;
2485 while (unpacked_bytes_left
> 0)
2487 accum
|= sign
<< accumSize
;
2488 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2489 accumSize
-= HOST_CHAR_BIT
;
2492 accum
>>= HOST_CHAR_BIT
;
2493 unpacked_bytes_left
-= 1;
2494 unpacked_idx
+= delta
;
2498 /* Create a new value of type TYPE from the contents of OBJ starting
2499 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2500 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2501 assigning through the result will set the field fetched from.
2502 VALADDR is ignored unless OBJ is NULL, in which case,
2503 VALADDR+OFFSET must address the start of storage containing the
2504 packed value. The value returned in this case is never an lval.
2505 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2508 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2509 long offset
, int bit_offset
, int bit_size
,
2513 const gdb_byte
*src
; /* First byte containing data to unpack */
2515 const int is_scalar
= is_scalar_type (type
);
2516 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2517 gdb::byte_vector staging
;
2519 type
= ada_check_typedef (type
);
2522 src
= valaddr
+ offset
;
2524 src
= value_contents (obj
) + offset
;
2526 if (is_dynamic_type (type
))
2528 /* The length of TYPE might by dynamic, so we need to resolve
2529 TYPE in order to know its actual size, which we then use
2530 to create the contents buffer of the value we return.
2531 The difficulty is that the data containing our object is
2532 packed, and therefore maybe not at a byte boundary. So, what
2533 we do, is unpack the data into a byte-aligned buffer, and then
2534 use that buffer as our object's value for resolving the type. */
2535 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2536 staging
.resize (staging_len
);
2538 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2539 staging
.data (), staging
.size (),
2540 is_big_endian
, has_negatives (type
),
2542 type
= resolve_dynamic_type (type
, staging
.data (), 0);
2543 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2545 /* This happens when the length of the object is dynamic,
2546 and is actually smaller than the space reserved for it.
2547 For instance, in an array of variant records, the bit_size
2548 we're given is the array stride, which is constant and
2549 normally equal to the maximum size of its element.
2550 But, in reality, each element only actually spans a portion
2552 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2558 v
= allocate_value (type
);
2559 src
= valaddr
+ offset
;
2561 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2563 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2566 v
= value_at (type
, value_address (obj
) + offset
);
2567 buf
= (gdb_byte
*) alloca (src_len
);
2568 read_memory (value_address (v
), buf
, src_len
);
2573 v
= allocate_value (type
);
2574 src
= value_contents (obj
) + offset
;
2579 long new_offset
= offset
;
2581 set_value_component_location (v
, obj
);
2582 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2583 set_value_bitsize (v
, bit_size
);
2584 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2587 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2589 set_value_offset (v
, new_offset
);
2591 /* Also set the parent value. This is needed when trying to
2592 assign a new value (in inferior memory). */
2593 set_value_parent (v
, obj
);
2596 set_value_bitsize (v
, bit_size
);
2597 unpacked
= value_contents_writeable (v
);
2601 memset (unpacked
, 0, TYPE_LENGTH (type
));
2605 if (staging
.size () == TYPE_LENGTH (type
))
2607 /* Small short-cut: If we've unpacked the data into a buffer
2608 of the same size as TYPE's length, then we can reuse that,
2609 instead of doing the unpacking again. */
2610 memcpy (unpacked
, staging
.data (), staging
.size ());
2613 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2614 unpacked
, TYPE_LENGTH (type
),
2615 is_big_endian
, has_negatives (type
), is_scalar
);
2620 /* Store the contents of FROMVAL into the location of TOVAL.
2621 Return a new value with the location of TOVAL and contents of
2622 FROMVAL. Handles assignment into packed fields that have
2623 floating-point or non-scalar types. */
2625 static struct value
*
2626 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2628 struct type
*type
= value_type (toval
);
2629 int bits
= value_bitsize (toval
);
2631 toval
= ada_coerce_ref (toval
);
2632 fromval
= ada_coerce_ref (fromval
);
2634 if (ada_is_direct_array_type (value_type (toval
)))
2635 toval
= ada_coerce_to_simple_array (toval
);
2636 if (ada_is_direct_array_type (value_type (fromval
)))
2637 fromval
= ada_coerce_to_simple_array (fromval
);
2639 if (!deprecated_value_modifiable (toval
))
2640 error (_("Left operand of assignment is not a modifiable lvalue."));
2642 if (VALUE_LVAL (toval
) == lval_memory
2644 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2645 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2647 int len
= (value_bitpos (toval
)
2648 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2650 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2652 CORE_ADDR to_addr
= value_address (toval
);
2654 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2655 fromval
= value_cast (type
, fromval
);
2657 read_memory (to_addr
, buffer
, len
);
2658 from_size
= value_bitsize (fromval
);
2660 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2662 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2663 ULONGEST from_offset
= 0;
2664 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2665 from_offset
= from_size
- bits
;
2666 copy_bitwise (buffer
, value_bitpos (toval
),
2667 value_contents (fromval
), from_offset
,
2668 bits
, is_big_endian
);
2669 write_memory_with_notification (to_addr
, buffer
, len
);
2671 val
= value_copy (toval
);
2672 memcpy (value_contents_raw (val
), value_contents (fromval
),
2673 TYPE_LENGTH (type
));
2674 deprecated_set_value_type (val
, type
);
2679 return value_assign (toval
, fromval
);
2683 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2684 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2685 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2686 COMPONENT, and not the inferior's memory. The current contents
2687 of COMPONENT are ignored.
2689 Although not part of the initial design, this function also works
2690 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2691 had a null address, and COMPONENT had an address which is equal to
2692 its offset inside CONTAINER. */
2695 value_assign_to_component (struct value
*container
, struct value
*component
,
2698 LONGEST offset_in_container
=
2699 (LONGEST
) (value_address (component
) - value_address (container
));
2700 int bit_offset_in_container
=
2701 value_bitpos (component
) - value_bitpos (container
);
2704 val
= value_cast (value_type (component
), val
);
2706 if (value_bitsize (component
) == 0)
2707 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2709 bits
= value_bitsize (component
);
2711 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2715 if (is_scalar_type (check_typedef (value_type (component
))))
2717 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2720 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2721 value_bitpos (container
) + bit_offset_in_container
,
2722 value_contents (val
), src_offset
, bits
, 1);
2725 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2726 value_bitpos (container
) + bit_offset_in_container
,
2727 value_contents (val
), 0, bits
, 0);
2730 /* Determine if TYPE is an access to an unconstrained array. */
2733 ada_is_access_to_unconstrained_array (struct type
*type
)
2735 return (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
2736 && is_thick_pntr (ada_typedef_target_type (type
)));
2739 /* The value of the element of array ARR at the ARITY indices given in IND.
2740 ARR may be either a simple array, GNAT array descriptor, or pointer
2744 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2748 struct type
*elt_type
;
2750 elt
= ada_coerce_to_simple_array (arr
);
2752 elt_type
= ada_check_typedef (value_type (elt
));
2753 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2754 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2755 return value_subscript_packed (elt
, arity
, ind
);
2757 for (k
= 0; k
< arity
; k
+= 1)
2759 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2761 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2762 error (_("too many subscripts (%d expected)"), k
);
2764 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2766 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2767 && TYPE_CODE (value_type (elt
)) != TYPE_CODE_TYPEDEF
)
2769 /* The element is a typedef to an unconstrained array,
2770 except that the value_subscript call stripped the
2771 typedef layer. The typedef layer is GNAT's way to
2772 specify that the element is, at the source level, an
2773 access to the unconstrained array, rather than the
2774 unconstrained array. So, we need to restore that
2775 typedef layer, which we can do by forcing the element's
2776 type back to its original type. Otherwise, the returned
2777 value is going to be printed as the array, rather
2778 than as an access. Another symptom of the same issue
2779 would be that an expression trying to dereference the
2780 element would also be improperly rejected. */
2781 deprecated_set_value_type (elt
, saved_elt_type
);
2784 elt_type
= ada_check_typedef (value_type (elt
));
2790 /* Assuming ARR is a pointer to a GDB array, the value of the element
2791 of *ARR at the ARITY indices given in IND.
2792 Does not read the entire array into memory.
2794 Note: Unlike what one would expect, this function is used instead of
2795 ada_value_subscript for basically all non-packed array types. The reason
2796 for this is that a side effect of doing our own pointer arithmetics instead
2797 of relying on value_subscript is that there is no implicit typedef peeling.
2798 This is important for arrays of array accesses, where it allows us to
2799 preserve the fact that the array's element is an array access, where the
2800 access part os encoded in a typedef layer. */
2802 static struct value
*
2803 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2806 struct value
*array_ind
= ada_value_ind (arr
);
2808 = check_typedef (value_enclosing_type (array_ind
));
2810 if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
2811 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2812 return value_subscript_packed (array_ind
, arity
, ind
);
2814 for (k
= 0; k
< arity
; k
+= 1)
2817 struct value
*lwb_value
;
2819 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2820 error (_("too many subscripts (%d expected)"), k
);
2821 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2823 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2824 lwb_value
= value_from_longest (value_type(ind
[k
]), lwb
);
2825 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - pos_atr (lwb_value
));
2826 type
= TYPE_TARGET_TYPE (type
);
2829 return value_ind (arr
);
2832 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2833 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2834 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2835 this array is LOW, as per Ada rules. */
2836 static struct value
*
2837 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2840 struct type
*type0
= ada_check_typedef (type
);
2841 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
));
2842 struct type
*index_type
2843 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2844 struct type
*slice_type
= create_array_type_with_stride
2845 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2846 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type0
),
2847 TYPE_FIELD_BITSIZE (type0
, 0));
2848 int base_low
= ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
));
2849 LONGEST base_low_pos
, low_pos
;
2852 if (!discrete_position (base_index_type
, low
, &low_pos
)
2853 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2855 warning (_("unable to get positions in slice, use bounds instead"));
2857 base_low_pos
= base_low
;
2860 base
= value_as_address (array_ptr
)
2861 + ((low_pos
- base_low_pos
)
2862 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2863 return value_at_lazy (slice_type
, base
);
2867 static struct value
*
2868 ada_value_slice (struct value
*array
, int low
, int high
)
2870 struct type
*type
= ada_check_typedef (value_type (array
));
2871 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2872 struct type
*index_type
2873 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2874 struct type
*slice_type
= create_array_type_with_stride
2875 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2876 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type
),
2877 TYPE_FIELD_BITSIZE (type
, 0));
2878 LONGEST low_pos
, high_pos
;
2880 if (!discrete_position (base_index_type
, low
, &low_pos
)
2881 || !discrete_position (base_index_type
, high
, &high_pos
))
2883 warning (_("unable to get positions in slice, use bounds instead"));
2888 return value_cast (slice_type
,
2889 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2892 /* If type is a record type in the form of a standard GNAT array
2893 descriptor, returns the number of dimensions for type. If arr is a
2894 simple array, returns the number of "array of"s that prefix its
2895 type designation. Otherwise, returns 0. */
2898 ada_array_arity (struct type
*type
)
2905 type
= desc_base_type (type
);
2908 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2909 return desc_arity (desc_bounds_type (type
));
2911 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2914 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2920 /* If TYPE is a record type in the form of a standard GNAT array
2921 descriptor or a simple array type, returns the element type for
2922 TYPE after indexing by NINDICES indices, or by all indices if
2923 NINDICES is -1. Otherwise, returns NULL. */
2926 ada_array_element_type (struct type
*type
, int nindices
)
2928 type
= desc_base_type (type
);
2930 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2933 struct type
*p_array_type
;
2935 p_array_type
= desc_data_target_type (type
);
2937 k
= ada_array_arity (type
);
2941 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2942 if (nindices
>= 0 && k
> nindices
)
2944 while (k
> 0 && p_array_type
!= NULL
)
2946 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2949 return p_array_type
;
2951 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2953 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2955 type
= TYPE_TARGET_TYPE (type
);
2964 /* The type of nth index in arrays of given type (n numbering from 1).
2965 Does not examine memory. Throws an error if N is invalid or TYPE
2966 is not an array type. NAME is the name of the Ada attribute being
2967 evaluated ('range, 'first, 'last, or 'length); it is used in building
2968 the error message. */
2970 static struct type
*
2971 ada_index_type (struct type
*type
, int n
, const char *name
)
2973 struct type
*result_type
;
2975 type
= desc_base_type (type
);
2977 if (n
< 0 || n
> ada_array_arity (type
))
2978 error (_("invalid dimension number to '%s"), name
);
2980 if (ada_is_simple_array_type (type
))
2984 for (i
= 1; i
< n
; i
+= 1)
2985 type
= TYPE_TARGET_TYPE (type
);
2986 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2987 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2988 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2989 perhaps stabsread.c would make more sense. */
2990 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2995 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2996 if (result_type
== NULL
)
2997 error (_("attempt to take bound of something that is not an array"));
3003 /* Given that arr is an array type, returns the lower bound of the
3004 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3005 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3006 array-descriptor type. It works for other arrays with bounds supplied
3007 by run-time quantities other than discriminants. */
3010 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
3012 struct type
*type
, *index_type_desc
, *index_type
;
3015 gdb_assert (which
== 0 || which
== 1);
3017 if (ada_is_constrained_packed_array_type (arr_type
))
3018 arr_type
= decode_constrained_packed_array_type (arr_type
);
3020 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
3021 return (LONGEST
) - which
;
3023 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
3024 type
= TYPE_TARGET_TYPE (arr_type
);
3028 if (TYPE_FIXED_INSTANCE (type
))
3030 /* The array has already been fixed, so we do not need to
3031 check the parallel ___XA type again. That encoding has
3032 already been applied, so ignore it now. */
3033 index_type_desc
= NULL
;
3037 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3038 ada_fixup_array_indexes_type (index_type_desc
);
3041 if (index_type_desc
!= NULL
)
3042 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
3046 struct type
*elt_type
= check_typedef (type
);
3048 for (i
= 1; i
< n
; i
++)
3049 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3051 index_type
= TYPE_INDEX_TYPE (elt_type
);
3055 (LONGEST
) (which
== 0
3056 ? ada_discrete_type_low_bound (index_type
)
3057 : ada_discrete_type_high_bound (index_type
));
3060 /* Given that arr is an array value, returns the lower bound of the
3061 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3062 WHICH is 1. This routine will also work for arrays with bounds
3063 supplied by run-time quantities other than discriminants. */
3066 ada_array_bound (struct value
*arr
, int n
, int which
)
3068 struct type
*arr_type
;
3070 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3071 arr
= value_ind (arr
);
3072 arr_type
= value_enclosing_type (arr
);
3074 if (ada_is_constrained_packed_array_type (arr_type
))
3075 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3076 else if (ada_is_simple_array_type (arr_type
))
3077 return ada_array_bound_from_type (arr_type
, n
, which
);
3079 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3082 /* Given that arr is an array value, returns the length of the
3083 nth index. This routine will also work for arrays with bounds
3084 supplied by run-time quantities other than discriminants.
3085 Does not work for arrays indexed by enumeration types with representation
3086 clauses at the moment. */
3089 ada_array_length (struct value
*arr
, int n
)
3091 struct type
*arr_type
, *index_type
;
3094 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3095 arr
= value_ind (arr
);
3096 arr_type
= value_enclosing_type (arr
);
3098 if (ada_is_constrained_packed_array_type (arr_type
))
3099 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3101 if (ada_is_simple_array_type (arr_type
))
3103 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3104 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3108 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3109 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3112 arr_type
= check_typedef (arr_type
);
3113 index_type
= ada_index_type (arr_type
, n
, "length");
3114 if (index_type
!= NULL
)
3116 struct type
*base_type
;
3117 if (TYPE_CODE (index_type
) == TYPE_CODE_RANGE
)
3118 base_type
= TYPE_TARGET_TYPE (index_type
);
3120 base_type
= index_type
;
3122 low
= pos_atr (value_from_longest (base_type
, low
));
3123 high
= pos_atr (value_from_longest (base_type
, high
));
3125 return high
- low
+ 1;
3128 /* An array whose type is that of ARR_TYPE (an array type), with
3129 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3130 less than LOW, then LOW-1 is used. */
3132 static struct value
*
3133 empty_array (struct type
*arr_type
, int low
, int high
)
3135 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3136 struct type
*index_type
3137 = create_static_range_type
3138 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
,
3139 high
< low
? low
- 1 : high
);
3140 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3142 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3146 /* Name resolution */
3148 /* The "decoded" name for the user-definable Ada operator corresponding
3152 ada_decoded_op_name (enum exp_opcode op
)
3156 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3158 if (ada_opname_table
[i
].op
== op
)
3159 return ada_opname_table
[i
].decoded
;
3161 error (_("Could not find operator name for opcode"));
3165 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3166 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3167 undefined namespace) and converts operators that are
3168 user-defined into appropriate function calls. If CONTEXT_TYPE is
3169 non-null, it provides a preferred result type [at the moment, only
3170 type void has any effect---causing procedures to be preferred over
3171 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3172 return type is preferred. May change (expand) *EXP. */
3175 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3176 innermost_block_tracker
*tracker
)
3178 struct type
*context_type
= NULL
;
3182 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3184 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3187 /* Resolve the operator of the subexpression beginning at
3188 position *POS of *EXPP. "Resolving" consists of replacing
3189 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3190 with their resolutions, replacing built-in operators with
3191 function calls to user-defined operators, where appropriate, and,
3192 when DEPROCEDURE_P is non-zero, converting function-valued variables
3193 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3194 are as in ada_resolve, above. */
3196 static struct value
*
3197 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3198 struct type
*context_type
, int parse_completion
,
3199 innermost_block_tracker
*tracker
)
3203 struct expression
*exp
; /* Convenience: == *expp. */
3204 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3205 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3206 int nargs
; /* Number of operands. */
3213 /* Pass one: resolve operands, saving their types and updating *pos,
3218 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3219 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3224 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3226 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3231 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3236 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3237 parse_completion
, tracker
);
3240 case OP_ATR_MODULUS
:
3250 case TERNOP_IN_RANGE
:
3251 case BINOP_IN_BOUNDS
:
3257 case OP_DISCRETE_RANGE
:
3259 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3268 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3270 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3272 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3290 case BINOP_LOGICAL_AND
:
3291 case BINOP_LOGICAL_OR
:
3292 case BINOP_BITWISE_AND
:
3293 case BINOP_BITWISE_IOR
:
3294 case BINOP_BITWISE_XOR
:
3297 case BINOP_NOTEQUAL
:
3304 case BINOP_SUBSCRIPT
:
3312 case UNOP_LOGICAL_NOT
:
3322 case OP_VAR_MSYM_VALUE
:
3329 case OP_INTERNALVAR
:
3339 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3342 case STRUCTOP_STRUCT
:
3343 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3356 error (_("Unexpected operator during name resolution"));
3359 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3360 for (i
= 0; i
< nargs
; i
+= 1)
3361 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3366 /* Pass two: perform any resolution on principal operator. */
3373 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3375 std::vector
<struct block_symbol
> candidates
;
3379 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3380 (exp
->elts
[pc
+ 2].symbol
),
3381 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3384 if (n_candidates
> 1)
3386 /* Types tend to get re-introduced locally, so if there
3387 are any local symbols that are not types, first filter
3390 for (j
= 0; j
< n_candidates
; j
+= 1)
3391 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3396 case LOC_REGPARM_ADDR
:
3404 if (j
< n_candidates
)
3407 while (j
< n_candidates
)
3409 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3411 candidates
[j
] = candidates
[n_candidates
- 1];
3420 if (n_candidates
== 0)
3421 error (_("No definition found for %s"),
3422 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3423 else if (n_candidates
== 1)
3425 else if (deprocedure_p
3426 && !is_nonfunction (candidates
.data (), n_candidates
))
3428 i
= ada_resolve_function
3429 (candidates
.data (), n_candidates
, NULL
, 0,
3430 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3431 context_type
, parse_completion
);
3433 error (_("Could not find a match for %s"),
3434 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3438 printf_filtered (_("Multiple matches for %s\n"),
3439 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3440 user_select_syms (candidates
.data (), n_candidates
, 1);
3444 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3445 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3446 tracker
->update (candidates
[i
]);
3450 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3453 replace_operator_with_call (expp
, pc
, 0, 4,
3454 exp
->elts
[pc
+ 2].symbol
,
3455 exp
->elts
[pc
+ 1].block
);
3462 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3463 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3465 std::vector
<struct block_symbol
> candidates
;
3469 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3470 (exp
->elts
[pc
+ 5].symbol
),
3471 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3474 if (n_candidates
== 1)
3478 i
= ada_resolve_function
3479 (candidates
.data (), n_candidates
,
3481 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3482 context_type
, parse_completion
);
3484 error (_("Could not find a match for %s"),
3485 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3488 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3489 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3490 tracker
->update (candidates
[i
]);
3501 case BINOP_BITWISE_AND
:
3502 case BINOP_BITWISE_IOR
:
3503 case BINOP_BITWISE_XOR
:
3505 case BINOP_NOTEQUAL
:
3513 case UNOP_LOGICAL_NOT
:
3515 if (possible_user_operator_p (op
, argvec
))
3517 std::vector
<struct block_symbol
> candidates
;
3521 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3525 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3526 nargs
, ada_decoded_op_name (op
), NULL
,
3531 replace_operator_with_call (expp
, pc
, nargs
, 1,
3532 candidates
[i
].symbol
,
3533 candidates
[i
].block
);
3544 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3545 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3546 exp
->elts
[pc
+ 1].objfile
,
3547 exp
->elts
[pc
+ 2].msymbol
);
3549 return evaluate_subexp_type (exp
, pos
);
3552 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3553 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3555 /* The term "match" here is rather loose. The match is heuristic and
3559 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3561 ftype
= ada_check_typedef (ftype
);
3562 atype
= ada_check_typedef (atype
);
3564 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3565 ftype
= TYPE_TARGET_TYPE (ftype
);
3566 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3567 atype
= TYPE_TARGET_TYPE (atype
);
3569 switch (TYPE_CODE (ftype
))
3572 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3574 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3575 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3576 TYPE_TARGET_TYPE (atype
), 0);
3579 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3581 case TYPE_CODE_ENUM
:
3582 case TYPE_CODE_RANGE
:
3583 switch (TYPE_CODE (atype
))
3586 case TYPE_CODE_ENUM
:
3587 case TYPE_CODE_RANGE
:
3593 case TYPE_CODE_ARRAY
:
3594 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3595 || ada_is_array_descriptor_type (atype
));
3597 case TYPE_CODE_STRUCT
:
3598 if (ada_is_array_descriptor_type (ftype
))
3599 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3600 || ada_is_array_descriptor_type (atype
));
3602 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3603 && !ada_is_array_descriptor_type (atype
));
3605 case TYPE_CODE_UNION
:
3607 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3611 /* Return non-zero if the formals of FUNC "sufficiently match" the
3612 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3613 may also be an enumeral, in which case it is treated as a 0-
3614 argument function. */
3617 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3620 struct type
*func_type
= SYMBOL_TYPE (func
);
3622 if (SYMBOL_CLASS (func
) == LOC_CONST
3623 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3624 return (n_actuals
== 0);
3625 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3628 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3631 for (i
= 0; i
< n_actuals
; i
+= 1)
3633 if (actuals
[i
] == NULL
)
3637 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3639 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3641 if (!ada_type_match (ftype
, atype
, 1))
3648 /* False iff function type FUNC_TYPE definitely does not produce a value
3649 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3650 FUNC_TYPE is not a valid function type with a non-null return type
3651 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3654 return_match (struct type
*func_type
, struct type
*context_type
)
3656 struct type
*return_type
;
3658 if (func_type
== NULL
)
3661 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3662 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3664 return_type
= get_base_type (func_type
);
3665 if (return_type
== NULL
)
3668 context_type
= get_base_type (context_type
);
3670 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3671 return context_type
== NULL
|| return_type
== context_type
;
3672 else if (context_type
== NULL
)
3673 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3675 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3679 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3680 function (if any) that matches the types of the NARGS arguments in
3681 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3682 that returns that type, then eliminate matches that don't. If
3683 CONTEXT_TYPE is void and there is at least one match that does not
3684 return void, eliminate all matches that do.
3686 Asks the user if there is more than one match remaining. Returns -1
3687 if there is no such symbol or none is selected. NAME is used
3688 solely for messages. May re-arrange and modify SYMS in
3689 the process; the index returned is for the modified vector. */
3692 ada_resolve_function (struct block_symbol syms
[],
3693 int nsyms
, struct value
**args
, int nargs
,
3694 const char *name
, struct type
*context_type
,
3695 int parse_completion
)
3699 int m
; /* Number of hits */
3702 /* In the first pass of the loop, we only accept functions matching
3703 context_type. If none are found, we add a second pass of the loop
3704 where every function is accepted. */
3705 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3707 for (k
= 0; k
< nsyms
; k
+= 1)
3709 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3711 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3712 && (fallback
|| return_match (type
, context_type
)))
3720 /* If we got multiple matches, ask the user which one to use. Don't do this
3721 interactive thing during completion, though, as the purpose of the
3722 completion is providing a list of all possible matches. Prompting the
3723 user to filter it down would be completely unexpected in this case. */
3726 else if (m
> 1 && !parse_completion
)
3728 printf_filtered (_("Multiple matches for %s\n"), name
);
3729 user_select_syms (syms
, m
, 1);
3735 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3736 in a listing of choices during disambiguation (see sort_choices, below).
3737 The idea is that overloadings of a subprogram name from the
3738 same package should sort in their source order. We settle for ordering
3739 such symbols by their trailing number (__N or $N). */
3742 encoded_ordered_before (const char *N0
, const char *N1
)
3746 else if (N0
== NULL
)
3752 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3754 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3756 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3757 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3762 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3765 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3767 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3768 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3770 return (strcmp (N0
, N1
) < 0);
3774 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3778 sort_choices (struct block_symbol syms
[], int nsyms
)
3782 for (i
= 1; i
< nsyms
; i
+= 1)
3784 struct block_symbol sym
= syms
[i
];
3787 for (j
= i
- 1; j
>= 0; j
-= 1)
3789 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].symbol
),
3790 SYMBOL_LINKAGE_NAME (sym
.symbol
)))
3792 syms
[j
+ 1] = syms
[j
];
3798 /* Whether GDB should display formals and return types for functions in the
3799 overloads selection menu. */
3800 static int print_signatures
= 1;
3802 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3803 all but functions, the signature is just the name of the symbol. For
3804 functions, this is the name of the function, the list of types for formals
3805 and the return type (if any). */
3808 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3809 const struct type_print_options
*flags
)
3811 struct type
*type
= SYMBOL_TYPE (sym
);
3813 fprintf_filtered (stream
, "%s", SYMBOL_PRINT_NAME (sym
));
3814 if (!print_signatures
3816 || TYPE_CODE (type
) != TYPE_CODE_FUNC
)
3819 if (TYPE_NFIELDS (type
) > 0)
3823 fprintf_filtered (stream
, " (");
3824 for (i
= 0; i
< TYPE_NFIELDS (type
); ++i
)
3827 fprintf_filtered (stream
, "; ");
3828 ada_print_type (TYPE_FIELD_TYPE (type
, i
), NULL
, stream
, -1, 0,
3831 fprintf_filtered (stream
, ")");
3833 if (TYPE_TARGET_TYPE (type
) != NULL
3834 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_VOID
)
3836 fprintf_filtered (stream
, " return ");
3837 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3841 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3842 by asking the user (if necessary), returning the number selected,
3843 and setting the first elements of SYMS items. Error if no symbols
3846 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3847 to be re-integrated one of these days. */
3850 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3853 int *chosen
= XALLOCAVEC (int , nsyms
);
3855 int first_choice
= (max_results
== 1) ? 1 : 2;
3856 const char *select_mode
= multiple_symbols_select_mode ();
3858 if (max_results
< 1)
3859 error (_("Request to select 0 symbols!"));
3863 if (select_mode
== multiple_symbols_cancel
)
3865 canceled because the command is ambiguous\n\
3866 See set/show multiple-symbol."));
3868 /* If select_mode is "all", then return all possible symbols.
3869 Only do that if more than one symbol can be selected, of course.
3870 Otherwise, display the menu as usual. */
3871 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3874 printf_filtered (_("[0] cancel\n"));
3875 if (max_results
> 1)
3876 printf_filtered (_("[1] all\n"));
3878 sort_choices (syms
, nsyms
);
3880 for (i
= 0; i
< nsyms
; i
+= 1)
3882 if (syms
[i
].symbol
== NULL
)
3885 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3887 struct symtab_and_line sal
=
3888 find_function_start_sal (syms
[i
].symbol
, 1);
3890 printf_filtered ("[%d] ", i
+ first_choice
);
3891 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3892 &type_print_raw_options
);
3893 if (sal
.symtab
== NULL
)
3894 printf_filtered (_(" at <no source file available>:%d\n"),
3897 printf_filtered (_(" at %s:%d\n"),
3898 symtab_to_filename_for_display (sal
.symtab
),
3905 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3906 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3907 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) == TYPE_CODE_ENUM
);
3908 struct symtab
*symtab
= NULL
;
3910 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3911 symtab
= symbol_symtab (syms
[i
].symbol
);
3913 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3915 printf_filtered ("[%d] ", i
+ first_choice
);
3916 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3917 &type_print_raw_options
);
3918 printf_filtered (_(" at %s:%d\n"),
3919 symtab_to_filename_for_display (symtab
),
3920 SYMBOL_LINE (syms
[i
].symbol
));
3922 else if (is_enumeral
3923 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].symbol
)) != NULL
)
3925 printf_filtered (("[%d] "), i
+ first_choice
);
3926 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3927 gdb_stdout
, -1, 0, &type_print_raw_options
);
3928 printf_filtered (_("'(%s) (enumeral)\n"),
3929 SYMBOL_PRINT_NAME (syms
[i
].symbol
));
3933 printf_filtered ("[%d] ", i
+ first_choice
);
3934 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3935 &type_print_raw_options
);
3938 printf_filtered (is_enumeral
3939 ? _(" in %s (enumeral)\n")
3941 symtab_to_filename_for_display (symtab
));
3943 printf_filtered (is_enumeral
3944 ? _(" (enumeral)\n")
3950 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3953 for (i
= 0; i
< n_chosen
; i
+= 1)
3954 syms
[i
] = syms
[chosen
[i
]];
3959 /* Read and validate a set of numeric choices from the user in the
3960 range 0 .. N_CHOICES-1. Place the results in increasing
3961 order in CHOICES[0 .. N-1], and return N.
3963 The user types choices as a sequence of numbers on one line
3964 separated by blanks, encoding them as follows:
3966 + A choice of 0 means to cancel the selection, throwing an error.
3967 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3968 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3970 The user is not allowed to choose more than MAX_RESULTS values.
3972 ANNOTATION_SUFFIX, if present, is used to annotate the input
3973 prompts (for use with the -f switch). */
3976 get_selections (int *choices
, int n_choices
, int max_results
,
3977 int is_all_choice
, const char *annotation_suffix
)
3982 int first_choice
= is_all_choice
? 2 : 1;
3984 prompt
= getenv ("PS2");
3988 args
= command_line_input (prompt
, annotation_suffix
);
3991 error_no_arg (_("one or more choice numbers"));
3995 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3996 order, as given in args. Choices are validated. */
4002 args
= skip_spaces (args
);
4003 if (*args
== '\0' && n_chosen
== 0)
4004 error_no_arg (_("one or more choice numbers"));
4005 else if (*args
== '\0')
4008 choice
= strtol (args
, &args2
, 10);
4009 if (args
== args2
|| choice
< 0
4010 || choice
> n_choices
+ first_choice
- 1)
4011 error (_("Argument must be choice number"));
4015 error (_("cancelled"));
4017 if (choice
< first_choice
)
4019 n_chosen
= n_choices
;
4020 for (j
= 0; j
< n_choices
; j
+= 1)
4024 choice
-= first_choice
;
4026 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
4030 if (j
< 0 || choice
!= choices
[j
])
4034 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
4035 choices
[k
+ 1] = choices
[k
];
4036 choices
[j
+ 1] = choice
;
4041 if (n_chosen
> max_results
)
4042 error (_("Select no more than %d of the above"), max_results
);
4047 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4048 on the function identified by SYM and BLOCK, and taking NARGS
4049 arguments. Update *EXPP as needed to hold more space. */
4052 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4053 int oplen
, struct symbol
*sym
,
4054 const struct block
*block
)
4056 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4057 symbol, -oplen for operator being replaced). */
4058 struct expression
*newexp
= (struct expression
*)
4059 xzalloc (sizeof (struct expression
)
4060 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
4061 struct expression
*exp
= expp
->get ();
4063 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
4064 newexp
->language_defn
= exp
->language_defn
;
4065 newexp
->gdbarch
= exp
->gdbarch
;
4066 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
4067 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4068 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
4070 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4071 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4073 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4074 newexp
->elts
[pc
+ 4].block
= block
;
4075 newexp
->elts
[pc
+ 5].symbol
= sym
;
4077 expp
->reset (newexp
);
4080 /* Type-class predicates */
4082 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4086 numeric_type_p (struct type
*type
)
4092 switch (TYPE_CODE (type
))
4097 case TYPE_CODE_RANGE
:
4098 return (type
== TYPE_TARGET_TYPE (type
)
4099 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4106 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4109 integer_type_p (struct type
*type
)
4115 switch (TYPE_CODE (type
))
4119 case TYPE_CODE_RANGE
:
4120 return (type
== TYPE_TARGET_TYPE (type
)
4121 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4128 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4131 scalar_type_p (struct type
*type
)
4137 switch (TYPE_CODE (type
))
4140 case TYPE_CODE_RANGE
:
4141 case TYPE_CODE_ENUM
:
4150 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4153 discrete_type_p (struct type
*type
)
4159 switch (TYPE_CODE (type
))
4162 case TYPE_CODE_RANGE
:
4163 case TYPE_CODE_ENUM
:
4164 case TYPE_CODE_BOOL
:
4172 /* Returns non-zero if OP with operands in the vector ARGS could be
4173 a user-defined function. Errs on the side of pre-defined operators
4174 (i.e., result 0). */
4177 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4179 struct type
*type0
=
4180 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4181 struct type
*type1
=
4182 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4196 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4200 case BINOP_BITWISE_AND
:
4201 case BINOP_BITWISE_IOR
:
4202 case BINOP_BITWISE_XOR
:
4203 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4206 case BINOP_NOTEQUAL
:
4211 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4214 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4217 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4221 case UNOP_LOGICAL_NOT
:
4223 return (!numeric_type_p (type0
));
4232 1. In the following, we assume that a renaming type's name may
4233 have an ___XD suffix. It would be nice if this went away at some
4235 2. We handle both the (old) purely type-based representation of
4236 renamings and the (new) variable-based encoding. At some point,
4237 it is devoutly to be hoped that the former goes away
4238 (FIXME: hilfinger-2007-07-09).
4239 3. Subprogram renamings are not implemented, although the XRS
4240 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4242 /* If SYM encodes a renaming,
4244 <renaming> renames <renamed entity>,
4246 sets *LEN to the length of the renamed entity's name,
4247 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4248 the string describing the subcomponent selected from the renamed
4249 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4250 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4251 are undefined). Otherwise, returns a value indicating the category
4252 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4253 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4254 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4255 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4256 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4257 may be NULL, in which case they are not assigned.
4259 [Currently, however, GCC does not generate subprogram renamings.] */
4261 enum ada_renaming_category
4262 ada_parse_renaming (struct symbol
*sym
,
4263 const char **renamed_entity
, int *len
,
4264 const char **renaming_expr
)
4266 enum ada_renaming_category kind
;
4271 return ADA_NOT_RENAMING
;
4272 switch (SYMBOL_CLASS (sym
))
4275 return ADA_NOT_RENAMING
;
4279 case LOC_OPTIMIZED_OUT
:
4280 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
4282 return ADA_NOT_RENAMING
;
4286 kind
= ADA_OBJECT_RENAMING
;
4290 kind
= ADA_EXCEPTION_RENAMING
;
4294 kind
= ADA_PACKAGE_RENAMING
;
4298 kind
= ADA_SUBPROGRAM_RENAMING
;
4302 return ADA_NOT_RENAMING
;
4306 if (renamed_entity
!= NULL
)
4307 *renamed_entity
= info
;
4308 suffix
= strstr (info
, "___XE");
4309 if (suffix
== NULL
|| suffix
== info
)
4310 return ADA_NOT_RENAMING
;
4312 *len
= strlen (info
) - strlen (suffix
);
4314 if (renaming_expr
!= NULL
)
4315 *renaming_expr
= suffix
;
4319 /* Compute the value of the given RENAMING_SYM, which is expected to
4320 be a symbol encoding a renaming expression. BLOCK is the block
4321 used to evaluate the renaming. */
4323 static struct value
*
4324 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4325 const struct block
*block
)
4327 const char *sym_name
;
4329 sym_name
= SYMBOL_LINKAGE_NAME (renaming_sym
);
4330 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4331 return evaluate_expression (expr
.get ());
4335 /* Evaluation: Function Calls */
4337 /* Return an lvalue containing the value VAL. This is the identity on
4338 lvalues, and otherwise has the side-effect of allocating memory
4339 in the inferior where a copy of the value contents is copied. */
4341 static struct value
*
4342 ensure_lval (struct value
*val
)
4344 if (VALUE_LVAL (val
) == not_lval
4345 || VALUE_LVAL (val
) == lval_internalvar
)
4347 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4348 const CORE_ADDR addr
=
4349 value_as_long (value_allocate_space_in_inferior (len
));
4351 VALUE_LVAL (val
) = lval_memory
;
4352 set_value_address (val
, addr
);
4353 write_memory (addr
, value_contents (val
), len
);
4359 /* Return the value ACTUAL, converted to be an appropriate value for a
4360 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4361 allocating any necessary descriptors (fat pointers), or copies of
4362 values not residing in memory, updating it as needed. */
4365 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4367 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4368 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4369 struct type
*formal_target
=
4370 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4371 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4372 struct type
*actual_target
=
4373 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4374 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4376 if (ada_is_array_descriptor_type (formal_target
)
4377 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4378 return make_array_descriptor (formal_type
, actual
);
4379 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4380 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4382 struct value
*result
;
4384 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4385 && ada_is_array_descriptor_type (actual_target
))
4386 result
= desc_data (actual
);
4387 else if (TYPE_CODE (formal_type
) != TYPE_CODE_PTR
)
4389 if (VALUE_LVAL (actual
) != lval_memory
)
4393 actual_type
= ada_check_typedef (value_type (actual
));
4394 val
= allocate_value (actual_type
);
4395 memcpy ((char *) value_contents_raw (val
),
4396 (char *) value_contents (actual
),
4397 TYPE_LENGTH (actual_type
));
4398 actual
= ensure_lval (val
);
4400 result
= value_addr (actual
);
4404 return value_cast_pointers (formal_type
, result
, 0);
4406 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4407 return ada_value_ind (actual
);
4408 else if (ada_is_aligner_type (formal_type
))
4410 /* We need to turn this parameter into an aligner type
4412 struct value
*aligner
= allocate_value (formal_type
);
4413 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4415 value_assign_to_component (aligner
, component
, actual
);
4422 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4423 type TYPE. This is usually an inefficient no-op except on some targets
4424 (such as AVR) where the representation of a pointer and an address
4428 value_pointer (struct value
*value
, struct type
*type
)
4430 struct gdbarch
*gdbarch
= get_type_arch (type
);
4431 unsigned len
= TYPE_LENGTH (type
);
4432 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4435 addr
= value_address (value
);
4436 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4437 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4442 /* Push a descriptor of type TYPE for array value ARR on the stack at
4443 *SP, updating *SP to reflect the new descriptor. Return either
4444 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4445 to-descriptor type rather than a descriptor type), a struct value *
4446 representing a pointer to this descriptor. */
4448 static struct value
*
4449 make_array_descriptor (struct type
*type
, struct value
*arr
)
4451 struct type
*bounds_type
= desc_bounds_type (type
);
4452 struct type
*desc_type
= desc_base_type (type
);
4453 struct value
*descriptor
= allocate_value (desc_type
);
4454 struct value
*bounds
= allocate_value (bounds_type
);
4457 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4460 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4461 ada_array_bound (arr
, i
, 0),
4462 desc_bound_bitpos (bounds_type
, i
, 0),
4463 desc_bound_bitsize (bounds_type
, i
, 0));
4464 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4465 ada_array_bound (arr
, i
, 1),
4466 desc_bound_bitpos (bounds_type
, i
, 1),
4467 desc_bound_bitsize (bounds_type
, i
, 1));
4470 bounds
= ensure_lval (bounds
);
4472 modify_field (value_type (descriptor
),
4473 value_contents_writeable (descriptor
),
4474 value_pointer (ensure_lval (arr
),
4475 TYPE_FIELD_TYPE (desc_type
, 0)),
4476 fat_pntr_data_bitpos (desc_type
),
4477 fat_pntr_data_bitsize (desc_type
));
4479 modify_field (value_type (descriptor
),
4480 value_contents_writeable (descriptor
),
4481 value_pointer (bounds
,
4482 TYPE_FIELD_TYPE (desc_type
, 1)),
4483 fat_pntr_bounds_bitpos (desc_type
),
4484 fat_pntr_bounds_bitsize (desc_type
));
4486 descriptor
= ensure_lval (descriptor
);
4488 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4489 return value_addr (descriptor
);
4494 /* Symbol Cache Module */
4496 /* Performance measurements made as of 2010-01-15 indicate that
4497 this cache does bring some noticeable improvements. Depending
4498 on the type of entity being printed, the cache can make it as much
4499 as an order of magnitude faster than without it.
4501 The descriptive type DWARF extension has significantly reduced
4502 the need for this cache, at least when DWARF is being used. However,
4503 even in this case, some expensive name-based symbol searches are still
4504 sometimes necessary - to find an XVZ variable, mostly. */
4506 /* Initialize the contents of SYM_CACHE. */
4509 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4511 obstack_init (&sym_cache
->cache_space
);
4512 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4515 /* Free the memory used by SYM_CACHE. */
4518 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4520 obstack_free (&sym_cache
->cache_space
, NULL
);
4524 /* Return the symbol cache associated to the given program space PSPACE.
4525 If not allocated for this PSPACE yet, allocate and initialize one. */
4527 static struct ada_symbol_cache
*
4528 ada_get_symbol_cache (struct program_space
*pspace
)
4530 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4532 if (pspace_data
->sym_cache
== NULL
)
4534 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4535 ada_init_symbol_cache (pspace_data
->sym_cache
);
4538 return pspace_data
->sym_cache
;
4541 /* Clear all entries from the symbol cache. */
4544 ada_clear_symbol_cache (void)
4546 struct ada_symbol_cache
*sym_cache
4547 = ada_get_symbol_cache (current_program_space
);
4549 obstack_free (&sym_cache
->cache_space
, NULL
);
4550 ada_init_symbol_cache (sym_cache
);
4553 /* Search our cache for an entry matching NAME and DOMAIN.
4554 Return it if found, or NULL otherwise. */
4556 static struct cache_entry
**
4557 find_entry (const char *name
, domain_enum domain
)
4559 struct ada_symbol_cache
*sym_cache
4560 = ada_get_symbol_cache (current_program_space
);
4561 int h
= msymbol_hash (name
) % HASH_SIZE
;
4562 struct cache_entry
**e
;
4564 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4566 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4572 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4573 Return 1 if found, 0 otherwise.
4575 If an entry was found and SYM is not NULL, set *SYM to the entry's
4576 SYM. Same principle for BLOCK if not NULL. */
4579 lookup_cached_symbol (const char *name
, domain_enum domain
,
4580 struct symbol
**sym
, const struct block
**block
)
4582 struct cache_entry
**e
= find_entry (name
, domain
);
4589 *block
= (*e
)->block
;
4593 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4594 in domain DOMAIN, save this result in our symbol cache. */
4597 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4598 const struct block
*block
)
4600 struct ada_symbol_cache
*sym_cache
4601 = ada_get_symbol_cache (current_program_space
);
4604 struct cache_entry
*e
;
4606 /* Symbols for builtin types don't have a block.
4607 For now don't cache such symbols. */
4608 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4611 /* If the symbol is a local symbol, then do not cache it, as a search
4612 for that symbol depends on the context. To determine whether
4613 the symbol is local or not, we check the block where we found it
4614 against the global and static blocks of its associated symtab. */
4616 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4617 GLOBAL_BLOCK
) != block
4618 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4619 STATIC_BLOCK
) != block
)
4622 h
= msymbol_hash (name
) % HASH_SIZE
;
4623 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4624 e
->next
= sym_cache
->root
[h
];
4625 sym_cache
->root
[h
] = e
;
4627 = (char *) obstack_alloc (&sym_cache
->cache_space
, strlen (name
) + 1);
4628 strcpy (copy
, name
);
4636 /* Return the symbol name match type that should be used used when
4637 searching for all symbols matching LOOKUP_NAME.
4639 LOOKUP_NAME is expected to be a symbol name after transformation
4642 static symbol_name_match_type
4643 name_match_type_from_name (const char *lookup_name
)
4645 return (strstr (lookup_name
, "__") == NULL
4646 ? symbol_name_match_type::WILD
4647 : symbol_name_match_type::FULL
);
4650 /* Return the result of a standard (literal, C-like) lookup of NAME in
4651 given DOMAIN, visible from lexical block BLOCK. */
4653 static struct symbol
*
4654 standard_lookup (const char *name
, const struct block
*block
,
4657 /* Initialize it just to avoid a GCC false warning. */
4658 struct block_symbol sym
= {};
4660 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4662 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4663 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4668 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4669 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4670 since they contend in overloading in the same way. */
4672 is_nonfunction (struct block_symbol syms
[], int n
)
4676 for (i
= 0; i
< n
; i
+= 1)
4677 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_FUNC
4678 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
4679 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4685 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4686 struct types. Otherwise, they may not. */
4689 equiv_types (struct type
*type0
, struct type
*type1
)
4693 if (type0
== NULL
|| type1
== NULL
4694 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4696 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4697 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4698 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4699 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4705 /* True iff SYM0 represents the same entity as SYM1, or one that is
4706 no more defined than that of SYM1. */
4709 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4713 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4714 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4717 switch (SYMBOL_CLASS (sym0
))
4723 struct type
*type0
= SYMBOL_TYPE (sym0
);
4724 struct type
*type1
= SYMBOL_TYPE (sym1
);
4725 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4726 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4727 int len0
= strlen (name0
);
4730 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4731 && (equiv_types (type0
, type1
)
4732 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4733 && startswith (name1
+ len0
, "___XV")));
4736 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4737 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4743 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4744 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4747 add_defn_to_vec (struct obstack
*obstackp
,
4749 const struct block
*block
)
4752 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4754 /* Do not try to complete stub types, as the debugger is probably
4755 already scanning all symbols matching a certain name at the
4756 time when this function is called. Trying to replace the stub
4757 type by its associated full type will cause us to restart a scan
4758 which may lead to an infinite recursion. Instead, the client
4759 collecting the matching symbols will end up collecting several
4760 matches, with at least one of them complete. It can then filter
4761 out the stub ones if needed. */
4763 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4765 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4767 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4769 prevDefns
[i
].symbol
= sym
;
4770 prevDefns
[i
].block
= block
;
4776 struct block_symbol info
;
4780 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4784 /* Number of block_symbol structures currently collected in current vector in
4788 num_defns_collected (struct obstack
*obstackp
)
4790 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4793 /* Vector of block_symbol structures currently collected in current vector in
4794 OBSTACKP. If FINISH, close off the vector and return its final address. */
4796 static struct block_symbol
*
4797 defns_collected (struct obstack
*obstackp
, int finish
)
4800 return (struct block_symbol
*) obstack_finish (obstackp
);
4802 return (struct block_symbol
*) obstack_base (obstackp
);
4805 /* Return a bound minimal symbol matching NAME according to Ada
4806 decoding rules. Returns an invalid symbol if there is no such
4807 minimal symbol. Names prefixed with "standard__" are handled
4808 specially: "standard__" is first stripped off, and only static and
4809 global symbols are searched. */
4811 struct bound_minimal_symbol
4812 ada_lookup_simple_minsym (const char *name
)
4814 struct bound_minimal_symbol result
;
4816 memset (&result
, 0, sizeof (result
));
4818 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4819 lookup_name_info
lookup_name (name
, match_type
);
4821 symbol_name_matcher_ftype
*match_name
4822 = ada_get_symbol_name_matcher (lookup_name
);
4824 for (objfile
*objfile
: current_program_space
->objfiles ())
4826 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4828 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), lookup_name
, NULL
)
4829 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4831 result
.minsym
= msymbol
;
4832 result
.objfile
= objfile
;
4841 /* Return all the bound minimal symbols matching NAME according to Ada
4842 decoding rules. Returns an empty vector if there is no such
4843 minimal symbol. Names prefixed with "standard__" are handled
4844 specially: "standard__" is first stripped off, and only static and
4845 global symbols are searched. */
4847 static std::vector
<struct bound_minimal_symbol
>
4848 ada_lookup_simple_minsyms (const char *name
)
4850 std::vector
<struct bound_minimal_symbol
> result
;
4852 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4853 lookup_name_info
lookup_name (name
, match_type
);
4855 symbol_name_matcher_ftype
*match_name
4856 = ada_get_symbol_name_matcher (lookup_name
);
4858 for (objfile
*objfile
: current_program_space
->objfiles ())
4860 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4862 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), lookup_name
, NULL
)
4863 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4864 result
.push_back ({msymbol
, objfile
});
4871 /* For all subprograms that statically enclose the subprogram of the
4872 selected frame, add symbols matching identifier NAME in DOMAIN
4873 and their blocks to the list of data in OBSTACKP, as for
4874 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4875 with a wildcard prefix. */
4878 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4879 const lookup_name_info
&lookup_name
,
4884 /* True if TYPE is definitely an artificial type supplied to a symbol
4885 for which no debugging information was given in the symbol file. */
4888 is_nondebugging_type (struct type
*type
)
4890 const char *name
= ada_type_name (type
);
4892 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4895 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4896 that are deemed "identical" for practical purposes.
4898 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4899 types and that their number of enumerals is identical (in other
4900 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4903 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4907 /* The heuristic we use here is fairly conservative. We consider
4908 that 2 enumerate types are identical if they have the same
4909 number of enumerals and that all enumerals have the same
4910 underlying value and name. */
4912 /* All enums in the type should have an identical underlying value. */
4913 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4914 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4917 /* All enumerals should also have the same name (modulo any numerical
4919 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4921 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4922 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4923 int len_1
= strlen (name_1
);
4924 int len_2
= strlen (name_2
);
4926 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4927 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4929 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4930 TYPE_FIELD_NAME (type2
, i
),
4938 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4939 that are deemed "identical" for practical purposes. Sometimes,
4940 enumerals are not strictly identical, but their types are so similar
4941 that they can be considered identical.
4943 For instance, consider the following code:
4945 type Color is (Black, Red, Green, Blue, White);
4946 type RGB_Color is new Color range Red .. Blue;
4948 Type RGB_Color is a subrange of an implicit type which is a copy
4949 of type Color. If we call that implicit type RGB_ColorB ("B" is
4950 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4951 As a result, when an expression references any of the enumeral
4952 by name (Eg. "print green"), the expression is technically
4953 ambiguous and the user should be asked to disambiguate. But
4954 doing so would only hinder the user, since it wouldn't matter
4955 what choice he makes, the outcome would always be the same.
4956 So, for practical purposes, we consider them as the same. */
4959 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
4963 /* Before performing a thorough comparison check of each type,
4964 we perform a series of inexpensive checks. We expect that these
4965 checks will quickly fail in the vast majority of cases, and thus
4966 help prevent the unnecessary use of a more expensive comparison.
4967 Said comparison also expects us to make some of these checks
4968 (see ada_identical_enum_types_p). */
4970 /* Quick check: All symbols should have an enum type. */
4971 for (i
= 0; i
< syms
.size (); i
++)
4972 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
)
4975 /* Quick check: They should all have the same value. */
4976 for (i
= 1; i
< syms
.size (); i
++)
4977 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
4980 /* Quick check: They should all have the same number of enumerals. */
4981 for (i
= 1; i
< syms
.size (); i
++)
4982 if (TYPE_NFIELDS (SYMBOL_TYPE (syms
[i
].symbol
))
4983 != TYPE_NFIELDS (SYMBOL_TYPE (syms
[0].symbol
)))
4986 /* All the sanity checks passed, so we might have a set of
4987 identical enumeration types. Perform a more complete
4988 comparison of the type of each symbol. */
4989 for (i
= 1; i
< syms
.size (); i
++)
4990 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
4991 SYMBOL_TYPE (syms
[0].symbol
)))
4997 /* Remove any non-debugging symbols in SYMS that definitely
4998 duplicate other symbols in the list (The only case I know of where
4999 this happens is when object files containing stabs-in-ecoff are
5000 linked with files containing ordinary ecoff debugging symbols (or no
5001 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5002 Returns the number of items in the modified list. */
5005 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5009 /* We should never be called with less than 2 symbols, as there
5010 cannot be any extra symbol in that case. But it's easy to
5011 handle, since we have nothing to do in that case. */
5012 if (syms
->size () < 2)
5013 return syms
->size ();
5016 while (i
< syms
->size ())
5020 /* If two symbols have the same name and one of them is a stub type,
5021 the get rid of the stub. */
5023 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
5024 && SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
)
5026 for (j
= 0; j
< syms
->size (); j
++)
5029 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
5030 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
5031 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
5032 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0)
5037 /* Two symbols with the same name, same class and same address
5038 should be identical. */
5040 else if (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
5041 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5042 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5044 for (j
= 0; j
< syms
->size (); j
+= 1)
5047 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
5048 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
5049 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0
5050 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5051 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5052 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5053 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5059 syms
->erase (syms
->begin () + i
);
5064 /* If all the remaining symbols are identical enumerals, then
5065 just keep the first one and discard the rest.
5067 Unlike what we did previously, we do not discard any entry
5068 unless they are ALL identical. This is because the symbol
5069 comparison is not a strict comparison, but rather a practical
5070 comparison. If all symbols are considered identical, then
5071 we can just go ahead and use the first one and discard the rest.
5072 But if we cannot reduce the list to a single element, we have
5073 to ask the user to disambiguate anyways. And if we have to
5074 present a multiple-choice menu, it's less confusing if the list
5075 isn't missing some choices that were identical and yet distinct. */
5076 if (symbols_are_identical_enums (*syms
))
5079 return syms
->size ();
5082 /* Given a type that corresponds to a renaming entity, use the type name
5083 to extract the scope (package name or function name, fully qualified,
5084 and following the GNAT encoding convention) where this renaming has been
5088 xget_renaming_scope (struct type
*renaming_type
)
5090 /* The renaming types adhere to the following convention:
5091 <scope>__<rename>___<XR extension>.
5092 So, to extract the scope, we search for the "___XR" extension,
5093 and then backtrack until we find the first "__". */
5095 const char *name
= TYPE_NAME (renaming_type
);
5096 const char *suffix
= strstr (name
, "___XR");
5099 /* Now, backtrack a bit until we find the first "__". Start looking
5100 at suffix - 3, as the <rename> part is at least one character long. */
5102 for (last
= suffix
- 3; last
> name
; last
--)
5103 if (last
[0] == '_' && last
[1] == '_')
5106 /* Make a copy of scope and return it. */
5107 return std::string (name
, last
);
5110 /* Return nonzero if NAME corresponds to a package name. */
5113 is_package_name (const char *name
)
5115 /* Here, We take advantage of the fact that no symbols are generated
5116 for packages, while symbols are generated for each function.
5117 So the condition for NAME represent a package becomes equivalent
5118 to NAME not existing in our list of symbols. There is only one
5119 small complication with library-level functions (see below). */
5121 /* If it is a function that has not been defined at library level,
5122 then we should be able to look it up in the symbols. */
5123 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5126 /* Library-level function names start with "_ada_". See if function
5127 "_ada_" followed by NAME can be found. */
5129 /* Do a quick check that NAME does not contain "__", since library-level
5130 functions names cannot contain "__" in them. */
5131 if (strstr (name
, "__") != NULL
)
5134 std::string fun_name
= string_printf ("_ada_%s", name
);
5136 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5139 /* Return nonzero if SYM corresponds to a renaming entity that is
5140 not visible from FUNCTION_NAME. */
5143 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5145 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5148 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5150 /* If the rename has been defined in a package, then it is visible. */
5151 if (is_package_name (scope
.c_str ()))
5154 /* Check that the rename is in the current function scope by checking
5155 that its name starts with SCOPE. */
5157 /* If the function name starts with "_ada_", it means that it is
5158 a library-level function. Strip this prefix before doing the
5159 comparison, as the encoding for the renaming does not contain
5161 if (startswith (function_name
, "_ada_"))
5164 return !startswith (function_name
, scope
.c_str ());
5167 /* Remove entries from SYMS that corresponds to a renaming entity that
5168 is not visible from the function associated with CURRENT_BLOCK or
5169 that is superfluous due to the presence of more specific renaming
5170 information. Places surviving symbols in the initial entries of
5171 SYMS and returns the number of surviving symbols.
5174 First, in cases where an object renaming is implemented as a
5175 reference variable, GNAT may produce both the actual reference
5176 variable and the renaming encoding. In this case, we discard the
5179 Second, GNAT emits a type following a specified encoding for each renaming
5180 entity. Unfortunately, STABS currently does not support the definition
5181 of types that are local to a given lexical block, so all renamings types
5182 are emitted at library level. As a consequence, if an application
5183 contains two renaming entities using the same name, and a user tries to
5184 print the value of one of these entities, the result of the ada symbol
5185 lookup will also contain the wrong renaming type.
5187 This function partially covers for this limitation by attempting to
5188 remove from the SYMS list renaming symbols that should be visible
5189 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5190 method with the current information available. The implementation
5191 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5193 - When the user tries to print a rename in a function while there
5194 is another rename entity defined in a package: Normally, the
5195 rename in the function has precedence over the rename in the
5196 package, so the latter should be removed from the list. This is
5197 currently not the case.
5199 - This function will incorrectly remove valid renames if
5200 the CURRENT_BLOCK corresponds to a function which symbol name
5201 has been changed by an "Export" pragma. As a consequence,
5202 the user will be unable to print such rename entities. */
5205 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5206 const struct block
*current_block
)
5208 struct symbol
*current_function
;
5209 const char *current_function_name
;
5211 int is_new_style_renaming
;
5213 /* If there is both a renaming foo___XR... encoded as a variable and
5214 a simple variable foo in the same block, discard the latter.
5215 First, zero out such symbols, then compress. */
5216 is_new_style_renaming
= 0;
5217 for (i
= 0; i
< syms
->size (); i
+= 1)
5219 struct symbol
*sym
= (*syms
)[i
].symbol
;
5220 const struct block
*block
= (*syms
)[i
].block
;
5224 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5226 name
= SYMBOL_LINKAGE_NAME (sym
);
5227 suffix
= strstr (name
, "___XR");
5231 int name_len
= suffix
- name
;
5234 is_new_style_renaming
= 1;
5235 for (j
= 0; j
< syms
->size (); j
+= 1)
5236 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5237 && strncmp (name
, SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
),
5239 && block
== (*syms
)[j
].block
)
5240 (*syms
)[j
].symbol
= NULL
;
5243 if (is_new_style_renaming
)
5247 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5248 if ((*syms
)[j
].symbol
!= NULL
)
5250 (*syms
)[k
] = (*syms
)[j
];
5256 /* Extract the function name associated to CURRENT_BLOCK.
5257 Abort if unable to do so. */
5259 if (current_block
== NULL
)
5260 return syms
->size ();
5262 current_function
= block_linkage_function (current_block
);
5263 if (current_function
== NULL
)
5264 return syms
->size ();
5266 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
5267 if (current_function_name
== NULL
)
5268 return syms
->size ();
5270 /* Check each of the symbols, and remove it from the list if it is
5271 a type corresponding to a renaming that is out of the scope of
5272 the current block. */
5275 while (i
< syms
->size ())
5277 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5278 == ADA_OBJECT_RENAMING
5279 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5280 current_function_name
))
5281 syms
->erase (syms
->begin () + i
);
5286 return syms
->size ();
5289 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5290 whose name and domain match NAME and DOMAIN respectively.
5291 If no match was found, then extend the search to "enclosing"
5292 routines (in other words, if we're inside a nested function,
5293 search the symbols defined inside the enclosing functions).
5294 If WILD_MATCH_P is nonzero, perform the naming matching in
5295 "wild" mode (see function "wild_match" for more info).
5297 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5300 ada_add_local_symbols (struct obstack
*obstackp
,
5301 const lookup_name_info
&lookup_name
,
5302 const struct block
*block
, domain_enum domain
)
5304 int block_depth
= 0;
5306 while (block
!= NULL
)
5309 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5311 /* If we found a non-function match, assume that's the one. */
5312 if (is_nonfunction (defns_collected (obstackp
, 0),
5313 num_defns_collected (obstackp
)))
5316 block
= BLOCK_SUPERBLOCK (block
);
5319 /* If no luck so far, try to find NAME as a local symbol in some lexically
5320 enclosing subprogram. */
5321 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5322 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5325 /* An object of this type is used as the user_data argument when
5326 calling the map_matching_symbols method. */
5330 struct objfile
*objfile
;
5331 struct obstack
*obstackp
;
5332 struct symbol
*arg_sym
;
5336 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5337 to a list of symbols. DATA0 is a pointer to a struct match_data *
5338 containing the obstack that collects the symbol list, the file that SYM
5339 must come from, a flag indicating whether a non-argument symbol has
5340 been found in the current block, and the last argument symbol
5341 passed in SYM within the current block (if any). When SYM is null,
5342 marking the end of a block, the argument symbol is added if no
5343 other has been found. */
5346 aux_add_nonlocal_symbols (const struct block
*block
, struct symbol
*sym
,
5349 struct match_data
*data
= (struct match_data
*) data0
;
5353 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5354 add_defn_to_vec (data
->obstackp
,
5355 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5357 data
->found_sym
= 0;
5358 data
->arg_sym
= NULL
;
5362 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5364 else if (SYMBOL_IS_ARGUMENT (sym
))
5365 data
->arg_sym
= sym
;
5368 data
->found_sym
= 1;
5369 add_defn_to_vec (data
->obstackp
,
5370 fixup_symbol_section (sym
, data
->objfile
),
5377 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5378 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5379 symbols to OBSTACKP. Return whether we found such symbols. */
5382 ada_add_block_renamings (struct obstack
*obstackp
,
5383 const struct block
*block
,
5384 const lookup_name_info
&lookup_name
,
5387 struct using_direct
*renaming
;
5388 int defns_mark
= num_defns_collected (obstackp
);
5390 symbol_name_matcher_ftype
*name_match
5391 = ada_get_symbol_name_matcher (lookup_name
);
5393 for (renaming
= block_using (block
);
5395 renaming
= renaming
->next
)
5399 /* Avoid infinite recursions: skip this renaming if we are actually
5400 already traversing it.
5402 Currently, symbol lookup in Ada don't use the namespace machinery from
5403 C++/Fortran support: skip namespace imports that use them. */
5404 if (renaming
->searched
5405 || (renaming
->import_src
!= NULL
5406 && renaming
->import_src
[0] != '\0')
5407 || (renaming
->import_dest
!= NULL
5408 && renaming
->import_dest
[0] != '\0'))
5410 renaming
->searched
= 1;
5412 /* TODO: here, we perform another name-based symbol lookup, which can
5413 pull its own multiple overloads. In theory, we should be able to do
5414 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5415 not a simple name. But in order to do this, we would need to enhance
5416 the DWARF reader to associate a symbol to this renaming, instead of a
5417 name. So, for now, we do something simpler: re-use the C++/Fortran
5418 namespace machinery. */
5419 r_name
= (renaming
->alias
!= NULL
5421 : renaming
->declaration
);
5422 if (name_match (r_name
, lookup_name
, NULL
))
5424 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5425 lookup_name
.match_type ());
5426 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5429 renaming
->searched
= 0;
5431 return num_defns_collected (obstackp
) != defns_mark
;
5434 /* Implements compare_names, but only applying the comparision using
5435 the given CASING. */
5438 compare_names_with_case (const char *string1
, const char *string2
,
5439 enum case_sensitivity casing
)
5441 while (*string1
!= '\0' && *string2
!= '\0')
5445 if (isspace (*string1
) || isspace (*string2
))
5446 return strcmp_iw_ordered (string1
, string2
);
5448 if (casing
== case_sensitive_off
)
5450 c1
= tolower (*string1
);
5451 c2
= tolower (*string2
);
5468 return strcmp_iw_ordered (string1
, string2
);
5470 if (*string2
== '\0')
5472 if (is_name_suffix (string1
))
5479 if (*string2
== '(')
5480 return strcmp_iw_ordered (string1
, string2
);
5483 if (casing
== case_sensitive_off
)
5484 return tolower (*string1
) - tolower (*string2
);
5486 return *string1
- *string2
;
5491 /* Compare STRING1 to STRING2, with results as for strcmp.
5492 Compatible with strcmp_iw_ordered in that...
5494 strcmp_iw_ordered (STRING1, STRING2) <= 0
5498 compare_names (STRING1, STRING2) <= 0
5500 (they may differ as to what symbols compare equal). */
5503 compare_names (const char *string1
, const char *string2
)
5507 /* Similar to what strcmp_iw_ordered does, we need to perform
5508 a case-insensitive comparison first, and only resort to
5509 a second, case-sensitive, comparison if the first one was
5510 not sufficient to differentiate the two strings. */
5512 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5514 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5519 /* Convenience function to get at the Ada encoded lookup name for
5520 LOOKUP_NAME, as a C string. */
5523 ada_lookup_name (const lookup_name_info
&lookup_name
)
5525 return lookup_name
.ada ().lookup_name ().c_str ();
5528 /* Add to OBSTACKP all non-local symbols whose name and domain match
5529 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5530 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5531 symbols otherwise. */
5534 add_nonlocal_symbols (struct obstack
*obstackp
,
5535 const lookup_name_info
&lookup_name
,
5536 domain_enum domain
, int global
)
5538 struct match_data data
;
5540 memset (&data
, 0, sizeof data
);
5541 data
.obstackp
= obstackp
;
5543 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5545 for (objfile
*objfile
: current_program_space
->objfiles ())
5547 data
.objfile
= objfile
;
5550 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
.name ().c_str (),
5552 aux_add_nonlocal_symbols
, &data
,
5553 symbol_name_match_type::WILD
,
5556 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
.name ().c_str (),
5558 aux_add_nonlocal_symbols
, &data
,
5559 symbol_name_match_type::FULL
,
5562 for (compunit_symtab
*cu
: objfile
->compunits ())
5564 const struct block
*global_block
5565 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5567 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5573 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5575 const char *name
= ada_lookup_name (lookup_name
);
5576 std::string name1
= std::string ("<_ada_") + name
+ '>';
5578 for (objfile
*objfile
: current_program_space
->objfiles ())
5580 data
.objfile
= objfile
;
5581 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
.c_str (),
5583 aux_add_nonlocal_symbols
,
5585 symbol_name_match_type::FULL
,
5591 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5592 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5593 returning the number of matches. Add these to OBSTACKP.
5595 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5596 symbol match within the nest of blocks whose innermost member is BLOCK,
5597 is the one match returned (no other matches in that or
5598 enclosing blocks is returned). If there are any matches in or
5599 surrounding BLOCK, then these alone are returned.
5601 Names prefixed with "standard__" are handled specially:
5602 "standard__" is first stripped off (by the lookup_name
5603 constructor), and only static and global symbols are searched.
5605 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5606 to lookup global symbols. */
5609 ada_add_all_symbols (struct obstack
*obstackp
,
5610 const struct block
*block
,
5611 const lookup_name_info
&lookup_name
,
5614 int *made_global_lookup_p
)
5618 if (made_global_lookup_p
)
5619 *made_global_lookup_p
= 0;
5621 /* Special case: If the user specifies a symbol name inside package
5622 Standard, do a non-wild matching of the symbol name without
5623 the "standard__" prefix. This was primarily introduced in order
5624 to allow the user to specifically access the standard exceptions
5625 using, for instance, Standard.Constraint_Error when Constraint_Error
5626 is ambiguous (due to the user defining its own Constraint_Error
5627 entity inside its program). */
5628 if (lookup_name
.ada ().standard_p ())
5631 /* Check the non-global symbols. If we have ANY match, then we're done. */
5636 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5639 /* In the !full_search case we're are being called by
5640 ada_iterate_over_symbols, and we don't want to search
5642 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5644 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5648 /* No non-global symbols found. Check our cache to see if we have
5649 already performed this search before. If we have, then return
5652 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5653 domain
, &sym
, &block
))
5656 add_defn_to_vec (obstackp
, sym
, block
);
5660 if (made_global_lookup_p
)
5661 *made_global_lookup_p
= 1;
5663 /* Search symbols from all global blocks. */
5665 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5667 /* Now add symbols from all per-file blocks if we've gotten no hits
5668 (not strictly correct, but perhaps better than an error). */
5670 if (num_defns_collected (obstackp
) == 0)
5671 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5674 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5675 is non-zero, enclosing scope and in global scopes, returning the number of
5677 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5678 found and the blocks and symbol tables (if any) in which they were
5681 When full_search is non-zero, any non-function/non-enumeral
5682 symbol match within the nest of blocks whose innermost member is BLOCK,
5683 is the one match returned (no other matches in that or
5684 enclosing blocks is returned). If there are any matches in or
5685 surrounding BLOCK, then these alone are returned.
5687 Names prefixed with "standard__" are handled specially: "standard__"
5688 is first stripped off, and only static and global symbols are searched. */
5691 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5692 const struct block
*block
,
5694 std::vector
<struct block_symbol
> *results
,
5697 int syms_from_global_search
;
5699 auto_obstack obstack
;
5701 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5702 domain
, full_search
, &syms_from_global_search
);
5704 ndefns
= num_defns_collected (&obstack
);
5706 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5707 for (int i
= 0; i
< ndefns
; ++i
)
5708 results
->push_back (base
[i
]);
5710 ndefns
= remove_extra_symbols (results
);
5712 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5713 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5715 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5716 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5717 (*results
)[0].symbol
, (*results
)[0].block
);
5719 ndefns
= remove_irrelevant_renamings (results
, block
);
5724 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5725 in global scopes, returning the number of matches, and filling *RESULTS
5726 with (SYM,BLOCK) tuples.
5728 See ada_lookup_symbol_list_worker for further details. */
5731 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5733 std::vector
<struct block_symbol
> *results
)
5735 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5736 lookup_name_info
lookup_name (name
, name_match_type
);
5738 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5741 /* Implementation of the la_iterate_over_symbols method. */
5744 ada_iterate_over_symbols
5745 (const struct block
*block
, const lookup_name_info
&name
,
5747 gdb::function_view
<symbol_found_callback_ftype
> callback
)
5750 std::vector
<struct block_symbol
> results
;
5752 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5754 for (i
= 0; i
< ndefs
; ++i
)
5756 if (!callback (&results
[i
]))
5761 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5762 to 1, but choosing the first symbol found if there are multiple
5765 The result is stored in *INFO, which must be non-NULL.
5766 If no match is found, INFO->SYM is set to NULL. */
5769 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5771 struct block_symbol
*info
)
5773 /* Since we already have an encoded name, wrap it in '<>' to force a
5774 verbatim match. Otherwise, if the name happens to not look like
5775 an encoded name (because it doesn't include a "__"),
5776 ada_lookup_name_info would re-encode/fold it again, and that
5777 would e.g., incorrectly lowercase object renaming names like
5778 "R28b" -> "r28b". */
5779 std::string verbatim
= std::string ("<") + name
+ '>';
5781 gdb_assert (info
!= NULL
);
5782 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
, NULL
);
5785 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5786 scope and in global scopes, or NULL if none. NAME is folded and
5787 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5788 choosing the first symbol if there are multiple choices.
5789 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5792 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5793 domain_enum domain
, int *is_a_field_of_this
)
5795 if (is_a_field_of_this
!= NULL
)
5796 *is_a_field_of_this
= 0;
5798 std::vector
<struct block_symbol
> candidates
;
5801 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5803 if (n_candidates
== 0)
5806 block_symbol info
= candidates
[0];
5807 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5811 static struct block_symbol
5812 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5814 const struct block
*block
,
5815 const domain_enum domain
)
5817 struct block_symbol sym
;
5819 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
5820 if (sym
.symbol
!= NULL
)
5823 /* If we haven't found a match at this point, try the primitive
5824 types. In other languages, this search is performed before
5825 searching for global symbols in order to short-circuit that
5826 global-symbol search if it happens that the name corresponds
5827 to a primitive type. But we cannot do the same in Ada, because
5828 it is perfectly legitimate for a program to declare a type which
5829 has the same name as a standard type. If looking up a type in
5830 that situation, we have traditionally ignored the primitive type
5831 in favor of user-defined types. This is why, unlike most other
5832 languages, we search the primitive types this late and only after
5833 having searched the global symbols without success. */
5835 if (domain
== VAR_DOMAIN
)
5837 struct gdbarch
*gdbarch
;
5840 gdbarch
= target_gdbarch ();
5842 gdbarch
= block_gdbarch (block
);
5843 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5844 if (sym
.symbol
!= NULL
)
5852 /* True iff STR is a possible encoded suffix of a normal Ada name
5853 that is to be ignored for matching purposes. Suffixes of parallel
5854 names (e.g., XVE) are not included here. Currently, the possible suffixes
5855 are given by any of the regular expressions:
5857 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5858 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5859 TKB [subprogram suffix for task bodies]
5860 _E[0-9]+[bs]$ [protected object entry suffixes]
5861 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5863 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5864 match is performed. This sequence is used to differentiate homonyms,
5865 is an optional part of a valid name suffix. */
5868 is_name_suffix (const char *str
)
5871 const char *matching
;
5872 const int len
= strlen (str
);
5874 /* Skip optional leading __[0-9]+. */
5876 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5879 while (isdigit (str
[0]))
5885 if (str
[0] == '.' || str
[0] == '$')
5888 while (isdigit (matching
[0]))
5890 if (matching
[0] == '\0')
5896 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5899 while (isdigit (matching
[0]))
5901 if (matching
[0] == '\0')
5905 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5907 if (strcmp (str
, "TKB") == 0)
5911 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5912 with a N at the end. Unfortunately, the compiler uses the same
5913 convention for other internal types it creates. So treating
5914 all entity names that end with an "N" as a name suffix causes
5915 some regressions. For instance, consider the case of an enumerated
5916 type. To support the 'Image attribute, it creates an array whose
5918 Having a single character like this as a suffix carrying some
5919 information is a bit risky. Perhaps we should change the encoding
5920 to be something like "_N" instead. In the meantime, do not do
5921 the following check. */
5922 /* Protected Object Subprograms */
5923 if (len
== 1 && str
[0] == 'N')
5928 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5931 while (isdigit (matching
[0]))
5933 if ((matching
[0] == 'b' || matching
[0] == 's')
5934 && matching
[1] == '\0')
5938 /* ??? We should not modify STR directly, as we are doing below. This
5939 is fine in this case, but may become problematic later if we find
5940 that this alternative did not work, and want to try matching
5941 another one from the begining of STR. Since we modified it, we
5942 won't be able to find the begining of the string anymore! */
5946 while (str
[0] != '_' && str
[0] != '\0')
5948 if (str
[0] != 'n' && str
[0] != 'b')
5954 if (str
[0] == '\000')
5959 if (str
[1] != '_' || str
[2] == '\000')
5963 if (strcmp (str
+ 3, "JM") == 0)
5965 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5966 the LJM suffix in favor of the JM one. But we will
5967 still accept LJM as a valid suffix for a reasonable
5968 amount of time, just to allow ourselves to debug programs
5969 compiled using an older version of GNAT. */
5970 if (strcmp (str
+ 3, "LJM") == 0)
5974 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5975 || str
[4] == 'U' || str
[4] == 'P')
5977 if (str
[4] == 'R' && str
[5] != 'T')
5981 if (!isdigit (str
[2]))
5983 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5984 if (!isdigit (str
[k
]) && str
[k
] != '_')
5988 if (str
[0] == '$' && isdigit (str
[1]))
5990 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5991 if (!isdigit (str
[k
]) && str
[k
] != '_')
5998 /* Return non-zero if the string starting at NAME and ending before
5999 NAME_END contains no capital letters. */
6002 is_valid_name_for_wild_match (const char *name0
)
6004 const char *decoded_name
= ada_decode (name0
);
6007 /* If the decoded name starts with an angle bracket, it means that
6008 NAME0 does not follow the GNAT encoding format. It should then
6009 not be allowed as a possible wild match. */
6010 if (decoded_name
[0] == '<')
6013 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6014 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6020 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6021 that could start a simple name. Assumes that *NAMEP points into
6022 the string beginning at NAME0. */
6025 advance_wild_match (const char **namep
, const char *name0
, int target0
)
6027 const char *name
= *namep
;
6037 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6040 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6045 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6046 || name
[2] == target0
))
6054 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6064 /* Return true iff NAME encodes a name of the form prefix.PATN.
6065 Ignores any informational suffixes of NAME (i.e., for which
6066 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6070 wild_match (const char *name
, const char *patn
)
6073 const char *name0
= name
;
6077 const char *match
= name
;
6081 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6084 if (*p
== '\0' && is_name_suffix (name
))
6085 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6087 if (name
[-1] == '_')
6090 if (!advance_wild_match (&name
, name0
, *patn
))
6095 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6096 any trailing suffixes that encode debugging information or leading
6097 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6098 information that is ignored). */
6101 full_match (const char *sym_name
, const char *search_name
)
6103 size_t search_name_len
= strlen (search_name
);
6105 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6106 && is_name_suffix (sym_name
+ search_name_len
))
6109 if (startswith (sym_name
, "_ada_")
6110 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6111 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6117 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6118 *defn_symbols, updating the list of symbols in OBSTACKP (if
6119 necessary). OBJFILE is the section containing BLOCK. */
6122 ada_add_block_symbols (struct obstack
*obstackp
,
6123 const struct block
*block
,
6124 const lookup_name_info
&lookup_name
,
6125 domain_enum domain
, struct objfile
*objfile
)
6127 struct block_iterator iter
;
6128 /* A matching argument symbol, if any. */
6129 struct symbol
*arg_sym
;
6130 /* Set true when we find a matching non-argument symbol. */
6136 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6138 sym
= block_iter_match_next (lookup_name
, &iter
))
6140 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6141 SYMBOL_DOMAIN (sym
), domain
))
6143 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6145 if (SYMBOL_IS_ARGUMENT (sym
))
6150 add_defn_to_vec (obstackp
,
6151 fixup_symbol_section (sym
, objfile
),
6158 /* Handle renamings. */
6160 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6163 if (!found_sym
&& arg_sym
!= NULL
)
6165 add_defn_to_vec (obstackp
,
6166 fixup_symbol_section (arg_sym
, objfile
),
6170 if (!lookup_name
.ada ().wild_match_p ())
6174 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6175 const char *name
= ada_lookup_name
.c_str ();
6176 size_t name_len
= ada_lookup_name
.size ();
6178 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6180 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6181 SYMBOL_DOMAIN (sym
), domain
))
6185 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
6188 cmp
= !startswith (SYMBOL_LINKAGE_NAME (sym
), "_ada_");
6190 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
6195 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
6197 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6199 if (SYMBOL_IS_ARGUMENT (sym
))
6204 add_defn_to_vec (obstackp
,
6205 fixup_symbol_section (sym
, objfile
),
6213 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6214 They aren't parameters, right? */
6215 if (!found_sym
&& arg_sym
!= NULL
)
6217 add_defn_to_vec (obstackp
,
6218 fixup_symbol_section (arg_sym
, objfile
),
6225 /* Symbol Completion */
6230 ada_lookup_name_info::matches
6231 (const char *sym_name
,
6232 symbol_name_match_type match_type
,
6233 completion_match_result
*comp_match_res
) const
6236 const char *text
= m_encoded_name
.c_str ();
6237 size_t text_len
= m_encoded_name
.size ();
6239 /* First, test against the fully qualified name of the symbol. */
6241 if (strncmp (sym_name
, text
, text_len
) == 0)
6244 if (match
&& !m_encoded_p
)
6246 /* One needed check before declaring a positive match is to verify
6247 that iff we are doing a verbatim match, the decoded version
6248 of the symbol name starts with '<'. Otherwise, this symbol name
6249 is not a suitable completion. */
6250 const char *sym_name_copy
= sym_name
;
6251 bool has_angle_bracket
;
6253 sym_name
= ada_decode (sym_name
);
6254 has_angle_bracket
= (sym_name
[0] == '<');
6255 match
= (has_angle_bracket
== m_verbatim_p
);
6256 sym_name
= sym_name_copy
;
6259 if (match
&& !m_verbatim_p
)
6261 /* When doing non-verbatim match, another check that needs to
6262 be done is to verify that the potentially matching symbol name
6263 does not include capital letters, because the ada-mode would
6264 not be able to understand these symbol names without the
6265 angle bracket notation. */
6268 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6273 /* Second: Try wild matching... */
6275 if (!match
&& m_wild_match_p
)
6277 /* Since we are doing wild matching, this means that TEXT
6278 may represent an unqualified symbol name. We therefore must
6279 also compare TEXT against the unqualified name of the symbol. */
6280 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
6282 if (strncmp (sym_name
, text
, text_len
) == 0)
6286 /* Finally: If we found a match, prepare the result to return. */
6291 if (comp_match_res
!= NULL
)
6293 std::string
&match_str
= comp_match_res
->match
.storage ();
6296 match_str
= ada_decode (sym_name
);
6300 match_str
= add_angle_brackets (sym_name
);
6302 match_str
= sym_name
;
6306 comp_match_res
->set_match (match_str
.c_str ());
6312 /* Add the list of possible symbol names completing TEXT to TRACKER.
6313 WORD is the entire command on which completion is made. */
6316 ada_collect_symbol_completion_matches (completion_tracker
&tracker
,
6317 complete_symbol_mode mode
,
6318 symbol_name_match_type name_match_type
,
6319 const char *text
, const char *word
,
6320 enum type_code code
)
6323 const struct block
*b
, *surrounding_static_block
= 0;
6324 struct block_iterator iter
;
6326 gdb_assert (code
== TYPE_CODE_UNDEF
);
6328 lookup_name_info
lookup_name (text
, name_match_type
, true);
6330 /* First, look at the partial symtab symbols. */
6331 expand_symtabs_matching (NULL
,
6337 /* At this point scan through the misc symbol vectors and add each
6338 symbol you find to the list. Eventually we want to ignore
6339 anything that isn't a text symbol (everything else will be
6340 handled by the psymtab code above). */
6342 for (objfile
*objfile
: current_program_space
->objfiles ())
6344 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
6348 if (completion_skip_symbol (mode
, msymbol
))
6351 language symbol_language
= MSYMBOL_LANGUAGE (msymbol
);
6353 /* Ada minimal symbols won't have their language set to Ada. If
6354 we let completion_list_add_name compare using the
6355 default/C-like matcher, then when completing e.g., symbols in a
6356 package named "pck", we'd match internal Ada symbols like
6357 "pckS", which are invalid in an Ada expression, unless you wrap
6358 them in '<' '>' to request a verbatim match.
6360 Unfortunately, some Ada encoded names successfully demangle as
6361 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6362 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6363 with the wrong language set. Paper over that issue here. */
6364 if (symbol_language
== language_auto
6365 || symbol_language
== language_cplus
)
6366 symbol_language
= language_ada
;
6368 completion_list_add_name (tracker
,
6370 MSYMBOL_LINKAGE_NAME (msymbol
),
6371 lookup_name
, text
, word
);
6375 /* Search upwards from currently selected frame (so that we can
6376 complete on local vars. */
6378 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6380 if (!BLOCK_SUPERBLOCK (b
))
6381 surrounding_static_block
= b
; /* For elmin of dups */
6383 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6385 if (completion_skip_symbol (mode
, sym
))
6388 completion_list_add_name (tracker
,
6389 SYMBOL_LANGUAGE (sym
),
6390 SYMBOL_LINKAGE_NAME (sym
),
6391 lookup_name
, text
, word
);
6395 /* Go through the symtabs and check the externs and statics for
6396 symbols which match. */
6398 for (objfile
*objfile
: current_program_space
->objfiles ())
6400 for (compunit_symtab
*s
: objfile
->compunits ())
6403 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6404 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6406 if (completion_skip_symbol (mode
, sym
))
6409 completion_list_add_name (tracker
,
6410 SYMBOL_LANGUAGE (sym
),
6411 SYMBOL_LINKAGE_NAME (sym
),
6412 lookup_name
, text
, word
);
6417 for (objfile
*objfile
: current_program_space
->objfiles ())
6419 for (compunit_symtab
*s
: objfile
->compunits ())
6422 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6423 /* Don't do this block twice. */
6424 if (b
== surrounding_static_block
)
6426 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6428 if (completion_skip_symbol (mode
, sym
))
6431 completion_list_add_name (tracker
,
6432 SYMBOL_LANGUAGE (sym
),
6433 SYMBOL_LINKAGE_NAME (sym
),
6434 lookup_name
, text
, word
);
6442 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6443 for tagged types. */
6446 ada_is_dispatch_table_ptr_type (struct type
*type
)
6450 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
6453 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
6457 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6460 /* Return non-zero if TYPE is an interface tag. */
6463 ada_is_interface_tag (struct type
*type
)
6465 const char *name
= TYPE_NAME (type
);
6470 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6473 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6474 to be invisible to users. */
6477 ada_is_ignored_field (struct type
*type
, int field_num
)
6479 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6482 /* Check the name of that field. */
6484 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6486 /* Anonymous field names should not be printed.
6487 brobecker/2007-02-20: I don't think this can actually happen
6488 but we don't want to print the value of annonymous fields anyway. */
6492 /* Normally, fields whose name start with an underscore ("_")
6493 are fields that have been internally generated by the compiler,
6494 and thus should not be printed. The "_parent" field is special,
6495 however: This is a field internally generated by the compiler
6496 for tagged types, and it contains the components inherited from
6497 the parent type. This field should not be printed as is, but
6498 should not be ignored either. */
6499 if (name
[0] == '_' && !startswith (name
, "_parent"))
6503 /* If this is the dispatch table of a tagged type or an interface tag,
6505 if (ada_is_tagged_type (type
, 1)
6506 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6507 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6510 /* Not a special field, so it should not be ignored. */
6514 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6515 pointer or reference type whose ultimate target has a tag field. */
6518 ada_is_tagged_type (struct type
*type
, int refok
)
6520 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6523 /* True iff TYPE represents the type of X'Tag */
6526 ada_is_tag_type (struct type
*type
)
6528 type
= ada_check_typedef (type
);
6530 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6534 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6536 return (name
!= NULL
6537 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6541 /* The type of the tag on VAL. */
6544 ada_tag_type (struct value
*val
)
6546 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6549 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6550 retired at Ada 05). */
6553 is_ada95_tag (struct value
*tag
)
6555 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6558 /* The value of the tag on VAL. */
6561 ada_value_tag (struct value
*val
)
6563 return ada_value_struct_elt (val
, "_tag", 0);
6566 /* The value of the tag on the object of type TYPE whose contents are
6567 saved at VALADDR, if it is non-null, or is at memory address
6570 static struct value
*
6571 value_tag_from_contents_and_address (struct type
*type
,
6572 const gdb_byte
*valaddr
,
6575 int tag_byte_offset
;
6576 struct type
*tag_type
;
6578 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6581 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6583 : valaddr
+ tag_byte_offset
);
6584 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6586 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6591 static struct type
*
6592 type_from_tag (struct value
*tag
)
6594 const char *type_name
= ada_tag_name (tag
);
6596 if (type_name
!= NULL
)
6597 return ada_find_any_type (ada_encode (type_name
));
6601 /* Given a value OBJ of a tagged type, return a value of this
6602 type at the base address of the object. The base address, as
6603 defined in Ada.Tags, it is the address of the primary tag of
6604 the object, and therefore where the field values of its full
6605 view can be fetched. */
6608 ada_tag_value_at_base_address (struct value
*obj
)
6611 LONGEST offset_to_top
= 0;
6612 struct type
*ptr_type
, *obj_type
;
6614 CORE_ADDR base_address
;
6616 obj_type
= value_type (obj
);
6618 /* It is the responsability of the caller to deref pointers. */
6620 if (TYPE_CODE (obj_type
) == TYPE_CODE_PTR
6621 || TYPE_CODE (obj_type
) == TYPE_CODE_REF
)
6624 tag
= ada_value_tag (obj
);
6628 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6630 if (is_ada95_tag (tag
))
6633 ptr_type
= language_lookup_primitive_type
6634 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6635 ptr_type
= lookup_pointer_type (ptr_type
);
6636 val
= value_cast (ptr_type
, tag
);
6640 /* It is perfectly possible that an exception be raised while
6641 trying to determine the base address, just like for the tag;
6642 see ada_tag_name for more details. We do not print the error
6643 message for the same reason. */
6647 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6650 catch (const gdb_exception_error
&e
)
6655 /* If offset is null, nothing to do. */
6657 if (offset_to_top
== 0)
6660 /* -1 is a special case in Ada.Tags; however, what should be done
6661 is not quite clear from the documentation. So do nothing for
6664 if (offset_to_top
== -1)
6667 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6668 from the base address. This was however incompatible with
6669 C++ dispatch table: C++ uses a *negative* value to *add*
6670 to the base address. Ada's convention has therefore been
6671 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6672 use the same convention. Here, we support both cases by
6673 checking the sign of OFFSET_TO_TOP. */
6675 if (offset_to_top
> 0)
6676 offset_to_top
= -offset_to_top
;
6678 base_address
= value_address (obj
) + offset_to_top
;
6679 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6681 /* Make sure that we have a proper tag at the new address.
6682 Otherwise, offset_to_top is bogus (which can happen when
6683 the object is not initialized yet). */
6688 obj_type
= type_from_tag (tag
);
6693 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6696 /* Return the "ada__tags__type_specific_data" type. */
6698 static struct type
*
6699 ada_get_tsd_type (struct inferior
*inf
)
6701 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6703 if (data
->tsd_type
== 0)
6704 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6705 return data
->tsd_type
;
6708 /* Return the TSD (type-specific data) associated to the given TAG.
6709 TAG is assumed to be the tag of a tagged-type entity.
6711 May return NULL if we are unable to get the TSD. */
6713 static struct value
*
6714 ada_get_tsd_from_tag (struct value
*tag
)
6719 /* First option: The TSD is simply stored as a field of our TAG.
6720 Only older versions of GNAT would use this format, but we have
6721 to test it first, because there are no visible markers for
6722 the current approach except the absence of that field. */
6724 val
= ada_value_struct_elt (tag
, "tsd", 1);
6728 /* Try the second representation for the dispatch table (in which
6729 there is no explicit 'tsd' field in the referent of the tag pointer,
6730 and instead the tsd pointer is stored just before the dispatch
6733 type
= ada_get_tsd_type (current_inferior());
6736 type
= lookup_pointer_type (lookup_pointer_type (type
));
6737 val
= value_cast (type
, tag
);
6740 return value_ind (value_ptradd (val
, -1));
6743 /* Given the TSD of a tag (type-specific data), return a string
6744 containing the name of the associated type.
6746 The returned value is good until the next call. May return NULL
6747 if we are unable to determine the tag name. */
6750 ada_tag_name_from_tsd (struct value
*tsd
)
6752 static char name
[1024];
6756 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6759 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6760 for (p
= name
; *p
!= '\0'; p
+= 1)
6766 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6769 Return NULL if the TAG is not an Ada tag, or if we were unable to
6770 determine the name of that tag. The result is good until the next
6774 ada_tag_name (struct value
*tag
)
6778 if (!ada_is_tag_type (value_type (tag
)))
6781 /* It is perfectly possible that an exception be raised while trying
6782 to determine the TAG's name, even under normal circumstances:
6783 The associated variable may be uninitialized or corrupted, for
6784 instance. We do not let any exception propagate past this point.
6785 instead we return NULL.
6787 We also do not print the error message either (which often is very
6788 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6789 the caller print a more meaningful message if necessary. */
6792 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6795 name
= ada_tag_name_from_tsd (tsd
);
6797 catch (const gdb_exception_error
&e
)
6804 /* The parent type of TYPE, or NULL if none. */
6807 ada_parent_type (struct type
*type
)
6811 type
= ada_check_typedef (type
);
6813 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6816 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6817 if (ada_is_parent_field (type
, i
))
6819 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6821 /* If the _parent field is a pointer, then dereference it. */
6822 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
6823 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6824 /* If there is a parallel XVS type, get the actual base type. */
6825 parent_type
= ada_get_base_type (parent_type
);
6827 return ada_check_typedef (parent_type
);
6833 /* True iff field number FIELD_NUM of structure type TYPE contains the
6834 parent-type (inherited) fields of a derived type. Assumes TYPE is
6835 a structure type with at least FIELD_NUM+1 fields. */
6838 ada_is_parent_field (struct type
*type
, int field_num
)
6840 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6842 return (name
!= NULL
6843 && (startswith (name
, "PARENT")
6844 || startswith (name
, "_parent")));
6847 /* True iff field number FIELD_NUM of structure type TYPE is a
6848 transparent wrapper field (which should be silently traversed when doing
6849 field selection and flattened when printing). Assumes TYPE is a
6850 structure type with at least FIELD_NUM+1 fields. Such fields are always
6854 ada_is_wrapper_field (struct type
*type
, int field_num
)
6856 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6858 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6860 /* This happens in functions with "out" or "in out" parameters
6861 which are passed by copy. For such functions, GNAT describes
6862 the function's return type as being a struct where the return
6863 value is in a field called RETVAL, and where the other "out"
6864 or "in out" parameters are fields of that struct. This is not
6869 return (name
!= NULL
6870 && (startswith (name
, "PARENT")
6871 || strcmp (name
, "REP") == 0
6872 || startswith (name
, "_parent")
6873 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6876 /* True iff field number FIELD_NUM of structure or union type TYPE
6877 is a variant wrapper. Assumes TYPE is a structure type with at least
6878 FIELD_NUM+1 fields. */
6881 ada_is_variant_part (struct type
*type
, int field_num
)
6883 /* Only Ada types are eligible. */
6884 if (!ADA_TYPE_P (type
))
6887 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6889 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6890 || (is_dynamic_field (type
, field_num
)
6891 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6892 == TYPE_CODE_UNION
)));
6895 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6896 whose discriminants are contained in the record type OUTER_TYPE,
6897 returns the type of the controlling discriminant for the variant.
6898 May return NULL if the type could not be found. */
6901 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6903 const char *name
= ada_variant_discrim_name (var_type
);
6905 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6908 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6909 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6910 represents a 'when others' clause; otherwise 0. */
6913 ada_is_others_clause (struct type
*type
, int field_num
)
6915 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6917 return (name
!= NULL
&& name
[0] == 'O');
6920 /* Assuming that TYPE0 is the type of the variant part of a record,
6921 returns the name of the discriminant controlling the variant.
6922 The value is valid until the next call to ada_variant_discrim_name. */
6925 ada_variant_discrim_name (struct type
*type0
)
6927 static char *result
= NULL
;
6928 static size_t result_len
= 0;
6931 const char *discrim_end
;
6932 const char *discrim_start
;
6934 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6935 type
= TYPE_TARGET_TYPE (type0
);
6939 name
= ada_type_name (type
);
6941 if (name
== NULL
|| name
[0] == '\000')
6944 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6947 if (startswith (discrim_end
, "___XVN"))
6950 if (discrim_end
== name
)
6953 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6956 if (discrim_start
== name
+ 1)
6958 if ((discrim_start
> name
+ 3
6959 && startswith (discrim_start
- 3, "___"))
6960 || discrim_start
[-1] == '.')
6964 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6965 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6966 result
[discrim_end
- discrim_start
] = '\0';
6970 /* Scan STR for a subtype-encoded number, beginning at position K.
6971 Put the position of the character just past the number scanned in
6972 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6973 Return 1 if there was a valid number at the given position, and 0
6974 otherwise. A "subtype-encoded" number consists of the absolute value
6975 in decimal, followed by the letter 'm' to indicate a negative number.
6976 Assumes 0m does not occur. */
6979 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6983 if (!isdigit (str
[k
]))
6986 /* Do it the hard way so as not to make any assumption about
6987 the relationship of unsigned long (%lu scan format code) and
6990 while (isdigit (str
[k
]))
6992 RU
= RU
* 10 + (str
[k
] - '0');
6999 *R
= (-(LONGEST
) (RU
- 1)) - 1;
7005 /* NOTE on the above: Technically, C does not say what the results of
7006 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7007 number representable as a LONGEST (although either would probably work
7008 in most implementations). When RU>0, the locution in the then branch
7009 above is always equivalent to the negative of RU. */
7016 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7017 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7018 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7021 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
7023 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
7037 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
7047 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
7048 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
7050 if (val
>= L
&& val
<= U
)
7062 /* FIXME: Lots of redundancy below. Try to consolidate. */
7064 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7065 ARG_TYPE, extract and return the value of one of its (non-static)
7066 fields. FIELDNO says which field. Differs from value_primitive_field
7067 only in that it can handle packed values of arbitrary type. */
7069 static struct value
*
7070 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
7071 struct type
*arg_type
)
7075 arg_type
= ada_check_typedef (arg_type
);
7076 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
7078 /* Handle packed fields. It might be that the field is not packed
7079 relative to its containing structure, but the structure itself is
7080 packed; in this case we must take the bit-field path. */
7081 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
7083 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
7084 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
7086 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
7087 offset
+ bit_pos
/ 8,
7088 bit_pos
% 8, bit_size
, type
);
7091 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
7094 /* Find field with name NAME in object of type TYPE. If found,
7095 set the following for each argument that is non-null:
7096 - *FIELD_TYPE_P to the field's type;
7097 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7098 an object of that type;
7099 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7100 - *BIT_SIZE_P to its size in bits if the field is packed, and
7102 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7103 fields up to but not including the desired field, or by the total
7104 number of fields if not found. A NULL value of NAME never
7105 matches; the function just counts visible fields in this case.
7107 Notice that we need to handle when a tagged record hierarchy
7108 has some components with the same name, like in this scenario:
7110 type Top_T is tagged record
7116 type Middle_T is new Top.Top_T with record
7117 N : Character := 'a';
7121 type Bottom_T is new Middle.Middle_T with record
7123 C : Character := '5';
7125 A : Character := 'J';
7128 Let's say we now have a variable declared and initialized as follow:
7130 TC : Top_A := new Bottom_T;
7132 And then we use this variable to call this function
7134 procedure Assign (Obj: in out Top_T; TV : Integer);
7138 Assign (Top_T (B), 12);
7140 Now, we're in the debugger, and we're inside that procedure
7141 then and we want to print the value of obj.c:
7143 Usually, the tagged record or one of the parent type owns the
7144 component to print and there's no issue but in this particular
7145 case, what does it mean to ask for Obj.C? Since the actual
7146 type for object is type Bottom_T, it could mean two things: type
7147 component C from the Middle_T view, but also component C from
7148 Bottom_T. So in that "undefined" case, when the component is
7149 not found in the non-resolved type (which includes all the
7150 components of the parent type), then resolve it and see if we
7151 get better luck once expanded.
7153 In the case of homonyms in the derived tagged type, we don't
7154 guaranty anything, and pick the one that's easiest for us
7157 Returns 1 if found, 0 otherwise. */
7160 find_struct_field (const char *name
, struct type
*type
, int offset
,
7161 struct type
**field_type_p
,
7162 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7166 int parent_offset
= -1;
7168 type
= ada_check_typedef (type
);
7170 if (field_type_p
!= NULL
)
7171 *field_type_p
= NULL
;
7172 if (byte_offset_p
!= NULL
)
7174 if (bit_offset_p
!= NULL
)
7176 if (bit_size_p
!= NULL
)
7179 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7181 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7182 int fld_offset
= offset
+ bit_pos
/ 8;
7183 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7185 if (t_field_name
== NULL
)
7188 else if (ada_is_parent_field (type
, i
))
7190 /* This is a field pointing us to the parent type of a tagged
7191 type. As hinted in this function's documentation, we give
7192 preference to fields in the current record first, so what
7193 we do here is just record the index of this field before
7194 we skip it. If it turns out we couldn't find our field
7195 in the current record, then we'll get back to it and search
7196 inside it whether the field might exist in the parent. */
7202 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7204 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7206 if (field_type_p
!= NULL
)
7207 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
7208 if (byte_offset_p
!= NULL
)
7209 *byte_offset_p
= fld_offset
;
7210 if (bit_offset_p
!= NULL
)
7211 *bit_offset_p
= bit_pos
% 8;
7212 if (bit_size_p
!= NULL
)
7213 *bit_size_p
= bit_size
;
7216 else if (ada_is_wrapper_field (type
, i
))
7218 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
7219 field_type_p
, byte_offset_p
, bit_offset_p
,
7220 bit_size_p
, index_p
))
7223 else if (ada_is_variant_part (type
, i
))
7225 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7228 struct type
*field_type
7229 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7231 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7233 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7235 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7236 field_type_p
, byte_offset_p
,
7237 bit_offset_p
, bit_size_p
, index_p
))
7241 else if (index_p
!= NULL
)
7245 /* Field not found so far. If this is a tagged type which
7246 has a parent, try finding that field in the parent now. */
7248 if (parent_offset
!= -1)
7250 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7251 int fld_offset
= offset
+ bit_pos
/ 8;
7253 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, parent_offset
),
7254 fld_offset
, field_type_p
, byte_offset_p
,
7255 bit_offset_p
, bit_size_p
, index_p
))
7262 /* Number of user-visible fields in record type TYPE. */
7265 num_visible_fields (struct type
*type
)
7270 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7274 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7275 and search in it assuming it has (class) type TYPE.
7276 If found, return value, else return NULL.
7278 Searches recursively through wrapper fields (e.g., '_parent').
7280 In the case of homonyms in the tagged types, please refer to the
7281 long explanation in find_struct_field's function documentation. */
7283 static struct value
*
7284 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7288 int parent_offset
= -1;
7290 type
= ada_check_typedef (type
);
7291 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7293 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7295 if (t_field_name
== NULL
)
7298 else if (ada_is_parent_field (type
, i
))
7300 /* This is a field pointing us to the parent type of a tagged
7301 type. As hinted in this function's documentation, we give
7302 preference to fields in the current record first, so what
7303 we do here is just record the index of this field before
7304 we skip it. If it turns out we couldn't find our field
7305 in the current record, then we'll get back to it and search
7306 inside it whether the field might exist in the parent. */
7312 else if (field_name_match (t_field_name
, name
))
7313 return ada_value_primitive_field (arg
, offset
, i
, type
);
7315 else if (ada_is_wrapper_field (type
, i
))
7317 struct value
*v
= /* Do not let indent join lines here. */
7318 ada_search_struct_field (name
, arg
,
7319 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7320 TYPE_FIELD_TYPE (type
, i
));
7326 else if (ada_is_variant_part (type
, i
))
7328 /* PNH: Do we ever get here? See find_struct_field. */
7330 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7332 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7334 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7336 struct value
*v
= ada_search_struct_field
/* Force line
7339 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7340 TYPE_FIELD_TYPE (field_type
, j
));
7348 /* Field not found so far. If this is a tagged type which
7349 has a parent, try finding that field in the parent now. */
7351 if (parent_offset
!= -1)
7353 struct value
*v
= ada_search_struct_field (
7354 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7355 TYPE_FIELD_TYPE (type
, parent_offset
));
7364 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7365 int, struct type
*);
7368 /* Return field #INDEX in ARG, where the index is that returned by
7369 * find_struct_field through its INDEX_P argument. Adjust the address
7370 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7371 * If found, return value, else return NULL. */
7373 static struct value
*
7374 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7377 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7381 /* Auxiliary function for ada_index_struct_field. Like
7382 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7385 static struct value
*
7386 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7390 type
= ada_check_typedef (type
);
7392 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7394 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7396 else if (ada_is_wrapper_field (type
, i
))
7398 struct value
*v
= /* Do not let indent join lines here. */
7399 ada_index_struct_field_1 (index_p
, arg
,
7400 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7401 TYPE_FIELD_TYPE (type
, i
));
7407 else if (ada_is_variant_part (type
, i
))
7409 /* PNH: Do we ever get here? See ada_search_struct_field,
7410 find_struct_field. */
7411 error (_("Cannot assign this kind of variant record"));
7413 else if (*index_p
== 0)
7414 return ada_value_primitive_field (arg
, offset
, i
, type
);
7421 /* Given ARG, a value of type (pointer or reference to a)*
7422 structure/union, extract the component named NAME from the ultimate
7423 target structure/union and return it as a value with its
7426 The routine searches for NAME among all members of the structure itself
7427 and (recursively) among all members of any wrapper members
7430 If NO_ERR, then simply return NULL in case of error, rather than
7434 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
7436 struct type
*t
, *t1
;
7441 t1
= t
= ada_check_typedef (value_type (arg
));
7442 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7444 t1
= TYPE_TARGET_TYPE (t
);
7447 t1
= ada_check_typedef (t1
);
7448 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7450 arg
= coerce_ref (arg
);
7455 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7457 t1
= TYPE_TARGET_TYPE (t
);
7460 t1
= ada_check_typedef (t1
);
7461 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7463 arg
= value_ind (arg
);
7470 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7474 v
= ada_search_struct_field (name
, arg
, 0, t
);
7477 int bit_offset
, bit_size
, byte_offset
;
7478 struct type
*field_type
;
7481 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7482 address
= value_address (ada_value_ind (arg
));
7484 address
= value_address (ada_coerce_ref (arg
));
7486 /* Check to see if this is a tagged type. We also need to handle
7487 the case where the type is a reference to a tagged type, but
7488 we have to be careful to exclude pointers to tagged types.
7489 The latter should be shown as usual (as a pointer), whereas
7490 a reference should mostly be transparent to the user. */
7492 if (ada_is_tagged_type (t1
, 0)
7493 || (TYPE_CODE (t1
) == TYPE_CODE_REF
7494 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
7496 /* We first try to find the searched field in the current type.
7497 If not found then let's look in the fixed type. */
7499 if (!find_struct_field (name
, t1
, 0,
7500 &field_type
, &byte_offset
, &bit_offset
,
7509 /* Convert to fixed type in all cases, so that we have proper
7510 offsets to each field in unconstrained record types. */
7511 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
7512 address
, NULL
, check_tag
);
7514 if (find_struct_field (name
, t1
, 0,
7515 &field_type
, &byte_offset
, &bit_offset
,
7520 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7521 arg
= ada_coerce_ref (arg
);
7523 arg
= ada_value_ind (arg
);
7524 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7525 bit_offset
, bit_size
,
7529 v
= value_at_lazy (field_type
, address
+ byte_offset
);
7533 if (v
!= NULL
|| no_err
)
7536 error (_("There is no member named %s."), name
);
7542 error (_("Attempt to extract a component of "
7543 "a value that is not a record."));
7546 /* Return a string representation of type TYPE. */
7549 type_as_string (struct type
*type
)
7551 string_file tmp_stream
;
7553 type_print (type
, "", &tmp_stream
, -1);
7555 return std::move (tmp_stream
.string ());
7558 /* Given a type TYPE, look up the type of the component of type named NAME.
7559 If DISPP is non-null, add its byte displacement from the beginning of a
7560 structure (pointed to by a value) of type TYPE to *DISPP (does not
7561 work for packed fields).
7563 Matches any field whose name has NAME as a prefix, possibly
7566 TYPE can be either a struct or union. If REFOK, TYPE may also
7567 be a (pointer or reference)+ to a struct or union, and the
7568 ultimate target type will be searched.
7570 Looks recursively into variant clauses and parent types.
7572 In the case of homonyms in the tagged types, please refer to the
7573 long explanation in find_struct_field's function documentation.
7575 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7576 TYPE is not a type of the right kind. */
7578 static struct type
*
7579 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7583 int parent_offset
= -1;
7588 if (refok
&& type
!= NULL
)
7591 type
= ada_check_typedef (type
);
7592 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7593 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7595 type
= TYPE_TARGET_TYPE (type
);
7599 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7600 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7605 error (_("Type %s is not a structure or union type"),
7606 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7609 type
= to_static_fixed_type (type
);
7611 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7613 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7616 if (t_field_name
== NULL
)
7619 else if (ada_is_parent_field (type
, i
))
7621 /* This is a field pointing us to the parent type of a tagged
7622 type. As hinted in this function's documentation, we give
7623 preference to fields in the current record first, so what
7624 we do here is just record the index of this field before
7625 we skip it. If it turns out we couldn't find our field
7626 in the current record, then we'll get back to it and search
7627 inside it whether the field might exist in the parent. */
7633 else if (field_name_match (t_field_name
, name
))
7634 return TYPE_FIELD_TYPE (type
, i
);
7636 else if (ada_is_wrapper_field (type
, i
))
7638 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7644 else if (ada_is_variant_part (type
, i
))
7647 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7650 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7652 /* FIXME pnh 2008/01/26: We check for a field that is
7653 NOT wrapped in a struct, since the compiler sometimes
7654 generates these for unchecked variant types. Revisit
7655 if the compiler changes this practice. */
7656 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7658 if (v_field_name
!= NULL
7659 && field_name_match (v_field_name
, name
))
7660 t
= TYPE_FIELD_TYPE (field_type
, j
);
7662 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7673 /* Field not found so far. If this is a tagged type which
7674 has a parent, try finding that field in the parent now. */
7676 if (parent_offset
!= -1)
7680 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, parent_offset
),
7689 const char *name_str
= name
!= NULL
? name
: _("<null>");
7691 error (_("Type %s has no component named %s"),
7692 type_as_string (type
).c_str (), name_str
);
7698 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7699 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7700 represents an unchecked union (that is, the variant part of a
7701 record that is named in an Unchecked_Union pragma). */
7704 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7706 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7708 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7712 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7713 within a value of type OUTER_TYPE that is stored in GDB at
7714 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7715 numbering from 0) is applicable. Returns -1 if none are. */
7718 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7719 const gdb_byte
*outer_valaddr
)
7723 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7724 struct value
*outer
;
7725 struct value
*discrim
;
7726 LONGEST discrim_val
;
7728 /* Using plain value_from_contents_and_address here causes problems
7729 because we will end up trying to resolve a type that is currently
7730 being constructed. */
7731 outer
= value_from_contents_and_address_unresolved (outer_type
,
7733 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7734 if (discrim
== NULL
)
7736 discrim_val
= value_as_long (discrim
);
7739 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7741 if (ada_is_others_clause (var_type
, i
))
7743 else if (ada_in_variant (discrim_val
, var_type
, i
))
7747 return others_clause
;
7752 /* Dynamic-Sized Records */
7754 /* Strategy: The type ostensibly attached to a value with dynamic size
7755 (i.e., a size that is not statically recorded in the debugging
7756 data) does not accurately reflect the size or layout of the value.
7757 Our strategy is to convert these values to values with accurate,
7758 conventional types that are constructed on the fly. */
7760 /* There is a subtle and tricky problem here. In general, we cannot
7761 determine the size of dynamic records without its data. However,
7762 the 'struct value' data structure, which GDB uses to represent
7763 quantities in the inferior process (the target), requires the size
7764 of the type at the time of its allocation in order to reserve space
7765 for GDB's internal copy of the data. That's why the
7766 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7767 rather than struct value*s.
7769 However, GDB's internal history variables ($1, $2, etc.) are
7770 struct value*s containing internal copies of the data that are not, in
7771 general, the same as the data at their corresponding addresses in
7772 the target. Fortunately, the types we give to these values are all
7773 conventional, fixed-size types (as per the strategy described
7774 above), so that we don't usually have to perform the
7775 'to_fixed_xxx_type' conversions to look at their values.
7776 Unfortunately, there is one exception: if one of the internal
7777 history variables is an array whose elements are unconstrained
7778 records, then we will need to create distinct fixed types for each
7779 element selected. */
7781 /* The upshot of all of this is that many routines take a (type, host
7782 address, target address) triple as arguments to represent a value.
7783 The host address, if non-null, is supposed to contain an internal
7784 copy of the relevant data; otherwise, the program is to consult the
7785 target at the target address. */
7787 /* Assuming that VAL0 represents a pointer value, the result of
7788 dereferencing it. Differs from value_ind in its treatment of
7789 dynamic-sized types. */
7792 ada_value_ind (struct value
*val0
)
7794 struct value
*val
= value_ind (val0
);
7796 if (ada_is_tagged_type (value_type (val
), 0))
7797 val
= ada_tag_value_at_base_address (val
);
7799 return ada_to_fixed_value (val
);
7802 /* The value resulting from dereferencing any "reference to"
7803 qualifiers on VAL0. */
7805 static struct value
*
7806 ada_coerce_ref (struct value
*val0
)
7808 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
7810 struct value
*val
= val0
;
7812 val
= coerce_ref (val
);
7814 if (ada_is_tagged_type (value_type (val
), 0))
7815 val
= ada_tag_value_at_base_address (val
);
7817 return ada_to_fixed_value (val
);
7823 /* Return OFF rounded upward if necessary to a multiple of
7824 ALIGNMENT (a power of 2). */
7827 align_value (unsigned int off
, unsigned int alignment
)
7829 return (off
+ alignment
- 1) & ~(alignment
- 1);
7832 /* Return the bit alignment required for field #F of template type TYPE. */
7835 field_alignment (struct type
*type
, int f
)
7837 const char *name
= TYPE_FIELD_NAME (type
, f
);
7841 /* The field name should never be null, unless the debugging information
7842 is somehow malformed. In this case, we assume the field does not
7843 require any alignment. */
7847 len
= strlen (name
);
7849 if (!isdigit (name
[len
- 1]))
7852 if (isdigit (name
[len
- 2]))
7853 align_offset
= len
- 2;
7855 align_offset
= len
- 1;
7857 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7858 return TARGET_CHAR_BIT
;
7860 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7863 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7865 static struct symbol
*
7866 ada_find_any_type_symbol (const char *name
)
7870 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7871 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7874 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7878 /* Find a type named NAME. Ignores ambiguity. This routine will look
7879 solely for types defined by debug info, it will not search the GDB
7882 static struct type
*
7883 ada_find_any_type (const char *name
)
7885 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7888 return SYMBOL_TYPE (sym
);
7893 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7894 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7895 symbol, in which case it is returned. Otherwise, this looks for
7896 symbols whose name is that of NAME_SYM suffixed with "___XR".
7897 Return symbol if found, and NULL otherwise. */
7900 ada_is_renaming_symbol (struct symbol
*name_sym
)
7902 const char *name
= SYMBOL_LINKAGE_NAME (name_sym
);
7903 return strstr (name
, "___XR") != NULL
;
7906 /* Because of GNAT encoding conventions, several GDB symbols may match a
7907 given type name. If the type denoted by TYPE0 is to be preferred to
7908 that of TYPE1 for purposes of type printing, return non-zero;
7909 otherwise return 0. */
7912 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7916 else if (type0
== NULL
)
7918 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7920 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7922 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7924 else if (ada_is_constrained_packed_array_type (type0
))
7926 else if (ada_is_array_descriptor_type (type0
)
7927 && !ada_is_array_descriptor_type (type1
))
7931 const char *type0_name
= TYPE_NAME (type0
);
7932 const char *type1_name
= TYPE_NAME (type1
);
7934 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7935 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7941 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7945 ada_type_name (struct type
*type
)
7949 return TYPE_NAME (type
);
7952 /* Search the list of "descriptive" types associated to TYPE for a type
7953 whose name is NAME. */
7955 static struct type
*
7956 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7958 struct type
*result
, *tmp
;
7960 if (ada_ignore_descriptive_types_p
)
7963 /* If there no descriptive-type info, then there is no parallel type
7965 if (!HAVE_GNAT_AUX_INFO (type
))
7968 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7969 while (result
!= NULL
)
7971 const char *result_name
= ada_type_name (result
);
7973 if (result_name
== NULL
)
7975 warning (_("unexpected null name on descriptive type"));
7979 /* If the names match, stop. */
7980 if (strcmp (result_name
, name
) == 0)
7983 /* Otherwise, look at the next item on the list, if any. */
7984 if (HAVE_GNAT_AUX_INFO (result
))
7985 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7989 /* If not found either, try after having resolved the typedef. */
7994 result
= check_typedef (result
);
7995 if (HAVE_GNAT_AUX_INFO (result
))
7996 result
= TYPE_DESCRIPTIVE_TYPE (result
);
8002 /* If we didn't find a match, see whether this is a packed array. With
8003 older compilers, the descriptive type information is either absent or
8004 irrelevant when it comes to packed arrays so the above lookup fails.
8005 Fall back to using a parallel lookup by name in this case. */
8006 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
8007 return ada_find_any_type (name
);
8012 /* Find a parallel type to TYPE with the specified NAME, using the
8013 descriptive type taken from the debugging information, if available,
8014 and otherwise using the (slower) name-based method. */
8016 static struct type
*
8017 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
8019 struct type
*result
= NULL
;
8021 if (HAVE_GNAT_AUX_INFO (type
))
8022 result
= find_parallel_type_by_descriptive_type (type
, name
);
8024 result
= ada_find_any_type (name
);
8029 /* Same as above, but specify the name of the parallel type by appending
8030 SUFFIX to the name of TYPE. */
8033 ada_find_parallel_type (struct type
*type
, const char *suffix
)
8036 const char *type_name
= ada_type_name (type
);
8039 if (type_name
== NULL
)
8042 len
= strlen (type_name
);
8044 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
8046 strcpy (name
, type_name
);
8047 strcpy (name
+ len
, suffix
);
8049 return ada_find_parallel_type_with_name (type
, name
);
8052 /* If TYPE is a variable-size record type, return the corresponding template
8053 type describing its fields. Otherwise, return NULL. */
8055 static struct type
*
8056 dynamic_template_type (struct type
*type
)
8058 type
= ada_check_typedef (type
);
8060 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
8061 || ada_type_name (type
) == NULL
)
8065 int len
= strlen (ada_type_name (type
));
8067 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
8070 return ada_find_parallel_type (type
, "___XVE");
8074 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8075 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8078 is_dynamic_field (struct type
*templ_type
, int field_num
)
8080 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
8083 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
8084 && strstr (name
, "___XVL") != NULL
;
8087 /* The index of the variant field of TYPE, or -1 if TYPE does not
8088 represent a variant record type. */
8091 variant_field_index (struct type
*type
)
8095 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
8098 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
8100 if (ada_is_variant_part (type
, f
))
8106 /* A record type with no fields. */
8108 static struct type
*
8109 empty_record (struct type
*templ
)
8111 struct type
*type
= alloc_type_copy (templ
);
8113 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
8114 TYPE_NFIELDS (type
) = 0;
8115 TYPE_FIELDS (type
) = NULL
;
8116 INIT_NONE_SPECIFIC (type
);
8117 TYPE_NAME (type
) = "<empty>";
8118 TYPE_LENGTH (type
) = 0;
8122 /* An ordinary record type (with fixed-length fields) that describes
8123 the value of type TYPE at VALADDR or ADDRESS (see comments at
8124 the beginning of this section) VAL according to GNAT conventions.
8125 DVAL0 should describe the (portion of a) record that contains any
8126 necessary discriminants. It should be NULL if value_type (VAL) is
8127 an outer-level type (i.e., as opposed to a branch of a variant.) A
8128 variant field (unless unchecked) is replaced by a particular branch
8131 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8132 length are not statically known are discarded. As a consequence,
8133 VALADDR, ADDRESS and DVAL0 are ignored.
8135 NOTE: Limitations: For now, we assume that dynamic fields and
8136 variants occupy whole numbers of bytes. However, they need not be
8140 ada_template_to_fixed_record_type_1 (struct type
*type
,
8141 const gdb_byte
*valaddr
,
8142 CORE_ADDR address
, struct value
*dval0
,
8143 int keep_dynamic_fields
)
8145 struct value
*mark
= value_mark ();
8148 int nfields
, bit_len
;
8154 /* Compute the number of fields in this record type that are going
8155 to be processed: unless keep_dynamic_fields, this includes only
8156 fields whose position and length are static will be processed. */
8157 if (keep_dynamic_fields
)
8158 nfields
= TYPE_NFIELDS (type
);
8162 while (nfields
< TYPE_NFIELDS (type
)
8163 && !ada_is_variant_part (type
, nfields
)
8164 && !is_dynamic_field (type
, nfields
))
8168 rtype
= alloc_type_copy (type
);
8169 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8170 INIT_NONE_SPECIFIC (rtype
);
8171 TYPE_NFIELDS (rtype
) = nfields
;
8172 TYPE_FIELDS (rtype
) = (struct field
*)
8173 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8174 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
8175 TYPE_NAME (rtype
) = ada_type_name (type
);
8176 TYPE_FIXED_INSTANCE (rtype
) = 1;
8182 for (f
= 0; f
< nfields
; f
+= 1)
8184 off
= align_value (off
, field_alignment (type
, f
))
8185 + TYPE_FIELD_BITPOS (type
, f
);
8186 SET_FIELD_BITPOS (TYPE_FIELD (rtype
, f
), off
);
8187 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
8189 if (ada_is_variant_part (type
, f
))
8194 else if (is_dynamic_field (type
, f
))
8196 const gdb_byte
*field_valaddr
= valaddr
;
8197 CORE_ADDR field_address
= address
;
8198 struct type
*field_type
=
8199 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
8203 /* rtype's length is computed based on the run-time
8204 value of discriminants. If the discriminants are not
8205 initialized, the type size may be completely bogus and
8206 GDB may fail to allocate a value for it. So check the
8207 size first before creating the value. */
8208 ada_ensure_varsize_limit (rtype
);
8209 /* Using plain value_from_contents_and_address here
8210 causes problems because we will end up trying to
8211 resolve a type that is currently being
8213 dval
= value_from_contents_and_address_unresolved (rtype
,
8216 rtype
= value_type (dval
);
8221 /* If the type referenced by this field is an aligner type, we need
8222 to unwrap that aligner type, because its size might not be set.
8223 Keeping the aligner type would cause us to compute the wrong
8224 size for this field, impacting the offset of the all the fields
8225 that follow this one. */
8226 if (ada_is_aligner_type (field_type
))
8228 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
8230 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
8231 field_address
= cond_offset_target (field_address
, field_offset
);
8232 field_type
= ada_aligned_type (field_type
);
8235 field_valaddr
= cond_offset_host (field_valaddr
,
8236 off
/ TARGET_CHAR_BIT
);
8237 field_address
= cond_offset_target (field_address
,
8238 off
/ TARGET_CHAR_BIT
);
8240 /* Get the fixed type of the field. Note that, in this case,
8241 we do not want to get the real type out of the tag: if
8242 the current field is the parent part of a tagged record,
8243 we will get the tag of the object. Clearly wrong: the real
8244 type of the parent is not the real type of the child. We
8245 would end up in an infinite loop. */
8246 field_type
= ada_get_base_type (field_type
);
8247 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8248 field_address
, dval
, 0);
8249 /* If the field size is already larger than the maximum
8250 object size, then the record itself will necessarily
8251 be larger than the maximum object size. We need to make
8252 this check now, because the size might be so ridiculously
8253 large (due to an uninitialized variable in the inferior)
8254 that it would cause an overflow when adding it to the
8256 ada_ensure_varsize_limit (field_type
);
8258 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
8259 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8260 /* The multiplication can potentially overflow. But because
8261 the field length has been size-checked just above, and
8262 assuming that the maximum size is a reasonable value,
8263 an overflow should not happen in practice. So rather than
8264 adding overflow recovery code to this already complex code,
8265 we just assume that it's not going to happen. */
8267 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
8271 /* Note: If this field's type is a typedef, it is important
8272 to preserve the typedef layer.
8274 Otherwise, we might be transforming a typedef to a fat
8275 pointer (encoding a pointer to an unconstrained array),
8276 into a basic fat pointer (encoding an unconstrained
8277 array). As both types are implemented using the same
8278 structure, the typedef is the only clue which allows us
8279 to distinguish between the two options. Stripping it
8280 would prevent us from printing this field appropriately. */
8281 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
8282 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8283 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8285 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8288 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
8290 /* We need to be careful of typedefs when computing
8291 the length of our field. If this is a typedef,
8292 get the length of the target type, not the length
8294 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
8295 field_type
= ada_typedef_target_type (field_type
);
8298 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8301 if (off
+ fld_bit_len
> bit_len
)
8302 bit_len
= off
+ fld_bit_len
;
8304 TYPE_LENGTH (rtype
) =
8305 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8308 /* We handle the variant part, if any, at the end because of certain
8309 odd cases in which it is re-ordered so as NOT to be the last field of
8310 the record. This can happen in the presence of representation
8312 if (variant_field
>= 0)
8314 struct type
*branch_type
;
8316 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8320 /* Using plain value_from_contents_and_address here causes
8321 problems because we will end up trying to resolve a type
8322 that is currently being constructed. */
8323 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8325 rtype
= value_type (dval
);
8331 to_fixed_variant_branch_type
8332 (TYPE_FIELD_TYPE (type
, variant_field
),
8333 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8334 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8335 if (branch_type
== NULL
)
8337 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
8338 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8339 TYPE_NFIELDS (rtype
) -= 1;
8343 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8344 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8346 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8348 if (off
+ fld_bit_len
> bit_len
)
8349 bit_len
= off
+ fld_bit_len
;
8350 TYPE_LENGTH (rtype
) =
8351 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8355 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8356 should contain the alignment of that record, which should be a strictly
8357 positive value. If null or negative, then something is wrong, most
8358 probably in the debug info. In that case, we don't round up the size
8359 of the resulting type. If this record is not part of another structure,
8360 the current RTYPE length might be good enough for our purposes. */
8361 if (TYPE_LENGTH (type
) <= 0)
8363 if (TYPE_NAME (rtype
))
8364 warning (_("Invalid type size for `%s' detected: %s."),
8365 TYPE_NAME (rtype
), pulongest (TYPE_LENGTH (type
)));
8367 warning (_("Invalid type size for <unnamed> detected: %s."),
8368 pulongest (TYPE_LENGTH (type
)));
8372 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
8373 TYPE_LENGTH (type
));
8376 value_free_to_mark (mark
);
8377 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8378 error (_("record type with dynamic size is larger than varsize-limit"));
8382 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8385 static struct type
*
8386 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8387 CORE_ADDR address
, struct value
*dval0
)
8389 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8393 /* An ordinary record type in which ___XVL-convention fields and
8394 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8395 static approximations, containing all possible fields. Uses
8396 no runtime values. Useless for use in values, but that's OK,
8397 since the results are used only for type determinations. Works on both
8398 structs and unions. Representation note: to save space, we memorize
8399 the result of this function in the TYPE_TARGET_TYPE of the
8402 static struct type
*
8403 template_to_static_fixed_type (struct type
*type0
)
8409 /* No need no do anything if the input type is already fixed. */
8410 if (TYPE_FIXED_INSTANCE (type0
))
8413 /* Likewise if we already have computed the static approximation. */
8414 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8415 return TYPE_TARGET_TYPE (type0
);
8417 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8419 nfields
= TYPE_NFIELDS (type0
);
8421 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8422 recompute all over next time. */
8423 TYPE_TARGET_TYPE (type0
) = type
;
8425 for (f
= 0; f
< nfields
; f
+= 1)
8427 struct type
*field_type
= TYPE_FIELD_TYPE (type0
, f
);
8428 struct type
*new_type
;
8430 if (is_dynamic_field (type0
, f
))
8432 field_type
= ada_check_typedef (field_type
);
8433 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8436 new_type
= static_unwrap_type (field_type
);
8438 if (new_type
!= field_type
)
8440 /* Clone TYPE0 only the first time we get a new field type. */
8443 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8444 TYPE_CODE (type
) = TYPE_CODE (type0
);
8445 INIT_NONE_SPECIFIC (type
);
8446 TYPE_NFIELDS (type
) = nfields
;
8447 TYPE_FIELDS (type
) = (struct field
*)
8448 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
8449 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
8450 sizeof (struct field
) * nfields
);
8451 TYPE_NAME (type
) = ada_type_name (type0
);
8452 TYPE_FIXED_INSTANCE (type
) = 1;
8453 TYPE_LENGTH (type
) = 0;
8455 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8456 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8463 /* Given an object of type TYPE whose contents are at VALADDR and
8464 whose address in memory is ADDRESS, returns a revision of TYPE,
8465 which should be a non-dynamic-sized record, in which the variant
8466 part, if any, is replaced with the appropriate branch. Looks
8467 for discriminant values in DVAL0, which can be NULL if the record
8468 contains the necessary discriminant values. */
8470 static struct type
*
8471 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8472 CORE_ADDR address
, struct value
*dval0
)
8474 struct value
*mark
= value_mark ();
8477 struct type
*branch_type
;
8478 int nfields
= TYPE_NFIELDS (type
);
8479 int variant_field
= variant_field_index (type
);
8481 if (variant_field
== -1)
8486 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8487 type
= value_type (dval
);
8492 rtype
= alloc_type_copy (type
);
8493 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8494 INIT_NONE_SPECIFIC (rtype
);
8495 TYPE_NFIELDS (rtype
) = nfields
;
8496 TYPE_FIELDS (rtype
) =
8497 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8498 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
8499 sizeof (struct field
) * nfields
);
8500 TYPE_NAME (rtype
) = ada_type_name (type
);
8501 TYPE_FIXED_INSTANCE (rtype
) = 1;
8502 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8504 branch_type
= to_fixed_variant_branch_type
8505 (TYPE_FIELD_TYPE (type
, variant_field
),
8506 cond_offset_host (valaddr
,
8507 TYPE_FIELD_BITPOS (type
, variant_field
)
8509 cond_offset_target (address
,
8510 TYPE_FIELD_BITPOS (type
, variant_field
)
8511 / TARGET_CHAR_BIT
), dval
);
8512 if (branch_type
== NULL
)
8516 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8517 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8518 TYPE_NFIELDS (rtype
) -= 1;
8522 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8523 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8524 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8525 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8527 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8529 value_free_to_mark (mark
);
8533 /* An ordinary record type (with fixed-length fields) that describes
8534 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8535 beginning of this section]. Any necessary discriminants' values
8536 should be in DVAL, a record value; it may be NULL if the object
8537 at ADDR itself contains any necessary discriminant values.
8538 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8539 values from the record are needed. Except in the case that DVAL,
8540 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8541 unchecked) is replaced by a particular branch of the variant.
8543 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8544 is questionable and may be removed. It can arise during the
8545 processing of an unconstrained-array-of-record type where all the
8546 variant branches have exactly the same size. This is because in
8547 such cases, the compiler does not bother to use the XVS convention
8548 when encoding the record. I am currently dubious of this
8549 shortcut and suspect the compiler should be altered. FIXME. */
8551 static struct type
*
8552 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8553 CORE_ADDR address
, struct value
*dval
)
8555 struct type
*templ_type
;
8557 if (TYPE_FIXED_INSTANCE (type0
))
8560 templ_type
= dynamic_template_type (type0
);
8562 if (templ_type
!= NULL
)
8563 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8564 else if (variant_field_index (type0
) >= 0)
8566 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8568 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8573 TYPE_FIXED_INSTANCE (type0
) = 1;
8579 /* An ordinary record type (with fixed-length fields) that describes
8580 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8581 union type. Any necessary discriminants' values should be in DVAL,
8582 a record value. That is, this routine selects the appropriate
8583 branch of the union at ADDR according to the discriminant value
8584 indicated in the union's type name. Returns VAR_TYPE0 itself if
8585 it represents a variant subject to a pragma Unchecked_Union. */
8587 static struct type
*
8588 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8589 CORE_ADDR address
, struct value
*dval
)
8592 struct type
*templ_type
;
8593 struct type
*var_type
;
8595 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8596 var_type
= TYPE_TARGET_TYPE (var_type0
);
8598 var_type
= var_type0
;
8600 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8602 if (templ_type
!= NULL
)
8603 var_type
= templ_type
;
8605 if (is_unchecked_variant (var_type
, value_type (dval
)))
8608 ada_which_variant_applies (var_type
,
8609 value_type (dval
), value_contents (dval
));
8612 return empty_record (var_type
);
8613 else if (is_dynamic_field (var_type
, which
))
8614 return to_fixed_record_type
8615 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8616 valaddr
, address
, dval
);
8617 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8619 to_fixed_record_type
8620 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8622 return TYPE_FIELD_TYPE (var_type
, which
);
8625 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8626 ENCODING_TYPE, a type following the GNAT conventions for discrete
8627 type encodings, only carries redundant information. */
8630 ada_is_redundant_range_encoding (struct type
*range_type
,
8631 struct type
*encoding_type
)
8633 const char *bounds_str
;
8637 gdb_assert (TYPE_CODE (range_type
) == TYPE_CODE_RANGE
);
8639 if (TYPE_CODE (get_base_type (range_type
))
8640 != TYPE_CODE (get_base_type (encoding_type
)))
8642 /* The compiler probably used a simple base type to describe
8643 the range type instead of the range's actual base type,
8644 expecting us to get the real base type from the encoding
8645 anyway. In this situation, the encoding cannot be ignored
8650 if (is_dynamic_type (range_type
))
8653 if (TYPE_NAME (encoding_type
) == NULL
)
8656 bounds_str
= strstr (TYPE_NAME (encoding_type
), "___XDLU_");
8657 if (bounds_str
== NULL
)
8660 n
= 8; /* Skip "___XDLU_". */
8661 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8663 if (TYPE_LOW_BOUND (range_type
) != lo
)
8666 n
+= 2; /* Skip the "__" separator between the two bounds. */
8667 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8669 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8675 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8676 a type following the GNAT encoding for describing array type
8677 indices, only carries redundant information. */
8680 ada_is_redundant_index_type_desc (struct type
*array_type
,
8681 struct type
*desc_type
)
8683 struct type
*this_layer
= check_typedef (array_type
);
8686 for (i
= 0; i
< TYPE_NFIELDS (desc_type
); i
++)
8688 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer
),
8689 TYPE_FIELD_TYPE (desc_type
, i
)))
8691 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8697 /* Assuming that TYPE0 is an array type describing the type of a value
8698 at ADDR, and that DVAL describes a record containing any
8699 discriminants used in TYPE0, returns a type for the value that
8700 contains no dynamic components (that is, no components whose sizes
8701 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8702 true, gives an error message if the resulting type's size is over
8705 static struct type
*
8706 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8709 struct type
*index_type_desc
;
8710 struct type
*result
;
8711 int constrained_packed_array_p
;
8712 static const char *xa_suffix
= "___XA";
8714 type0
= ada_check_typedef (type0
);
8715 if (TYPE_FIXED_INSTANCE (type0
))
8718 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8719 if (constrained_packed_array_p
)
8720 type0
= decode_constrained_packed_array_type (type0
);
8722 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8724 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8725 encoding suffixed with 'P' may still be generated. If so,
8726 it should be used to find the XA type. */
8728 if (index_type_desc
== NULL
)
8730 const char *type_name
= ada_type_name (type0
);
8732 if (type_name
!= NULL
)
8734 const int len
= strlen (type_name
);
8735 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8737 if (type_name
[len
- 1] == 'P')
8739 strcpy (name
, type_name
);
8740 strcpy (name
+ len
- 1, xa_suffix
);
8741 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8746 ada_fixup_array_indexes_type (index_type_desc
);
8747 if (index_type_desc
!= NULL
8748 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8750 /* Ignore this ___XA parallel type, as it does not bring any
8751 useful information. This allows us to avoid creating fixed
8752 versions of the array's index types, which would be identical
8753 to the original ones. This, in turn, can also help avoid
8754 the creation of fixed versions of the array itself. */
8755 index_type_desc
= NULL
;
8758 if (index_type_desc
== NULL
)
8760 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8762 /* NOTE: elt_type---the fixed version of elt_type0---should never
8763 depend on the contents of the array in properly constructed
8765 /* Create a fixed version of the array element type.
8766 We're not providing the address of an element here,
8767 and thus the actual object value cannot be inspected to do
8768 the conversion. This should not be a problem, since arrays of
8769 unconstrained objects are not allowed. In particular, all
8770 the elements of an array of a tagged type should all be of
8771 the same type specified in the debugging info. No need to
8772 consult the object tag. */
8773 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8775 /* Make sure we always create a new array type when dealing with
8776 packed array types, since we're going to fix-up the array
8777 type length and element bitsize a little further down. */
8778 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8781 result
= create_array_type (alloc_type_copy (type0
),
8782 elt_type
, TYPE_INDEX_TYPE (type0
));
8787 struct type
*elt_type0
;
8790 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8791 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8793 /* NOTE: result---the fixed version of elt_type0---should never
8794 depend on the contents of the array in properly constructed
8796 /* Create a fixed version of the array element type.
8797 We're not providing the address of an element here,
8798 and thus the actual object value cannot be inspected to do
8799 the conversion. This should not be a problem, since arrays of
8800 unconstrained objects are not allowed. In particular, all
8801 the elements of an array of a tagged type should all be of
8802 the same type specified in the debugging info. No need to
8803 consult the object tag. */
8805 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8808 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8810 struct type
*range_type
=
8811 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8813 result
= create_array_type (alloc_type_copy (elt_type0
),
8814 result
, range_type
);
8815 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8817 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8818 error (_("array type with dynamic size is larger than varsize-limit"));
8821 /* We want to preserve the type name. This can be useful when
8822 trying to get the type name of a value that has already been
8823 printed (for instance, if the user did "print VAR; whatis $". */
8824 TYPE_NAME (result
) = TYPE_NAME (type0
);
8826 if (constrained_packed_array_p
)
8828 /* So far, the resulting type has been created as if the original
8829 type was a regular (non-packed) array type. As a result, the
8830 bitsize of the array elements needs to be set again, and the array
8831 length needs to be recomputed based on that bitsize. */
8832 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8833 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8835 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8836 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8837 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8838 TYPE_LENGTH (result
)++;
8841 TYPE_FIXED_INSTANCE (result
) = 1;
8846 /* A standard type (containing no dynamically sized components)
8847 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8848 DVAL describes a record containing any discriminants used in TYPE0,
8849 and may be NULL if there are none, or if the object of type TYPE at
8850 ADDRESS or in VALADDR contains these discriminants.
8852 If CHECK_TAG is not null, in the case of tagged types, this function
8853 attempts to locate the object's tag and use it to compute the actual
8854 type. However, when ADDRESS is null, we cannot use it to determine the
8855 location of the tag, and therefore compute the tagged type's actual type.
8856 So we return the tagged type without consulting the tag. */
8858 static struct type
*
8859 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8860 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8862 type
= ada_check_typedef (type
);
8864 /* Only un-fixed types need to be handled here. */
8865 if (!HAVE_GNAT_AUX_INFO (type
))
8868 switch (TYPE_CODE (type
))
8872 case TYPE_CODE_STRUCT
:
8874 struct type
*static_type
= to_static_fixed_type (type
);
8875 struct type
*fixed_record_type
=
8876 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8878 /* If STATIC_TYPE is a tagged type and we know the object's address,
8879 then we can determine its tag, and compute the object's actual
8880 type from there. Note that we have to use the fixed record
8881 type (the parent part of the record may have dynamic fields
8882 and the way the location of _tag is expressed may depend on
8885 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8888 value_tag_from_contents_and_address
8892 struct type
*real_type
= type_from_tag (tag
);
8894 value_from_contents_and_address (fixed_record_type
,
8897 fixed_record_type
= value_type (obj
);
8898 if (real_type
!= NULL
)
8899 return to_fixed_record_type
8901 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8904 /* Check to see if there is a parallel ___XVZ variable.
8905 If there is, then it provides the actual size of our type. */
8906 else if (ada_type_name (fixed_record_type
) != NULL
)
8908 const char *name
= ada_type_name (fixed_record_type
);
8910 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8911 bool xvz_found
= false;
8914 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8917 xvz_found
= get_int_var_value (xvz_name
, size
);
8919 catch (const gdb_exception_error
&except
)
8921 /* We found the variable, but somehow failed to read
8922 its value. Rethrow the same error, but with a little
8923 bit more information, to help the user understand
8924 what went wrong (Eg: the variable might have been
8926 throw_error (except
.error
,
8927 _("unable to read value of %s (%s)"),
8928 xvz_name
, except
.what ());
8931 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8933 fixed_record_type
= copy_type (fixed_record_type
);
8934 TYPE_LENGTH (fixed_record_type
) = size
;
8936 /* The FIXED_RECORD_TYPE may have be a stub. We have
8937 observed this when the debugging info is STABS, and
8938 apparently it is something that is hard to fix.
8940 In practice, we don't need the actual type definition
8941 at all, because the presence of the XVZ variable allows us
8942 to assume that there must be a XVS type as well, which we
8943 should be able to use later, when we need the actual type
8946 In the meantime, pretend that the "fixed" type we are
8947 returning is NOT a stub, because this can cause trouble
8948 when using this type to create new types targeting it.
8949 Indeed, the associated creation routines often check
8950 whether the target type is a stub and will try to replace
8951 it, thus using a type with the wrong size. This, in turn,
8952 might cause the new type to have the wrong size too.
8953 Consider the case of an array, for instance, where the size
8954 of the array is computed from the number of elements in
8955 our array multiplied by the size of its element. */
8956 TYPE_STUB (fixed_record_type
) = 0;
8959 return fixed_record_type
;
8961 case TYPE_CODE_ARRAY
:
8962 return to_fixed_array_type (type
, dval
, 1);
8963 case TYPE_CODE_UNION
:
8967 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8971 /* The same as ada_to_fixed_type_1, except that it preserves the type
8972 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8974 The typedef layer needs be preserved in order to differentiate between
8975 arrays and array pointers when both types are implemented using the same
8976 fat pointer. In the array pointer case, the pointer is encoded as
8977 a typedef of the pointer type. For instance, considering:
8979 type String_Access is access String;
8980 S1 : String_Access := null;
8982 To the debugger, S1 is defined as a typedef of type String. But
8983 to the user, it is a pointer. So if the user tries to print S1,
8984 we should not dereference the array, but print the array address
8987 If we didn't preserve the typedef layer, we would lose the fact that
8988 the type is to be presented as a pointer (needs de-reference before
8989 being printed). And we would also use the source-level type name. */
8992 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8993 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8996 struct type
*fixed_type
=
8997 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8999 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9000 then preserve the typedef layer.
9002 Implementation note: We can only check the main-type portion of
9003 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9004 from TYPE now returns a type that has the same instance flags
9005 as TYPE. For instance, if TYPE is a "typedef const", and its
9006 target type is a "struct", then the typedef elimination will return
9007 a "const" version of the target type. See check_typedef for more
9008 details about how the typedef layer elimination is done.
9010 brobecker/2010-11-19: It seems to me that the only case where it is
9011 useful to preserve the typedef layer is when dealing with fat pointers.
9012 Perhaps, we could add a check for that and preserve the typedef layer
9013 only in that situation. But this seems unecessary so far, probably
9014 because we call check_typedef/ada_check_typedef pretty much everywhere.
9016 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
9017 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
9018 == TYPE_MAIN_TYPE (fixed_type
)))
9024 /* A standard (static-sized) type corresponding as well as possible to
9025 TYPE0, but based on no runtime data. */
9027 static struct type
*
9028 to_static_fixed_type (struct type
*type0
)
9035 if (TYPE_FIXED_INSTANCE (type0
))
9038 type0
= ada_check_typedef (type0
);
9040 switch (TYPE_CODE (type0
))
9044 case TYPE_CODE_STRUCT
:
9045 type
= dynamic_template_type (type0
);
9047 return template_to_static_fixed_type (type
);
9049 return template_to_static_fixed_type (type0
);
9050 case TYPE_CODE_UNION
:
9051 type
= ada_find_parallel_type (type0
, "___XVU");
9053 return template_to_static_fixed_type (type
);
9055 return template_to_static_fixed_type (type0
);
9059 /* A static approximation of TYPE with all type wrappers removed. */
9061 static struct type
*
9062 static_unwrap_type (struct type
*type
)
9064 if (ada_is_aligner_type (type
))
9066 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
9067 if (ada_type_name (type1
) == NULL
)
9068 TYPE_NAME (type1
) = ada_type_name (type
);
9070 return static_unwrap_type (type1
);
9074 struct type
*raw_real_type
= ada_get_base_type (type
);
9076 if (raw_real_type
== type
)
9079 return to_static_fixed_type (raw_real_type
);
9083 /* In some cases, incomplete and private types require
9084 cross-references that are not resolved as records (for example,
9086 type FooP is access Foo;
9088 type Foo is array ...;
9089 ). In these cases, since there is no mechanism for producing
9090 cross-references to such types, we instead substitute for FooP a
9091 stub enumeration type that is nowhere resolved, and whose tag is
9092 the name of the actual type. Call these types "non-record stubs". */
9094 /* A type equivalent to TYPE that is not a non-record stub, if one
9095 exists, otherwise TYPE. */
9098 ada_check_typedef (struct type
*type
)
9103 /* If our type is an access to an unconstrained array, which is encoded
9104 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9105 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9106 what allows us to distinguish between fat pointers that represent
9107 array types, and fat pointers that represent array access types
9108 (in both cases, the compiler implements them as fat pointers). */
9109 if (ada_is_access_to_unconstrained_array (type
))
9112 type
= check_typedef (type
);
9113 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
9114 || !TYPE_STUB (type
)
9115 || TYPE_NAME (type
) == NULL
)
9119 const char *name
= TYPE_NAME (type
);
9120 struct type
*type1
= ada_find_any_type (name
);
9125 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9126 stubs pointing to arrays, as we don't create symbols for array
9127 types, only for the typedef-to-array types). If that's the case,
9128 strip the typedef layer. */
9129 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
9130 type1
= ada_check_typedef (type1
);
9136 /* A value representing the data at VALADDR/ADDRESS as described by
9137 type TYPE0, but with a standard (static-sized) type that correctly
9138 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9139 type, then return VAL0 [this feature is simply to avoid redundant
9140 creation of struct values]. */
9142 static struct value
*
9143 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
9146 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
9148 if (type
== type0
&& val0
!= NULL
)
9151 if (VALUE_LVAL (val0
) != lval_memory
)
9153 /* Our value does not live in memory; it could be a convenience
9154 variable, for instance. Create a not_lval value using val0's
9156 return value_from_contents (type
, value_contents (val0
));
9159 return value_from_contents_and_address (type
, 0, address
);
9162 /* A value representing VAL, but with a standard (static-sized) type
9163 that correctly describes it. Does not necessarily create a new
9167 ada_to_fixed_value (struct value
*val
)
9169 val
= unwrap_value (val
);
9170 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
9177 /* Table mapping attribute numbers to names.
9178 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9180 static const char *attribute_names
[] = {
9198 ada_attribute_name (enum exp_opcode n
)
9200 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
9201 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
9203 return attribute_names
[0];
9206 /* Evaluate the 'POS attribute applied to ARG. */
9209 pos_atr (struct value
*arg
)
9211 struct value
*val
= coerce_ref (arg
);
9212 struct type
*type
= value_type (val
);
9215 if (!discrete_type_p (type
))
9216 error (_("'POS only defined on discrete types"));
9218 if (!discrete_position (type
, value_as_long (val
), &result
))
9219 error (_("enumeration value is invalid: can't find 'POS"));
9224 static struct value
*
9225 value_pos_atr (struct type
*type
, struct value
*arg
)
9227 return value_from_longest (type
, pos_atr (arg
));
9230 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9232 static struct value
*
9233 value_val_atr (struct type
*type
, struct value
*arg
)
9235 if (!discrete_type_p (type
))
9236 error (_("'VAL only defined on discrete types"));
9237 if (!integer_type_p (value_type (arg
)))
9238 error (_("'VAL requires integral argument"));
9240 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
9242 long pos
= value_as_long (arg
);
9244 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
9245 error (_("argument to 'VAL out of range"));
9246 return value_from_longest (type
, TYPE_FIELD_ENUMVAL (type
, pos
));
9249 return value_from_longest (type
, value_as_long (arg
));
9255 /* True if TYPE appears to be an Ada character type.
9256 [At the moment, this is true only for Character and Wide_Character;
9257 It is a heuristic test that could stand improvement]. */
9260 ada_is_character_type (struct type
*type
)
9264 /* If the type code says it's a character, then assume it really is,
9265 and don't check any further. */
9266 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
9269 /* Otherwise, assume it's a character type iff it is a discrete type
9270 with a known character type name. */
9271 name
= ada_type_name (type
);
9272 return (name
!= NULL
9273 && (TYPE_CODE (type
) == TYPE_CODE_INT
9274 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9275 && (strcmp (name
, "character") == 0
9276 || strcmp (name
, "wide_character") == 0
9277 || strcmp (name
, "wide_wide_character") == 0
9278 || strcmp (name
, "unsigned char") == 0));
9281 /* True if TYPE appears to be an Ada string type. */
9284 ada_is_string_type (struct type
*type
)
9286 type
= ada_check_typedef (type
);
9288 && TYPE_CODE (type
) != TYPE_CODE_PTR
9289 && (ada_is_simple_array_type (type
)
9290 || ada_is_array_descriptor_type (type
))
9291 && ada_array_arity (type
) == 1)
9293 struct type
*elttype
= ada_array_element_type (type
, 1);
9295 return ada_is_character_type (elttype
);
9301 /* The compiler sometimes provides a parallel XVS type for a given
9302 PAD type. Normally, it is safe to follow the PAD type directly,
9303 but older versions of the compiler have a bug that causes the offset
9304 of its "F" field to be wrong. Following that field in that case
9305 would lead to incorrect results, but this can be worked around
9306 by ignoring the PAD type and using the associated XVS type instead.
9308 Set to True if the debugger should trust the contents of PAD types.
9309 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9310 static int trust_pad_over_xvs
= 1;
9312 /* True if TYPE is a struct type introduced by the compiler to force the
9313 alignment of a value. Such types have a single field with a
9314 distinctive name. */
9317 ada_is_aligner_type (struct type
*type
)
9319 type
= ada_check_typedef (type
);
9321 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9324 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
9325 && TYPE_NFIELDS (type
) == 1
9326 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9329 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9330 the parallel type. */
9333 ada_get_base_type (struct type
*raw_type
)
9335 struct type
*real_type_namer
;
9336 struct type
*raw_real_type
;
9338 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
9341 if (ada_is_aligner_type (raw_type
))
9342 /* The encoding specifies that we should always use the aligner type.
9343 So, even if this aligner type has an associated XVS type, we should
9346 According to the compiler gurus, an XVS type parallel to an aligner
9347 type may exist because of a stabs limitation. In stabs, aligner
9348 types are empty because the field has a variable-sized type, and
9349 thus cannot actually be used as an aligner type. As a result,
9350 we need the associated parallel XVS type to decode the type.
9351 Since the policy in the compiler is to not change the internal
9352 representation based on the debugging info format, we sometimes
9353 end up having a redundant XVS type parallel to the aligner type. */
9356 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9357 if (real_type_namer
== NULL
9358 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
9359 || TYPE_NFIELDS (real_type_namer
) != 1)
9362 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
9364 /* This is an older encoding form where the base type needs to be
9365 looked up by name. We prefer the newer enconding because it is
9367 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9368 if (raw_real_type
== NULL
)
9371 return raw_real_type
;
9374 /* The field in our XVS type is a reference to the base type. */
9375 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
9378 /* The type of value designated by TYPE, with all aligners removed. */
9381 ada_aligned_type (struct type
*type
)
9383 if (ada_is_aligner_type (type
))
9384 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
9386 return ada_get_base_type (type
);
9390 /* The address of the aligned value in an object at address VALADDR
9391 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9394 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9396 if (ada_is_aligner_type (type
))
9397 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
9399 TYPE_FIELD_BITPOS (type
,
9400 0) / TARGET_CHAR_BIT
);
9407 /* The printed representation of an enumeration literal with encoded
9408 name NAME. The value is good to the next call of ada_enum_name. */
9410 ada_enum_name (const char *name
)
9412 static char *result
;
9413 static size_t result_len
= 0;
9416 /* First, unqualify the enumeration name:
9417 1. Search for the last '.' character. If we find one, then skip
9418 all the preceding characters, the unqualified name starts
9419 right after that dot.
9420 2. Otherwise, we may be debugging on a target where the compiler
9421 translates dots into "__". Search forward for double underscores,
9422 but stop searching when we hit an overloading suffix, which is
9423 of the form "__" followed by digits. */
9425 tmp
= strrchr (name
, '.');
9430 while ((tmp
= strstr (name
, "__")) != NULL
)
9432 if (isdigit (tmp
[2]))
9443 if (name
[1] == 'U' || name
[1] == 'W')
9445 if (sscanf (name
+ 2, "%x", &v
) != 1)
9451 GROW_VECT (result
, result_len
, 16);
9452 if (isascii (v
) && isprint (v
))
9453 xsnprintf (result
, result_len
, "'%c'", v
);
9454 else if (name
[1] == 'U')
9455 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9457 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9463 tmp
= strstr (name
, "__");
9465 tmp
= strstr (name
, "$");
9468 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9469 strncpy (result
, name
, tmp
- name
);
9470 result
[tmp
- name
] = '\0';
9478 /* Evaluate the subexpression of EXP starting at *POS as for
9479 evaluate_type, updating *POS to point just past the evaluated
9482 static struct value
*
9483 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9485 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9488 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9491 static struct value
*
9492 unwrap_value (struct value
*val
)
9494 struct type
*type
= ada_check_typedef (value_type (val
));
9496 if (ada_is_aligner_type (type
))
9498 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9499 struct type
*val_type
= ada_check_typedef (value_type (v
));
9501 if (ada_type_name (val_type
) == NULL
)
9502 TYPE_NAME (val_type
) = ada_type_name (type
);
9504 return unwrap_value (v
);
9508 struct type
*raw_real_type
=
9509 ada_check_typedef (ada_get_base_type (type
));
9511 /* If there is no parallel XVS or XVE type, then the value is
9512 already unwrapped. Return it without further modification. */
9513 if ((type
== raw_real_type
)
9514 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9518 coerce_unspec_val_to_type
9519 (val
, ada_to_fixed_type (raw_real_type
, 0,
9520 value_address (val
),
9525 static struct value
*
9526 cast_from_fixed (struct type
*type
, struct value
*arg
)
9528 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9529 arg
= value_cast (value_type (scale
), arg
);
9531 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9532 return value_cast (type
, arg
);
9535 static struct value
*
9536 cast_to_fixed (struct type
*type
, struct value
*arg
)
9538 if (type
== value_type (arg
))
9541 struct value
*scale
= ada_scaling_factor (type
);
9542 if (ada_is_fixed_point_type (value_type (arg
)))
9543 arg
= cast_from_fixed (value_type (scale
), arg
);
9545 arg
= value_cast (value_type (scale
), arg
);
9547 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9548 return value_cast (type
, arg
);
9551 /* Given two array types T1 and T2, return nonzero iff both arrays
9552 contain the same number of elements. */
9555 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9557 LONGEST lo1
, hi1
, lo2
, hi2
;
9559 /* Get the array bounds in order to verify that the size of
9560 the two arrays match. */
9561 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9562 || !get_array_bounds (t2
, &lo2
, &hi2
))
9563 error (_("unable to determine array bounds"));
9565 /* To make things easier for size comparison, normalize a bit
9566 the case of empty arrays by making sure that the difference
9567 between upper bound and lower bound is always -1. */
9573 return (hi1
- lo1
== hi2
- lo2
);
9576 /* Assuming that VAL is an array of integrals, and TYPE represents
9577 an array with the same number of elements, but with wider integral
9578 elements, return an array "casted" to TYPE. In practice, this
9579 means that the returned array is built by casting each element
9580 of the original array into TYPE's (wider) element type. */
9582 static struct value
*
9583 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9585 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9590 /* Verify that both val and type are arrays of scalars, and
9591 that the size of val's elements is smaller than the size
9592 of type's element. */
9593 gdb_assert (TYPE_CODE (type
) == TYPE_CODE_ARRAY
);
9594 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9595 gdb_assert (TYPE_CODE (value_type (val
)) == TYPE_CODE_ARRAY
);
9596 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9597 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9598 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9600 if (!get_array_bounds (type
, &lo
, &hi
))
9601 error (_("unable to determine array bounds"));
9603 res
= allocate_value (type
);
9605 /* Promote each array element. */
9606 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9608 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9610 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9611 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9617 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9618 return the converted value. */
9620 static struct value
*
9621 coerce_for_assign (struct type
*type
, struct value
*val
)
9623 struct type
*type2
= value_type (val
);
9628 type2
= ada_check_typedef (type2
);
9629 type
= ada_check_typedef (type
);
9631 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
9632 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9634 val
= ada_value_ind (val
);
9635 type2
= value_type (val
);
9638 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
9639 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9641 if (!ada_same_array_size_p (type
, type2
))
9642 error (_("cannot assign arrays of different length"));
9644 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9645 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9646 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9647 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9649 /* Allow implicit promotion of the array elements to
9651 return ada_promote_array_of_integrals (type
, val
);
9654 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9655 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9656 error (_("Incompatible types in assignment"));
9657 deprecated_set_value_type (val
, type
);
9662 static struct value
*
9663 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9666 struct type
*type1
, *type2
;
9669 arg1
= coerce_ref (arg1
);
9670 arg2
= coerce_ref (arg2
);
9671 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9672 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9674 if (TYPE_CODE (type1
) != TYPE_CODE_INT
9675 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
9676 return value_binop (arg1
, arg2
, op
);
9685 return value_binop (arg1
, arg2
, op
);
9688 v2
= value_as_long (arg2
);
9690 error (_("second operand of %s must not be zero."), op_string (op
));
9692 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9693 return value_binop (arg1
, arg2
, op
);
9695 v1
= value_as_long (arg1
);
9700 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9701 v
+= v
> 0 ? -1 : 1;
9709 /* Should not reach this point. */
9713 val
= allocate_value (type1
);
9714 store_unsigned_integer (value_contents_raw (val
),
9715 TYPE_LENGTH (value_type (val
)),
9716 gdbarch_byte_order (get_type_arch (type1
)), v
);
9721 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9723 if (ada_is_direct_array_type (value_type (arg1
))
9724 || ada_is_direct_array_type (value_type (arg2
)))
9726 struct type
*arg1_type
, *arg2_type
;
9728 /* Automatically dereference any array reference before
9729 we attempt to perform the comparison. */
9730 arg1
= ada_coerce_ref (arg1
);
9731 arg2
= ada_coerce_ref (arg2
);
9733 arg1
= ada_coerce_to_simple_array (arg1
);
9734 arg2
= ada_coerce_to_simple_array (arg2
);
9736 arg1_type
= ada_check_typedef (value_type (arg1
));
9737 arg2_type
= ada_check_typedef (value_type (arg2
));
9739 if (TYPE_CODE (arg1_type
) != TYPE_CODE_ARRAY
9740 || TYPE_CODE (arg2_type
) != TYPE_CODE_ARRAY
)
9741 error (_("Attempt to compare array with non-array"));
9742 /* FIXME: The following works only for types whose
9743 representations use all bits (no padding or undefined bits)
9744 and do not have user-defined equality. */
9745 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9746 && memcmp (value_contents (arg1
), value_contents (arg2
),
9747 TYPE_LENGTH (arg1_type
)) == 0);
9749 return value_equal (arg1
, arg2
);
9752 /* Total number of component associations in the aggregate starting at
9753 index PC in EXP. Assumes that index PC is the start of an
9757 num_component_specs (struct expression
*exp
, int pc
)
9761 m
= exp
->elts
[pc
+ 1].longconst
;
9764 for (i
= 0; i
< m
; i
+= 1)
9766 switch (exp
->elts
[pc
].opcode
)
9772 n
+= exp
->elts
[pc
+ 1].longconst
;
9775 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9780 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9781 component of LHS (a simple array or a record), updating *POS past
9782 the expression, assuming that LHS is contained in CONTAINER. Does
9783 not modify the inferior's memory, nor does it modify LHS (unless
9784 LHS == CONTAINER). */
9787 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9788 struct expression
*exp
, int *pos
)
9790 struct value
*mark
= value_mark ();
9792 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9794 if (TYPE_CODE (lhs_type
) == TYPE_CODE_ARRAY
)
9796 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9797 struct value
*index_val
= value_from_longest (index_type
, index
);
9799 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9803 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9804 elt
= ada_to_fixed_value (elt
);
9807 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9808 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9810 value_assign_to_component (container
, elt
,
9811 ada_evaluate_subexp (NULL
, exp
, pos
,
9814 value_free_to_mark (mark
);
9817 /* Assuming that LHS represents an lvalue having a record or array
9818 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9819 of that aggregate's value to LHS, advancing *POS past the
9820 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9821 lvalue containing LHS (possibly LHS itself). Does not modify
9822 the inferior's memory, nor does it modify the contents of
9823 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9825 static struct value
*
9826 assign_aggregate (struct value
*container
,
9827 struct value
*lhs
, struct expression
*exp
,
9828 int *pos
, enum noside noside
)
9830 struct type
*lhs_type
;
9831 int n
= exp
->elts
[*pos
+1].longconst
;
9832 LONGEST low_index
, high_index
;
9835 int max_indices
, num_indices
;
9839 if (noside
!= EVAL_NORMAL
)
9841 for (i
= 0; i
< n
; i
+= 1)
9842 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9846 container
= ada_coerce_ref (container
);
9847 if (ada_is_direct_array_type (value_type (container
)))
9848 container
= ada_coerce_to_simple_array (container
);
9849 lhs
= ada_coerce_ref (lhs
);
9850 if (!deprecated_value_modifiable (lhs
))
9851 error (_("Left operand of assignment is not a modifiable lvalue."));
9853 lhs_type
= check_typedef (value_type (lhs
));
9854 if (ada_is_direct_array_type (lhs_type
))
9856 lhs
= ada_coerce_to_simple_array (lhs
);
9857 lhs_type
= check_typedef (value_type (lhs
));
9858 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9859 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9861 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
9864 high_index
= num_visible_fields (lhs_type
) - 1;
9867 error (_("Left-hand side must be array or record."));
9869 num_specs
= num_component_specs (exp
, *pos
- 3);
9870 max_indices
= 4 * num_specs
+ 4;
9871 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9872 indices
[0] = indices
[1] = low_index
- 1;
9873 indices
[2] = indices
[3] = high_index
+ 1;
9876 for (i
= 0; i
< n
; i
+= 1)
9878 switch (exp
->elts
[*pos
].opcode
)
9881 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9882 &num_indices
, max_indices
,
9883 low_index
, high_index
);
9886 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9887 &num_indices
, max_indices
,
9888 low_index
, high_index
);
9892 error (_("Misplaced 'others' clause"));
9893 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9894 num_indices
, low_index
, high_index
);
9897 error (_("Internal error: bad aggregate clause"));
9904 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9905 construct at *POS, updating *POS past the construct, given that
9906 the positions are relative to lower bound LOW, where HIGH is the
9907 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9908 updating *NUM_INDICES as needed. CONTAINER is as for
9909 assign_aggregate. */
9911 aggregate_assign_positional (struct value
*container
,
9912 struct value
*lhs
, struct expression
*exp
,
9913 int *pos
, LONGEST
*indices
, int *num_indices
,
9914 int max_indices
, LONGEST low
, LONGEST high
)
9916 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9918 if (ind
- 1 == high
)
9919 warning (_("Extra components in aggregate ignored."));
9922 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9924 assign_component (container
, lhs
, ind
, exp
, pos
);
9927 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9930 /* Assign into the components of LHS indexed by the OP_CHOICES
9931 construct at *POS, updating *POS past the construct, given that
9932 the allowable indices are LOW..HIGH. Record the indices assigned
9933 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9934 needed. CONTAINER is as for assign_aggregate. */
9936 aggregate_assign_from_choices (struct value
*container
,
9937 struct value
*lhs
, struct expression
*exp
,
9938 int *pos
, LONGEST
*indices
, int *num_indices
,
9939 int max_indices
, LONGEST low
, LONGEST high
)
9942 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9943 int choice_pos
, expr_pc
;
9944 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9946 choice_pos
= *pos
+= 3;
9948 for (j
= 0; j
< n_choices
; j
+= 1)
9949 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9951 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9953 for (j
= 0; j
< n_choices
; j
+= 1)
9955 LONGEST lower
, upper
;
9956 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9958 if (op
== OP_DISCRETE_RANGE
)
9961 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9963 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9968 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9980 name
= &exp
->elts
[choice_pos
+ 2].string
;
9983 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
9986 error (_("Invalid record component association."));
9988 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9990 if (! find_struct_field (name
, value_type (lhs
), 0,
9991 NULL
, NULL
, NULL
, NULL
, &ind
))
9992 error (_("Unknown component name: %s."), name
);
9993 lower
= upper
= ind
;
9996 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9997 error (_("Index in component association out of bounds."));
9999 add_component_interval (lower
, upper
, indices
, num_indices
,
10001 while (lower
<= upper
)
10006 assign_component (container
, lhs
, lower
, exp
, &pos1
);
10012 /* Assign the value of the expression in the OP_OTHERS construct in
10013 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10014 have not been previously assigned. The index intervals already assigned
10015 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10016 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10018 aggregate_assign_others (struct value
*container
,
10019 struct value
*lhs
, struct expression
*exp
,
10020 int *pos
, LONGEST
*indices
, int num_indices
,
10021 LONGEST low
, LONGEST high
)
10024 int expr_pc
= *pos
+ 1;
10026 for (i
= 0; i
< num_indices
- 2; i
+= 2)
10030 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
10034 localpos
= expr_pc
;
10035 assign_component (container
, lhs
, ind
, exp
, &localpos
);
10038 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10041 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10042 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10043 modifying *SIZE as needed. It is an error if *SIZE exceeds
10044 MAX_SIZE. The resulting intervals do not overlap. */
10046 add_component_interval (LONGEST low
, LONGEST high
,
10047 LONGEST
* indices
, int *size
, int max_size
)
10051 for (i
= 0; i
< *size
; i
+= 2) {
10052 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
10056 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
10057 if (high
< indices
[kh
])
10059 if (low
< indices
[i
])
10061 indices
[i
+ 1] = indices
[kh
- 1];
10062 if (high
> indices
[i
+ 1])
10063 indices
[i
+ 1] = high
;
10064 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
10065 *size
-= kh
- i
- 2;
10068 else if (high
< indices
[i
])
10072 if (*size
== max_size
)
10073 error (_("Internal error: miscounted aggregate components."));
10075 for (j
= *size
-1; j
>= i
+2; j
-= 1)
10076 indices
[j
] = indices
[j
- 2];
10078 indices
[i
+ 1] = high
;
10081 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10084 static struct value
*
10085 ada_value_cast (struct type
*type
, struct value
*arg2
)
10087 if (type
== ada_check_typedef (value_type (arg2
)))
10090 if (ada_is_fixed_point_type (type
))
10091 return cast_to_fixed (type
, arg2
);
10093 if (ada_is_fixed_point_type (value_type (arg2
)))
10094 return cast_from_fixed (type
, arg2
);
10096 return value_cast (type
, arg2
);
10099 /* Evaluating Ada expressions, and printing their result.
10100 ------------------------------------------------------
10105 We usually evaluate an Ada expression in order to print its value.
10106 We also evaluate an expression in order to print its type, which
10107 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10108 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10109 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10110 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10113 Evaluating expressions is a little more complicated for Ada entities
10114 than it is for entities in languages such as C. The main reason for
10115 this is that Ada provides types whose definition might be dynamic.
10116 One example of such types is variant records. Or another example
10117 would be an array whose bounds can only be known at run time.
10119 The following description is a general guide as to what should be
10120 done (and what should NOT be done) in order to evaluate an expression
10121 involving such types, and when. This does not cover how the semantic
10122 information is encoded by GNAT as this is covered separatly. For the
10123 document used as the reference for the GNAT encoding, see exp_dbug.ads
10124 in the GNAT sources.
10126 Ideally, we should embed each part of this description next to its
10127 associated code. Unfortunately, the amount of code is so vast right
10128 now that it's hard to see whether the code handling a particular
10129 situation might be duplicated or not. One day, when the code is
10130 cleaned up, this guide might become redundant with the comments
10131 inserted in the code, and we might want to remove it.
10133 2. ``Fixing'' an Entity, the Simple Case:
10134 -----------------------------------------
10136 When evaluating Ada expressions, the tricky issue is that they may
10137 reference entities whose type contents and size are not statically
10138 known. Consider for instance a variant record:
10140 type Rec (Empty : Boolean := True) is record
10143 when False => Value : Integer;
10146 Yes : Rec := (Empty => False, Value => 1);
10147 No : Rec := (empty => True);
10149 The size and contents of that record depends on the value of the
10150 descriminant (Rec.Empty). At this point, neither the debugging
10151 information nor the associated type structure in GDB are able to
10152 express such dynamic types. So what the debugger does is to create
10153 "fixed" versions of the type that applies to the specific object.
10154 We also informally refer to this opperation as "fixing" an object,
10155 which means creating its associated fixed type.
10157 Example: when printing the value of variable "Yes" above, its fixed
10158 type would look like this:
10165 On the other hand, if we printed the value of "No", its fixed type
10172 Things become a little more complicated when trying to fix an entity
10173 with a dynamic type that directly contains another dynamic type,
10174 such as an array of variant records, for instance. There are
10175 two possible cases: Arrays, and records.
10177 3. ``Fixing'' Arrays:
10178 ---------------------
10180 The type structure in GDB describes an array in terms of its bounds,
10181 and the type of its elements. By design, all elements in the array
10182 have the same type and we cannot represent an array of variant elements
10183 using the current type structure in GDB. When fixing an array,
10184 we cannot fix the array element, as we would potentially need one
10185 fixed type per element of the array. As a result, the best we can do
10186 when fixing an array is to produce an array whose bounds and size
10187 are correct (allowing us to read it from memory), but without having
10188 touched its element type. Fixing each element will be done later,
10189 when (if) necessary.
10191 Arrays are a little simpler to handle than records, because the same
10192 amount of memory is allocated for each element of the array, even if
10193 the amount of space actually used by each element differs from element
10194 to element. Consider for instance the following array of type Rec:
10196 type Rec_Array is array (1 .. 2) of Rec;
10198 The actual amount of memory occupied by each element might be different
10199 from element to element, depending on the value of their discriminant.
10200 But the amount of space reserved for each element in the array remains
10201 fixed regardless. So we simply need to compute that size using
10202 the debugging information available, from which we can then determine
10203 the array size (we multiply the number of elements of the array by
10204 the size of each element).
10206 The simplest case is when we have an array of a constrained element
10207 type. For instance, consider the following type declarations:
10209 type Bounded_String (Max_Size : Integer) is
10211 Buffer : String (1 .. Max_Size);
10213 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10215 In this case, the compiler describes the array as an array of
10216 variable-size elements (identified by its XVS suffix) for which
10217 the size can be read in the parallel XVZ variable.
10219 In the case of an array of an unconstrained element type, the compiler
10220 wraps the array element inside a private PAD type. This type should not
10221 be shown to the user, and must be "unwrap"'ed before printing. Note
10222 that we also use the adjective "aligner" in our code to designate
10223 these wrapper types.
10225 In some cases, the size allocated for each element is statically
10226 known. In that case, the PAD type already has the correct size,
10227 and the array element should remain unfixed.
10229 But there are cases when this size is not statically known.
10230 For instance, assuming that "Five" is an integer variable:
10232 type Dynamic is array (1 .. Five) of Integer;
10233 type Wrapper (Has_Length : Boolean := False) is record
10236 when True => Length : Integer;
10237 when False => null;
10240 type Wrapper_Array is array (1 .. 2) of Wrapper;
10242 Hello : Wrapper_Array := (others => (Has_Length => True,
10243 Data => (others => 17),
10247 The debugging info would describe variable Hello as being an
10248 array of a PAD type. The size of that PAD type is not statically
10249 known, but can be determined using a parallel XVZ variable.
10250 In that case, a copy of the PAD type with the correct size should
10251 be used for the fixed array.
10253 3. ``Fixing'' record type objects:
10254 ----------------------------------
10256 Things are slightly different from arrays in the case of dynamic
10257 record types. In this case, in order to compute the associated
10258 fixed type, we need to determine the size and offset of each of
10259 its components. This, in turn, requires us to compute the fixed
10260 type of each of these components.
10262 Consider for instance the example:
10264 type Bounded_String (Max_Size : Natural) is record
10265 Str : String (1 .. Max_Size);
10268 My_String : Bounded_String (Max_Size => 10);
10270 In that case, the position of field "Length" depends on the size
10271 of field Str, which itself depends on the value of the Max_Size
10272 discriminant. In order to fix the type of variable My_String,
10273 we need to fix the type of field Str. Therefore, fixing a variant
10274 record requires us to fix each of its components.
10276 However, if a component does not have a dynamic size, the component
10277 should not be fixed. In particular, fields that use a PAD type
10278 should not fixed. Here is an example where this might happen
10279 (assuming type Rec above):
10281 type Container (Big : Boolean) is record
10285 when True => Another : Integer;
10286 when False => null;
10289 My_Container : Container := (Big => False,
10290 First => (Empty => True),
10293 In that example, the compiler creates a PAD type for component First,
10294 whose size is constant, and then positions the component After just
10295 right after it. The offset of component After is therefore constant
10298 The debugger computes the position of each field based on an algorithm
10299 that uses, among other things, the actual position and size of the field
10300 preceding it. Let's now imagine that the user is trying to print
10301 the value of My_Container. If the type fixing was recursive, we would
10302 end up computing the offset of field After based on the size of the
10303 fixed version of field First. And since in our example First has
10304 only one actual field, the size of the fixed type is actually smaller
10305 than the amount of space allocated to that field, and thus we would
10306 compute the wrong offset of field After.
10308 To make things more complicated, we need to watch out for dynamic
10309 components of variant records (identified by the ___XVL suffix in
10310 the component name). Even if the target type is a PAD type, the size
10311 of that type might not be statically known. So the PAD type needs
10312 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10313 we might end up with the wrong size for our component. This can be
10314 observed with the following type declarations:
10316 type Octal is new Integer range 0 .. 7;
10317 type Octal_Array is array (Positive range <>) of Octal;
10318 pragma Pack (Octal_Array);
10320 type Octal_Buffer (Size : Positive) is record
10321 Buffer : Octal_Array (1 .. Size);
10325 In that case, Buffer is a PAD type whose size is unset and needs
10326 to be computed by fixing the unwrapped type.
10328 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10329 ----------------------------------------------------------
10331 Lastly, when should the sub-elements of an entity that remained unfixed
10332 thus far, be actually fixed?
10334 The answer is: Only when referencing that element. For instance
10335 when selecting one component of a record, this specific component
10336 should be fixed at that point in time. Or when printing the value
10337 of a record, each component should be fixed before its value gets
10338 printed. Similarly for arrays, the element of the array should be
10339 fixed when printing each element of the array, or when extracting
10340 one element out of that array. On the other hand, fixing should
10341 not be performed on the elements when taking a slice of an array!
10343 Note that one of the side effects of miscomputing the offset and
10344 size of each field is that we end up also miscomputing the size
10345 of the containing type. This can have adverse results when computing
10346 the value of an entity. GDB fetches the value of an entity based
10347 on the size of its type, and thus a wrong size causes GDB to fetch
10348 the wrong amount of memory. In the case where the computed size is
10349 too small, GDB fetches too little data to print the value of our
10350 entity. Results in this case are unpredictable, as we usually read
10351 past the buffer containing the data =:-o. */
10353 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10354 for that subexpression cast to TO_TYPE. Advance *POS over the
10358 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10359 enum noside noside
, struct type
*to_type
)
10363 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10364 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10369 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10371 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10372 return value_zero (to_type
, not_lval
);
10374 val
= evaluate_var_msym_value (noside
,
10375 exp
->elts
[pc
+ 1].objfile
,
10376 exp
->elts
[pc
+ 2].msymbol
);
10379 val
= evaluate_var_value (noside
,
10380 exp
->elts
[pc
+ 1].block
,
10381 exp
->elts
[pc
+ 2].symbol
);
10383 if (noside
== EVAL_SKIP
)
10384 return eval_skip_value (exp
);
10386 val
= ada_value_cast (to_type
, val
);
10388 /* Follow the Ada language semantics that do not allow taking
10389 an address of the result of a cast (view conversion in Ada). */
10390 if (VALUE_LVAL (val
) == lval_memory
)
10392 if (value_lazy (val
))
10393 value_fetch_lazy (val
);
10394 VALUE_LVAL (val
) = not_lval
;
10399 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10400 if (noside
== EVAL_SKIP
)
10401 return eval_skip_value (exp
);
10402 return ada_value_cast (to_type
, val
);
10405 /* Implement the evaluate_exp routine in the exp_descriptor structure
10406 for the Ada language. */
10408 static struct value
*
10409 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10410 int *pos
, enum noside noside
)
10412 enum exp_opcode op
;
10416 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10419 struct value
**argvec
;
10423 op
= exp
->elts
[pc
].opcode
;
10429 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10431 if (noside
== EVAL_NORMAL
)
10432 arg1
= unwrap_value (arg1
);
10434 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10435 then we need to perform the conversion manually, because
10436 evaluate_subexp_standard doesn't do it. This conversion is
10437 necessary in Ada because the different kinds of float/fixed
10438 types in Ada have different representations.
10440 Similarly, we need to perform the conversion from OP_LONG
10442 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10443 arg1
= ada_value_cast (expect_type
, arg1
);
10449 struct value
*result
;
10452 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10453 /* The result type will have code OP_STRING, bashed there from
10454 OP_ARRAY. Bash it back. */
10455 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
10456 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
10462 type
= exp
->elts
[pc
+ 1].type
;
10463 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10467 type
= exp
->elts
[pc
+ 1].type
;
10468 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10471 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10472 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10474 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10475 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10477 return ada_value_assign (arg1
, arg1
);
10479 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10480 except if the lhs of our assignment is a convenience variable.
10481 In the case of assigning to a convenience variable, the lhs
10482 should be exactly the result of the evaluation of the rhs. */
10483 type
= value_type (arg1
);
10484 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10486 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10487 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10489 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10493 else if (ada_is_fixed_point_type (value_type (arg1
)))
10494 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10495 else if (ada_is_fixed_point_type (value_type (arg2
)))
10497 (_("Fixed-point values must be assigned to fixed-point variables"));
10499 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10500 return ada_value_assign (arg1
, arg2
);
10503 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10504 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10505 if (noside
== EVAL_SKIP
)
10507 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10508 return (value_from_longest
10509 (value_type (arg1
),
10510 value_as_long (arg1
) + value_as_long (arg2
)));
10511 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10512 return (value_from_longest
10513 (value_type (arg2
),
10514 value_as_long (arg1
) + value_as_long (arg2
)));
10515 if ((ada_is_fixed_point_type (value_type (arg1
))
10516 || ada_is_fixed_point_type (value_type (arg2
)))
10517 && value_type (arg1
) != value_type (arg2
))
10518 error (_("Operands of fixed-point addition must have the same type"));
10519 /* Do the addition, and cast the result to the type of the first
10520 argument. We cannot cast the result to a reference type, so if
10521 ARG1 is a reference type, find its underlying type. */
10522 type
= value_type (arg1
);
10523 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10524 type
= TYPE_TARGET_TYPE (type
);
10525 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10526 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10529 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10530 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10531 if (noside
== EVAL_SKIP
)
10533 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10534 return (value_from_longest
10535 (value_type (arg1
),
10536 value_as_long (arg1
) - value_as_long (arg2
)));
10537 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10538 return (value_from_longest
10539 (value_type (arg2
),
10540 value_as_long (arg1
) - value_as_long (arg2
)));
10541 if ((ada_is_fixed_point_type (value_type (arg1
))
10542 || ada_is_fixed_point_type (value_type (arg2
)))
10543 && value_type (arg1
) != value_type (arg2
))
10544 error (_("Operands of fixed-point subtraction "
10545 "must have the same type"));
10546 /* Do the substraction, and cast the result to the type of the first
10547 argument. We cannot cast the result to a reference type, so if
10548 ARG1 is a reference type, find its underlying type. */
10549 type
= value_type (arg1
);
10550 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10551 type
= TYPE_TARGET_TYPE (type
);
10552 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10553 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10559 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10560 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10561 if (noside
== EVAL_SKIP
)
10563 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10565 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10566 return value_zero (value_type (arg1
), not_lval
);
10570 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10571 if (ada_is_fixed_point_type (value_type (arg1
)))
10572 arg1
= cast_from_fixed (type
, arg1
);
10573 if (ada_is_fixed_point_type (value_type (arg2
)))
10574 arg2
= cast_from_fixed (type
, arg2
);
10575 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10576 return ada_value_binop (arg1
, arg2
, op
);
10580 case BINOP_NOTEQUAL
:
10581 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10582 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10583 if (noside
== EVAL_SKIP
)
10585 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10589 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10590 tem
= ada_value_equal (arg1
, arg2
);
10592 if (op
== BINOP_NOTEQUAL
)
10594 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10595 return value_from_longest (type
, (LONGEST
) tem
);
10598 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10599 if (noside
== EVAL_SKIP
)
10601 else if (ada_is_fixed_point_type (value_type (arg1
)))
10602 return value_cast (value_type (arg1
), value_neg (arg1
));
10605 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10606 return value_neg (arg1
);
10609 case BINOP_LOGICAL_AND
:
10610 case BINOP_LOGICAL_OR
:
10611 case UNOP_LOGICAL_NOT
:
10616 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10617 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10618 return value_cast (type
, val
);
10621 case BINOP_BITWISE_AND
:
10622 case BINOP_BITWISE_IOR
:
10623 case BINOP_BITWISE_XOR
:
10627 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10629 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10631 return value_cast (value_type (arg1
), val
);
10637 if (noside
== EVAL_SKIP
)
10643 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10644 /* Only encountered when an unresolved symbol occurs in a
10645 context other than a function call, in which case, it is
10647 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10648 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
10650 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10652 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10653 /* Check to see if this is a tagged type. We also need to handle
10654 the case where the type is a reference to a tagged type, but
10655 we have to be careful to exclude pointers to tagged types.
10656 The latter should be shown as usual (as a pointer), whereas
10657 a reference should mostly be transparent to the user. */
10658 if (ada_is_tagged_type (type
, 0)
10659 || (TYPE_CODE (type
) == TYPE_CODE_REF
10660 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10662 /* Tagged types are a little special in the fact that the real
10663 type is dynamic and can only be determined by inspecting the
10664 object's tag. This means that we need to get the object's
10665 value first (EVAL_NORMAL) and then extract the actual object
10668 Note that we cannot skip the final step where we extract
10669 the object type from its tag, because the EVAL_NORMAL phase
10670 results in dynamic components being resolved into fixed ones.
10671 This can cause problems when trying to print the type
10672 description of tagged types whose parent has a dynamic size:
10673 We use the type name of the "_parent" component in order
10674 to print the name of the ancestor type in the type description.
10675 If that component had a dynamic size, the resolution into
10676 a fixed type would result in the loss of that type name,
10677 thus preventing us from printing the name of the ancestor
10678 type in the type description. */
10679 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10681 if (TYPE_CODE (type
) != TYPE_CODE_REF
)
10683 struct type
*actual_type
;
10685 actual_type
= type_from_tag (ada_value_tag (arg1
));
10686 if (actual_type
== NULL
)
10687 /* If, for some reason, we were unable to determine
10688 the actual type from the tag, then use the static
10689 approximation that we just computed as a fallback.
10690 This can happen if the debugging information is
10691 incomplete, for instance. */
10692 actual_type
= type
;
10693 return value_zero (actual_type
, not_lval
);
10697 /* In the case of a ref, ada_coerce_ref takes care
10698 of determining the actual type. But the evaluation
10699 should return a ref as it should be valid to ask
10700 for its address; so rebuild a ref after coerce. */
10701 arg1
= ada_coerce_ref (arg1
);
10702 return value_ref (arg1
, TYPE_CODE_REF
);
10706 /* Records and unions for which GNAT encodings have been
10707 generated need to be statically fixed as well.
10708 Otherwise, non-static fixing produces a type where
10709 all dynamic properties are removed, which prevents "ptype"
10710 from being able to completely describe the type.
10711 For instance, a case statement in a variant record would be
10712 replaced by the relevant components based on the actual
10713 value of the discriminants. */
10714 if ((TYPE_CODE (type
) == TYPE_CODE_STRUCT
10715 && dynamic_template_type (type
) != NULL
)
10716 || (TYPE_CODE (type
) == TYPE_CODE_UNION
10717 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10720 return value_zero (to_static_fixed_type (type
), not_lval
);
10724 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10725 return ada_to_fixed_value (arg1
);
10730 /* Allocate arg vector, including space for the function to be
10731 called in argvec[0] and a terminating NULL. */
10732 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10733 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10735 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10736 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10737 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10738 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
10741 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10742 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10745 if (noside
== EVAL_SKIP
)
10749 if (ada_is_constrained_packed_array_type
10750 (desc_base_type (value_type (argvec
[0]))))
10751 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10752 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10753 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10754 /* This is a packed array that has already been fixed, and
10755 therefore already coerced to a simple array. Nothing further
10758 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
)
10760 /* Make sure we dereference references so that all the code below
10761 feels like it's really handling the referenced value. Wrapping
10762 types (for alignment) may be there, so make sure we strip them as
10764 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10766 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10767 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10768 argvec
[0] = value_addr (argvec
[0]);
10770 type
= ada_check_typedef (value_type (argvec
[0]));
10772 /* Ada allows us to implicitly dereference arrays when subscripting
10773 them. So, if this is an array typedef (encoding use for array
10774 access types encoded as fat pointers), strip it now. */
10775 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
10776 type
= ada_typedef_target_type (type
);
10778 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
10780 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
10782 case TYPE_CODE_FUNC
:
10783 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10785 case TYPE_CODE_ARRAY
:
10787 case TYPE_CODE_STRUCT
:
10788 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10789 argvec
[0] = ada_value_ind (argvec
[0]);
10790 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10793 error (_("cannot subscript or call something of type `%s'"),
10794 ada_type_name (value_type (argvec
[0])));
10799 switch (TYPE_CODE (type
))
10801 case TYPE_CODE_FUNC
:
10802 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10804 if (TYPE_TARGET_TYPE (type
) == NULL
)
10805 error_call_unknown_return_type (NULL
);
10806 return allocate_value (TYPE_TARGET_TYPE (type
));
10808 return call_function_by_hand (argvec
[0], NULL
,
10809 gdb::make_array_view (argvec
+ 1,
10811 case TYPE_CODE_INTERNAL_FUNCTION
:
10812 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10813 /* We don't know anything about what the internal
10814 function might return, but we have to return
10816 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10819 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10820 argvec
[0], nargs
, argvec
+ 1);
10822 case TYPE_CODE_STRUCT
:
10826 arity
= ada_array_arity (type
);
10827 type
= ada_array_element_type (type
, nargs
);
10829 error (_("cannot subscript or call a record"));
10830 if (arity
!= nargs
)
10831 error (_("wrong number of subscripts; expecting %d"), arity
);
10832 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10833 return value_zero (ada_aligned_type (type
), lval_memory
);
10835 unwrap_value (ada_value_subscript
10836 (argvec
[0], nargs
, argvec
+ 1));
10838 case TYPE_CODE_ARRAY
:
10839 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10841 type
= ada_array_element_type (type
, nargs
);
10843 error (_("element type of array unknown"));
10845 return value_zero (ada_aligned_type (type
), lval_memory
);
10848 unwrap_value (ada_value_subscript
10849 (ada_coerce_to_simple_array (argvec
[0]),
10850 nargs
, argvec
+ 1));
10851 case TYPE_CODE_PTR
: /* Pointer to array */
10852 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10854 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10855 type
= ada_array_element_type (type
, nargs
);
10857 error (_("element type of array unknown"));
10859 return value_zero (ada_aligned_type (type
), lval_memory
);
10862 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10863 nargs
, argvec
+ 1));
10866 error (_("Attempt to index or call something other than an "
10867 "array or function"));
10872 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10873 struct value
*low_bound_val
=
10874 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10875 struct value
*high_bound_val
=
10876 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10878 LONGEST high_bound
;
10880 low_bound_val
= coerce_ref (low_bound_val
);
10881 high_bound_val
= coerce_ref (high_bound_val
);
10882 low_bound
= value_as_long (low_bound_val
);
10883 high_bound
= value_as_long (high_bound_val
);
10885 if (noside
== EVAL_SKIP
)
10888 /* If this is a reference to an aligner type, then remove all
10890 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10891 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10892 TYPE_TARGET_TYPE (value_type (array
)) =
10893 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10895 if (ada_is_constrained_packed_array_type (value_type (array
)))
10896 error (_("cannot slice a packed array"));
10898 /* If this is a reference to an array or an array lvalue,
10899 convert to a pointer. */
10900 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10901 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
10902 && VALUE_LVAL (array
) == lval_memory
))
10903 array
= value_addr (array
);
10905 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10906 && ada_is_array_descriptor_type (ada_check_typedef
10907 (value_type (array
))))
10908 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10911 array
= ada_coerce_to_simple_array_ptr (array
);
10913 /* If we have more than one level of pointer indirection,
10914 dereference the value until we get only one level. */
10915 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
10916 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
10918 array
= value_ind (array
);
10920 /* Make sure we really do have an array type before going further,
10921 to avoid a SEGV when trying to get the index type or the target
10922 type later down the road if the debug info generated by
10923 the compiler is incorrect or incomplete. */
10924 if (!ada_is_simple_array_type (value_type (array
)))
10925 error (_("cannot take slice of non-array"));
10927 if (TYPE_CODE (ada_check_typedef (value_type (array
)))
10930 struct type
*type0
= ada_check_typedef (value_type (array
));
10932 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10933 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10936 struct type
*arr_type0
=
10937 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10939 return ada_value_slice_from_ptr (array
, arr_type0
,
10940 longest_to_int (low_bound
),
10941 longest_to_int (high_bound
));
10944 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10946 else if (high_bound
< low_bound
)
10947 return empty_array (value_type (array
), low_bound
, high_bound
);
10949 return ada_value_slice (array
, longest_to_int (low_bound
),
10950 longest_to_int (high_bound
));
10953 case UNOP_IN_RANGE
:
10955 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10956 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10958 if (noside
== EVAL_SKIP
)
10961 switch (TYPE_CODE (type
))
10964 lim_warning (_("Membership test incompletely implemented; "
10965 "always returns true"));
10966 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10967 return value_from_longest (type
, (LONGEST
) 1);
10969 case TYPE_CODE_RANGE
:
10970 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10971 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10972 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10973 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10974 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10976 value_from_longest (type
,
10977 (value_less (arg1
, arg3
)
10978 || value_equal (arg1
, arg3
))
10979 && (value_less (arg2
, arg1
)
10980 || value_equal (arg2
, arg1
)));
10983 case BINOP_IN_BOUNDS
:
10985 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10986 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10988 if (noside
== EVAL_SKIP
)
10991 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10993 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10994 return value_zero (type
, not_lval
);
10997 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10999 type
= ada_index_type (value_type (arg2
), tem
, "range");
11001 type
= value_type (arg1
);
11003 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
11004 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
11006 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11007 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
11008 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11010 value_from_longest (type
,
11011 (value_less (arg1
, arg3
)
11012 || value_equal (arg1
, arg3
))
11013 && (value_less (arg2
, arg1
)
11014 || value_equal (arg2
, arg1
)));
11016 case TERNOP_IN_RANGE
:
11017 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11018 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11019 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11021 if (noside
== EVAL_SKIP
)
11024 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11025 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
11026 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11028 value_from_longest (type
,
11029 (value_less (arg1
, arg3
)
11030 || value_equal (arg1
, arg3
))
11031 && (value_less (arg2
, arg1
)
11032 || value_equal (arg2
, arg1
)));
11036 case OP_ATR_LENGTH
:
11038 struct type
*type_arg
;
11040 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11042 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11044 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11048 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11052 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
11053 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
11054 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
11057 if (noside
== EVAL_SKIP
)
11060 if (type_arg
== NULL
)
11062 arg1
= ada_coerce_ref (arg1
);
11064 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
11065 arg1
= ada_coerce_to_simple_array (arg1
);
11067 if (op
== OP_ATR_LENGTH
)
11068 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11071 type
= ada_index_type (value_type (arg1
), tem
,
11072 ada_attribute_name (op
));
11074 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11077 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11078 return allocate_value (type
);
11082 default: /* Should never happen. */
11083 error (_("unexpected attribute encountered"));
11085 return value_from_longest
11086 (type
, ada_array_bound (arg1
, tem
, 0));
11088 return value_from_longest
11089 (type
, ada_array_bound (arg1
, tem
, 1));
11090 case OP_ATR_LENGTH
:
11091 return value_from_longest
11092 (type
, ada_array_length (arg1
, tem
));
11095 else if (discrete_type_p (type_arg
))
11097 struct type
*range_type
;
11098 const char *name
= ada_type_name (type_arg
);
11101 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
11102 range_type
= to_fixed_range_type (type_arg
, NULL
);
11103 if (range_type
== NULL
)
11104 range_type
= type_arg
;
11108 error (_("unexpected attribute encountered"));
11110 return value_from_longest
11111 (range_type
, ada_discrete_type_low_bound (range_type
));
11113 return value_from_longest
11114 (range_type
, ada_discrete_type_high_bound (range_type
));
11115 case OP_ATR_LENGTH
:
11116 error (_("the 'length attribute applies only to array types"));
11119 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
11120 error (_("unimplemented type attribute"));
11125 if (ada_is_constrained_packed_array_type (type_arg
))
11126 type_arg
= decode_constrained_packed_array_type (type_arg
);
11128 if (op
== OP_ATR_LENGTH
)
11129 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11132 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
11134 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11137 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11138 return allocate_value (type
);
11143 error (_("unexpected attribute encountered"));
11145 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11146 return value_from_longest (type
, low
);
11148 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11149 return value_from_longest (type
, high
);
11150 case OP_ATR_LENGTH
:
11151 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11152 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11153 return value_from_longest (type
, high
- low
+ 1);
11159 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11160 if (noside
== EVAL_SKIP
)
11163 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11164 return value_zero (ada_tag_type (arg1
), not_lval
);
11166 return ada_value_tag (arg1
);
11170 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11171 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11172 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11173 if (noside
== EVAL_SKIP
)
11175 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11176 return value_zero (value_type (arg1
), not_lval
);
11179 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11180 return value_binop (arg1
, arg2
,
11181 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
11184 case OP_ATR_MODULUS
:
11186 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11188 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11189 if (noside
== EVAL_SKIP
)
11192 if (!ada_is_modular_type (type_arg
))
11193 error (_("'modulus must be applied to modular type"));
11195 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
11196 ada_modulus (type_arg
));
11201 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11202 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11203 if (noside
== EVAL_SKIP
)
11205 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11206 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11207 return value_zero (type
, not_lval
);
11209 return value_pos_atr (type
, arg1
);
11212 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11213 type
= value_type (arg1
);
11215 /* If the argument is a reference, then dereference its type, since
11216 the user is really asking for the size of the actual object,
11217 not the size of the pointer. */
11218 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
11219 type
= TYPE_TARGET_TYPE (type
);
11221 if (noside
== EVAL_SKIP
)
11223 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11224 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
11226 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
11227 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
11230 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11231 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11232 type
= exp
->elts
[pc
+ 2].type
;
11233 if (noside
== EVAL_SKIP
)
11235 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11236 return value_zero (type
, not_lval
);
11238 return value_val_atr (type
, arg1
);
11241 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11242 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11243 if (noside
== EVAL_SKIP
)
11245 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11246 return value_zero (value_type (arg1
), not_lval
);
11249 /* For integer exponentiation operations,
11250 only promote the first argument. */
11251 if (is_integral_type (value_type (arg2
)))
11252 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11254 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11256 return value_binop (arg1
, arg2
, op
);
11260 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11261 if (noside
== EVAL_SKIP
)
11267 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11268 if (noside
== EVAL_SKIP
)
11270 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11271 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11272 return value_neg (arg1
);
11277 preeval_pos
= *pos
;
11278 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11279 if (noside
== EVAL_SKIP
)
11281 type
= ada_check_typedef (value_type (arg1
));
11282 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11284 if (ada_is_array_descriptor_type (type
))
11285 /* GDB allows dereferencing GNAT array descriptors. */
11287 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11289 if (arrType
== NULL
)
11290 error (_("Attempt to dereference null array pointer."));
11291 return value_at_lazy (arrType
, 0);
11293 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
11294 || TYPE_CODE (type
) == TYPE_CODE_REF
11295 /* In C you can dereference an array to get the 1st elt. */
11296 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
11298 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11299 only be determined by inspecting the object's tag.
11300 This means that we need to evaluate completely the
11301 expression in order to get its type. */
11303 if ((TYPE_CODE (type
) == TYPE_CODE_REF
11304 || TYPE_CODE (type
) == TYPE_CODE_PTR
)
11305 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11307 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11309 type
= value_type (ada_value_ind (arg1
));
11313 type
= to_static_fixed_type
11315 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11317 ada_ensure_varsize_limit (type
);
11318 return value_zero (type
, lval_memory
);
11320 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11322 /* GDB allows dereferencing an int. */
11323 if (expect_type
== NULL
)
11324 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11329 to_static_fixed_type (ada_aligned_type (expect_type
));
11330 return value_zero (expect_type
, lval_memory
);
11334 error (_("Attempt to take contents of a non-pointer value."));
11336 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11337 type
= ada_check_typedef (value_type (arg1
));
11339 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11340 /* GDB allows dereferencing an int. If we were given
11341 the expect_type, then use that as the target type.
11342 Otherwise, assume that the target type is an int. */
11344 if (expect_type
!= NULL
)
11345 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11348 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11349 (CORE_ADDR
) value_as_address (arg1
));
11352 if (ada_is_array_descriptor_type (type
))
11353 /* GDB allows dereferencing GNAT array descriptors. */
11354 return ada_coerce_to_simple_array (arg1
);
11356 return ada_value_ind (arg1
);
11358 case STRUCTOP_STRUCT
:
11359 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11360 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11361 preeval_pos
= *pos
;
11362 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11363 if (noside
== EVAL_SKIP
)
11365 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11367 struct type
*type1
= value_type (arg1
);
11369 if (ada_is_tagged_type (type1
, 1))
11371 type
= ada_lookup_struct_elt_type (type1
,
11372 &exp
->elts
[pc
+ 2].string
,
11375 /* If the field is not found, check if it exists in the
11376 extension of this object's type. This means that we
11377 need to evaluate completely the expression. */
11381 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11383 arg1
= ada_value_struct_elt (arg1
,
11384 &exp
->elts
[pc
+ 2].string
,
11386 arg1
= unwrap_value (arg1
);
11387 type
= value_type (ada_to_fixed_value (arg1
));
11392 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11395 return value_zero (ada_aligned_type (type
), lval_memory
);
11399 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11400 arg1
= unwrap_value (arg1
);
11401 return ada_to_fixed_value (arg1
);
11405 /* The value is not supposed to be used. This is here to make it
11406 easier to accommodate expressions that contain types. */
11408 if (noside
== EVAL_SKIP
)
11410 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11411 return allocate_value (exp
->elts
[pc
+ 1].type
);
11413 error (_("Attempt to use a type name as an expression"));
11418 case OP_DISCRETE_RANGE
:
11419 case OP_POSITIONAL
:
11421 if (noside
== EVAL_NORMAL
)
11425 error (_("Undefined name, ambiguous name, or renaming used in "
11426 "component association: %s."), &exp
->elts
[pc
+2].string
);
11428 error (_("Aggregates only allowed on the right of an assignment"));
11430 internal_error (__FILE__
, __LINE__
,
11431 _("aggregate apparently mangled"));
11434 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11436 for (tem
= 0; tem
< nargs
; tem
+= 1)
11437 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11442 return eval_skip_value (exp
);
11448 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11449 type name that encodes the 'small and 'delta information.
11450 Otherwise, return NULL. */
11452 static const char *
11453 fixed_type_info (struct type
*type
)
11455 const char *name
= ada_type_name (type
);
11456 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
11458 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11460 const char *tail
= strstr (name
, "___XF_");
11467 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11468 return fixed_type_info (TYPE_TARGET_TYPE (type
));
11473 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11476 ada_is_fixed_point_type (struct type
*type
)
11478 return fixed_type_info (type
) != NULL
;
11481 /* Return non-zero iff TYPE represents a System.Address type. */
11484 ada_is_system_address_type (struct type
*type
)
11486 return (TYPE_NAME (type
)
11487 && strcmp (TYPE_NAME (type
), "system__address") == 0);
11490 /* Assuming that TYPE is the representation of an Ada fixed-point
11491 type, return the target floating-point type to be used to represent
11492 of this type during internal computation. */
11494 static struct type
*
11495 ada_scaling_type (struct type
*type
)
11497 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11500 /* Assuming that TYPE is the representation of an Ada fixed-point
11501 type, return its delta, or NULL if the type is malformed and the
11502 delta cannot be determined. */
11505 ada_delta (struct type
*type
)
11507 const char *encoding
= fixed_type_info (type
);
11508 struct type
*scale_type
= ada_scaling_type (type
);
11510 long long num
, den
;
11512 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11515 return value_binop (value_from_longest (scale_type
, num
),
11516 value_from_longest (scale_type
, den
), BINOP_DIV
);
11519 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11520 factor ('SMALL value) associated with the type. */
11523 ada_scaling_factor (struct type
*type
)
11525 const char *encoding
= fixed_type_info (type
);
11526 struct type
*scale_type
= ada_scaling_type (type
);
11528 long long num0
, den0
, num1
, den1
;
11531 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11532 &num0
, &den0
, &num1
, &den1
);
11535 return value_from_longest (scale_type
, 1);
11537 return value_binop (value_from_longest (scale_type
, num1
),
11538 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11540 return value_binop (value_from_longest (scale_type
, num0
),
11541 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11548 /* Scan STR beginning at position K for a discriminant name, and
11549 return the value of that discriminant field of DVAL in *PX. If
11550 PNEW_K is not null, put the position of the character beyond the
11551 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11552 not alter *PX and *PNEW_K if unsuccessful. */
11555 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11558 static char *bound_buffer
= NULL
;
11559 static size_t bound_buffer_len
= 0;
11560 const char *pstart
, *pend
, *bound
;
11561 struct value
*bound_val
;
11563 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11567 pend
= strstr (pstart
, "__");
11571 k
+= strlen (bound
);
11575 int len
= pend
- pstart
;
11577 /* Strip __ and beyond. */
11578 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11579 strncpy (bound_buffer
, pstart
, len
);
11580 bound_buffer
[len
] = '\0';
11582 bound
= bound_buffer
;
11586 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11587 if (bound_val
== NULL
)
11590 *px
= value_as_long (bound_val
);
11591 if (pnew_k
!= NULL
)
11596 /* Value of variable named NAME in the current environment. If
11597 no such variable found, then if ERR_MSG is null, returns 0, and
11598 otherwise causes an error with message ERR_MSG. */
11600 static struct value
*
11601 get_var_value (const char *name
, const char *err_msg
)
11603 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11605 std::vector
<struct block_symbol
> syms
;
11606 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11607 get_selected_block (0),
11608 VAR_DOMAIN
, &syms
, 1);
11612 if (err_msg
== NULL
)
11615 error (("%s"), err_msg
);
11618 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11621 /* Value of integer variable named NAME in the current environment.
11622 If no such variable is found, returns false. Otherwise, sets VALUE
11623 to the variable's value and returns true. */
11626 get_int_var_value (const char *name
, LONGEST
&value
)
11628 struct value
*var_val
= get_var_value (name
, 0);
11633 value
= value_as_long (var_val
);
11638 /* Return a range type whose base type is that of the range type named
11639 NAME in the current environment, and whose bounds are calculated
11640 from NAME according to the GNAT range encoding conventions.
11641 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11642 corresponding range type from debug information; fall back to using it
11643 if symbol lookup fails. If a new type must be created, allocate it
11644 like ORIG_TYPE was. The bounds information, in general, is encoded
11645 in NAME, the base type given in the named range type. */
11647 static struct type
*
11648 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11651 struct type
*base_type
;
11652 const char *subtype_info
;
11654 gdb_assert (raw_type
!= NULL
);
11655 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
11657 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
11658 base_type
= TYPE_TARGET_TYPE (raw_type
);
11660 base_type
= raw_type
;
11662 name
= TYPE_NAME (raw_type
);
11663 subtype_info
= strstr (name
, "___XD");
11664 if (subtype_info
== NULL
)
11666 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11667 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11669 if (L
< INT_MIN
|| U
> INT_MAX
)
11672 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11677 static char *name_buf
= NULL
;
11678 static size_t name_len
= 0;
11679 int prefix_len
= subtype_info
- name
;
11682 const char *bounds_str
;
11685 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11686 strncpy (name_buf
, name
, prefix_len
);
11687 name_buf
[prefix_len
] = '\0';
11690 bounds_str
= strchr (subtype_info
, '_');
11693 if (*subtype_info
== 'L')
11695 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11696 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11698 if (bounds_str
[n
] == '_')
11700 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11706 strcpy (name_buf
+ prefix_len
, "___L");
11707 if (!get_int_var_value (name_buf
, L
))
11709 lim_warning (_("Unknown lower bound, using 1."));
11714 if (*subtype_info
== 'U')
11716 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11717 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11722 strcpy (name_buf
+ prefix_len
, "___U");
11723 if (!get_int_var_value (name_buf
, U
))
11725 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11730 type
= create_static_range_type (alloc_type_copy (raw_type
),
11732 /* create_static_range_type alters the resulting type's length
11733 to match the size of the base_type, which is not what we want.
11734 Set it back to the original range type's length. */
11735 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11736 TYPE_NAME (type
) = name
;
11741 /* True iff NAME is the name of a range type. */
11744 ada_is_range_type_name (const char *name
)
11746 return (name
!= NULL
&& strstr (name
, "___XD"));
11750 /* Modular types */
11752 /* True iff TYPE is an Ada modular type. */
11755 ada_is_modular_type (struct type
*type
)
11757 struct type
*subranged_type
= get_base_type (type
);
11759 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
11760 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
11761 && TYPE_UNSIGNED (subranged_type
));
11764 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11767 ada_modulus (struct type
*type
)
11769 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11773 /* Ada exception catchpoint support:
11774 ---------------------------------
11776 We support 3 kinds of exception catchpoints:
11777 . catchpoints on Ada exceptions
11778 . catchpoints on unhandled Ada exceptions
11779 . catchpoints on failed assertions
11781 Exceptions raised during failed assertions, or unhandled exceptions
11782 could perfectly be caught with the general catchpoint on Ada exceptions.
11783 However, we can easily differentiate these two special cases, and having
11784 the option to distinguish these two cases from the rest can be useful
11785 to zero-in on certain situations.
11787 Exception catchpoints are a specialized form of breakpoint,
11788 since they rely on inserting breakpoints inside known routines
11789 of the GNAT runtime. The implementation therefore uses a standard
11790 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11793 Support in the runtime for exception catchpoints have been changed
11794 a few times already, and these changes affect the implementation
11795 of these catchpoints. In order to be able to support several
11796 variants of the runtime, we use a sniffer that will determine
11797 the runtime variant used by the program being debugged. */
11799 /* Ada's standard exceptions.
11801 The Ada 83 standard also defined Numeric_Error. But there so many
11802 situations where it was unclear from the Ada 83 Reference Manual
11803 (RM) whether Constraint_Error or Numeric_Error should be raised,
11804 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11805 Interpretation saying that anytime the RM says that Numeric_Error
11806 should be raised, the implementation may raise Constraint_Error.
11807 Ada 95 went one step further and pretty much removed Numeric_Error
11808 from the list of standard exceptions (it made it a renaming of
11809 Constraint_Error, to help preserve compatibility when compiling
11810 an Ada83 compiler). As such, we do not include Numeric_Error from
11811 this list of standard exceptions. */
11813 static const char *standard_exc
[] = {
11814 "constraint_error",
11820 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11822 /* A structure that describes how to support exception catchpoints
11823 for a given executable. */
11825 struct exception_support_info
11827 /* The name of the symbol to break on in order to insert
11828 a catchpoint on exceptions. */
11829 const char *catch_exception_sym
;
11831 /* The name of the symbol to break on in order to insert
11832 a catchpoint on unhandled exceptions. */
11833 const char *catch_exception_unhandled_sym
;
11835 /* The name of the symbol to break on in order to insert
11836 a catchpoint on failed assertions. */
11837 const char *catch_assert_sym
;
11839 /* The name of the symbol to break on in order to insert
11840 a catchpoint on exception handling. */
11841 const char *catch_handlers_sym
;
11843 /* Assuming that the inferior just triggered an unhandled exception
11844 catchpoint, this function is responsible for returning the address
11845 in inferior memory where the name of that exception is stored.
11846 Return zero if the address could not be computed. */
11847 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11850 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11851 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11853 /* The following exception support info structure describes how to
11854 implement exception catchpoints with the latest version of the
11855 Ada runtime (as of 2007-03-06). */
11857 static const struct exception_support_info default_exception_support_info
=
11859 "__gnat_debug_raise_exception", /* catch_exception_sym */
11860 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11861 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11862 "__gnat_begin_handler", /* catch_handlers_sym */
11863 ada_unhandled_exception_name_addr
11866 /* The following exception support info structure describes how to
11867 implement exception catchpoints with a slightly older version
11868 of the Ada runtime. */
11870 static const struct exception_support_info exception_support_info_fallback
=
11872 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11873 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11874 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11875 "__gnat_begin_handler", /* catch_handlers_sym */
11876 ada_unhandled_exception_name_addr_from_raise
11879 /* Return nonzero if we can detect the exception support routines
11880 described in EINFO.
11882 This function errors out if an abnormal situation is detected
11883 (for instance, if we find the exception support routines, but
11884 that support is found to be incomplete). */
11887 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11889 struct symbol
*sym
;
11891 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11892 that should be compiled with debugging information. As a result, we
11893 expect to find that symbol in the symtabs. */
11895 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11898 /* Perhaps we did not find our symbol because the Ada runtime was
11899 compiled without debugging info, or simply stripped of it.
11900 It happens on some GNU/Linux distributions for instance, where
11901 users have to install a separate debug package in order to get
11902 the runtime's debugging info. In that situation, let the user
11903 know why we cannot insert an Ada exception catchpoint.
11905 Note: Just for the purpose of inserting our Ada exception
11906 catchpoint, we could rely purely on the associated minimal symbol.
11907 But we would be operating in degraded mode anyway, since we are
11908 still lacking the debugging info needed later on to extract
11909 the name of the exception being raised (this name is printed in
11910 the catchpoint message, and is also used when trying to catch
11911 a specific exception). We do not handle this case for now. */
11912 struct bound_minimal_symbol msym
11913 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11915 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11916 error (_("Your Ada runtime appears to be missing some debugging "
11917 "information.\nCannot insert Ada exception catchpoint "
11918 "in this configuration."));
11923 /* Make sure that the symbol we found corresponds to a function. */
11925 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11926 error (_("Symbol \"%s\" is not a function (class = %d)"),
11927 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
11932 /* Inspect the Ada runtime and determine which exception info structure
11933 should be used to provide support for exception catchpoints.
11935 This function will always set the per-inferior exception_info,
11936 or raise an error. */
11939 ada_exception_support_info_sniffer (void)
11941 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11943 /* If the exception info is already known, then no need to recompute it. */
11944 if (data
->exception_info
!= NULL
)
11947 /* Check the latest (default) exception support info. */
11948 if (ada_has_this_exception_support (&default_exception_support_info
))
11950 data
->exception_info
= &default_exception_support_info
;
11954 /* Try our fallback exception suport info. */
11955 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11957 data
->exception_info
= &exception_support_info_fallback
;
11961 /* Sometimes, it is normal for us to not be able to find the routine
11962 we are looking for. This happens when the program is linked with
11963 the shared version of the GNAT runtime, and the program has not been
11964 started yet. Inform the user of these two possible causes if
11967 if (ada_update_initial_language (language_unknown
) != language_ada
)
11968 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11970 /* If the symbol does not exist, then check that the program is
11971 already started, to make sure that shared libraries have been
11972 loaded. If it is not started, this may mean that the symbol is
11973 in a shared library. */
11975 if (inferior_ptid
.pid () == 0)
11976 error (_("Unable to insert catchpoint. Try to start the program first."));
11978 /* At this point, we know that we are debugging an Ada program and
11979 that the inferior has been started, but we still are not able to
11980 find the run-time symbols. That can mean that we are in
11981 configurable run time mode, or that a-except as been optimized
11982 out by the linker... In any case, at this point it is not worth
11983 supporting this feature. */
11985 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11988 /* True iff FRAME is very likely to be that of a function that is
11989 part of the runtime system. This is all very heuristic, but is
11990 intended to be used as advice as to what frames are uninteresting
11994 is_known_support_routine (struct frame_info
*frame
)
11996 enum language func_lang
;
11998 const char *fullname
;
12000 /* If this code does not have any debugging information (no symtab),
12001 This cannot be any user code. */
12003 symtab_and_line sal
= find_frame_sal (frame
);
12004 if (sal
.symtab
== NULL
)
12007 /* If there is a symtab, but the associated source file cannot be
12008 located, then assume this is not user code: Selecting a frame
12009 for which we cannot display the code would not be very helpful
12010 for the user. This should also take care of case such as VxWorks
12011 where the kernel has some debugging info provided for a few units. */
12013 fullname
= symtab_to_fullname (sal
.symtab
);
12014 if (access (fullname
, R_OK
) != 0)
12017 /* Check the unit filename againt the Ada runtime file naming.
12018 We also check the name of the objfile against the name of some
12019 known system libraries that sometimes come with debugging info
12022 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
12024 re_comp (known_runtime_file_name_patterns
[i
]);
12025 if (re_exec (lbasename (sal
.symtab
->filename
)))
12027 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
12028 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
12032 /* Check whether the function is a GNAT-generated entity. */
12034 gdb::unique_xmalloc_ptr
<char> func_name
12035 = find_frame_funname (frame
, &func_lang
, NULL
);
12036 if (func_name
== NULL
)
12039 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
12041 re_comp (known_auxiliary_function_name_patterns
[i
]);
12042 if (re_exec (func_name
.get ()))
12049 /* Find the first frame that contains debugging information and that is not
12050 part of the Ada run-time, starting from FI and moving upward. */
12053 ada_find_printable_frame (struct frame_info
*fi
)
12055 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
12057 if (!is_known_support_routine (fi
))
12066 /* Assuming that the inferior just triggered an unhandled exception
12067 catchpoint, return the address in inferior memory where the name
12068 of the exception is stored.
12070 Return zero if the address could not be computed. */
12073 ada_unhandled_exception_name_addr (void)
12075 return parse_and_eval_address ("e.full_name");
12078 /* Same as ada_unhandled_exception_name_addr, except that this function
12079 should be used when the inferior uses an older version of the runtime,
12080 where the exception name needs to be extracted from a specific frame
12081 several frames up in the callstack. */
12084 ada_unhandled_exception_name_addr_from_raise (void)
12087 struct frame_info
*fi
;
12088 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12090 /* To determine the name of this exception, we need to select
12091 the frame corresponding to RAISE_SYM_NAME. This frame is
12092 at least 3 levels up, so we simply skip the first 3 frames
12093 without checking the name of their associated function. */
12094 fi
= get_current_frame ();
12095 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
12097 fi
= get_prev_frame (fi
);
12101 enum language func_lang
;
12103 gdb::unique_xmalloc_ptr
<char> func_name
12104 = find_frame_funname (fi
, &func_lang
, NULL
);
12105 if (func_name
!= NULL
)
12107 if (strcmp (func_name
.get (),
12108 data
->exception_info
->catch_exception_sym
) == 0)
12109 break; /* We found the frame we were looking for... */
12111 fi
= get_prev_frame (fi
);
12118 return parse_and_eval_address ("id.full_name");
12121 /* Assuming the inferior just triggered an Ada exception catchpoint
12122 (of any type), return the address in inferior memory where the name
12123 of the exception is stored, if applicable.
12125 Assumes the selected frame is the current frame.
12127 Return zero if the address could not be computed, or if not relevant. */
12130 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
12131 struct breakpoint
*b
)
12133 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12137 case ada_catch_exception
:
12138 return (parse_and_eval_address ("e.full_name"));
12141 case ada_catch_exception_unhandled
:
12142 return data
->exception_info
->unhandled_exception_name_addr ();
12145 case ada_catch_handlers
:
12146 return 0; /* The runtimes does not provide access to the exception
12150 case ada_catch_assert
:
12151 return 0; /* Exception name is not relevant in this case. */
12155 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12159 return 0; /* Should never be reached. */
12162 /* Assuming the inferior is stopped at an exception catchpoint,
12163 return the message which was associated to the exception, if
12164 available. Return NULL if the message could not be retrieved.
12166 Note: The exception message can be associated to an exception
12167 either through the use of the Raise_Exception function, or
12168 more simply (Ada 2005 and later), via:
12170 raise Exception_Name with "exception message";
12174 static gdb::unique_xmalloc_ptr
<char>
12175 ada_exception_message_1 (void)
12177 struct value
*e_msg_val
;
12180 /* For runtimes that support this feature, the exception message
12181 is passed as an unbounded string argument called "message". */
12182 e_msg_val
= parse_and_eval ("message");
12183 if (e_msg_val
== NULL
)
12184 return NULL
; /* Exception message not supported. */
12186 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12187 gdb_assert (e_msg_val
!= NULL
);
12188 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12190 /* If the message string is empty, then treat it as if there was
12191 no exception message. */
12192 if (e_msg_len
<= 0)
12195 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12196 read_memory_string (value_address (e_msg_val
), e_msg
.get (), e_msg_len
+ 1);
12197 e_msg
.get ()[e_msg_len
] = '\0';
12202 /* Same as ada_exception_message_1, except that all exceptions are
12203 contained here (returning NULL instead). */
12205 static gdb::unique_xmalloc_ptr
<char>
12206 ada_exception_message (void)
12208 gdb::unique_xmalloc_ptr
<char> e_msg
;
12212 e_msg
= ada_exception_message_1 ();
12214 catch (const gdb_exception_error
&e
)
12216 e_msg
.reset (nullptr);
12222 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12223 any error that ada_exception_name_addr_1 might cause to be thrown.
12224 When an error is intercepted, a warning with the error message is printed,
12225 and zero is returned. */
12228 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12229 struct breakpoint
*b
)
12231 CORE_ADDR result
= 0;
12235 result
= ada_exception_name_addr_1 (ex
, b
);
12238 catch (const gdb_exception_error
&e
)
12240 warning (_("failed to get exception name: %s"), e
.what ());
12247 static std::string ada_exception_catchpoint_cond_string
12248 (const char *excep_string
,
12249 enum ada_exception_catchpoint_kind ex
);
12251 /* Ada catchpoints.
12253 In the case of catchpoints on Ada exceptions, the catchpoint will
12254 stop the target on every exception the program throws. When a user
12255 specifies the name of a specific exception, we translate this
12256 request into a condition expression (in text form), and then parse
12257 it into an expression stored in each of the catchpoint's locations.
12258 We then use this condition to check whether the exception that was
12259 raised is the one the user is interested in. If not, then the
12260 target is resumed again. We store the name of the requested
12261 exception, in order to be able to re-set the condition expression
12262 when symbols change. */
12264 /* An instance of this type is used to represent an Ada catchpoint
12265 breakpoint location. */
12267 class ada_catchpoint_location
: public bp_location
12270 ada_catchpoint_location (breakpoint
*owner
)
12271 : bp_location (owner
)
12274 /* The condition that checks whether the exception that was raised
12275 is the specific exception the user specified on catchpoint
12277 expression_up excep_cond_expr
;
12280 /* An instance of this type is used to represent an Ada catchpoint. */
12282 struct ada_catchpoint
: public breakpoint
12284 /* The name of the specific exception the user specified. */
12285 std::string excep_string
;
12288 /* Parse the exception condition string in the context of each of the
12289 catchpoint's locations, and store them for later evaluation. */
12292 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12293 enum ada_exception_catchpoint_kind ex
)
12295 /* Nothing to do if there's no specific exception to catch. */
12296 if (c
->excep_string
.empty ())
12299 /* Same if there are no locations... */
12300 if (c
->loc
== NULL
)
12303 /* We have to compute the expression once for each program space,
12304 because the expression may hold the addresses of multiple symbols
12306 std::multimap
<program_space
*, struct bp_location
*> loc_map
;
12307 for (bp_location
*bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12308 loc_map
.emplace (bl
->pspace
, bl
);
12310 scoped_restore_current_program_space save_pspace
;
12312 std::string cond_string
;
12313 program_space
*last_ps
= nullptr;
12314 for (auto iter
: loc_map
)
12316 struct ada_catchpoint_location
*ada_loc
12317 = (struct ada_catchpoint_location
*) iter
.second
;
12319 if (ada_loc
->pspace
!= last_ps
)
12321 last_ps
= ada_loc
->pspace
;
12322 set_current_program_space (last_ps
);
12324 /* Compute the condition expression in text form, from the
12325 specific expection we want to catch. */
12327 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (),
12333 if (!ada_loc
->shlib_disabled
)
12337 s
= cond_string
.c_str ();
12340 exp
= parse_exp_1 (&s
, ada_loc
->address
,
12341 block_for_pc (ada_loc
->address
),
12344 catch (const gdb_exception_error
&e
)
12346 warning (_("failed to reevaluate internal exception condition "
12347 "for catchpoint %d: %s"),
12348 c
->number
, e
.what ());
12352 ada_loc
->excep_cond_expr
= std::move (exp
);
12356 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12357 structure for all exception catchpoint kinds. */
12359 static struct bp_location
*
12360 allocate_location_exception (enum ada_exception_catchpoint_kind ex
,
12361 struct breakpoint
*self
)
12363 return new ada_catchpoint_location (self
);
12366 /* Implement the RE_SET method in the breakpoint_ops structure for all
12367 exception catchpoint kinds. */
12370 re_set_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
12372 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12374 /* Call the base class's method. This updates the catchpoint's
12376 bkpt_breakpoint_ops
.re_set (b
);
12378 /* Reparse the exception conditional expressions. One for each
12380 create_excep_cond_exprs (c
, ex
);
12383 /* Returns true if we should stop for this breakpoint hit. If the
12384 user specified a specific exception, we only want to cause a stop
12385 if the program thrown that exception. */
12388 should_stop_exception (const struct bp_location
*bl
)
12390 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12391 const struct ada_catchpoint_location
*ada_loc
12392 = (const struct ada_catchpoint_location
*) bl
;
12395 /* With no specific exception, should always stop. */
12396 if (c
->excep_string
.empty ())
12399 if (ada_loc
->excep_cond_expr
== NULL
)
12401 /* We will have a NULL expression if back when we were creating
12402 the expressions, this location's had failed to parse. */
12409 struct value
*mark
;
12411 mark
= value_mark ();
12412 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12413 value_free_to_mark (mark
);
12415 catch (const gdb_exception
&ex
)
12417 exception_fprintf (gdb_stderr
, ex
,
12418 _("Error in testing exception condition:\n"));
12424 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12425 for all exception catchpoint kinds. */
12428 check_status_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12430 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12433 /* Implement the PRINT_IT method in the breakpoint_ops structure
12434 for all exception catchpoint kinds. */
12436 static enum print_stop_action
12437 print_it_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12439 struct ui_out
*uiout
= current_uiout
;
12440 struct breakpoint
*b
= bs
->breakpoint_at
;
12442 annotate_catchpoint (b
->number
);
12444 if (uiout
->is_mi_like_p ())
12446 uiout
->field_string ("reason",
12447 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12448 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12451 uiout
->text (b
->disposition
== disp_del
12452 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12453 uiout
->field_int ("bkptno", b
->number
);
12454 uiout
->text (", ");
12456 /* ada_exception_name_addr relies on the selected frame being the
12457 current frame. Need to do this here because this function may be
12458 called more than once when printing a stop, and below, we'll
12459 select the first frame past the Ada run-time (see
12460 ada_find_printable_frame). */
12461 select_frame (get_current_frame ());
12465 case ada_catch_exception
:
12466 case ada_catch_exception_unhandled
:
12467 case ada_catch_handlers
:
12469 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
12470 char exception_name
[256];
12474 read_memory (addr
, (gdb_byte
*) exception_name
,
12475 sizeof (exception_name
) - 1);
12476 exception_name
[sizeof (exception_name
) - 1] = '\0';
12480 /* For some reason, we were unable to read the exception
12481 name. This could happen if the Runtime was compiled
12482 without debugging info, for instance. In that case,
12483 just replace the exception name by the generic string
12484 "exception" - it will read as "an exception" in the
12485 notification we are about to print. */
12486 memcpy (exception_name
, "exception", sizeof ("exception"));
12488 /* In the case of unhandled exception breakpoints, we print
12489 the exception name as "unhandled EXCEPTION_NAME", to make
12490 it clearer to the user which kind of catchpoint just got
12491 hit. We used ui_out_text to make sure that this extra
12492 info does not pollute the exception name in the MI case. */
12493 if (ex
== ada_catch_exception_unhandled
)
12494 uiout
->text ("unhandled ");
12495 uiout
->field_string ("exception-name", exception_name
);
12498 case ada_catch_assert
:
12499 /* In this case, the name of the exception is not really
12500 important. Just print "failed assertion" to make it clearer
12501 that his program just hit an assertion-failure catchpoint.
12502 We used ui_out_text because this info does not belong in
12504 uiout
->text ("failed assertion");
12508 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12509 if (exception_message
!= NULL
)
12511 uiout
->text (" (");
12512 uiout
->field_string ("exception-message", exception_message
.get ());
12516 uiout
->text (" at ");
12517 ada_find_printable_frame (get_current_frame ());
12519 return PRINT_SRC_AND_LOC
;
12522 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12523 for all exception catchpoint kinds. */
12526 print_one_exception (enum ada_exception_catchpoint_kind ex
,
12527 struct breakpoint
*b
, struct bp_location
**last_loc
)
12529 struct ui_out
*uiout
= current_uiout
;
12530 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12531 struct value_print_options opts
;
12533 get_user_print_options (&opts
);
12534 if (opts
.addressprint
)
12536 annotate_field (4);
12537 uiout
->field_core_addr ("addr", b
->loc
->gdbarch
, b
->loc
->address
);
12540 annotate_field (5);
12541 *last_loc
= b
->loc
;
12544 case ada_catch_exception
:
12545 if (!c
->excep_string
.empty ())
12547 std::string msg
= string_printf (_("`%s' Ada exception"),
12548 c
->excep_string
.c_str ());
12550 uiout
->field_string ("what", msg
);
12553 uiout
->field_string ("what", "all Ada exceptions");
12557 case ada_catch_exception_unhandled
:
12558 uiout
->field_string ("what", "unhandled Ada exceptions");
12561 case ada_catch_handlers
:
12562 if (!c
->excep_string
.empty ())
12564 uiout
->field_fmt ("what",
12565 _("`%s' Ada exception handlers"),
12566 c
->excep_string
.c_str ());
12569 uiout
->field_string ("what", "all Ada exceptions handlers");
12572 case ada_catch_assert
:
12573 uiout
->field_string ("what", "failed Ada assertions");
12577 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12582 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12583 for all exception catchpoint kinds. */
12586 print_mention_exception (enum ada_exception_catchpoint_kind ex
,
12587 struct breakpoint
*b
)
12589 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12590 struct ui_out
*uiout
= current_uiout
;
12592 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12593 : _("Catchpoint "));
12594 uiout
->field_int ("bkptno", b
->number
);
12595 uiout
->text (": ");
12599 case ada_catch_exception
:
12600 if (!c
->excep_string
.empty ())
12602 std::string info
= string_printf (_("`%s' Ada exception"),
12603 c
->excep_string
.c_str ());
12604 uiout
->text (info
.c_str ());
12607 uiout
->text (_("all Ada exceptions"));
12610 case ada_catch_exception_unhandled
:
12611 uiout
->text (_("unhandled Ada exceptions"));
12614 case ada_catch_handlers
:
12615 if (!c
->excep_string
.empty ())
12618 = string_printf (_("`%s' Ada exception handlers"),
12619 c
->excep_string
.c_str ());
12620 uiout
->text (info
.c_str ());
12623 uiout
->text (_("all Ada exceptions handlers"));
12626 case ada_catch_assert
:
12627 uiout
->text (_("failed Ada assertions"));
12631 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12636 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12637 for all exception catchpoint kinds. */
12640 print_recreate_exception (enum ada_exception_catchpoint_kind ex
,
12641 struct breakpoint
*b
, struct ui_file
*fp
)
12643 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12647 case ada_catch_exception
:
12648 fprintf_filtered (fp
, "catch exception");
12649 if (!c
->excep_string
.empty ())
12650 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12653 case ada_catch_exception_unhandled
:
12654 fprintf_filtered (fp
, "catch exception unhandled");
12657 case ada_catch_handlers
:
12658 fprintf_filtered (fp
, "catch handlers");
12661 case ada_catch_assert
:
12662 fprintf_filtered (fp
, "catch assert");
12666 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12668 print_recreate_thread (b
, fp
);
12671 /* Virtual table for "catch exception" breakpoints. */
12673 static struct bp_location
*
12674 allocate_location_catch_exception (struct breakpoint
*self
)
12676 return allocate_location_exception (ada_catch_exception
, self
);
12680 re_set_catch_exception (struct breakpoint
*b
)
12682 re_set_exception (ada_catch_exception
, b
);
12686 check_status_catch_exception (bpstat bs
)
12688 check_status_exception (ada_catch_exception
, bs
);
12691 static enum print_stop_action
12692 print_it_catch_exception (bpstat bs
)
12694 return print_it_exception (ada_catch_exception
, bs
);
12698 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12700 print_one_exception (ada_catch_exception
, b
, last_loc
);
12704 print_mention_catch_exception (struct breakpoint
*b
)
12706 print_mention_exception (ada_catch_exception
, b
);
12710 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12712 print_recreate_exception (ada_catch_exception
, b
, fp
);
12715 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12717 /* Virtual table for "catch exception unhandled" breakpoints. */
12719 static struct bp_location
*
12720 allocate_location_catch_exception_unhandled (struct breakpoint
*self
)
12722 return allocate_location_exception (ada_catch_exception_unhandled
, self
);
12726 re_set_catch_exception_unhandled (struct breakpoint
*b
)
12728 re_set_exception (ada_catch_exception_unhandled
, b
);
12732 check_status_catch_exception_unhandled (bpstat bs
)
12734 check_status_exception (ada_catch_exception_unhandled
, bs
);
12737 static enum print_stop_action
12738 print_it_catch_exception_unhandled (bpstat bs
)
12740 return print_it_exception (ada_catch_exception_unhandled
, bs
);
12744 print_one_catch_exception_unhandled (struct breakpoint
*b
,
12745 struct bp_location
**last_loc
)
12747 print_one_exception (ada_catch_exception_unhandled
, b
, last_loc
);
12751 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
12753 print_mention_exception (ada_catch_exception_unhandled
, b
);
12757 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
12758 struct ui_file
*fp
)
12760 print_recreate_exception (ada_catch_exception_unhandled
, b
, fp
);
12763 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12765 /* Virtual table for "catch assert" breakpoints. */
12767 static struct bp_location
*
12768 allocate_location_catch_assert (struct breakpoint
*self
)
12770 return allocate_location_exception (ada_catch_assert
, self
);
12774 re_set_catch_assert (struct breakpoint
*b
)
12776 re_set_exception (ada_catch_assert
, b
);
12780 check_status_catch_assert (bpstat bs
)
12782 check_status_exception (ada_catch_assert
, bs
);
12785 static enum print_stop_action
12786 print_it_catch_assert (bpstat bs
)
12788 return print_it_exception (ada_catch_assert
, bs
);
12792 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
12794 print_one_exception (ada_catch_assert
, b
, last_loc
);
12798 print_mention_catch_assert (struct breakpoint
*b
)
12800 print_mention_exception (ada_catch_assert
, b
);
12804 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
12806 print_recreate_exception (ada_catch_assert
, b
, fp
);
12809 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12811 /* Virtual table for "catch handlers" breakpoints. */
12813 static struct bp_location
*
12814 allocate_location_catch_handlers (struct breakpoint
*self
)
12816 return allocate_location_exception (ada_catch_handlers
, self
);
12820 re_set_catch_handlers (struct breakpoint
*b
)
12822 re_set_exception (ada_catch_handlers
, b
);
12826 check_status_catch_handlers (bpstat bs
)
12828 check_status_exception (ada_catch_handlers
, bs
);
12831 static enum print_stop_action
12832 print_it_catch_handlers (bpstat bs
)
12834 return print_it_exception (ada_catch_handlers
, bs
);
12838 print_one_catch_handlers (struct breakpoint
*b
,
12839 struct bp_location
**last_loc
)
12841 print_one_exception (ada_catch_handlers
, b
, last_loc
);
12845 print_mention_catch_handlers (struct breakpoint
*b
)
12847 print_mention_exception (ada_catch_handlers
, b
);
12851 print_recreate_catch_handlers (struct breakpoint
*b
,
12852 struct ui_file
*fp
)
12854 print_recreate_exception (ada_catch_handlers
, b
, fp
);
12857 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12859 /* Split the arguments specified in a "catch exception" command.
12860 Set EX to the appropriate catchpoint type.
12861 Set EXCEP_STRING to the name of the specific exception if
12862 specified by the user.
12863 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12864 "catch handlers" command. False otherwise.
12865 If a condition is found at the end of the arguments, the condition
12866 expression is stored in COND_STRING (memory must be deallocated
12867 after use). Otherwise COND_STRING is set to NULL. */
12870 catch_ada_exception_command_split (const char *args
,
12871 bool is_catch_handlers_cmd
,
12872 enum ada_exception_catchpoint_kind
*ex
,
12873 std::string
*excep_string
,
12874 std::string
*cond_string
)
12876 std::string exception_name
;
12878 exception_name
= extract_arg (&args
);
12879 if (exception_name
== "if")
12881 /* This is not an exception name; this is the start of a condition
12882 expression for a catchpoint on all exceptions. So, "un-get"
12883 this token, and set exception_name to NULL. */
12884 exception_name
.clear ();
12888 /* Check to see if we have a condition. */
12890 args
= skip_spaces (args
);
12891 if (startswith (args
, "if")
12892 && (isspace (args
[2]) || args
[2] == '\0'))
12895 args
= skip_spaces (args
);
12897 if (args
[0] == '\0')
12898 error (_("Condition missing after `if' keyword"));
12899 *cond_string
= args
;
12901 args
+= strlen (args
);
12904 /* Check that we do not have any more arguments. Anything else
12907 if (args
[0] != '\0')
12908 error (_("Junk at end of expression"));
12910 if (is_catch_handlers_cmd
)
12912 /* Catch handling of exceptions. */
12913 *ex
= ada_catch_handlers
;
12914 *excep_string
= exception_name
;
12916 else if (exception_name
.empty ())
12918 /* Catch all exceptions. */
12919 *ex
= ada_catch_exception
;
12920 excep_string
->clear ();
12922 else if (exception_name
== "unhandled")
12924 /* Catch unhandled exceptions. */
12925 *ex
= ada_catch_exception_unhandled
;
12926 excep_string
->clear ();
12930 /* Catch a specific exception. */
12931 *ex
= ada_catch_exception
;
12932 *excep_string
= exception_name
;
12936 /* Return the name of the symbol on which we should break in order to
12937 implement a catchpoint of the EX kind. */
12939 static const char *
12940 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12942 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12944 gdb_assert (data
->exception_info
!= NULL
);
12948 case ada_catch_exception
:
12949 return (data
->exception_info
->catch_exception_sym
);
12951 case ada_catch_exception_unhandled
:
12952 return (data
->exception_info
->catch_exception_unhandled_sym
);
12954 case ada_catch_assert
:
12955 return (data
->exception_info
->catch_assert_sym
);
12957 case ada_catch_handlers
:
12958 return (data
->exception_info
->catch_handlers_sym
);
12961 internal_error (__FILE__
, __LINE__
,
12962 _("unexpected catchpoint kind (%d)"), ex
);
12966 /* Return the breakpoint ops "virtual table" used for catchpoints
12969 static const struct breakpoint_ops
*
12970 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12974 case ada_catch_exception
:
12975 return (&catch_exception_breakpoint_ops
);
12977 case ada_catch_exception_unhandled
:
12978 return (&catch_exception_unhandled_breakpoint_ops
);
12980 case ada_catch_assert
:
12981 return (&catch_assert_breakpoint_ops
);
12983 case ada_catch_handlers
:
12984 return (&catch_handlers_breakpoint_ops
);
12987 internal_error (__FILE__
, __LINE__
,
12988 _("unexpected catchpoint kind (%d)"), ex
);
12992 /* Return the condition that will be used to match the current exception
12993 being raised with the exception that the user wants to catch. This
12994 assumes that this condition is used when the inferior just triggered
12995 an exception catchpoint.
12996 EX: the type of catchpoints used for catching Ada exceptions. */
12999 ada_exception_catchpoint_cond_string (const char *excep_string
,
13000 enum ada_exception_catchpoint_kind ex
)
13003 std::string result
;
13006 if (ex
== ada_catch_handlers
)
13008 /* For exception handlers catchpoints, the condition string does
13009 not use the same parameter as for the other exceptions. */
13010 name
= ("long_integer (GNAT_GCC_exception_Access"
13011 "(gcc_exception).all.occurrence.id)");
13014 name
= "long_integer (e)";
13016 /* The standard exceptions are a special case. They are defined in
13017 runtime units that have been compiled without debugging info; if
13018 EXCEP_STRING is the not-fully-qualified name of a standard
13019 exception (e.g. "constraint_error") then, during the evaluation
13020 of the condition expression, the symbol lookup on this name would
13021 *not* return this standard exception. The catchpoint condition
13022 may then be set only on user-defined exceptions which have the
13023 same not-fully-qualified name (e.g. my_package.constraint_error).
13025 To avoid this unexcepted behavior, these standard exceptions are
13026 systematically prefixed by "standard". This means that "catch
13027 exception constraint_error" is rewritten into "catch exception
13028 standard.constraint_error".
13030 If an exception named contraint_error is defined in another package of
13031 the inferior program, then the only way to specify this exception as a
13032 breakpoint condition is to use its fully-qualified named:
13033 e.g. my_package.constraint_error.
13035 Furthermore, in some situations a standard exception's symbol may
13036 be present in more than one objfile, because the compiler may
13037 choose to emit copy relocations for them. So, we have to compare
13038 against all the possible addresses. */
13040 /* Storage for a rewritten symbol name. */
13041 std::string std_name
;
13042 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
13044 if (strcmp (standard_exc
[i
], excep_string
) == 0)
13046 std_name
= std::string ("standard.") + excep_string
;
13047 excep_string
= std_name
.c_str ();
13052 excep_string
= ada_encode (excep_string
);
13053 std::vector
<struct bound_minimal_symbol
> symbols
13054 = ada_lookup_simple_minsyms (excep_string
);
13055 for (const bound_minimal_symbol
&msym
: symbols
)
13057 if (!result
.empty ())
13059 string_appendf (result
, "%s = %s", name
,
13060 pulongest (BMSYMBOL_VALUE_ADDRESS (msym
)));
13066 /* Return the symtab_and_line that should be used to insert an exception
13067 catchpoint of the TYPE kind.
13069 ADDR_STRING returns the name of the function where the real
13070 breakpoint that implements the catchpoints is set, depending on the
13071 type of catchpoint we need to create. */
13073 static struct symtab_and_line
13074 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
13075 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
13077 const char *sym_name
;
13078 struct symbol
*sym
;
13080 /* First, find out which exception support info to use. */
13081 ada_exception_support_info_sniffer ();
13083 /* Then lookup the function on which we will break in order to catch
13084 the Ada exceptions requested by the user. */
13085 sym_name
= ada_exception_sym_name (ex
);
13086 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
13089 error (_("Catchpoint symbol not found: %s"), sym_name
);
13091 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
13092 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
13094 /* Set ADDR_STRING. */
13095 *addr_string
= sym_name
;
13098 *ops
= ada_exception_breakpoint_ops (ex
);
13100 return find_function_start_sal (sym
, 1);
13103 /* Create an Ada exception catchpoint.
13105 EX_KIND is the kind of exception catchpoint to be created.
13107 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
13108 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13109 of the exception to which this catchpoint applies.
13111 COND_STRING, if not empty, is the catchpoint condition.
13113 TEMPFLAG, if nonzero, means that the underlying breakpoint
13114 should be temporary.
13116 FROM_TTY is the usual argument passed to all commands implementations. */
13119 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
13120 enum ada_exception_catchpoint_kind ex_kind
,
13121 const std::string
&excep_string
,
13122 const std::string
&cond_string
,
13127 std::string addr_string
;
13128 const struct breakpoint_ops
*ops
= NULL
;
13129 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
13131 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint ());
13132 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
13133 ops
, tempflag
, disabled
, from_tty
);
13134 c
->excep_string
= excep_string
;
13135 create_excep_cond_exprs (c
.get (), ex_kind
);
13136 if (!cond_string
.empty ())
13137 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
13138 install_breakpoint (0, std::move (c
), 1);
13141 /* Implement the "catch exception" command. */
13144 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
13145 struct cmd_list_element
*command
)
13147 const char *arg
= arg_entry
;
13148 struct gdbarch
*gdbarch
= get_current_arch ();
13150 enum ada_exception_catchpoint_kind ex_kind
;
13151 std::string excep_string
;
13152 std::string cond_string
;
13154 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13158 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
13160 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13161 excep_string
, cond_string
,
13162 tempflag
, 1 /* enabled */,
13166 /* Implement the "catch handlers" command. */
13169 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
13170 struct cmd_list_element
*command
)
13172 const char *arg
= arg_entry
;
13173 struct gdbarch
*gdbarch
= get_current_arch ();
13175 enum ada_exception_catchpoint_kind ex_kind
;
13176 std::string excep_string
;
13177 std::string cond_string
;
13179 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13183 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
13185 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13186 excep_string
, cond_string
,
13187 tempflag
, 1 /* enabled */,
13191 /* Completion function for the Ada "catch" commands. */
13194 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
13195 const char *text
, const char *word
)
13197 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
13199 for (const ada_exc_info
&info
: exceptions
)
13201 if (startswith (info
.name
, word
))
13202 tracker
.add_completion (make_unique_xstrdup (info
.name
));
13206 /* Split the arguments specified in a "catch assert" command.
13208 ARGS contains the command's arguments (or the empty string if
13209 no arguments were passed).
13211 If ARGS contains a condition, set COND_STRING to that condition
13212 (the memory needs to be deallocated after use). */
13215 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
13217 args
= skip_spaces (args
);
13219 /* Check whether a condition was provided. */
13220 if (startswith (args
, "if")
13221 && (isspace (args
[2]) || args
[2] == '\0'))
13224 args
= skip_spaces (args
);
13225 if (args
[0] == '\0')
13226 error (_("condition missing after `if' keyword"));
13227 cond_string
.assign (args
);
13230 /* Otherwise, there should be no other argument at the end of
13232 else if (args
[0] != '\0')
13233 error (_("Junk at end of arguments."));
13236 /* Implement the "catch assert" command. */
13239 catch_assert_command (const char *arg_entry
, int from_tty
,
13240 struct cmd_list_element
*command
)
13242 const char *arg
= arg_entry
;
13243 struct gdbarch
*gdbarch
= get_current_arch ();
13245 std::string cond_string
;
13247 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13251 catch_ada_assert_command_split (arg
, cond_string
);
13252 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
13254 tempflag
, 1 /* enabled */,
13258 /* Return non-zero if the symbol SYM is an Ada exception object. */
13261 ada_is_exception_sym (struct symbol
*sym
)
13263 const char *type_name
= TYPE_NAME (SYMBOL_TYPE (sym
));
13265 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
13266 && SYMBOL_CLASS (sym
) != LOC_BLOCK
13267 && SYMBOL_CLASS (sym
) != LOC_CONST
13268 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
13269 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
13272 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13273 Ada exception object. This matches all exceptions except the ones
13274 defined by the Ada language. */
13277 ada_is_non_standard_exception_sym (struct symbol
*sym
)
13281 if (!ada_is_exception_sym (sym
))
13284 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13285 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), standard_exc
[i
]) == 0)
13286 return 0; /* A standard exception. */
13288 /* Numeric_Error is also a standard exception, so exclude it.
13289 See the STANDARD_EXC description for more details as to why
13290 this exception is not listed in that array. */
13291 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), "numeric_error") == 0)
13297 /* A helper function for std::sort, comparing two struct ada_exc_info
13300 The comparison is determined first by exception name, and then
13301 by exception address. */
13304 ada_exc_info::operator< (const ada_exc_info
&other
) const
13308 result
= strcmp (name
, other
.name
);
13311 if (result
== 0 && addr
< other
.addr
)
13317 ada_exc_info::operator== (const ada_exc_info
&other
) const
13319 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
13322 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13323 routine, but keeping the first SKIP elements untouched.
13325 All duplicates are also removed. */
13328 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
13331 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
13332 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
13333 exceptions
->end ());
13336 /* Add all exceptions defined by the Ada standard whose name match
13337 a regular expression.
13339 If PREG is not NULL, then this regexp_t object is used to
13340 perform the symbol name matching. Otherwise, no name-based
13341 filtering is performed.
13343 EXCEPTIONS is a vector of exceptions to which matching exceptions
13347 ada_add_standard_exceptions (compiled_regex
*preg
,
13348 std::vector
<ada_exc_info
> *exceptions
)
13352 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13355 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
13357 struct bound_minimal_symbol msymbol
13358 = ada_lookup_simple_minsym (standard_exc
[i
]);
13360 if (msymbol
.minsym
!= NULL
)
13362 struct ada_exc_info info
13363 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13365 exceptions
->push_back (info
);
13371 /* Add all Ada exceptions defined locally and accessible from the given
13374 If PREG is not NULL, then this regexp_t object is used to
13375 perform the symbol name matching. Otherwise, no name-based
13376 filtering is performed.
13378 EXCEPTIONS is a vector of exceptions to which matching exceptions
13382 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13383 struct frame_info
*frame
,
13384 std::vector
<ada_exc_info
> *exceptions
)
13386 const struct block
*block
= get_frame_block (frame
, 0);
13390 struct block_iterator iter
;
13391 struct symbol
*sym
;
13393 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13395 switch (SYMBOL_CLASS (sym
))
13402 if (ada_is_exception_sym (sym
))
13404 struct ada_exc_info info
= {SYMBOL_PRINT_NAME (sym
),
13405 SYMBOL_VALUE_ADDRESS (sym
)};
13407 exceptions
->push_back (info
);
13411 if (BLOCK_FUNCTION (block
) != NULL
)
13413 block
= BLOCK_SUPERBLOCK (block
);
13417 /* Return true if NAME matches PREG or if PREG is NULL. */
13420 name_matches_regex (const char *name
, compiled_regex
*preg
)
13422 return (preg
== NULL
13423 || preg
->exec (ada_decode (name
), 0, NULL
, 0) == 0);
13426 /* Add all exceptions defined globally whose name name match
13427 a regular expression, excluding standard exceptions.
13429 The reason we exclude standard exceptions is that they need
13430 to be handled separately: Standard exceptions are defined inside
13431 a runtime unit which is normally not compiled with debugging info,
13432 and thus usually do not show up in our symbol search. However,
13433 if the unit was in fact built with debugging info, we need to
13434 exclude them because they would duplicate the entry we found
13435 during the special loop that specifically searches for those
13436 standard exceptions.
13438 If PREG is not NULL, then this regexp_t object is used to
13439 perform the symbol name matching. Otherwise, no name-based
13440 filtering is performed.
13442 EXCEPTIONS is a vector of exceptions to which matching exceptions
13446 ada_add_global_exceptions (compiled_regex
*preg
,
13447 std::vector
<ada_exc_info
> *exceptions
)
13449 /* In Ada, the symbol "search name" is a linkage name, whereas the
13450 regular expression used to do the matching refers to the natural
13451 name. So match against the decoded name. */
13452 expand_symtabs_matching (NULL
,
13453 lookup_name_info::match_any (),
13454 [&] (const char *search_name
)
13456 const char *decoded
= ada_decode (search_name
);
13457 return name_matches_regex (decoded
, preg
);
13462 for (objfile
*objfile
: current_program_space
->objfiles ())
13464 for (compunit_symtab
*s
: objfile
->compunits ())
13466 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13469 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13471 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13472 struct block_iterator iter
;
13473 struct symbol
*sym
;
13475 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13476 if (ada_is_non_standard_exception_sym (sym
)
13477 && name_matches_regex (SYMBOL_NATURAL_NAME (sym
), preg
))
13479 struct ada_exc_info info
13480 = {SYMBOL_PRINT_NAME (sym
), SYMBOL_VALUE_ADDRESS (sym
)};
13482 exceptions
->push_back (info
);
13489 /* Implements ada_exceptions_list with the regular expression passed
13490 as a regex_t, rather than a string.
13492 If not NULL, PREG is used to filter out exceptions whose names
13493 do not match. Otherwise, all exceptions are listed. */
13495 static std::vector
<ada_exc_info
>
13496 ada_exceptions_list_1 (compiled_regex
*preg
)
13498 std::vector
<ada_exc_info
> result
;
13501 /* First, list the known standard exceptions. These exceptions
13502 need to be handled separately, as they are usually defined in
13503 runtime units that have been compiled without debugging info. */
13505 ada_add_standard_exceptions (preg
, &result
);
13507 /* Next, find all exceptions whose scope is local and accessible
13508 from the currently selected frame. */
13510 if (has_stack_frames ())
13512 prev_len
= result
.size ();
13513 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13515 if (result
.size () > prev_len
)
13516 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13519 /* Add all exceptions whose scope is global. */
13521 prev_len
= result
.size ();
13522 ada_add_global_exceptions (preg
, &result
);
13523 if (result
.size () > prev_len
)
13524 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13529 /* Return a vector of ada_exc_info.
13531 If REGEXP is NULL, all exceptions are included in the result.
13532 Otherwise, it should contain a valid regular expression,
13533 and only the exceptions whose names match that regular expression
13534 are included in the result.
13536 The exceptions are sorted in the following order:
13537 - Standard exceptions (defined by the Ada language), in
13538 alphabetical order;
13539 - Exceptions only visible from the current frame, in
13540 alphabetical order;
13541 - Exceptions whose scope is global, in alphabetical order. */
13543 std::vector
<ada_exc_info
>
13544 ada_exceptions_list (const char *regexp
)
13546 if (regexp
== NULL
)
13547 return ada_exceptions_list_1 (NULL
);
13549 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13550 return ada_exceptions_list_1 (®
);
13553 /* Implement the "info exceptions" command. */
13556 info_exceptions_command (const char *regexp
, int from_tty
)
13558 struct gdbarch
*gdbarch
= get_current_arch ();
13560 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13562 if (regexp
!= NULL
)
13564 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13566 printf_filtered (_("All defined Ada exceptions:\n"));
13568 for (const ada_exc_info
&info
: exceptions
)
13569 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13573 /* Information about operators given special treatment in functions
13575 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13577 #define ADA_OPERATORS \
13578 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13579 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13580 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13581 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13582 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13583 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13584 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13585 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13586 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13587 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13588 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13589 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13590 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13591 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13592 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13593 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13594 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13595 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13596 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13599 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13602 switch (exp
->elts
[pc
- 1].opcode
)
13605 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13608 #define OP_DEFN(op, len, args, binop) \
13609 case op: *oplenp = len; *argsp = args; break;
13615 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13620 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13625 /* Implementation of the exp_descriptor method operator_check. */
13628 ada_operator_check (struct expression
*exp
, int pos
,
13629 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13632 const union exp_element
*const elts
= exp
->elts
;
13633 struct type
*type
= NULL
;
13635 switch (elts
[pos
].opcode
)
13637 case UNOP_IN_RANGE
:
13639 type
= elts
[pos
+ 1].type
;
13643 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13646 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13648 if (type
&& TYPE_OBJFILE (type
)
13649 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13655 static const char *
13656 ada_op_name (enum exp_opcode opcode
)
13661 return op_name_standard (opcode
);
13663 #define OP_DEFN(op, len, args, binop) case op: return #op;
13668 return "OP_AGGREGATE";
13670 return "OP_CHOICES";
13676 /* As for operator_length, but assumes PC is pointing at the first
13677 element of the operator, and gives meaningful results only for the
13678 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13681 ada_forward_operator_length (struct expression
*exp
, int pc
,
13682 int *oplenp
, int *argsp
)
13684 switch (exp
->elts
[pc
].opcode
)
13687 *oplenp
= *argsp
= 0;
13690 #define OP_DEFN(op, len, args, binop) \
13691 case op: *oplenp = len; *argsp = args; break;
13697 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13702 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13708 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13710 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13718 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13720 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13725 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13729 /* Ada attributes ('Foo). */
13732 case OP_ATR_LENGTH
:
13736 case OP_ATR_MODULUS
:
13743 case UNOP_IN_RANGE
:
13745 /* XXX: gdb_sprint_host_address, type_sprint */
13746 fprintf_filtered (stream
, _("Type @"));
13747 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13748 fprintf_filtered (stream
, " (");
13749 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13750 fprintf_filtered (stream
, ")");
13752 case BINOP_IN_BOUNDS
:
13753 fprintf_filtered (stream
, " (%d)",
13754 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13756 case TERNOP_IN_RANGE
:
13761 case OP_DISCRETE_RANGE
:
13762 case OP_POSITIONAL
:
13769 char *name
= &exp
->elts
[elt
+ 2].string
;
13770 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13772 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13777 return dump_subexp_body_standard (exp
, stream
, elt
);
13781 for (i
= 0; i
< nargs
; i
+= 1)
13782 elt
= dump_subexp (exp
, stream
, elt
);
13787 /* The Ada extension of print_subexp (q.v.). */
13790 ada_print_subexp (struct expression
*exp
, int *pos
,
13791 struct ui_file
*stream
, enum precedence prec
)
13793 int oplen
, nargs
, i
;
13795 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13797 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13804 print_subexp_standard (exp
, pos
, stream
, prec
);
13808 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
13811 case BINOP_IN_BOUNDS
:
13812 /* XXX: sprint_subexp */
13813 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13814 fputs_filtered (" in ", stream
);
13815 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13816 fputs_filtered ("'range", stream
);
13817 if (exp
->elts
[pc
+ 1].longconst
> 1)
13818 fprintf_filtered (stream
, "(%ld)",
13819 (long) exp
->elts
[pc
+ 1].longconst
);
13822 case TERNOP_IN_RANGE
:
13823 if (prec
>= PREC_EQUAL
)
13824 fputs_filtered ("(", stream
);
13825 /* XXX: sprint_subexp */
13826 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13827 fputs_filtered (" in ", stream
);
13828 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13829 fputs_filtered (" .. ", stream
);
13830 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13831 if (prec
>= PREC_EQUAL
)
13832 fputs_filtered (")", stream
);
13837 case OP_ATR_LENGTH
:
13841 case OP_ATR_MODULUS
:
13846 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13848 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
13849 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13850 &type_print_raw_options
);
13854 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13855 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13860 for (tem
= 1; tem
< nargs
; tem
+= 1)
13862 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13863 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13865 fputs_filtered (")", stream
);
13870 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13871 fputs_filtered ("'(", stream
);
13872 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13873 fputs_filtered (")", stream
);
13876 case UNOP_IN_RANGE
:
13877 /* XXX: sprint_subexp */
13878 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13879 fputs_filtered (" in ", stream
);
13880 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13881 &type_print_raw_options
);
13884 case OP_DISCRETE_RANGE
:
13885 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13886 fputs_filtered ("..", stream
);
13887 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13891 fputs_filtered ("others => ", stream
);
13892 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13896 for (i
= 0; i
< nargs
-1; i
+= 1)
13899 fputs_filtered ("|", stream
);
13900 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13902 fputs_filtered (" => ", stream
);
13903 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13906 case OP_POSITIONAL
:
13907 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13911 fputs_filtered ("(", stream
);
13912 for (i
= 0; i
< nargs
; i
+= 1)
13915 fputs_filtered (", ", stream
);
13916 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13918 fputs_filtered (")", stream
);
13923 /* Table mapping opcodes into strings for printing operators
13924 and precedences of the operators. */
13926 static const struct op_print ada_op_print_tab
[] = {
13927 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13928 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13929 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13930 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13931 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13932 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13933 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13934 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13935 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13936 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13937 {">", BINOP_GTR
, PREC_ORDER
, 0},
13938 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13939 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13940 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13941 {"+", BINOP_ADD
, PREC_ADD
, 0},
13942 {"-", BINOP_SUB
, PREC_ADD
, 0},
13943 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13944 {"*", BINOP_MUL
, PREC_MUL
, 0},
13945 {"/", BINOP_DIV
, PREC_MUL
, 0},
13946 {"rem", BINOP_REM
, PREC_MUL
, 0},
13947 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13948 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13949 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13950 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13951 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13952 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13953 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13954 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13955 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13956 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13957 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13958 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13961 enum ada_primitive_types
{
13962 ada_primitive_type_int
,
13963 ada_primitive_type_long
,
13964 ada_primitive_type_short
,
13965 ada_primitive_type_char
,
13966 ada_primitive_type_float
,
13967 ada_primitive_type_double
,
13968 ada_primitive_type_void
,
13969 ada_primitive_type_long_long
,
13970 ada_primitive_type_long_double
,
13971 ada_primitive_type_natural
,
13972 ada_primitive_type_positive
,
13973 ada_primitive_type_system_address
,
13974 ada_primitive_type_storage_offset
,
13975 nr_ada_primitive_types
13979 ada_language_arch_info (struct gdbarch
*gdbarch
,
13980 struct language_arch_info
*lai
)
13982 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13984 lai
->primitive_type_vector
13985 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13988 lai
->primitive_type_vector
[ada_primitive_type_int
]
13989 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13991 lai
->primitive_type_vector
[ada_primitive_type_long
]
13992 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13993 0, "long_integer");
13994 lai
->primitive_type_vector
[ada_primitive_type_short
]
13995 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13996 0, "short_integer");
13997 lai
->string_char_type
13998 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13999 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
14000 lai
->primitive_type_vector
[ada_primitive_type_float
]
14001 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
14002 "float", gdbarch_float_format (gdbarch
));
14003 lai
->primitive_type_vector
[ada_primitive_type_double
]
14004 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
14005 "long_float", gdbarch_double_format (gdbarch
));
14006 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
14007 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
14008 0, "long_long_integer");
14009 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
14010 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
14011 "long_long_float", gdbarch_long_double_format (gdbarch
));
14012 lai
->primitive_type_vector
[ada_primitive_type_natural
]
14013 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14015 lai
->primitive_type_vector
[ada_primitive_type_positive
]
14016 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14018 lai
->primitive_type_vector
[ada_primitive_type_void
]
14019 = builtin
->builtin_void
;
14021 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14022 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
14024 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
14025 = "system__address";
14027 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14028 type. This is a signed integral type whose size is the same as
14029 the size of addresses. */
14031 unsigned int addr_length
= TYPE_LENGTH
14032 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
14034 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
14035 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
14039 lai
->bool_type_symbol
= NULL
;
14040 lai
->bool_type_default
= builtin
->builtin_bool
;
14043 /* Language vector */
14045 /* Not really used, but needed in the ada_language_defn. */
14048 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
14050 ada_emit_char (c
, type
, stream
, quoter
, 1);
14054 parse (struct parser_state
*ps
)
14056 warnings_issued
= 0;
14057 return ada_parse (ps
);
14060 static const struct exp_descriptor ada_exp_descriptor
= {
14062 ada_operator_length
,
14063 ada_operator_check
,
14065 ada_dump_subexp_body
,
14066 ada_evaluate_subexp
14069 /* symbol_name_matcher_ftype adapter for wild_match. */
14072 do_wild_match (const char *symbol_search_name
,
14073 const lookup_name_info
&lookup_name
,
14074 completion_match_result
*comp_match_res
)
14076 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
14079 /* symbol_name_matcher_ftype adapter for full_match. */
14082 do_full_match (const char *symbol_search_name
,
14083 const lookup_name_info
&lookup_name
,
14084 completion_match_result
*comp_match_res
)
14086 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
14089 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
14092 do_exact_match (const char *symbol_search_name
,
14093 const lookup_name_info
&lookup_name
,
14094 completion_match_result
*comp_match_res
)
14096 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
14099 /* Build the Ada lookup name for LOOKUP_NAME. */
14101 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
14103 const std::string
&user_name
= lookup_name
.name ();
14105 if (user_name
[0] == '<')
14107 if (user_name
.back () == '>')
14108 m_encoded_name
= user_name
.substr (1, user_name
.size () - 2);
14110 m_encoded_name
= user_name
.substr (1, user_name
.size () - 1);
14111 m_encoded_p
= true;
14112 m_verbatim_p
= true;
14113 m_wild_match_p
= false;
14114 m_standard_p
= false;
14118 m_verbatim_p
= false;
14120 m_encoded_p
= user_name
.find ("__") != std::string::npos
;
14124 const char *folded
= ada_fold_name (user_name
.c_str ());
14125 const char *encoded
= ada_encode_1 (folded
, false);
14126 if (encoded
!= NULL
)
14127 m_encoded_name
= encoded
;
14129 m_encoded_name
= user_name
;
14132 m_encoded_name
= user_name
;
14134 /* Handle the 'package Standard' special case. See description
14135 of m_standard_p. */
14136 if (startswith (m_encoded_name
.c_str (), "standard__"))
14138 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
14139 m_standard_p
= true;
14142 m_standard_p
= false;
14144 /* If the name contains a ".", then the user is entering a fully
14145 qualified entity name, and the match must not be done in wild
14146 mode. Similarly, if the user wants to complete what looks
14147 like an encoded name, the match must not be done in wild
14148 mode. Also, in the standard__ special case always do
14149 non-wild matching. */
14151 = (lookup_name
.match_type () != symbol_name_match_type::FULL
14154 && user_name
.find ('.') == std::string::npos
);
14158 /* symbol_name_matcher_ftype method for Ada. This only handles
14159 completion mode. */
14162 ada_symbol_name_matches (const char *symbol_search_name
,
14163 const lookup_name_info
&lookup_name
,
14164 completion_match_result
*comp_match_res
)
14166 return lookup_name
.ada ().matches (symbol_search_name
,
14167 lookup_name
.match_type (),
14171 /* A name matcher that matches the symbol name exactly, with
14175 literal_symbol_name_matcher (const char *symbol_search_name
,
14176 const lookup_name_info
&lookup_name
,
14177 completion_match_result
*comp_match_res
)
14179 const std::string
&name
= lookup_name
.name ();
14181 int cmp
= (lookup_name
.completion_mode ()
14182 ? strncmp (symbol_search_name
, name
.c_str (), name
.size ())
14183 : strcmp (symbol_search_name
, name
.c_str ()));
14186 if (comp_match_res
!= NULL
)
14187 comp_match_res
->set_match (symbol_search_name
);
14194 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14197 static symbol_name_matcher_ftype
*
14198 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
14200 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
14201 return literal_symbol_name_matcher
;
14203 if (lookup_name
.completion_mode ())
14204 return ada_symbol_name_matches
;
14207 if (lookup_name
.ada ().wild_match_p ())
14208 return do_wild_match
;
14209 else if (lookup_name
.ada ().verbatim_p ())
14210 return do_exact_match
;
14212 return do_full_match
;
14216 /* Implement the "la_read_var_value" language_defn method for Ada. */
14218 static struct value
*
14219 ada_read_var_value (struct symbol
*var
, const struct block
*var_block
,
14220 struct frame_info
*frame
)
14222 /* The only case where default_read_var_value is not sufficient
14223 is when VAR is a renaming... */
14224 if (frame
!= nullptr)
14226 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
14227 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
14228 return ada_read_renaming_var_value (var
, frame_block
);
14231 /* This is a typical case where we expect the default_read_var_value
14232 function to work. */
14233 return default_read_var_value (var
, var_block
, frame
);
14236 static const char *ada_extensions
[] =
14238 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14241 extern const struct language_defn ada_language_defn
= {
14242 "ada", /* Language name */
14246 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
14247 that's not quite what this means. */
14249 macro_expansion_no
,
14251 &ada_exp_descriptor
,
14254 ada_printchar
, /* Print a character constant */
14255 ada_printstr
, /* Function to print string constant */
14256 emit_char
, /* Function to print single char (not used) */
14257 ada_print_type
, /* Print a type using appropriate syntax */
14258 ada_print_typedef
, /* Print a typedef using appropriate syntax */
14259 ada_val_print
, /* Print a value using appropriate syntax */
14260 ada_value_print
, /* Print a top-level value */
14261 ada_read_var_value
, /* la_read_var_value */
14262 NULL
, /* Language specific skip_trampoline */
14263 NULL
, /* name_of_this */
14264 true, /* la_store_sym_names_in_linkage_form_p */
14265 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
14266 basic_lookup_transparent_type
, /* lookup_transparent_type */
14267 ada_la_decode
, /* Language specific symbol demangler */
14268 ada_sniff_from_mangled_name
,
14269 NULL
, /* Language specific
14270 class_name_from_physname */
14271 ada_op_print_tab
, /* expression operators for printing */
14272 0, /* c-style arrays */
14273 1, /* String lower bound */
14274 ada_get_gdb_completer_word_break_characters
,
14275 ada_collect_symbol_completion_matches
,
14276 ada_language_arch_info
,
14277 ada_print_array_index
,
14278 default_pass_by_reference
,
14280 ada_watch_location_expression
,
14281 ada_get_symbol_name_matcher
, /* la_get_symbol_name_matcher */
14282 ada_iterate_over_symbols
,
14283 default_search_name_hash
,
14287 ada_is_string_type
,
14288 "(...)" /* la_struct_too_deep_ellipsis */
14291 /* Command-list for the "set/show ada" prefix command. */
14292 static struct cmd_list_element
*set_ada_list
;
14293 static struct cmd_list_element
*show_ada_list
;
14295 /* Implement the "set ada" prefix command. */
14298 set_ada_command (const char *arg
, int from_tty
)
14300 printf_unfiltered (_(\
14301 "\"set ada\" must be followed by the name of a setting.\n"));
14302 help_list (set_ada_list
, "set ada ", all_commands
, gdb_stdout
);
14305 /* Implement the "show ada" prefix command. */
14308 show_ada_command (const char *args
, int from_tty
)
14310 cmd_show_list (show_ada_list
, from_tty
, "");
14314 initialize_ada_catchpoint_ops (void)
14316 struct breakpoint_ops
*ops
;
14318 initialize_breakpoint_ops ();
14320 ops
= &catch_exception_breakpoint_ops
;
14321 *ops
= bkpt_breakpoint_ops
;
14322 ops
->allocate_location
= allocate_location_catch_exception
;
14323 ops
->re_set
= re_set_catch_exception
;
14324 ops
->check_status
= check_status_catch_exception
;
14325 ops
->print_it
= print_it_catch_exception
;
14326 ops
->print_one
= print_one_catch_exception
;
14327 ops
->print_mention
= print_mention_catch_exception
;
14328 ops
->print_recreate
= print_recreate_catch_exception
;
14330 ops
= &catch_exception_unhandled_breakpoint_ops
;
14331 *ops
= bkpt_breakpoint_ops
;
14332 ops
->allocate_location
= allocate_location_catch_exception_unhandled
;
14333 ops
->re_set
= re_set_catch_exception_unhandled
;
14334 ops
->check_status
= check_status_catch_exception_unhandled
;
14335 ops
->print_it
= print_it_catch_exception_unhandled
;
14336 ops
->print_one
= print_one_catch_exception_unhandled
;
14337 ops
->print_mention
= print_mention_catch_exception_unhandled
;
14338 ops
->print_recreate
= print_recreate_catch_exception_unhandled
;
14340 ops
= &catch_assert_breakpoint_ops
;
14341 *ops
= bkpt_breakpoint_ops
;
14342 ops
->allocate_location
= allocate_location_catch_assert
;
14343 ops
->re_set
= re_set_catch_assert
;
14344 ops
->check_status
= check_status_catch_assert
;
14345 ops
->print_it
= print_it_catch_assert
;
14346 ops
->print_one
= print_one_catch_assert
;
14347 ops
->print_mention
= print_mention_catch_assert
;
14348 ops
->print_recreate
= print_recreate_catch_assert
;
14350 ops
= &catch_handlers_breakpoint_ops
;
14351 *ops
= bkpt_breakpoint_ops
;
14352 ops
->allocate_location
= allocate_location_catch_handlers
;
14353 ops
->re_set
= re_set_catch_handlers
;
14354 ops
->check_status
= check_status_catch_handlers
;
14355 ops
->print_it
= print_it_catch_handlers
;
14356 ops
->print_one
= print_one_catch_handlers
;
14357 ops
->print_mention
= print_mention_catch_handlers
;
14358 ops
->print_recreate
= print_recreate_catch_handlers
;
14361 /* This module's 'new_objfile' observer. */
14364 ada_new_objfile_observer (struct objfile
*objfile
)
14366 ada_clear_symbol_cache ();
14369 /* This module's 'free_objfile' observer. */
14372 ada_free_objfile_observer (struct objfile
*objfile
)
14374 ada_clear_symbol_cache ();
14378 _initialize_ada_language (void)
14380 initialize_ada_catchpoint_ops ();
14382 add_prefix_cmd ("ada", no_class
, set_ada_command
,
14383 _("Prefix command for changing Ada-specific settings"),
14384 &set_ada_list
, "set ada ", 0, &setlist
);
14386 add_prefix_cmd ("ada", no_class
, show_ada_command
,
14387 _("Generic command for showing Ada-specific settings."),
14388 &show_ada_list
, "show ada ", 0, &showlist
);
14390 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14391 &trust_pad_over_xvs
, _("\
14392 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14393 Show whether an optimization trusting PAD types over XVS types is activated"),
14395 This is related to the encoding used by the GNAT compiler. The debugger\n\
14396 should normally trust the contents of PAD types, but certain older versions\n\
14397 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14398 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14399 work around this bug. It is always safe to turn this option \"off\", but\n\
14400 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14401 this option to \"off\" unless necessary."),
14402 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14404 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14405 &print_signatures
, _("\
14406 Enable or disable the output of formal and return types for functions in the \
14407 overloads selection menu"), _("\
14408 Show whether the output of formal and return types for functions in the \
14409 overloads selection menu is activated"),
14410 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14412 add_catch_command ("exception", _("\
14413 Catch Ada exceptions, when raised.\n\
14414 Usage: catch exception [ARG] [if CONDITION]\n\
14415 Without any argument, stop when any Ada exception is raised.\n\
14416 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14417 being raised does not have a handler (and will therefore lead to the task's\n\
14419 Otherwise, the catchpoint only stops when the name of the exception being\n\
14420 raised is the same as ARG.\n\
14421 CONDITION is a boolean expression that is evaluated to see whether the\n\
14422 exception should cause a stop."),
14423 catch_ada_exception_command
,
14424 catch_ada_completer
,
14428 add_catch_command ("handlers", _("\
14429 Catch Ada exceptions, when handled.\n\
14430 Usage: catch handlers [ARG] [if CONDITION]\n\
14431 Without any argument, stop when any Ada exception is handled.\n\
14432 With an argument, catch only exceptions with the given name.\n\
14433 CONDITION is a boolean expression that is evaluated to see whether the\n\
14434 exception should cause a stop."),
14435 catch_ada_handlers_command
,
14436 catch_ada_completer
,
14439 add_catch_command ("assert", _("\
14440 Catch failed Ada assertions, when raised.\n\
14441 Usage: catch assert [if CONDITION]\n\
14442 CONDITION is a boolean expression that is evaluated to see whether the\n\
14443 exception should cause a stop."),
14444 catch_assert_command
,
14449 varsize_limit
= 65536;
14450 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14451 &varsize_limit
, _("\
14452 Set the maximum number of bytes allowed in a variable-size object."), _("\
14453 Show the maximum number of bytes allowed in a variable-size object."), _("\
14454 Attempts to access an object whose size is not a compile-time constant\n\
14455 and exceeds this limit will cause an error."),
14456 NULL
, NULL
, &setlist
, &showlist
);
14458 add_info ("exceptions", info_exceptions_command
,
14460 List all Ada exception names.\n\
14461 Usage: info exceptions [REGEXP]\n\
14462 If a regular expression is passed as an argument, only those matching\n\
14463 the regular expression are listed."));
14465 add_prefix_cmd ("ada", class_maintenance
, maint_set_ada_cmd
,
14466 _("Set Ada maintenance-related variables."),
14467 &maint_set_ada_cmdlist
, "maintenance set ada ",
14468 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14470 add_prefix_cmd ("ada", class_maintenance
, maint_show_ada_cmd
,
14471 _("Show Ada maintenance-related variables"),
14472 &maint_show_ada_cmdlist
, "maintenance show ada ",
14473 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14475 add_setshow_boolean_cmd
14476 ("ignore-descriptive-types", class_maintenance
,
14477 &ada_ignore_descriptive_types_p
,
14478 _("Set whether descriptive types generated by GNAT should be ignored."),
14479 _("Show whether descriptive types generated by GNAT should be ignored."),
14481 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14482 DWARF attribute."),
14483 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14485 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14486 NULL
, xcalloc
, xfree
);
14488 /* The ada-lang observers. */
14489 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14490 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14491 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);