1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2022 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/>. */
23 #include "gdbsupport/gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdbsupport/gdb_obstack.h"
40 #include "completer.h"
47 #include "observable.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
52 #include "cli/cli-decode.h"
55 #include "mi/mi-common.h"
56 #include "arch-utils.h"
57 #include "cli/cli-utils.h"
58 #include "gdbsupport/function-view.h"
59 #include "gdbsupport/byte-vector.h"
64 /* Define whether or not the C operator '/' truncates towards zero for
65 differently signed operands (truncation direction is undefined in C).
66 Copied from valarith.c. */
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72 static struct type *desc_base_type (struct type *);
74 static struct type *desc_bounds_type (struct type *);
76 static struct value *desc_bounds (struct value *);
78 static int fat_pntr_bounds_bitpos (struct type *);
80 static int fat_pntr_bounds_bitsize (struct type *);
82 static struct type *desc_data_target_type (struct type *);
84 static struct value *desc_data (struct value *);
86 static int fat_pntr_data_bitpos (struct type *);
88 static int fat_pntr_data_bitsize (struct type *);
90 static struct value *desc_one_bound (struct value *, int, int);
92 static int desc_bound_bitpos (struct type *, int, int);
94 static int desc_bound_bitsize (struct type *, int, int);
96 static struct type *desc_index_type (struct type *, int);
98 static int desc_arity (struct type *);
100 static int ada_args_match (struct symbol *, struct value **, int);
102 static struct value *make_array_descriptor (struct type *, struct value *);
104 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
105 const struct block *,
106 const lookup_name_info &lookup_name,
107 domain_enum, struct objfile *);
109 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, int, int *);
114 static int is_nonfunction (const std::vector<struct block_symbol> &);
116 static void add_defn_to_vec (std::vector<struct block_symbol> &,
118 const struct block *);
120 static int possible_user_operator_p (enum exp_opcode, struct value **);
122 static const char *ada_decoded_op_name (enum exp_opcode);
124 static int numeric_type_p (struct type *);
126 static int integer_type_p (struct type *);
128 static int scalar_type_p (struct type *);
130 static int discrete_type_p (struct type *);
132 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
135 static struct type *ada_find_parallel_type_with_name (struct type *,
138 static int is_dynamic_field (struct type *, int);
140 static struct type *to_fixed_variant_branch_type (struct type *,
142 CORE_ADDR, struct value *);
144 static struct type *to_fixed_array_type (struct type *, struct value *, int);
146 static struct type *to_fixed_range_type (struct type *, struct value *);
148 static struct type *to_static_fixed_type (struct type *);
149 static struct type *static_unwrap_type (struct type *type);
151 static struct value *unwrap_value (struct value *);
153 static struct type *constrained_packed_array_type (struct type *, long *);
155 static struct type *decode_constrained_packed_array_type (struct type *);
157 static long decode_packed_array_bitsize (struct type *);
159 static struct value *decode_constrained_packed_array (struct value *);
161 static int ada_is_unconstrained_packed_array_type (struct type *);
163 static struct value *value_subscript_packed (struct value *, int,
166 static struct value *coerce_unspec_val_to_type (struct value *,
169 static int lesseq_defined_than (struct symbol *, struct symbol *);
171 static int equiv_types (struct type *, struct type *);
173 static int is_name_suffix (const char *);
175 static int advance_wild_match (const char **, const char *, char);
177 static bool wild_match (const char *name, const char *patn);
179 static struct value *ada_coerce_ref (struct value *);
181 static LONGEST pos_atr (struct value *);
183 static struct value *val_atr (struct type *, LONGEST);
185 static struct symbol *standard_lookup (const char *, const struct block *,
188 static struct value *ada_search_struct_field (const char *, struct value *, int,
191 static int find_struct_field (const char *, struct type *, int,
192 struct type **, int *, int *, int *, int *);
194 static int ada_resolve_function (std::vector<struct block_symbol> &,
195 struct value **, int, const char *,
196 struct type *, bool);
198 static int ada_is_direct_array_type (struct type *);
200 static struct value *ada_index_struct_field (int, struct value *, int,
203 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
206 static struct type *ada_find_any_type (const char *name);
208 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
209 (const lookup_name_info &lookup_name);
213 /* The character set used for source files. */
214 static const char *ada_source_charset;
216 /* The string "UTF-8". This is here so we can check for the UTF-8
217 charset using == rather than strcmp. */
218 static const char ada_utf8[] = "UTF-8";
220 /* Each entry in the UTF-32 case-folding table is of this form. */
223 /* The start and end, inclusive, of this range of codepoints. */
225 /* The delta to apply to get the upper-case form. 0 if this is
226 already upper-case. */
228 /* The delta to apply to get the lower-case form. 0 if this is
229 already lower-case. */
232 bool operator< (uint32_t val) const
238 static const utf8_entry ada_case_fold[] =
240 #include "ada-casefold.h"
245 /* The result of a symbol lookup to be stored in our symbol cache. */
249 /* The name used to perform the lookup. */
251 /* The namespace used during the lookup. */
253 /* The symbol returned by the lookup, or NULL if no matching symbol
256 /* The block where the symbol was found, or NULL if no matching
258 const struct block *block;
259 /* A pointer to the next entry with the same hash. */
260 struct cache_entry *next;
263 /* The Ada symbol cache, used to store the result of Ada-mode symbol
264 lookups in the course of executing the user's commands.
266 The cache is implemented using a simple, fixed-sized hash.
267 The size is fixed on the grounds that there are not likely to be
268 all that many symbols looked up during any given session, regardless
269 of the size of the symbol table. If we decide to go to a resizable
270 table, let's just use the stuff from libiberty instead. */
272 #define HASH_SIZE 1009
274 struct ada_symbol_cache
276 /* An obstack used to store the entries in our cache. */
277 struct auto_obstack cache_space;
279 /* The root of the hash table used to implement our symbol cache. */
280 struct cache_entry *root[HASH_SIZE] {};
283 static const char ada_completer_word_break_characters[] =
285 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
290 /* The name of the symbol to use to get the name of the main subprogram. */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
292 = "__gnat_ada_main_program_name";
294 /* Limit on the number of warnings to raise per expression evaluation. */
295 static int warning_limit = 2;
297 /* Number of warning messages issued; reset to 0 by cleanups after
298 expression evaluation. */
299 static int warnings_issued = 0;
301 static const char * const known_runtime_file_name_patterns[] = {
302 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
305 static const char * const known_auxiliary_function_name_patterns[] = {
306 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
309 /* Maintenance-related settings for this module. */
311 static struct cmd_list_element *maint_set_ada_cmdlist;
312 static struct cmd_list_element *maint_show_ada_cmdlist;
314 /* The "maintenance ada set/show ignore-descriptive-type" value. */
316 static bool ada_ignore_descriptive_types_p = false;
318 /* Inferior-specific data. */
320 /* Per-inferior data for this module. */
322 struct ada_inferior_data
324 /* The ada__tags__type_specific_data type, which is used when decoding
325 tagged types. With older versions of GNAT, this type was directly
326 accessible through a component ("tsd") in the object tag. But this
327 is no longer the case, so we cache it for each inferior. */
328 struct type *tsd_type = nullptr;
330 /* The exception_support_info data. This data is used to determine
331 how to implement support for Ada exception catchpoints in a given
333 const struct exception_support_info *exception_info = nullptr;
336 /* Our key to this module's inferior data. */
337 static const registry<inferior>::key<ada_inferior_data> ada_inferior_data;
339 /* Return our inferior data for the given inferior (INF).
341 This function always returns a valid pointer to an allocated
342 ada_inferior_data structure. If INF's inferior data has not
343 been previously set, this functions creates a new one with all
344 fields set to zero, sets INF's inferior to it, and then returns
345 a pointer to that newly allocated ada_inferior_data. */
347 static struct ada_inferior_data *
348 get_ada_inferior_data (struct inferior *inf)
350 struct ada_inferior_data *data;
352 data = ada_inferior_data.get (inf);
354 data = ada_inferior_data.emplace (inf);
359 /* Perform all necessary cleanups regarding our module's inferior data
360 that is required after the inferior INF just exited. */
363 ada_inferior_exit (struct inferior *inf)
365 ada_inferior_data.clear (inf);
369 /* program-space-specific data. */
371 /* This module's per-program-space data. */
372 struct ada_pspace_data
374 /* The Ada symbol cache. */
375 std::unique_ptr<ada_symbol_cache> sym_cache;
378 /* Key to our per-program-space data. */
379 static const registry<program_space>::key<ada_pspace_data>
380 ada_pspace_data_handle;
382 /* Return this module's data for the given program space (PSPACE).
383 If not is found, add a zero'ed one now.
385 This function always returns a valid object. */
387 static struct ada_pspace_data *
388 get_ada_pspace_data (struct program_space *pspace)
390 struct ada_pspace_data *data;
392 data = ada_pspace_data_handle.get (pspace);
394 data = ada_pspace_data_handle.emplace (pspace);
401 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
402 all typedef layers have been peeled. Otherwise, return TYPE.
404 Normally, we really expect a typedef type to only have 1 typedef layer.
405 In other words, we really expect the target type of a typedef type to be
406 a non-typedef type. This is particularly true for Ada units, because
407 the language does not have a typedef vs not-typedef distinction.
408 In that respect, the Ada compiler has been trying to eliminate as many
409 typedef definitions in the debugging information, since they generally
410 do not bring any extra information (we still use typedef under certain
411 circumstances related mostly to the GNAT encoding).
413 Unfortunately, we have seen situations where the debugging information
414 generated by the compiler leads to such multiple typedef layers. For
415 instance, consider the following example with stabs:
417 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
418 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
420 This is an error in the debugging information which causes type
421 pck__float_array___XUP to be defined twice, and the second time,
422 it is defined as a typedef of a typedef.
424 This is on the fringe of legality as far as debugging information is
425 concerned, and certainly unexpected. But it is easy to handle these
426 situations correctly, so we can afford to be lenient in this case. */
429 ada_typedef_target_type (struct type *type)
431 while (type->code () == TYPE_CODE_TYPEDEF)
432 type = type->target_type ();
436 /* Given DECODED_NAME a string holding a symbol name in its
437 decoded form (ie using the Ada dotted notation), returns
438 its unqualified name. */
441 ada_unqualified_name (const char *decoded_name)
445 /* If the decoded name starts with '<', it means that the encoded
446 name does not follow standard naming conventions, and thus that
447 it is not your typical Ada symbol name. Trying to unqualify it
448 is therefore pointless and possibly erroneous. */
449 if (decoded_name[0] == '<')
452 result = strrchr (decoded_name, '.');
454 result++; /* Skip the dot... */
456 result = decoded_name;
461 /* Return a string starting with '<', followed by STR, and '>'. */
464 add_angle_brackets (const char *str)
466 return string_printf ("<%s>", str);
469 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
470 suffix of FIELD_NAME beginning "___". */
473 field_name_match (const char *field_name, const char *target)
475 int len = strlen (target);
478 (strncmp (field_name, target, len) == 0
479 && (field_name[len] == '\0'
480 || (startswith (field_name + len, "___")
481 && strcmp (field_name + strlen (field_name) - 6,
486 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
487 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
488 and return its index. This function also handles fields whose name
489 have ___ suffixes because the compiler sometimes alters their name
490 by adding such a suffix to represent fields with certain constraints.
491 If the field could not be found, return a negative number if
492 MAYBE_MISSING is set. Otherwise raise an error. */
495 ada_get_field_index (const struct type *type, const char *field_name,
499 struct type *struct_type = check_typedef ((struct type *) type);
501 for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
502 if (field_name_match (struct_type->field (fieldno).name (), field_name))
506 error (_("Unable to find field %s in struct %s. Aborting"),
507 field_name, struct_type->name ());
512 /* The length of the prefix of NAME prior to any "___" suffix. */
515 ada_name_prefix_len (const char *name)
521 const char *p = strstr (name, "___");
524 return strlen (name);
530 /* Return non-zero if SUFFIX is a suffix of STR.
531 Return zero if STR is null. */
534 is_suffix (const char *str, const char *suffix)
541 len2 = strlen (suffix);
542 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
545 /* The contents of value VAL, treated as a value of type TYPE. The
546 result is an lval in memory if VAL is. */
548 static struct value *
549 coerce_unspec_val_to_type (struct value *val, struct type *type)
551 type = ada_check_typedef (type);
552 if (value_type (val) == type)
556 struct value *result;
558 if (value_optimized_out (val))
559 result = allocate_optimized_out_value (type);
560 else if (value_lazy (val)
561 /* Be careful not to make a lazy not_lval value. */
562 || (VALUE_LVAL (val) != not_lval
563 && type->length () > value_type (val)->length ()))
564 result = allocate_value_lazy (type);
567 result = allocate_value (type);
568 value_contents_copy (result, 0, val, 0, type->length ());
570 set_value_component_location (result, val);
571 set_value_bitsize (result, value_bitsize (val));
572 set_value_bitpos (result, value_bitpos (val));
573 if (VALUE_LVAL (result) == lval_memory)
574 set_value_address (result, value_address (val));
579 static const gdb_byte *
580 cond_offset_host (const gdb_byte *valaddr, long offset)
585 return valaddr + offset;
589 cond_offset_target (CORE_ADDR address, long offset)
594 return address + offset;
597 /* Issue a warning (as for the definition of warning in utils.c, but
598 with exactly one argument rather than ...), unless the limit on the
599 number of warnings has passed during the evaluation of the current
602 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
603 provided by "complaint". */
604 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
607 lim_warning (const char *format, ...)
611 va_start (args, format);
612 warnings_issued += 1;
613 if (warnings_issued <= warning_limit)
614 vwarning (format, args);
619 /* Maximum value of a SIZE-byte signed integer type. */
621 max_of_size (int size)
623 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
625 return top_bit | (top_bit - 1);
628 /* Minimum value of a SIZE-byte signed integer type. */
630 min_of_size (int size)
632 return -max_of_size (size) - 1;
635 /* Maximum value of a SIZE-byte unsigned integer type. */
637 umax_of_size (int size)
639 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
641 return top_bit | (top_bit - 1);
644 /* Maximum value of integral type T, as a signed quantity. */
646 max_of_type (struct type *t)
648 if (t->is_unsigned ())
649 return (LONGEST) umax_of_size (t->length ());
651 return max_of_size (t->length ());
654 /* Minimum value of integral type T, as a signed quantity. */
656 min_of_type (struct type *t)
658 if (t->is_unsigned ())
661 return min_of_size (t->length ());
664 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
666 ada_discrete_type_high_bound (struct type *type)
668 type = resolve_dynamic_type (type, {}, 0);
669 switch (type->code ())
671 case TYPE_CODE_RANGE:
673 const dynamic_prop &high = type->bounds ()->high;
675 if (high.kind () == PROP_CONST)
676 return high.const_val ();
679 gdb_assert (high.kind () == PROP_UNDEFINED);
681 /* This happens when trying to evaluate a type's dynamic bound
682 without a live target. There is nothing relevant for us to
683 return here, so return 0. */
688 return type->field (type->num_fields () - 1).loc_enumval ();
693 return max_of_type (type);
695 error (_("Unexpected type in ada_discrete_type_high_bound."));
699 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
701 ada_discrete_type_low_bound (struct type *type)
703 type = resolve_dynamic_type (type, {}, 0);
704 switch (type->code ())
706 case TYPE_CODE_RANGE:
708 const dynamic_prop &low = type->bounds ()->low;
710 if (low.kind () == PROP_CONST)
711 return low.const_val ();
714 gdb_assert (low.kind () == PROP_UNDEFINED);
716 /* This happens when trying to evaluate a type's dynamic bound
717 without a live target. There is nothing relevant for us to
718 return here, so return 0. */
723 return type->field (0).loc_enumval ();
728 return min_of_type (type);
730 error (_("Unexpected type in ada_discrete_type_low_bound."));
734 /* The identity on non-range types. For range types, the underlying
735 non-range scalar type. */
738 get_base_type (struct type *type)
740 while (type != NULL && type->code () == TYPE_CODE_RANGE)
742 if (type == type->target_type () || type->target_type () == NULL)
744 type = type->target_type ();
749 /* Return a decoded version of the given VALUE. This means returning
750 a value whose type is obtained by applying all the GNAT-specific
751 encodings, making the resulting type a static but standard description
752 of the initial type. */
755 ada_get_decoded_value (struct value *value)
757 struct type *type = ada_check_typedef (value_type (value));
759 if (ada_is_array_descriptor_type (type)
760 || (ada_is_constrained_packed_array_type (type)
761 && type->code () != TYPE_CODE_PTR))
763 if (type->code () == TYPE_CODE_TYPEDEF) /* array access type. */
764 value = ada_coerce_to_simple_array_ptr (value);
766 value = ada_coerce_to_simple_array (value);
769 value = ada_to_fixed_value (value);
774 /* Same as ada_get_decoded_value, but with the given TYPE.
775 Because there is no associated actual value for this type,
776 the resulting type might be a best-effort approximation in
777 the case of dynamic types. */
780 ada_get_decoded_type (struct type *type)
782 type = to_static_fixed_type (type);
783 if (ada_is_constrained_packed_array_type (type))
784 type = ada_coerce_to_simple_array_type (type);
790 /* Language Selection */
792 /* If the main program is in Ada, return language_ada, otherwise return LANG
793 (the main program is in Ada iif the adainit symbol is found). */
796 ada_update_initial_language (enum language lang)
798 if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
804 /* If the main procedure is written in Ada, then return its name.
805 The result is good until the next call. Return NULL if the main
806 procedure doesn't appear to be in Ada. */
811 struct bound_minimal_symbol msym;
812 static gdb::unique_xmalloc_ptr<char> main_program_name;
814 /* For Ada, the name of the main procedure is stored in a specific
815 string constant, generated by the binder. Look for that symbol,
816 extract its address, and then read that string. If we didn't find
817 that string, then most probably the main procedure is not written
819 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
821 if (msym.minsym != NULL)
823 CORE_ADDR main_program_name_addr = msym.value_address ();
824 if (main_program_name_addr == 0)
825 error (_("Invalid address for Ada main program name."));
827 main_program_name = target_read_string (main_program_name_addr, 1024);
828 return main_program_name.get ();
831 /* The main procedure doesn't seem to be in Ada. */
837 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
840 const struct ada_opname_map ada_opname_table[] = {
841 {"Oadd", "\"+\"", BINOP_ADD},
842 {"Osubtract", "\"-\"", BINOP_SUB},
843 {"Omultiply", "\"*\"", BINOP_MUL},
844 {"Odivide", "\"/\"", BINOP_DIV},
845 {"Omod", "\"mod\"", BINOP_MOD},
846 {"Orem", "\"rem\"", BINOP_REM},
847 {"Oexpon", "\"**\"", BINOP_EXP},
848 {"Olt", "\"<\"", BINOP_LESS},
849 {"Ole", "\"<=\"", BINOP_LEQ},
850 {"Ogt", "\">\"", BINOP_GTR},
851 {"Oge", "\">=\"", BINOP_GEQ},
852 {"Oeq", "\"=\"", BINOP_EQUAL},
853 {"One", "\"/=\"", BINOP_NOTEQUAL},
854 {"Oand", "\"and\"", BINOP_BITWISE_AND},
855 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857 {"Oconcat", "\"&\"", BINOP_CONCAT},
858 {"Oabs", "\"abs\"", UNOP_ABS},
859 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860 {"Oadd", "\"+\"", UNOP_PLUS},
861 {"Osubtract", "\"-\"", UNOP_NEG},
865 /* If STR is a decoded version of a compiler-provided suffix (like the
866 "[cold]" in "symbol[cold]"), return true. Otherwise, return
870 is_compiler_suffix (const char *str)
872 gdb_assert (*str == '[');
874 while (*str != '\0' && isalpha (*str))
876 /* We accept a missing "]" in order to support completion. */
877 return *str == '\0' || (str[0] == ']' && str[1] == '\0');
880 /* Append a non-ASCII character to RESULT. */
882 append_hex_encoded (std::string &result, uint32_t one_char)
884 if (one_char <= 0xff)
887 result.append (phex (one_char, 1));
889 else if (one_char <= 0xffff)
892 result.append (phex (one_char, 2));
896 result.append ("WW");
897 result.append (phex (one_char, 4));
901 /* Return a string that is a copy of the data in STORAGE, with
902 non-ASCII characters replaced by the appropriate hex encoding. A
903 template is used because, for UTF-8, we actually want to work with
904 UTF-32 codepoints. */
907 copy_and_hex_encode (struct obstack *storage)
909 const T *chars = (T *) obstack_base (storage);
910 int num_chars = obstack_object_size (storage) / sizeof (T);
912 for (int i = 0; i < num_chars; ++i)
914 if (chars[i] <= 0x7f)
916 /* The host character set has to be a superset of ASCII, as
917 are all the other character sets we can use. */
918 result.push_back (chars[i]);
921 append_hex_encoded (result, chars[i]);
926 /* The "encoded" form of DECODED, according to GNAT conventions. If
927 THROW_ERRORS, throw an error if invalid operator name is found.
928 Otherwise, return the empty string in that case. */
931 ada_encode_1 (const char *decoded, bool throw_errors)
936 std::string encoding_buffer;
937 bool saw_non_ascii = false;
938 for (const char *p = decoded; *p != '\0'; p += 1)
940 if ((*p & 0x80) != 0)
941 saw_non_ascii = true;
944 encoding_buffer.append ("__");
945 else if (*p == '[' && is_compiler_suffix (p))
947 encoding_buffer = encoding_buffer + "." + (p + 1);
948 if (encoding_buffer.back () == ']')
949 encoding_buffer.pop_back ();
954 const struct ada_opname_map *mapping;
956 for (mapping = ada_opname_table;
957 mapping->encoded != NULL
958 && !startswith (p, mapping->decoded); mapping += 1)
960 if (mapping->encoded == NULL)
963 error (_("invalid Ada operator name: %s"), p);
967 encoding_buffer.append (mapping->encoded);
971 encoding_buffer.push_back (*p);
974 /* If a non-ASCII character is seen, we must convert it to the
975 appropriate hex form. As this is more expensive, we keep track
976 of whether it is even necessary. */
979 auto_obstack storage;
980 bool is_utf8 = ada_source_charset == ada_utf8;
983 convert_between_encodings
985 is_utf8 ? HOST_UTF32 : ada_source_charset,
986 (const gdb_byte *) encoding_buffer.c_str (),
987 encoding_buffer.length (), 1,
988 &storage, translit_none);
990 catch (const gdb_exception &)
992 static bool warned = false;
994 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
995 might like to know why. */
999 warning (_("charset conversion failure for '%s'.\n"
1000 "You may have the wrong value for 'set ada source-charset'."),
1001 encoding_buffer.c_str ());
1004 /* We don't try to recover from errors. */
1005 return encoding_buffer;
1009 return copy_and_hex_encode<uint32_t> (&storage);
1010 return copy_and_hex_encode<gdb_byte> (&storage);
1013 return encoding_buffer;
1016 /* Find the entry for C in the case-folding table. Return nullptr if
1017 the entry does not cover C. */
1018 static const utf8_entry *
1019 find_case_fold_entry (uint32_t c)
1021 auto iter = std::lower_bound (std::begin (ada_case_fold),
1022 std::end (ada_case_fold),
1024 if (iter == std::end (ada_case_fold)
1031 /* Return NAME folded to lower case, or, if surrounded by single
1032 quotes, unfolded, but with the quotes stripped away. If
1033 THROW_ON_ERROR is true, encoding failures will throw an exception
1034 rather than emitting a warning. Result good to next call. */
1037 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1039 static std::string fold_storage;
1041 if (!name.empty () && name[0] == '\'')
1042 fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1045 /* Why convert to UTF-32 and implement our own case-folding,
1046 rather than convert to wchar_t and use the platform's
1047 functions? I'm glad you asked.
1049 The main problem is that GNAT implements an unusual rule for
1050 case folding. For ASCII letters, letters in single-byte
1051 encodings (such as ISO-8859-*), and Unicode letters that fit
1052 in a single byte (i.e., code point is <= 0xff), the letter is
1053 folded to lower case. Other Unicode letters are folded to
1056 This rule means that the code must be able to examine the
1057 value of the character. And, some hosts do not use Unicode
1058 for wchar_t, so examining the value of such characters is
1060 auto_obstack storage;
1063 convert_between_encodings
1064 (host_charset (), HOST_UTF32,
1065 (const gdb_byte *) name.data (),
1067 &storage, translit_none);
1069 catch (const gdb_exception &)
1074 static bool warned = false;
1076 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1077 might like to know why. */
1081 warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1082 "This normally should not happen, please file a bug report."),
1083 gdb::to_string (name).c_str (), host_charset ());
1086 /* We don't try to recover from errors; just return the
1088 fold_storage = gdb::to_string (name);
1089 return fold_storage.c_str ();
1092 bool is_utf8 = ada_source_charset == ada_utf8;
1093 uint32_t *chars = (uint32_t *) obstack_base (&storage);
1094 int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1095 for (int i = 0; i < num_chars; ++i)
1097 const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1098 if (entry != nullptr)
1100 uint32_t low = chars[i] + entry->lower_delta;
1101 if (!is_utf8 || low <= 0xff)
1104 chars[i] = chars[i] + entry->upper_delta;
1108 /* Now convert back to ordinary characters. */
1109 auto_obstack reconverted;
1112 convert_between_encodings (HOST_UTF32,
1114 (const gdb_byte *) chars,
1115 num_chars * sizeof (uint32_t),
1119 obstack_1grow (&reconverted, '\0');
1120 fold_storage = std::string ((const char *) obstack_base (&reconverted));
1122 catch (const gdb_exception &)
1127 static bool warned = false;
1129 /* Converting back from UTF-32 shouldn't normally fail, but
1130 there are some host encodings without upper/lower
1135 warning (_("could not convert the lower-cased variant of '%s'\n"
1136 "from UTF-32 to the host encoding (%s)."),
1137 gdb::to_string (name).c_str (), host_charset ());
1140 /* We don't try to recover from errors; just return the
1142 fold_storage = gdb::to_string (name);
1146 return fold_storage.c_str ();
1149 /* The "encoded" form of DECODED, according to GNAT conventions. */
1152 ada_encode (const char *decoded)
1154 if (decoded[0] != '<')
1155 decoded = ada_fold_name (decoded);
1156 return ada_encode_1 (decoded, true);
1159 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1162 is_lower_alphanum (const char c)
1164 return (isdigit (c) || (isalpha (c) && islower (c)));
1167 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1168 This function saves in LEN the length of that same symbol name but
1169 without either of these suffixes:
1175 These are suffixes introduced by the compiler for entities such as
1176 nested subprogram for instance, in order to avoid name clashes.
1177 They do not serve any purpose for the debugger. */
1180 ada_remove_trailing_digits (const char *encoded, int *len)
1182 if (*len > 1 && isdigit (encoded[*len - 1]))
1186 while (i > 0 && isdigit (encoded[i]))
1188 if (i >= 0 && encoded[i] == '.')
1190 else if (i >= 0 && encoded[i] == '$')
1192 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1194 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1199 /* Remove the suffix introduced by the compiler for protected object
1203 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1205 /* Remove trailing N. */
1207 /* Protected entry subprograms are broken into two
1208 separate subprograms: The first one is unprotected, and has
1209 a 'N' suffix; the second is the protected version, and has
1210 the 'P' suffix. The second calls the first one after handling
1211 the protection. Since the P subprograms are internally generated,
1212 we leave these names undecoded, giving the user a clue that this
1213 entity is internal. */
1216 && encoded[*len - 1] == 'N'
1217 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1221 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1222 then update *LEN to remove the suffix and return the offset of the
1223 character just past the ".". Otherwise, return -1. */
1226 remove_compiler_suffix (const char *encoded, int *len)
1228 int offset = *len - 1;
1229 while (offset > 0 && isalpha (encoded[offset]))
1231 if (offset > 0 && encoded[offset] == '.')
1239 /* Convert an ASCII hex string to a number. Reads exactly N
1240 characters from STR. Returns true on success, false if one of the
1241 digits was not a hex digit. */
1243 convert_hex (const char *str, int n, uint32_t *out)
1245 uint32_t result = 0;
1247 for (int i = 0; i < n; ++i)
1249 if (!isxdigit (str[i]))
1252 result |= fromhex (str[i]);
1259 /* Convert a wide character from its ASCII hex representation in STR
1260 (consisting of exactly N characters) to the host encoding,
1261 appending the resulting bytes to OUT. If N==2 and the Ada source
1262 charset is not UTF-8, then hex refers to an encoding in the
1263 ADA_SOURCE_CHARSET; otherwise, use UTF-32. Return true on success.
1264 Return false and do not modify OUT on conversion failure. */
1266 convert_from_hex_encoded (std::string &out, const char *str, int n)
1270 if (!convert_hex (str, n, &value))
1275 /* In the 'U' case, the hex digits encode the character in the
1276 Ada source charset. However, if the source charset is UTF-8,
1277 this really means it is a single-byte UTF-32 character. */
1278 if (n == 2 && ada_source_charset != ada_utf8)
1280 gdb_byte one_char = (gdb_byte) value;
1282 convert_between_encodings (ada_source_charset, host_charset (),
1284 sizeof (one_char), sizeof (one_char),
1285 &bytes, translit_none);
1288 convert_between_encodings (HOST_UTF32, host_charset (),
1289 (const gdb_byte *) &value,
1290 sizeof (value), sizeof (value),
1291 &bytes, translit_none);
1292 obstack_1grow (&bytes, '\0');
1293 out.append ((const char *) obstack_base (&bytes));
1295 catch (const gdb_exception &)
1297 /* On failure, the caller will just let the encoded form
1298 through, which seems basically reasonable. */
1305 /* See ada-lang.h. */
1308 ada_decode (const char *encoded, bool wrap, bool operators)
1314 std::string decoded;
1317 /* With function descriptors on PPC64, the value of a symbol named
1318 ".FN", if it exists, is the entry point of the function "FN". */
1319 if (encoded[0] == '.')
1322 /* The name of the Ada main procedure starts with "_ada_".
1323 This prefix is not part of the decoded name, so skip this part
1324 if we see this prefix. */
1325 if (startswith (encoded, "_ada_"))
1327 /* The "___ghost_" prefix is used for ghost entities. Normally
1328 these aren't preserved but when they are, it's useful to see
1330 if (startswith (encoded, "___ghost_"))
1333 /* If the name starts with '_', then it is not a properly encoded
1334 name, so do not attempt to decode it. Similarly, if the name
1335 starts with '<', the name should not be decoded. */
1336 if (encoded[0] == '_' || encoded[0] == '<')
1339 len0 = strlen (encoded);
1341 suffix = remove_compiler_suffix (encoded, &len0);
1343 ada_remove_trailing_digits (encoded, &len0);
1344 ada_remove_po_subprogram_suffix (encoded, &len0);
1346 /* Remove the ___X.* suffix if present. Do not forget to verify that
1347 the suffix is located before the current "end" of ENCODED. We want
1348 to avoid re-matching parts of ENCODED that have previously been
1349 marked as discarded (by decrementing LEN0). */
1350 p = strstr (encoded, "___");
1351 if (p != NULL && p - encoded < len0 - 3)
1359 /* Remove any trailing TKB suffix. It tells us that this symbol
1360 is for the body of a task, but that information does not actually
1361 appear in the decoded name. */
1363 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1366 /* Remove any trailing TB suffix. The TB suffix is slightly different
1367 from the TKB suffix because it is used for non-anonymous task
1370 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1373 /* Remove trailing "B" suffixes. */
1374 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1376 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1379 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1381 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1384 while ((i >= 0 && isdigit (encoded[i]))
1385 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1387 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1389 else if (encoded[i] == '$')
1393 /* The first few characters that are not alphabetic are not part
1394 of any encoding we use, so we can copy them over verbatim. */
1396 for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1397 decoded.push_back (encoded[i]);
1402 /* Is this a symbol function? */
1403 if (operators && at_start_name && encoded[i] == 'O')
1407 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1409 int op_len = strlen (ada_opname_table[k].encoded);
1410 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1412 && !isalnum (encoded[i + op_len]))
1414 decoded.append (ada_opname_table[k].decoded);
1420 if (ada_opname_table[k].encoded != NULL)
1425 /* Replace "TK__" with "__", which will eventually be translated
1426 into "." (just below). */
1428 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1431 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1432 be translated into "." (just below). These are internal names
1433 generated for anonymous blocks inside which our symbol is nested. */
1435 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1436 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1437 && isdigit (encoded [i+4]))
1441 while (k < len0 && isdigit (encoded[k]))
1442 k++; /* Skip any extra digit. */
1444 /* Double-check that the "__B_{DIGITS}+" sequence we found
1445 is indeed followed by "__". */
1446 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1450 /* Remove _E{DIGITS}+[sb] */
1452 /* Just as for protected object subprograms, there are 2 categories
1453 of subprograms created by the compiler for each entry. The first
1454 one implements the actual entry code, and has a suffix following
1455 the convention above; the second one implements the barrier and
1456 uses the same convention as above, except that the 'E' is replaced
1459 Just as above, we do not decode the name of barrier functions
1460 to give the user a clue that the code he is debugging has been
1461 internally generated. */
1463 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1464 && isdigit (encoded[i+2]))
1468 while (k < len0 && isdigit (encoded[k]))
1472 && (encoded[k] == 'b' || encoded[k] == 's'))
1475 /* Just as an extra precaution, make sure that if this
1476 suffix is followed by anything else, it is a '_'.
1477 Otherwise, we matched this sequence by accident. */
1479 || (k < len0 && encoded[k] == '_'))
1484 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1485 the GNAT front-end in protected object subprograms. */
1488 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1490 /* Backtrack a bit up until we reach either the begining of
1491 the encoded name, or "__". Make sure that we only find
1492 digits or lowercase characters. */
1493 const char *ptr = encoded + i - 1;
1495 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1498 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1502 if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1504 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1510 else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1512 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1518 else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1519 && isxdigit (encoded[i + 2]))
1521 if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1528 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1530 /* This is a X[bn]* sequence not separated from the previous
1531 part of the name with a non-alpha-numeric character (in other
1532 words, immediately following an alpha-numeric character), then
1533 verify that it is placed at the end of the encoded name. If
1534 not, then the encoding is not valid and we should abort the
1535 decoding. Otherwise, just skip it, it is used in body-nested
1539 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1543 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1545 /* Replace '__' by '.'. */
1546 decoded.push_back ('.');
1552 /* It's a character part of the decoded name, so just copy it
1554 decoded.push_back (encoded[i]);
1559 /* Decoded names should never contain any uppercase character.
1560 Double-check this, and abort the decoding if we find one. */
1564 for (i = 0; i < decoded.length(); ++i)
1565 if (isupper (decoded[i]) || decoded[i] == ' ')
1569 /* If the compiler added a suffix, append it now. */
1571 decoded = decoded + "[" + &encoded[suffix] + "]";
1579 if (encoded[0] == '<')
1582 decoded = '<' + std::string(encoded) + '>';
1586 /* Table for keeping permanent unique copies of decoded names. Once
1587 allocated, names in this table are never released. While this is a
1588 storage leak, it should not be significant unless there are massive
1589 changes in the set of decoded names in successive versions of a
1590 symbol table loaded during a single session. */
1591 static struct htab *decoded_names_store;
1593 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1594 in the language-specific part of GSYMBOL, if it has not been
1595 previously computed. Tries to save the decoded name in the same
1596 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1597 in any case, the decoded symbol has a lifetime at least that of
1599 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1600 const, but nevertheless modified to a semantically equivalent form
1601 when a decoded name is cached in it. */
1604 ada_decode_symbol (const struct general_symbol_info *arg)
1606 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1607 const char **resultp =
1608 &gsymbol->language_specific.demangled_name;
1610 if (!gsymbol->ada_mangled)
1612 std::string decoded = ada_decode (gsymbol->linkage_name ());
1613 struct obstack *obstack = gsymbol->language_specific.obstack;
1615 gsymbol->ada_mangled = 1;
1617 if (obstack != NULL)
1618 *resultp = obstack_strdup (obstack, decoded.c_str ());
1621 /* Sometimes, we can't find a corresponding objfile, in
1622 which case, we put the result on the heap. Since we only
1623 decode when needed, we hope this usually does not cause a
1624 significant memory leak (FIXME). */
1626 char **slot = (char **) htab_find_slot (decoded_names_store,
1627 decoded.c_str (), INSERT);
1630 *slot = xstrdup (decoded.c_str ());
1642 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1643 generated by the GNAT compiler to describe the index type used
1644 for each dimension of an array, check whether it follows the latest
1645 known encoding. If not, fix it up to conform to the latest encoding.
1646 Otherwise, do nothing. This function also does nothing if
1647 INDEX_DESC_TYPE is NULL.
1649 The GNAT encoding used to describe the array index type evolved a bit.
1650 Initially, the information would be provided through the name of each
1651 field of the structure type only, while the type of these fields was
1652 described as unspecified and irrelevant. The debugger was then expected
1653 to perform a global type lookup using the name of that field in order
1654 to get access to the full index type description. Because these global
1655 lookups can be very expensive, the encoding was later enhanced to make
1656 the global lookup unnecessary by defining the field type as being
1657 the full index type description.
1659 The purpose of this routine is to allow us to support older versions
1660 of the compiler by detecting the use of the older encoding, and by
1661 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1662 we essentially replace each field's meaningless type by the associated
1666 ada_fixup_array_indexes_type (struct type *index_desc_type)
1670 if (index_desc_type == NULL)
1672 gdb_assert (index_desc_type->num_fields () > 0);
1674 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1675 to check one field only, no need to check them all). If not, return
1678 If our INDEX_DESC_TYPE was generated using the older encoding,
1679 the field type should be a meaningless integer type whose name
1680 is not equal to the field name. */
1681 if (index_desc_type->field (0).type ()->name () != NULL
1682 && strcmp (index_desc_type->field (0).type ()->name (),
1683 index_desc_type->field (0).name ()) == 0)
1686 /* Fixup each field of INDEX_DESC_TYPE. */
1687 for (i = 0; i < index_desc_type->num_fields (); i++)
1689 const char *name = index_desc_type->field (i).name ();
1690 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1693 index_desc_type->field (i).set_type (raw_type);
1697 /* The desc_* routines return primitive portions of array descriptors
1700 /* The descriptor or array type, if any, indicated by TYPE; removes
1701 level of indirection, if needed. */
1703 static struct type *
1704 desc_base_type (struct type *type)
1708 type = ada_check_typedef (type);
1709 if (type->code () == TYPE_CODE_TYPEDEF)
1710 type = ada_typedef_target_type (type);
1713 && (type->code () == TYPE_CODE_PTR
1714 || type->code () == TYPE_CODE_REF))
1715 return ada_check_typedef (type->target_type ());
1720 /* True iff TYPE indicates a "thin" array pointer type. */
1723 is_thin_pntr (struct type *type)
1726 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1727 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1730 /* The descriptor type for thin pointer type TYPE. */
1732 static struct type *
1733 thin_descriptor_type (struct type *type)
1735 struct type *base_type = desc_base_type (type);
1737 if (base_type == NULL)
1739 if (is_suffix (ada_type_name (base_type), "___XVE"))
1743 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1745 if (alt_type == NULL)
1752 /* A pointer to the array data for thin-pointer value VAL. */
1754 static struct value *
1755 thin_data_pntr (struct value *val)
1757 struct type *type = ada_check_typedef (value_type (val));
1758 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1760 data_type = lookup_pointer_type (data_type);
1762 if (type->code () == TYPE_CODE_PTR)
1763 return value_cast (data_type, value_copy (val));
1765 return value_from_longest (data_type, value_address (val));
1768 /* True iff TYPE indicates a "thick" array pointer type. */
1771 is_thick_pntr (struct type *type)
1773 type = desc_base_type (type);
1774 return (type != NULL && type->code () == TYPE_CODE_STRUCT
1775 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1778 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1779 pointer to one, the type of its bounds data; otherwise, NULL. */
1781 static struct type *
1782 desc_bounds_type (struct type *type)
1786 type = desc_base_type (type);
1790 else if (is_thin_pntr (type))
1792 type = thin_descriptor_type (type);
1795 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1797 return ada_check_typedef (r);
1799 else if (type->code () == TYPE_CODE_STRUCT)
1801 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1803 return ada_check_typedef (ada_check_typedef (r)->target_type ());
1808 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1809 one, a pointer to its bounds data. Otherwise NULL. */
1811 static struct value *
1812 desc_bounds (struct value *arr)
1814 struct type *type = ada_check_typedef (value_type (arr));
1816 if (is_thin_pntr (type))
1818 struct type *bounds_type =
1819 desc_bounds_type (thin_descriptor_type (type));
1822 if (bounds_type == NULL)
1823 error (_("Bad GNAT array descriptor"));
1825 /* NOTE: The following calculation is not really kosher, but
1826 since desc_type is an XVE-encoded type (and shouldn't be),
1827 the correct calculation is a real pain. FIXME (and fix GCC). */
1828 if (type->code () == TYPE_CODE_PTR)
1829 addr = value_as_long (arr);
1831 addr = value_address (arr);
1834 value_from_longest (lookup_pointer_type (bounds_type),
1835 addr - bounds_type->length ());
1838 else if (is_thick_pntr (type))
1840 struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1841 _("Bad GNAT array descriptor"));
1842 struct type *p_bounds_type = value_type (p_bounds);
1845 && p_bounds_type->code () == TYPE_CODE_PTR)
1847 struct type *target_type = p_bounds_type->target_type ();
1849 if (target_type->is_stub ())
1850 p_bounds = value_cast (lookup_pointer_type
1851 (ada_check_typedef (target_type)),
1855 error (_("Bad GNAT array descriptor"));
1863 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1864 position of the field containing the address of the bounds data. */
1867 fat_pntr_bounds_bitpos (struct type *type)
1869 return desc_base_type (type)->field (1).loc_bitpos ();
1872 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1873 size of the field containing the address of the bounds data. */
1876 fat_pntr_bounds_bitsize (struct type *type)
1878 type = desc_base_type (type);
1880 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1881 return TYPE_FIELD_BITSIZE (type, 1);
1883 return 8 * ada_check_typedef (type->field (1).type ())->length ();
1886 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1887 pointer to one, the type of its array data (a array-with-no-bounds type);
1888 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1891 static struct type *
1892 desc_data_target_type (struct type *type)
1894 type = desc_base_type (type);
1896 /* NOTE: The following is bogus; see comment in desc_bounds. */
1897 if (is_thin_pntr (type))
1898 return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1899 else if (is_thick_pntr (type))
1901 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1904 && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1905 return ada_check_typedef (data_type->target_type ());
1911 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1914 static struct value *
1915 desc_data (struct value *arr)
1917 struct type *type = value_type (arr);
1919 if (is_thin_pntr (type))
1920 return thin_data_pntr (arr);
1921 else if (is_thick_pntr (type))
1922 return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1923 _("Bad GNAT array descriptor"));
1929 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1930 position of the field containing the address of the data. */
1933 fat_pntr_data_bitpos (struct type *type)
1935 return desc_base_type (type)->field (0).loc_bitpos ();
1938 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1939 size of the field containing the address of the data. */
1942 fat_pntr_data_bitsize (struct type *type)
1944 type = desc_base_type (type);
1946 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1947 return TYPE_FIELD_BITSIZE (type, 0);
1949 return TARGET_CHAR_BIT * type->field (0).type ()->length ();
1952 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1953 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1954 bound, if WHICH is 1. The first bound is I=1. */
1956 static struct value *
1957 desc_one_bound (struct value *bounds, int i, int which)
1959 char bound_name[20];
1960 xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1961 which ? 'U' : 'L', i - 1);
1962 return value_struct_elt (&bounds, {}, bound_name, NULL,
1963 _("Bad GNAT array descriptor bounds"));
1966 /* If BOUNDS is an array-bounds structure type, return the bit position
1967 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1968 bound, if WHICH is 1. The first bound is I=1. */
1971 desc_bound_bitpos (struct type *type, int i, int which)
1973 return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1976 /* If BOUNDS is an array-bounds structure type, return the bit field size
1977 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1978 bound, if WHICH is 1. The first bound is I=1. */
1981 desc_bound_bitsize (struct type *type, int i, int which)
1983 type = desc_base_type (type);
1985 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1986 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1988 return 8 * type->field (2 * i + which - 2).type ()->length ();
1991 /* If TYPE is the type of an array-bounds structure, the type of its
1992 Ith bound (numbering from 1). Otherwise, NULL. */
1994 static struct type *
1995 desc_index_type (struct type *type, int i)
1997 type = desc_base_type (type);
1999 if (type->code () == TYPE_CODE_STRUCT)
2001 char bound_name[20];
2002 xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2003 return lookup_struct_elt_type (type, bound_name, 1);
2009 /* The number of index positions in the array-bounds type TYPE.
2010 Return 0 if TYPE is NULL. */
2013 desc_arity (struct type *type)
2015 type = desc_base_type (type);
2018 return type->num_fields () / 2;
2022 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
2023 an array descriptor type (representing an unconstrained array
2027 ada_is_direct_array_type (struct type *type)
2031 type = ada_check_typedef (type);
2032 return (type->code () == TYPE_CODE_ARRAY
2033 || ada_is_array_descriptor_type (type));
2036 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2040 ada_is_array_type (struct type *type)
2043 && (type->code () == TYPE_CODE_PTR
2044 || type->code () == TYPE_CODE_REF))
2045 type = type->target_type ();
2046 return ada_is_direct_array_type (type);
2049 /* Non-zero iff TYPE is a simple array type or pointer to one. */
2052 ada_is_simple_array_type (struct type *type)
2056 type = ada_check_typedef (type);
2057 return (type->code () == TYPE_CODE_ARRAY
2058 || (type->code () == TYPE_CODE_PTR
2059 && (ada_check_typedef (type->target_type ())->code ()
2060 == TYPE_CODE_ARRAY)));
2063 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
2066 ada_is_array_descriptor_type (struct type *type)
2068 struct type *data_type = desc_data_target_type (type);
2072 type = ada_check_typedef (type);
2073 return (data_type != NULL
2074 && data_type->code () == TYPE_CODE_ARRAY
2075 && desc_arity (desc_bounds_type (type)) > 0);
2078 /* Non-zero iff type is a partially mal-formed GNAT array
2079 descriptor. FIXME: This is to compensate for some problems with
2080 debugging output from GNAT. Re-examine periodically to see if it
2084 ada_is_bogus_array_descriptor (struct type *type)
2088 && type->code () == TYPE_CODE_STRUCT
2089 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2090 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2091 && !ada_is_array_descriptor_type (type);
2095 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2096 (fat pointer) returns the type of the array data described---specifically,
2097 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
2098 in from the descriptor; otherwise, they are left unspecified. If
2099 the ARR denotes a null array descriptor and BOUNDS is non-zero,
2100 returns NULL. The result is simply the type of ARR if ARR is not
2103 static struct type *
2104 ada_type_of_array (struct value *arr, int bounds)
2106 if (ada_is_constrained_packed_array_type (value_type (arr)))
2107 return decode_constrained_packed_array_type (value_type (arr));
2109 if (!ada_is_array_descriptor_type (value_type (arr)))
2110 return value_type (arr);
2114 struct type *array_type =
2115 ada_check_typedef (desc_data_target_type (value_type (arr)));
2117 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2118 TYPE_FIELD_BITSIZE (array_type, 0) =
2119 decode_packed_array_bitsize (value_type (arr));
2125 struct type *elt_type;
2127 struct value *descriptor;
2129 elt_type = ada_array_element_type (value_type (arr), -1);
2130 arity = ada_array_arity (value_type (arr));
2132 if (elt_type == NULL || arity == 0)
2133 return ada_check_typedef (value_type (arr));
2135 descriptor = desc_bounds (arr);
2136 if (value_as_long (descriptor) == 0)
2140 struct type *range_type = alloc_type_copy (value_type (arr));
2141 struct type *array_type = alloc_type_copy (value_type (arr));
2142 struct value *low = desc_one_bound (descriptor, arity, 0);
2143 struct value *high = desc_one_bound (descriptor, arity, 1);
2146 create_static_range_type (range_type, value_type (low),
2147 longest_to_int (value_as_long (low)),
2148 longest_to_int (value_as_long (high)));
2149 elt_type = create_array_type (array_type, elt_type, range_type);
2151 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2153 /* We need to store the element packed bitsize, as well as
2154 recompute the array size, because it was previously
2155 computed based on the unpacked element size. */
2156 LONGEST lo = value_as_long (low);
2157 LONGEST hi = value_as_long (high);
2159 TYPE_FIELD_BITSIZE (elt_type, 0) =
2160 decode_packed_array_bitsize (value_type (arr));
2161 /* If the array has no element, then the size is already
2162 zero, and does not need to be recomputed. */
2166 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2168 array_type->set_length ((array_bitsize + 7) / 8);
2173 return lookup_pointer_type (elt_type);
2177 /* If ARR does not represent an array, returns ARR unchanged.
2178 Otherwise, returns either a standard GDB array with bounds set
2179 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2180 GDB array. Returns NULL if ARR is a null fat pointer. */
2183 ada_coerce_to_simple_array_ptr (struct value *arr)
2185 if (ada_is_array_descriptor_type (value_type (arr)))
2187 struct type *arrType = ada_type_of_array (arr, 1);
2189 if (arrType == NULL)
2191 return value_cast (arrType, value_copy (desc_data (arr)));
2193 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2194 return decode_constrained_packed_array (arr);
2199 /* If ARR does not represent an array, returns ARR unchanged.
2200 Otherwise, returns a standard GDB array describing ARR (which may
2201 be ARR itself if it already is in the proper form). */
2204 ada_coerce_to_simple_array (struct value *arr)
2206 if (ada_is_array_descriptor_type (value_type (arr)))
2208 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2211 error (_("Bounds unavailable for null array pointer."));
2212 return value_ind (arrVal);
2214 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2215 return decode_constrained_packed_array (arr);
2220 /* If TYPE represents a GNAT array type, return it translated to an
2221 ordinary GDB array type (possibly with BITSIZE fields indicating
2222 packing). For other types, is the identity. */
2225 ada_coerce_to_simple_array_type (struct type *type)
2227 if (ada_is_constrained_packed_array_type (type))
2228 return decode_constrained_packed_array_type (type);
2230 if (ada_is_array_descriptor_type (type))
2231 return ada_check_typedef (desc_data_target_type (type));
2236 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2239 ada_is_gnat_encoded_packed_array_type (struct type *type)
2243 type = desc_base_type (type);
2244 type = ada_check_typedef (type);
2246 ada_type_name (type) != NULL
2247 && strstr (ada_type_name (type), "___XP") != NULL;
2250 /* Non-zero iff TYPE represents a standard GNAT constrained
2251 packed-array type. */
2254 ada_is_constrained_packed_array_type (struct type *type)
2256 return ada_is_gnat_encoded_packed_array_type (type)
2257 && !ada_is_array_descriptor_type (type);
2260 /* Non-zero iff TYPE represents an array descriptor for a
2261 unconstrained packed-array type. */
2264 ada_is_unconstrained_packed_array_type (struct type *type)
2266 if (!ada_is_array_descriptor_type (type))
2269 if (ada_is_gnat_encoded_packed_array_type (type))
2272 /* If we saw GNAT encodings, then the above code is sufficient.
2273 However, with minimal encodings, we will just have a thick
2275 if (is_thick_pntr (type))
2277 type = desc_base_type (type);
2278 /* The structure's first field is a pointer to an array, so this
2279 fetches the array type. */
2280 type = type->field (0).type ()->target_type ();
2281 if (type->code () == TYPE_CODE_TYPEDEF)
2282 type = ada_typedef_target_type (type);
2283 /* Now we can see if the array elements are packed. */
2284 return TYPE_FIELD_BITSIZE (type, 0) > 0;
2290 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2291 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2294 ada_is_any_packed_array_type (struct type *type)
2296 return (ada_is_constrained_packed_array_type (type)
2297 || (type->code () == TYPE_CODE_ARRAY
2298 && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2301 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2302 return the size of its elements in bits. */
2305 decode_packed_array_bitsize (struct type *type)
2307 const char *raw_name;
2311 /* Access to arrays implemented as fat pointers are encoded as a typedef
2312 of the fat pointer type. We need the name of the fat pointer type
2313 to do the decoding, so strip the typedef layer. */
2314 if (type->code () == TYPE_CODE_TYPEDEF)
2315 type = ada_typedef_target_type (type);
2317 raw_name = ada_type_name (ada_check_typedef (type));
2319 raw_name = ada_type_name (desc_base_type (type));
2324 tail = strstr (raw_name, "___XP");
2325 if (tail == nullptr)
2327 gdb_assert (is_thick_pntr (type));
2328 /* The structure's first field is a pointer to an array, so this
2329 fetches the array type. */
2330 type = type->field (0).type ()->target_type ();
2331 /* Now we can see if the array elements are packed. */
2332 return TYPE_FIELD_BITSIZE (type, 0);
2335 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2338 (_("could not understand bit size information on packed array"));
2345 /* Given that TYPE is a standard GDB array type with all bounds filled
2346 in, and that the element size of its ultimate scalar constituents
2347 (that is, either its elements, or, if it is an array of arrays, its
2348 elements' elements, etc.) is *ELT_BITS, return an identical type,
2349 but with the bit sizes of its elements (and those of any
2350 constituent arrays) recorded in the BITSIZE components of its
2351 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2354 Note that, for arrays whose index type has an XA encoding where
2355 a bound references a record discriminant, getting that discriminant,
2356 and therefore the actual value of that bound, is not possible
2357 because none of the given parameters gives us access to the record.
2358 This function assumes that it is OK in the context where it is being
2359 used to return an array whose bounds are still dynamic and where
2360 the length is arbitrary. */
2362 static struct type *
2363 constrained_packed_array_type (struct type *type, long *elt_bits)
2365 struct type *new_elt_type;
2366 struct type *new_type;
2367 struct type *index_type_desc;
2368 struct type *index_type;
2369 LONGEST low_bound, high_bound;
2371 type = ada_check_typedef (type);
2372 if (type->code () != TYPE_CODE_ARRAY)
2375 index_type_desc = ada_find_parallel_type (type, "___XA");
2376 if (index_type_desc)
2377 index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2380 index_type = type->index_type ();
2382 new_type = alloc_type_copy (type);
2384 constrained_packed_array_type (ada_check_typedef (type->target_type ()),
2386 create_array_type (new_type, new_elt_type, index_type);
2387 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2388 new_type->set_name (ada_type_name (type));
2390 if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2391 && is_dynamic_type (check_typedef (index_type)))
2392 || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2393 low_bound = high_bound = 0;
2394 if (high_bound < low_bound)
2397 new_type->set_length (0);
2401 *elt_bits *= (high_bound - low_bound + 1);
2402 new_type->set_length ((*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT);
2405 new_type->set_is_fixed_instance (true);
2409 /* The array type encoded by TYPE, where
2410 ada_is_constrained_packed_array_type (TYPE). */
2412 static struct type *
2413 decode_constrained_packed_array_type (struct type *type)
2415 const char *raw_name = ada_type_name (ada_check_typedef (type));
2418 struct type *shadow_type;
2422 raw_name = ada_type_name (desc_base_type (type));
2427 name = (char *) alloca (strlen (raw_name) + 1);
2428 tail = strstr (raw_name, "___XP");
2429 type = desc_base_type (type);
2431 memcpy (name, raw_name, tail - raw_name);
2432 name[tail - raw_name] = '\000';
2434 shadow_type = ada_find_parallel_type_with_name (type, name);
2436 if (shadow_type == NULL)
2438 lim_warning (_("could not find bounds information on packed array"));
2441 shadow_type = check_typedef (shadow_type);
2443 if (shadow_type->code () != TYPE_CODE_ARRAY)
2445 lim_warning (_("could not understand bounds "
2446 "information on packed array"));
2450 bits = decode_packed_array_bitsize (type);
2451 return constrained_packed_array_type (shadow_type, &bits);
2454 /* Helper function for decode_constrained_packed_array. Set the field
2455 bitsize on a series of packed arrays. Returns the number of
2456 elements in TYPE. */
2459 recursively_update_array_bitsize (struct type *type)
2461 gdb_assert (type->code () == TYPE_CODE_ARRAY);
2464 if (!get_discrete_bounds (type->index_type (), &low, &high)
2467 LONGEST our_len = high - low + 1;
2469 struct type *elt_type = type->target_type ();
2470 if (elt_type->code () == TYPE_CODE_ARRAY)
2472 LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2473 LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2474 TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2476 type->set_length (((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2483 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2484 array, returns a simple array that denotes that array. Its type is a
2485 standard GDB array type except that the BITSIZEs of the array
2486 target types are set to the number of bits in each element, and the
2487 type length is set appropriately. */
2489 static struct value *
2490 decode_constrained_packed_array (struct value *arr)
2494 /* If our value is a pointer, then dereference it. Likewise if
2495 the value is a reference. Make sure that this operation does not
2496 cause the target type to be fixed, as this would indirectly cause
2497 this array to be decoded. The rest of the routine assumes that
2498 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2499 and "value_ind" routines to perform the dereferencing, as opposed
2500 to using "ada_coerce_ref" or "ada_value_ind". */
2501 arr = coerce_ref (arr);
2502 if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2503 arr = value_ind (arr);
2505 type = decode_constrained_packed_array_type (value_type (arr));
2508 error (_("can't unpack array"));
2512 /* Decoding the packed array type could not correctly set the field
2513 bitsizes for any dimension except the innermost, because the
2514 bounds may be variable and were not passed to that function. So,
2515 we further resolve the array bounds here and then update the
2517 const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2518 CORE_ADDR address = value_address (arr);
2519 gdb::array_view<const gdb_byte> view
2520 = gdb::make_array_view (valaddr, type->length ());
2521 type = resolve_dynamic_type (type, view, address);
2522 recursively_update_array_bitsize (type);
2524 if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2525 && ada_is_modular_type (value_type (arr)))
2527 /* This is a (right-justified) modular type representing a packed
2528 array with no wrapper. In order to interpret the value through
2529 the (left-justified) packed array type we just built, we must
2530 first left-justify it. */
2531 int bit_size, bit_pos;
2534 mod = ada_modulus (value_type (arr)) - 1;
2541 bit_pos = HOST_CHAR_BIT * value_type (arr)->length () - bit_size;
2542 arr = ada_value_primitive_packed_val (arr, NULL,
2543 bit_pos / HOST_CHAR_BIT,
2544 bit_pos % HOST_CHAR_BIT,
2549 return coerce_unspec_val_to_type (arr, type);
2553 /* The value of the element of packed array ARR at the ARITY indices
2554 given in IND. ARR must be a simple array. */
2556 static struct value *
2557 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2560 int bits, elt_off, bit_off;
2561 long elt_total_bit_offset;
2562 struct type *elt_type;
2566 elt_total_bit_offset = 0;
2567 elt_type = ada_check_typedef (value_type (arr));
2568 for (i = 0; i < arity; i += 1)
2570 if (elt_type->code () != TYPE_CODE_ARRAY
2571 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2573 (_("attempt to do packed indexing of "
2574 "something other than a packed array"));
2577 struct type *range_type = elt_type->index_type ();
2578 LONGEST lowerbound, upperbound;
2581 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2583 lim_warning (_("don't know bounds of array"));
2584 lowerbound = upperbound = 0;
2587 idx = pos_atr (ind[i]);
2588 if (idx < lowerbound || idx > upperbound)
2589 lim_warning (_("packed array index %ld out of bounds"),
2591 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2592 elt_total_bit_offset += (idx - lowerbound) * bits;
2593 elt_type = ada_check_typedef (elt_type->target_type ());
2596 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2597 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2599 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2604 /* Non-zero iff TYPE includes negative integer values. */
2607 has_negatives (struct type *type)
2609 switch (type->code ())
2614 return !type->is_unsigned ();
2615 case TYPE_CODE_RANGE:
2616 return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2620 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2621 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2622 the unpacked buffer.
2624 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2625 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2627 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2630 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2632 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2635 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2636 gdb_byte *unpacked, int unpacked_len,
2637 int is_big_endian, int is_signed_type,
2640 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2641 int src_idx; /* Index into the source area */
2642 int src_bytes_left; /* Number of source bytes left to process. */
2643 int srcBitsLeft; /* Number of source bits left to move */
2644 int unusedLS; /* Number of bits in next significant
2645 byte of source that are unused */
2647 int unpacked_idx; /* Index into the unpacked buffer */
2648 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2650 unsigned long accum; /* Staging area for bits being transferred */
2651 int accumSize; /* Number of meaningful bits in accum */
2654 /* Transmit bytes from least to most significant; delta is the direction
2655 the indices move. */
2656 int delta = is_big_endian ? -1 : 1;
2658 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2660 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2661 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2662 bit_size, unpacked_len);
2664 srcBitsLeft = bit_size;
2665 src_bytes_left = src_len;
2666 unpacked_bytes_left = unpacked_len;
2671 src_idx = src_len - 1;
2673 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2677 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2683 unpacked_idx = unpacked_len - 1;
2687 /* Non-scalar values must be aligned at a byte boundary... */
2689 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2690 /* ... And are placed at the beginning (most-significant) bytes
2692 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2693 unpacked_bytes_left = unpacked_idx + 1;
2698 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2700 src_idx = unpacked_idx = 0;
2701 unusedLS = bit_offset;
2704 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2709 while (src_bytes_left > 0)
2711 /* Mask for removing bits of the next source byte that are not
2712 part of the value. */
2713 unsigned int unusedMSMask =
2714 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2716 /* Sign-extend bits for this byte. */
2717 unsigned int signMask = sign & ~unusedMSMask;
2720 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2721 accumSize += HOST_CHAR_BIT - unusedLS;
2722 if (accumSize >= HOST_CHAR_BIT)
2724 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2725 accumSize -= HOST_CHAR_BIT;
2726 accum >>= HOST_CHAR_BIT;
2727 unpacked_bytes_left -= 1;
2728 unpacked_idx += delta;
2730 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2732 src_bytes_left -= 1;
2735 while (unpacked_bytes_left > 0)
2737 accum |= sign << accumSize;
2738 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2739 accumSize -= HOST_CHAR_BIT;
2742 accum >>= HOST_CHAR_BIT;
2743 unpacked_bytes_left -= 1;
2744 unpacked_idx += delta;
2748 /* Create a new value of type TYPE from the contents of OBJ starting
2749 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2750 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2751 assigning through the result will set the field fetched from.
2752 VALADDR is ignored unless OBJ is NULL, in which case,
2753 VALADDR+OFFSET must address the start of storage containing the
2754 packed value. The value returned in this case is never an lval.
2755 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2758 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2759 long offset, int bit_offset, int bit_size,
2763 const gdb_byte *src; /* First byte containing data to unpack */
2765 const int is_scalar = is_scalar_type (type);
2766 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2767 gdb::byte_vector staging;
2769 type = ada_check_typedef (type);
2772 src = valaddr + offset;
2774 src = value_contents (obj).data () + offset;
2776 if (is_dynamic_type (type))
2778 /* The length of TYPE might by dynamic, so we need to resolve
2779 TYPE in order to know its actual size, which we then use
2780 to create the contents buffer of the value we return.
2781 The difficulty is that the data containing our object is
2782 packed, and therefore maybe not at a byte boundary. So, what
2783 we do, is unpack the data into a byte-aligned buffer, and then
2784 use that buffer as our object's value for resolving the type. */
2785 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2786 staging.resize (staging_len);
2788 ada_unpack_from_contents (src, bit_offset, bit_size,
2789 staging.data (), staging.size (),
2790 is_big_endian, has_negatives (type),
2792 type = resolve_dynamic_type (type, staging, 0);
2793 if (type->length () < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2795 /* This happens when the length of the object is dynamic,
2796 and is actually smaller than the space reserved for it.
2797 For instance, in an array of variant records, the bit_size
2798 we're given is the array stride, which is constant and
2799 normally equal to the maximum size of its element.
2800 But, in reality, each element only actually spans a portion
2802 bit_size = type->length () * HOST_CHAR_BIT;
2808 v = allocate_value (type);
2809 src = valaddr + offset;
2811 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2813 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2816 v = value_at (type, value_address (obj) + offset);
2817 buf = (gdb_byte *) alloca (src_len);
2818 read_memory (value_address (v), buf, src_len);
2823 v = allocate_value (type);
2824 src = value_contents (obj).data () + offset;
2829 long new_offset = offset;
2831 set_value_component_location (v, obj);
2832 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2833 set_value_bitsize (v, bit_size);
2834 if (value_bitpos (v) >= HOST_CHAR_BIT)
2837 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2839 set_value_offset (v, new_offset);
2841 /* Also set the parent value. This is needed when trying to
2842 assign a new value (in inferior memory). */
2843 set_value_parent (v, obj);
2846 set_value_bitsize (v, bit_size);
2847 unpacked = value_contents_writeable (v).data ();
2851 memset (unpacked, 0, type->length ());
2855 if (staging.size () == type->length ())
2857 /* Small short-cut: If we've unpacked the data into a buffer
2858 of the same size as TYPE's length, then we can reuse that,
2859 instead of doing the unpacking again. */
2860 memcpy (unpacked, staging.data (), staging.size ());
2863 ada_unpack_from_contents (src, bit_offset, bit_size,
2864 unpacked, type->length (),
2865 is_big_endian, has_negatives (type), is_scalar);
2870 /* Store the contents of FROMVAL into the location of TOVAL.
2871 Return a new value with the location of TOVAL and contents of
2872 FROMVAL. Handles assignment into packed fields that have
2873 floating-point or non-scalar types. */
2875 static struct value *
2876 ada_value_assign (struct value *toval, struct value *fromval)
2878 struct type *type = value_type (toval);
2879 int bits = value_bitsize (toval);
2881 toval = ada_coerce_ref (toval);
2882 fromval = ada_coerce_ref (fromval);
2884 if (ada_is_direct_array_type (value_type (toval)))
2885 toval = ada_coerce_to_simple_array (toval);
2886 if (ada_is_direct_array_type (value_type (fromval)))
2887 fromval = ada_coerce_to_simple_array (fromval);
2889 if (!deprecated_value_modifiable (toval))
2890 error (_("Left operand of assignment is not a modifiable lvalue."));
2892 if (VALUE_LVAL (toval) == lval_memory
2894 && (type->code () == TYPE_CODE_FLT
2895 || type->code () == TYPE_CODE_STRUCT))
2897 int len = (value_bitpos (toval)
2898 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2900 gdb_byte *buffer = (gdb_byte *) alloca (len);
2902 CORE_ADDR to_addr = value_address (toval);
2904 if (type->code () == TYPE_CODE_FLT)
2905 fromval = value_cast (type, fromval);
2907 read_memory (to_addr, buffer, len);
2908 from_size = value_bitsize (fromval);
2910 from_size = value_type (fromval)->length () * TARGET_CHAR_BIT;
2912 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2913 ULONGEST from_offset = 0;
2914 if (is_big_endian && is_scalar_type (value_type (fromval)))
2915 from_offset = from_size - bits;
2916 copy_bitwise (buffer, value_bitpos (toval),
2917 value_contents (fromval).data (), from_offset,
2918 bits, is_big_endian);
2919 write_memory_with_notification (to_addr, buffer, len);
2921 val = value_copy (toval);
2922 memcpy (value_contents_raw (val).data (),
2923 value_contents (fromval).data (),
2925 deprecated_set_value_type (val, type);
2930 return value_assign (toval, fromval);
2934 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2935 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2936 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2937 COMPONENT, and not the inferior's memory. The current contents
2938 of COMPONENT are ignored.
2940 Although not part of the initial design, this function also works
2941 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2942 had a null address, and COMPONENT had an address which is equal to
2943 its offset inside CONTAINER. */
2946 value_assign_to_component (struct value *container, struct value *component,
2949 LONGEST offset_in_container =
2950 (LONGEST) (value_address (component) - value_address (container));
2951 int bit_offset_in_container =
2952 value_bitpos (component) - value_bitpos (container);
2955 val = value_cast (value_type (component), val);
2957 if (value_bitsize (component) == 0)
2958 bits = TARGET_CHAR_BIT * value_type (component)->length ();
2960 bits = value_bitsize (component);
2962 if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2966 if (is_scalar_type (check_typedef (value_type (component))))
2968 = value_type (component)->length () * TARGET_CHAR_BIT - bits;
2971 copy_bitwise ((value_contents_writeable (container).data ()
2972 + offset_in_container),
2973 value_bitpos (container) + bit_offset_in_container,
2974 value_contents (val).data (), src_offset, bits, 1);
2977 copy_bitwise ((value_contents_writeable (container).data ()
2978 + offset_in_container),
2979 value_bitpos (container) + bit_offset_in_container,
2980 value_contents (val).data (), 0, bits, 0);
2983 /* Determine if TYPE is an access to an unconstrained array. */
2986 ada_is_access_to_unconstrained_array (struct type *type)
2988 return (type->code () == TYPE_CODE_TYPEDEF
2989 && is_thick_pntr (ada_typedef_target_type (type)));
2992 /* The value of the element of array ARR at the ARITY indices given in IND.
2993 ARR may be either a simple array, GNAT array descriptor, or pointer
2997 ada_value_subscript (struct value *arr, int arity, struct value **ind)
3001 struct type *elt_type;
3003 elt = ada_coerce_to_simple_array (arr);
3005 elt_type = ada_check_typedef (value_type (elt));
3006 if (elt_type->code () == TYPE_CODE_ARRAY
3007 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3008 return value_subscript_packed (elt, arity, ind);
3010 for (k = 0; k < arity; k += 1)
3012 struct type *saved_elt_type = elt_type->target_type ();
3014 if (elt_type->code () != TYPE_CODE_ARRAY)
3015 error (_("too many subscripts (%d expected)"), k);
3017 elt = value_subscript (elt, pos_atr (ind[k]));
3019 if (ada_is_access_to_unconstrained_array (saved_elt_type)
3020 && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3022 /* The element is a typedef to an unconstrained array,
3023 except that the value_subscript call stripped the
3024 typedef layer. The typedef layer is GNAT's way to
3025 specify that the element is, at the source level, an
3026 access to the unconstrained array, rather than the
3027 unconstrained array. So, we need to restore that
3028 typedef layer, which we can do by forcing the element's
3029 type back to its original type. Otherwise, the returned
3030 value is going to be printed as the array, rather
3031 than as an access. Another symptom of the same issue
3032 would be that an expression trying to dereference the
3033 element would also be improperly rejected. */
3034 deprecated_set_value_type (elt, saved_elt_type);
3037 elt_type = ada_check_typedef (value_type (elt));
3043 /* Assuming ARR is a pointer to a GDB array, the value of the element
3044 of *ARR at the ARITY indices given in IND.
3045 Does not read the entire array into memory.
3047 Note: Unlike what one would expect, this function is used instead of
3048 ada_value_subscript for basically all non-packed array types. The reason
3049 for this is that a side effect of doing our own pointer arithmetics instead
3050 of relying on value_subscript is that there is no implicit typedef peeling.
3051 This is important for arrays of array accesses, where it allows us to
3052 preserve the fact that the array's element is an array access, where the
3053 access part os encoded in a typedef layer. */
3055 static struct value *
3056 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3059 struct value *array_ind = ada_value_ind (arr);
3061 = check_typedef (value_enclosing_type (array_ind));
3063 if (type->code () == TYPE_CODE_ARRAY
3064 && TYPE_FIELD_BITSIZE (type, 0) > 0)
3065 return value_subscript_packed (array_ind, arity, ind);
3067 for (k = 0; k < arity; k += 1)
3071 if (type->code () != TYPE_CODE_ARRAY)
3072 error (_("too many subscripts (%d expected)"), k);
3073 arr = value_cast (lookup_pointer_type (type->target_type ()),
3075 get_discrete_bounds (type->index_type (), &lwb, &upb);
3076 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3077 type = type->target_type ();
3080 return value_ind (arr);
3083 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3084 actual type of ARRAY_PTR is ignored), returns the Ada slice of
3085 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
3086 this array is LOW, as per Ada rules. */
3087 static struct value *
3088 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3091 struct type *type0 = ada_check_typedef (type);
3092 struct type *base_index_type = type0->index_type ()->target_type ();
3093 struct type *index_type
3094 = create_static_range_type (NULL, base_index_type, low, high);
3095 struct type *slice_type = create_array_type_with_stride
3096 (NULL, type0->target_type (), index_type,
3097 type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3098 TYPE_FIELD_BITSIZE (type0, 0));
3099 int base_low = ada_discrete_type_low_bound (type0->index_type ());
3100 gdb::optional<LONGEST> base_low_pos, low_pos;
3103 low_pos = discrete_position (base_index_type, low);
3104 base_low_pos = discrete_position (base_index_type, base_low);
3106 if (!low_pos.has_value () || !base_low_pos.has_value ())
3108 warning (_("unable to get positions in slice, use bounds instead"));
3110 base_low_pos = base_low;
3113 ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3115 stride = type0->target_type ()->length ();
3117 base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3118 return value_at_lazy (slice_type, base);
3122 static struct value *
3123 ada_value_slice (struct value *array, int low, int high)
3125 struct type *type = ada_check_typedef (value_type (array));
3126 struct type *base_index_type = type->index_type ()->target_type ();
3127 struct type *index_type
3128 = create_static_range_type (NULL, type->index_type (), low, high);
3129 struct type *slice_type = create_array_type_with_stride
3130 (NULL, type->target_type (), index_type,
3131 type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3132 TYPE_FIELD_BITSIZE (type, 0));
3133 gdb::optional<LONGEST> low_pos, high_pos;
3136 low_pos = discrete_position (base_index_type, low);
3137 high_pos = discrete_position (base_index_type, high);
3139 if (!low_pos.has_value () || !high_pos.has_value ())
3141 warning (_("unable to get positions in slice, use bounds instead"));
3146 return value_cast (slice_type,
3147 value_slice (array, low, *high_pos - *low_pos + 1));
3150 /* If type is a record type in the form of a standard GNAT array
3151 descriptor, returns the number of dimensions for type. If arr is a
3152 simple array, returns the number of "array of"s that prefix its
3153 type designation. Otherwise, returns 0. */
3156 ada_array_arity (struct type *type)
3163 type = desc_base_type (type);
3166 if (type->code () == TYPE_CODE_STRUCT)
3167 return desc_arity (desc_bounds_type (type));
3169 while (type->code () == TYPE_CODE_ARRAY)
3172 type = ada_check_typedef (type->target_type ());
3178 /* If TYPE is a record type in the form of a standard GNAT array
3179 descriptor or a simple array type, returns the element type for
3180 TYPE after indexing by NINDICES indices, or by all indices if
3181 NINDICES is -1. Otherwise, returns NULL. */
3184 ada_array_element_type (struct type *type, int nindices)
3186 type = desc_base_type (type);
3188 if (type->code () == TYPE_CODE_STRUCT)
3191 struct type *p_array_type;
3193 p_array_type = desc_data_target_type (type);
3195 k = ada_array_arity (type);
3199 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3200 if (nindices >= 0 && k > nindices)
3202 while (k > 0 && p_array_type != NULL)
3204 p_array_type = ada_check_typedef (p_array_type->target_type ());
3207 return p_array_type;
3209 else if (type->code () == TYPE_CODE_ARRAY)
3211 while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3213 type = type->target_type ();
3214 /* A multi-dimensional array is represented using a sequence
3215 of array types. If one of these types has a name, then
3216 it is not another dimension of the outer array, but
3217 rather the element type of the outermost array. */
3218 if (type->name () != nullptr)
3228 /* See ada-lang.h. */
3231 ada_index_type (struct type *type, int n, const char *name)
3233 struct type *result_type;
3235 type = desc_base_type (type);
3237 if (n < 0 || n > ada_array_arity (type))
3238 error (_("invalid dimension number to '%s"), name);
3240 if (ada_is_simple_array_type (type))
3244 for (i = 1; i < n; i += 1)
3246 type = ada_check_typedef (type);
3247 type = type->target_type ();
3249 result_type = ada_check_typedef (type)->index_type ()->target_type ();
3250 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3251 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3252 perhaps stabsread.c would make more sense. */
3253 if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3258 result_type = desc_index_type (desc_bounds_type (type), n);
3259 if (result_type == NULL)
3260 error (_("attempt to take bound of something that is not an array"));
3266 /* Given that arr is an array type, returns the lower bound of the
3267 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3268 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3269 array-descriptor type. It works for other arrays with bounds supplied
3270 by run-time quantities other than discriminants. */
3273 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3275 struct type *type, *index_type_desc, *index_type;
3278 gdb_assert (which == 0 || which == 1);
3280 if (ada_is_constrained_packed_array_type (arr_type))
3281 arr_type = decode_constrained_packed_array_type (arr_type);
3283 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3284 return (LONGEST) - which;
3286 if (arr_type->code () == TYPE_CODE_PTR)
3287 type = arr_type->target_type ();
3291 if (type->is_fixed_instance ())
3293 /* The array has already been fixed, so we do not need to
3294 check the parallel ___XA type again. That encoding has
3295 already been applied, so ignore it now. */
3296 index_type_desc = NULL;
3300 index_type_desc = ada_find_parallel_type (type, "___XA");
3301 ada_fixup_array_indexes_type (index_type_desc);
3304 if (index_type_desc != NULL)
3305 index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3309 struct type *elt_type = check_typedef (type);
3311 for (i = 1; i < n; i++)
3312 elt_type = check_typedef (elt_type->target_type ());
3314 index_type = elt_type->index_type ();
3318 (LONGEST) (which == 0
3319 ? ada_discrete_type_low_bound (index_type)
3320 : ada_discrete_type_high_bound (index_type));
3323 /* Given that arr is an array value, returns the lower bound of the
3324 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3325 WHICH is 1. This routine will also work for arrays with bounds
3326 supplied by run-time quantities other than discriminants. */
3329 ada_array_bound (struct value *arr, int n, int which)
3331 struct type *arr_type;
3333 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3334 arr = value_ind (arr);
3335 arr_type = value_enclosing_type (arr);
3337 if (ada_is_constrained_packed_array_type (arr_type))
3338 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3339 else if (ada_is_simple_array_type (arr_type))
3340 return ada_array_bound_from_type (arr_type, n, which);
3342 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3345 /* Given that arr is an array value, returns the length of the
3346 nth index. This routine will also work for arrays with bounds
3347 supplied by run-time quantities other than discriminants.
3348 Does not work for arrays indexed by enumeration types with representation
3349 clauses at the moment. */
3352 ada_array_length (struct value *arr, int n)
3354 struct type *arr_type, *index_type;
3357 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3358 arr = value_ind (arr);
3359 arr_type = value_enclosing_type (arr);
3361 if (ada_is_constrained_packed_array_type (arr_type))
3362 return ada_array_length (decode_constrained_packed_array (arr), n);
3364 if (ada_is_simple_array_type (arr_type))
3366 low = ada_array_bound_from_type (arr_type, n, 0);
3367 high = ada_array_bound_from_type (arr_type, n, 1);
3371 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3372 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3375 arr_type = check_typedef (arr_type);
3376 index_type = ada_index_type (arr_type, n, "length");
3377 if (index_type != NULL)
3379 struct type *base_type;
3380 if (index_type->code () == TYPE_CODE_RANGE)
3381 base_type = index_type->target_type ();
3383 base_type = index_type;
3385 low = pos_atr (value_from_longest (base_type, low));
3386 high = pos_atr (value_from_longest (base_type, high));
3388 return high - low + 1;
3391 /* An array whose type is that of ARR_TYPE (an array type), with
3392 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3393 less than LOW, then LOW-1 is used. */
3395 static struct value *
3396 empty_array (struct type *arr_type, int low, int high)
3398 struct type *arr_type0 = ada_check_typedef (arr_type);
3399 struct type *index_type
3400 = create_static_range_type
3401 (NULL, arr_type0->index_type ()->target_type (), low,
3402 high < low ? low - 1 : high);
3403 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3405 return allocate_value (create_array_type (NULL, elt_type, index_type));
3409 /* Name resolution */
3411 /* The "decoded" name for the user-definable Ada operator corresponding
3415 ada_decoded_op_name (enum exp_opcode op)
3419 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3421 if (ada_opname_table[i].op == op)
3422 return ada_opname_table[i].decoded;
3424 error (_("Could not find operator name for opcode"));
3427 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3428 in a listing of choices during disambiguation (see sort_choices, below).
3429 The idea is that overloadings of a subprogram name from the
3430 same package should sort in their source order. We settle for ordering
3431 such symbols by their trailing number (__N or $N). */
3434 encoded_ordered_before (const char *N0, const char *N1)
3438 else if (N0 == NULL)
3444 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3446 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3448 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3449 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3454 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3457 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3459 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3460 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3462 return (strcmp (N0, N1) < 0);
3466 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3470 sort_choices (struct block_symbol syms[], int nsyms)
3474 for (i = 1; i < nsyms; i += 1)
3476 struct block_symbol sym = syms[i];
3479 for (j = i - 1; j >= 0; j -= 1)
3481 if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3482 sym.symbol->linkage_name ()))
3484 syms[j + 1] = syms[j];
3490 /* Whether GDB should display formals and return types for functions in the
3491 overloads selection menu. */
3492 static bool print_signatures = true;
3494 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3495 all but functions, the signature is just the name of the symbol. For
3496 functions, this is the name of the function, the list of types for formals
3497 and the return type (if any). */
3500 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3501 const struct type_print_options *flags)
3503 struct type *type = sym->type ();
3505 gdb_printf (stream, "%s", sym->print_name ());
3506 if (!print_signatures
3508 || type->code () != TYPE_CODE_FUNC)
3511 if (type->num_fields () > 0)
3515 gdb_printf (stream, " (");
3516 for (i = 0; i < type->num_fields (); ++i)
3519 gdb_printf (stream, "; ");
3520 ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3523 gdb_printf (stream, ")");
3525 if (type->target_type () != NULL
3526 && type->target_type ()->code () != TYPE_CODE_VOID)
3528 gdb_printf (stream, " return ");
3529 ada_print_type (type->target_type (), NULL, stream, -1, 0, flags);
3533 /* Read and validate a set of numeric choices from the user in the
3534 range 0 .. N_CHOICES-1. Place the results in increasing
3535 order in CHOICES[0 .. N-1], and return N.
3537 The user types choices as a sequence of numbers on one line
3538 separated by blanks, encoding them as follows:
3540 + A choice of 0 means to cancel the selection, throwing an error.
3541 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3542 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3544 The user is not allowed to choose more than MAX_RESULTS values.
3546 ANNOTATION_SUFFIX, if present, is used to annotate the input
3547 prompts (for use with the -f switch). */
3550 get_selections (int *choices, int n_choices, int max_results,
3551 int is_all_choice, const char *annotation_suffix)
3556 int first_choice = is_all_choice ? 2 : 1;
3558 prompt = getenv ("PS2");
3562 args = command_line_input (prompt, annotation_suffix);
3565 error_no_arg (_("one or more choice numbers"));
3569 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3570 order, as given in args. Choices are validated. */
3576 args = skip_spaces (args);
3577 if (*args == '\0' && n_chosen == 0)
3578 error_no_arg (_("one or more choice numbers"));
3579 else if (*args == '\0')
3582 choice = strtol (args, &args2, 10);
3583 if (args == args2 || choice < 0
3584 || choice > n_choices + first_choice - 1)
3585 error (_("Argument must be choice number"));
3589 error (_("cancelled"));
3591 if (choice < first_choice)
3593 n_chosen = n_choices;
3594 for (j = 0; j < n_choices; j += 1)
3598 choice -= first_choice;
3600 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3604 if (j < 0 || choice != choices[j])
3608 for (k = n_chosen - 1; k > j; k -= 1)
3609 choices[k + 1] = choices[k];
3610 choices[j + 1] = choice;
3615 if (n_chosen > max_results)
3616 error (_("Select no more than %d of the above"), max_results);
3621 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3622 by asking the user (if necessary), returning the number selected,
3623 and setting the first elements of SYMS items. Error if no symbols
3626 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3627 to be re-integrated one of these days. */
3630 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3633 int *chosen = XALLOCAVEC (int , nsyms);
3635 int first_choice = (max_results == 1) ? 1 : 2;
3636 const char *select_mode = multiple_symbols_select_mode ();
3638 if (max_results < 1)
3639 error (_("Request to select 0 symbols!"));
3643 if (select_mode == multiple_symbols_cancel)
3645 canceled because the command is ambiguous\n\
3646 See set/show multiple-symbol."));
3648 /* If select_mode is "all", then return all possible symbols.
3649 Only do that if more than one symbol can be selected, of course.
3650 Otherwise, display the menu as usual. */
3651 if (select_mode == multiple_symbols_all && max_results > 1)
3654 gdb_printf (_("[0] cancel\n"));
3655 if (max_results > 1)
3656 gdb_printf (_("[1] all\n"));
3658 sort_choices (syms, nsyms);
3660 for (i = 0; i < nsyms; i += 1)
3662 if (syms[i].symbol == NULL)
3665 if (syms[i].symbol->aclass () == LOC_BLOCK)
3667 struct symtab_and_line sal =
3668 find_function_start_sal (syms[i].symbol, 1);
3670 gdb_printf ("[%d] ", i + first_choice);
3671 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3672 &type_print_raw_options);
3673 if (sal.symtab == NULL)
3674 gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3675 metadata_style.style ().ptr (), nullptr, sal.line);
3679 styled_string (file_name_style.style (),
3680 symtab_to_filename_for_display (sal.symtab)),
3687 (syms[i].symbol->aclass () == LOC_CONST
3688 && syms[i].symbol->type () != NULL
3689 && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3690 struct symtab *symtab = NULL;
3692 if (syms[i].symbol->is_objfile_owned ())
3693 symtab = syms[i].symbol->symtab ();
3695 if (syms[i].symbol->line () != 0 && symtab != NULL)
3697 gdb_printf ("[%d] ", i + first_choice);
3698 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3699 &type_print_raw_options);
3700 gdb_printf (_(" at %s:%d\n"),
3701 symtab_to_filename_for_display (symtab),
3702 syms[i].symbol->line ());
3704 else if (is_enumeral
3705 && syms[i].symbol->type ()->name () != NULL)
3707 gdb_printf (("[%d] "), i + first_choice);
3708 ada_print_type (syms[i].symbol->type (), NULL,
3709 gdb_stdout, -1, 0, &type_print_raw_options);
3710 gdb_printf (_("'(%s) (enumeral)\n"),
3711 syms[i].symbol->print_name ());
3715 gdb_printf ("[%d] ", i + first_choice);
3716 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3717 &type_print_raw_options);
3720 gdb_printf (is_enumeral
3721 ? _(" in %s (enumeral)\n")
3723 symtab_to_filename_for_display (symtab));
3725 gdb_printf (is_enumeral
3726 ? _(" (enumeral)\n")
3732 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3735 for (i = 0; i < n_chosen; i += 1)
3736 syms[i] = syms[chosen[i]];
3741 /* See ada-lang.h. */
3744 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3745 int nargs, value *argvec[])
3747 if (possible_user_operator_p (op, argvec))
3749 std::vector<struct block_symbol> candidates
3750 = ada_lookup_symbol_list (ada_decoded_op_name (op),
3753 int i = ada_resolve_function (candidates, argvec,
3754 nargs, ada_decoded_op_name (op), NULL,
3757 return candidates[i];
3762 /* See ada-lang.h. */
3765 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3766 struct type *context_type,
3767 bool parse_completion,
3768 int nargs, value *argvec[],
3769 innermost_block_tracker *tracker)
3771 std::vector<struct block_symbol> candidates
3772 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3775 if (candidates.size () == 1)
3779 i = ada_resolve_function
3782 sym->linkage_name (),
3783 context_type, parse_completion);
3785 error (_("Could not find a match for %s"), sym->print_name ());
3788 tracker->update (candidates[i]);
3789 return candidates[i];
3792 /* Resolve a mention of a name where the context type is an
3793 enumeration type. */
3796 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3797 const char *name, struct type *context_type,
3798 bool parse_completion)
3800 gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3801 context_type = ada_check_typedef (context_type);
3803 for (int i = 0; i < syms.size (); ++i)
3805 /* We already know the name matches, so we're just looking for
3806 an element of the correct enum type. */
3807 if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3811 error (_("No name '%s' in enumeration type '%s'"), name,
3812 ada_type_name (context_type));
3815 /* See ada-lang.h. */
3818 ada_resolve_variable (struct symbol *sym, const struct block *block,
3819 struct type *context_type,
3820 bool parse_completion,
3822 innermost_block_tracker *tracker)
3824 std::vector<struct block_symbol> candidates
3825 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3827 if (std::any_of (candidates.begin (),
3829 [] (block_symbol &bsym)
3831 switch (bsym.symbol->aclass ())
3836 case LOC_REGPARM_ADDR:
3845 /* Types tend to get re-introduced locally, so if there
3846 are any local symbols that are not types, first filter
3850 (candidates.begin (),
3852 [] (block_symbol &bsym)
3854 return bsym.symbol->aclass () == LOC_TYPEDEF;
3859 /* Filter out artificial symbols. */
3862 (candidates.begin (),
3864 [] (block_symbol &bsym)
3866 return bsym.symbol->is_artificial ();
3871 if (candidates.empty ())
3872 error (_("No definition found for %s"), sym->print_name ());
3873 else if (candidates.size () == 1)
3875 else if (context_type != nullptr
3876 && context_type->code () == TYPE_CODE_ENUM)
3877 i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3879 else if (deprocedure_p && !is_nonfunction (candidates))
3881 i = ada_resolve_function
3882 (candidates, NULL, 0,
3883 sym->linkage_name (),
3884 context_type, parse_completion);
3886 error (_("Could not find a match for %s"), sym->print_name ());
3890 gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3891 user_select_syms (candidates.data (), candidates.size (), 1);
3895 tracker->update (candidates[i]);
3896 return candidates[i];
3899 /* Return non-zero if formal type FTYPE matches actual type ATYPE. */
3900 /* The term "match" here is rather loose. The match is heuristic and
3904 ada_type_match (struct type *ftype, struct type *atype)
3906 ftype = ada_check_typedef (ftype);
3907 atype = ada_check_typedef (atype);
3909 if (ftype->code () == TYPE_CODE_REF)
3910 ftype = ftype->target_type ();
3911 if (atype->code () == TYPE_CODE_REF)
3912 atype = atype->target_type ();
3914 switch (ftype->code ())
3917 return ftype->code () == atype->code ();
3919 if (atype->code () != TYPE_CODE_PTR)
3921 atype = atype->target_type ();
3922 /* This can only happen if the actual argument is 'null'. */
3923 if (atype->code () == TYPE_CODE_INT && atype->length () == 0)
3925 return ada_type_match (ftype->target_type (), atype);
3927 case TYPE_CODE_ENUM:
3928 case TYPE_CODE_RANGE:
3929 switch (atype->code ())
3932 case TYPE_CODE_ENUM:
3933 case TYPE_CODE_RANGE:
3939 case TYPE_CODE_ARRAY:
3940 return (atype->code () == TYPE_CODE_ARRAY
3941 || ada_is_array_descriptor_type (atype));
3943 case TYPE_CODE_STRUCT:
3944 if (ada_is_array_descriptor_type (ftype))
3945 return (atype->code () == TYPE_CODE_ARRAY
3946 || ada_is_array_descriptor_type (atype));
3948 return (atype->code () == TYPE_CODE_STRUCT
3949 && !ada_is_array_descriptor_type (atype));
3951 case TYPE_CODE_UNION:
3953 return (atype->code () == ftype->code ());
3957 /* Return non-zero if the formals of FUNC "sufficiently match" the
3958 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3959 may also be an enumeral, in which case it is treated as a 0-
3960 argument function. */
3963 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3966 struct type *func_type = func->type ();
3968 if (func->aclass () == LOC_CONST
3969 && func_type->code () == TYPE_CODE_ENUM)
3970 return (n_actuals == 0);
3971 else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3974 if (func_type->num_fields () != n_actuals)
3977 for (i = 0; i < n_actuals; i += 1)
3979 if (actuals[i] == NULL)
3983 struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3984 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3986 if (!ada_type_match (ftype, atype))
3993 /* False iff function type FUNC_TYPE definitely does not produce a value
3994 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3995 FUNC_TYPE is not a valid function type with a non-null return type
3996 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3999 return_match (struct type *func_type, struct type *context_type)
4001 struct type *return_type;
4003 if (func_type == NULL)
4006 if (func_type->code () == TYPE_CODE_FUNC)
4007 return_type = get_base_type (func_type->target_type ());
4009 return_type = get_base_type (func_type);
4010 if (return_type == NULL)
4013 context_type = get_base_type (context_type);
4015 if (return_type->code () == TYPE_CODE_ENUM)
4016 return context_type == NULL || return_type == context_type;
4017 else if (context_type == NULL)
4018 return return_type->code () != TYPE_CODE_VOID;
4020 return return_type->code () == context_type->code ();
4024 /* Returns the index in SYMS that contains the symbol for the
4025 function (if any) that matches the types of the NARGS arguments in
4026 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
4027 that returns that type, then eliminate matches that don't. If
4028 CONTEXT_TYPE is void and there is at least one match that does not
4029 return void, eliminate all matches that do.
4031 Asks the user if there is more than one match remaining. Returns -1
4032 if there is no such symbol or none is selected. NAME is used
4033 solely for messages. May re-arrange and modify SYMS in
4034 the process; the index returned is for the modified vector. */
4037 ada_resolve_function (std::vector<struct block_symbol> &syms,
4038 struct value **args, int nargs,
4039 const char *name, struct type *context_type,
4040 bool parse_completion)
4044 int m; /* Number of hits */
4047 /* In the first pass of the loop, we only accept functions matching
4048 context_type. If none are found, we add a second pass of the loop
4049 where every function is accepted. */
4050 for (fallback = 0; m == 0 && fallback < 2; fallback++)
4052 for (k = 0; k < syms.size (); k += 1)
4054 struct type *type = ada_check_typedef (syms[k].symbol->type ());
4056 if (ada_args_match (syms[k].symbol, args, nargs)
4057 && (fallback || return_match (type, context_type)))
4065 /* If we got multiple matches, ask the user which one to use. Don't do this
4066 interactive thing during completion, though, as the purpose of the
4067 completion is providing a list of all possible matches. Prompting the
4068 user to filter it down would be completely unexpected in this case. */
4071 else if (m > 1 && !parse_completion)
4073 gdb_printf (_("Multiple matches for %s\n"), name);
4074 user_select_syms (syms.data (), m, 1);
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 ())
4096 case TYPE_CODE_FIXED_POINT:
4098 case TYPE_CODE_RANGE:
4099 return (type == type->target_type ()
4100 || numeric_type_p (type->target_type ()));
4107 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4110 integer_type_p (struct type *type)
4116 switch (type->code ())
4120 case TYPE_CODE_RANGE:
4121 return (type == type->target_type ()
4122 || integer_type_p (type->target_type ()));
4129 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4132 scalar_type_p (struct type *type)
4138 switch (type->code ())
4141 case TYPE_CODE_RANGE:
4142 case TYPE_CODE_ENUM:
4144 case TYPE_CODE_FIXED_POINT:
4152 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4155 discrete_type_p (struct type *type)
4161 switch (type->code ())
4164 case TYPE_CODE_RANGE:
4165 case TYPE_CODE_ENUM:
4166 case TYPE_CODE_BOOL:
4174 /* Returns non-zero if OP with operands in the vector ARGS could be
4175 a user-defined function. Errs on the side of pre-defined operators
4176 (i.e., result 0). */
4179 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4181 struct type *type0 =
4182 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4183 struct type *type1 =
4184 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4198 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4202 case BINOP_BITWISE_AND:
4203 case BINOP_BITWISE_IOR:
4204 case BINOP_BITWISE_XOR:
4205 return (!(integer_type_p (type0) && integer_type_p (type1)));
4208 case BINOP_NOTEQUAL:
4213 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4216 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4219 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4223 case UNOP_LOGICAL_NOT:
4225 return (!numeric_type_p (type0));
4234 1. In the following, we assume that a renaming type's name may
4235 have an ___XD suffix. It would be nice if this went away at some
4237 2. We handle both the (old) purely type-based representation of
4238 renamings and the (new) variable-based encoding. At some point,
4239 it is devoutly to be hoped that the former goes away
4240 (FIXME: hilfinger-2007-07-09).
4241 3. Subprogram renamings are not implemented, although the XRS
4242 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4244 /* If SYM encodes a renaming,
4246 <renaming> renames <renamed entity>,
4248 sets *LEN to the length of the renamed entity's name,
4249 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4250 the string describing the subcomponent selected from the renamed
4251 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4252 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4253 are undefined). Otherwise, returns a value indicating the category
4254 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4255 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4256 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4257 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4258 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4259 may be NULL, in which case they are not assigned.
4261 [Currently, however, GCC does not generate subprogram renamings.] */
4263 enum ada_renaming_category
4264 ada_parse_renaming (struct symbol *sym,
4265 const char **renamed_entity, int *len,
4266 const char **renaming_expr)
4268 enum ada_renaming_category kind;
4273 return ADA_NOT_RENAMING;
4274 switch (sym->aclass ())
4277 return ADA_NOT_RENAMING;
4281 case LOC_OPTIMIZED_OUT:
4282 info = strstr (sym->linkage_name (), "___XR");
4284 return ADA_NOT_RENAMING;
4288 kind = ADA_OBJECT_RENAMING;
4292 kind = ADA_EXCEPTION_RENAMING;
4296 kind = ADA_PACKAGE_RENAMING;
4300 kind = ADA_SUBPROGRAM_RENAMING;
4304 return ADA_NOT_RENAMING;
4308 if (renamed_entity != NULL)
4309 *renamed_entity = info;
4310 suffix = strstr (info, "___XE");
4311 if (suffix == NULL || suffix == info)
4312 return ADA_NOT_RENAMING;
4314 *len = strlen (info) - strlen (suffix);
4316 if (renaming_expr != NULL)
4317 *renaming_expr = suffix;
4321 /* Compute the value of the given RENAMING_SYM, which is expected to
4322 be a symbol encoding a renaming expression. BLOCK is the block
4323 used to evaluate the renaming. */
4325 static struct value *
4326 ada_read_renaming_var_value (struct symbol *renaming_sym,
4327 const struct block *block)
4329 const char *sym_name;
4331 sym_name = renaming_sym->linkage_name ();
4332 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4333 return evaluate_expression (expr.get ());
4337 /* Evaluation: Function Calls */
4339 /* Return an lvalue containing the value VAL. This is the identity on
4340 lvalues, and otherwise has the side-effect of allocating memory
4341 in the inferior where a copy of the value contents is copied. */
4343 static struct value *
4344 ensure_lval (struct value *val)
4346 if (VALUE_LVAL (val) == not_lval
4347 || VALUE_LVAL (val) == lval_internalvar)
4349 int len = ada_check_typedef (value_type (val))->length ();
4350 const CORE_ADDR addr =
4351 value_as_long (value_allocate_space_in_inferior (len));
4353 VALUE_LVAL (val) = lval_memory;
4354 set_value_address (val, addr);
4355 write_memory (addr, value_contents (val).data (), len);
4361 /* Given ARG, a value of type (pointer or reference to a)*
4362 structure/union, extract the component named NAME from the ultimate
4363 target structure/union and return it as a value with its
4366 The routine searches for NAME among all members of the structure itself
4367 and (recursively) among all members of any wrapper members
4370 If NO_ERR, then simply return NULL in case of error, rather than
4373 static struct value *
4374 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4376 struct type *t, *t1;
4381 t1 = t = ada_check_typedef (value_type (arg));
4382 if (t->code () == TYPE_CODE_REF)
4384 t1 = t->target_type ();
4387 t1 = ada_check_typedef (t1);
4388 if (t1->code () == TYPE_CODE_PTR)
4390 arg = coerce_ref (arg);
4395 while (t->code () == TYPE_CODE_PTR)
4397 t1 = t->target_type ();
4400 t1 = ada_check_typedef (t1);
4401 if (t1->code () == TYPE_CODE_PTR)
4403 arg = value_ind (arg);
4410 if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4414 v = ada_search_struct_field (name, arg, 0, t);
4417 int bit_offset, bit_size, byte_offset;
4418 struct type *field_type;
4421 if (t->code () == TYPE_CODE_PTR)
4422 address = value_address (ada_value_ind (arg));
4424 address = value_address (ada_coerce_ref (arg));
4426 /* Check to see if this is a tagged type. We also need to handle
4427 the case where the type is a reference to a tagged type, but
4428 we have to be careful to exclude pointers to tagged types.
4429 The latter should be shown as usual (as a pointer), whereas
4430 a reference should mostly be transparent to the user. */
4432 if (ada_is_tagged_type (t1, 0)
4433 || (t1->code () == TYPE_CODE_REF
4434 && ada_is_tagged_type (t1->target_type (), 0)))
4436 /* We first try to find the searched field in the current type.
4437 If not found then let's look in the fixed type. */
4439 if (!find_struct_field (name, t1, 0,
4440 nullptr, nullptr, nullptr,
4449 /* Convert to fixed type in all cases, so that we have proper
4450 offsets to each field in unconstrained record types. */
4451 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4452 address, NULL, check_tag);
4454 /* Resolve the dynamic type as well. */
4455 arg = value_from_contents_and_address (t1, nullptr, address);
4456 t1 = value_type (arg);
4458 if (find_struct_field (name, t1, 0,
4459 &field_type, &byte_offset, &bit_offset,
4464 if (t->code () == TYPE_CODE_REF)
4465 arg = ada_coerce_ref (arg);
4467 arg = ada_value_ind (arg);
4468 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4469 bit_offset, bit_size,
4473 v = value_at_lazy (field_type, address + byte_offset);
4477 if (v != NULL || no_err)
4480 error (_("There is no member named %s."), name);
4486 error (_("Attempt to extract a component of "
4487 "a value that is not a record."));
4490 /* Return the value ACTUAL, converted to be an appropriate value for a
4491 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4492 allocating any necessary descriptors (fat pointers), or copies of
4493 values not residing in memory, updating it as needed. */
4496 ada_convert_actual (struct value *actual, struct type *formal_type0)
4498 struct type *actual_type = ada_check_typedef (value_type (actual));
4499 struct type *formal_type = ada_check_typedef (formal_type0);
4500 struct type *formal_target =
4501 formal_type->code () == TYPE_CODE_PTR
4502 ? ada_check_typedef (formal_type->target_type ()) : formal_type;
4503 struct type *actual_target =
4504 actual_type->code () == TYPE_CODE_PTR
4505 ? ada_check_typedef (actual_type->target_type ()) : actual_type;
4507 if (ada_is_array_descriptor_type (formal_target)
4508 && actual_target->code () == TYPE_CODE_ARRAY)
4509 return make_array_descriptor (formal_type, actual);
4510 else if (formal_type->code () == TYPE_CODE_PTR
4511 || formal_type->code () == TYPE_CODE_REF)
4513 struct value *result;
4515 if (formal_target->code () == TYPE_CODE_ARRAY
4516 && ada_is_array_descriptor_type (actual_target))
4517 result = desc_data (actual);
4518 else if (formal_type->code () != TYPE_CODE_PTR)
4520 if (VALUE_LVAL (actual) != lval_memory)
4524 actual_type = ada_check_typedef (value_type (actual));
4525 val = allocate_value (actual_type);
4526 copy (value_contents (actual), value_contents_raw (val));
4527 actual = ensure_lval (val);
4529 result = value_addr (actual);
4533 return value_cast_pointers (formal_type, result, 0);
4535 else if (actual_type->code () == TYPE_CODE_PTR)
4536 return ada_value_ind (actual);
4537 else if (ada_is_aligner_type (formal_type))
4539 /* We need to turn this parameter into an aligner type
4541 struct value *aligner = allocate_value (formal_type);
4542 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4544 value_assign_to_component (aligner, component, actual);
4551 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4552 type TYPE. This is usually an inefficient no-op except on some targets
4553 (such as AVR) where the representation of a pointer and an address
4557 value_pointer (struct value *value, struct type *type)
4559 unsigned len = type->length ();
4560 gdb_byte *buf = (gdb_byte *) alloca (len);
4563 addr = value_address (value);
4564 gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4565 addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4570 /* Push a descriptor of type TYPE for array value ARR on the stack at
4571 *SP, updating *SP to reflect the new descriptor. Return either
4572 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4573 to-descriptor type rather than a descriptor type), a struct value *
4574 representing a pointer to this descriptor. */
4576 static struct value *
4577 make_array_descriptor (struct type *type, struct value *arr)
4579 struct type *bounds_type = desc_bounds_type (type);
4580 struct type *desc_type = desc_base_type (type);
4581 struct value *descriptor = allocate_value (desc_type);
4582 struct value *bounds = allocate_value (bounds_type);
4585 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4588 modify_field (value_type (bounds),
4589 value_contents_writeable (bounds).data (),
4590 ada_array_bound (arr, i, 0),
4591 desc_bound_bitpos (bounds_type, i, 0),
4592 desc_bound_bitsize (bounds_type, i, 0));
4593 modify_field (value_type (bounds),
4594 value_contents_writeable (bounds).data (),
4595 ada_array_bound (arr, i, 1),
4596 desc_bound_bitpos (bounds_type, i, 1),
4597 desc_bound_bitsize (bounds_type, i, 1));
4600 bounds = ensure_lval (bounds);
4602 modify_field (value_type (descriptor),
4603 value_contents_writeable (descriptor).data (),
4604 value_pointer (ensure_lval (arr),
4605 desc_type->field (0).type ()),
4606 fat_pntr_data_bitpos (desc_type),
4607 fat_pntr_data_bitsize (desc_type));
4609 modify_field (value_type (descriptor),
4610 value_contents_writeable (descriptor).data (),
4611 value_pointer (bounds,
4612 desc_type->field (1).type ()),
4613 fat_pntr_bounds_bitpos (desc_type),
4614 fat_pntr_bounds_bitsize (desc_type));
4616 descriptor = ensure_lval (descriptor);
4618 if (type->code () == TYPE_CODE_PTR)
4619 return value_addr (descriptor);
4624 /* Symbol Cache Module */
4626 /* Performance measurements made as of 2010-01-15 indicate that
4627 this cache does bring some noticeable improvements. Depending
4628 on the type of entity being printed, the cache can make it as much
4629 as an order of magnitude faster than without it.
4631 The descriptive type DWARF extension has significantly reduced
4632 the need for this cache, at least when DWARF is being used. However,
4633 even in this case, some expensive name-based symbol searches are still
4634 sometimes necessary - to find an XVZ variable, mostly. */
4636 /* Return the symbol cache associated to the given program space PSPACE.
4637 If not allocated for this PSPACE yet, allocate and initialize one. */
4639 static struct ada_symbol_cache *
4640 ada_get_symbol_cache (struct program_space *pspace)
4642 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4644 if (pspace_data->sym_cache == nullptr)
4645 pspace_data->sym_cache.reset (new ada_symbol_cache);
4647 return pspace_data->sym_cache.get ();
4650 /* Clear all entries from the symbol cache. */
4653 ada_clear_symbol_cache ()
4655 struct ada_pspace_data *pspace_data
4656 = get_ada_pspace_data (current_program_space);
4658 if (pspace_data->sym_cache != nullptr)
4659 pspace_data->sym_cache.reset ();
4662 /* Search our cache for an entry matching NAME and DOMAIN.
4663 Return it if found, or NULL otherwise. */
4665 static struct cache_entry **
4666 find_entry (const char *name, domain_enum domain)
4668 struct ada_symbol_cache *sym_cache
4669 = ada_get_symbol_cache (current_program_space);
4670 int h = msymbol_hash (name) % HASH_SIZE;
4671 struct cache_entry **e;
4673 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4675 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4681 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4682 Return 1 if found, 0 otherwise.
4684 If an entry was found and SYM is not NULL, set *SYM to the entry's
4685 SYM. Same principle for BLOCK if not NULL. */
4688 lookup_cached_symbol (const char *name, domain_enum domain,
4689 struct symbol **sym, const struct block **block)
4691 struct cache_entry **e = find_entry (name, domain);
4698 *block = (*e)->block;
4702 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4703 in domain DOMAIN, save this result in our symbol cache. */
4706 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4707 const struct block *block)
4709 struct ada_symbol_cache *sym_cache
4710 = ada_get_symbol_cache (current_program_space);
4712 struct cache_entry *e;
4714 /* Symbols for builtin types don't have a block.
4715 For now don't cache such symbols. */
4716 if (sym != NULL && !sym->is_objfile_owned ())
4719 /* If the symbol is a local symbol, then do not cache it, as a search
4720 for that symbol depends on the context. To determine whether
4721 the symbol is local or not, we check the block where we found it
4722 against the global and static blocks of its associated symtab. */
4725 const blockvector &bv = *sym->symtab ()->compunit ()->blockvector ();
4727 if (bv.global_block () != block && bv.static_block () != block)
4731 h = msymbol_hash (name) % HASH_SIZE;
4732 e = XOBNEW (&sym_cache->cache_space, cache_entry);
4733 e->next = sym_cache->root[h];
4734 sym_cache->root[h] = e;
4735 e->name = obstack_strdup (&sym_cache->cache_space, name);
4743 /* Return the symbol name match type that should be used used when
4744 searching for all symbols matching LOOKUP_NAME.
4746 LOOKUP_NAME is expected to be a symbol name after transformation
4749 static symbol_name_match_type
4750 name_match_type_from_name (const char *lookup_name)
4752 return (strstr (lookup_name, "__") == NULL
4753 ? symbol_name_match_type::WILD
4754 : symbol_name_match_type::FULL);
4757 /* Return the result of a standard (literal, C-like) lookup of NAME in
4758 given DOMAIN, visible from lexical block BLOCK. */
4760 static struct symbol *
4761 standard_lookup (const char *name, const struct block *block,
4764 /* Initialize it just to avoid a GCC false warning. */
4765 struct block_symbol sym = {};
4767 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4769 ada_lookup_encoded_symbol (name, block, domain, &sym);
4770 cache_symbol (name, domain, sym.symbol, sym.block);
4775 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4776 in the symbol fields of SYMS. We treat enumerals as functions,
4777 since they contend in overloading in the same way. */
4779 is_nonfunction (const std::vector<struct block_symbol> &syms)
4781 for (const block_symbol &sym : syms)
4782 if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4783 && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4784 || sym.symbol->aclass () != LOC_CONST))
4790 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4791 struct types. Otherwise, they may not. */
4794 equiv_types (struct type *type0, struct type *type1)
4798 if (type0 == NULL || type1 == NULL
4799 || type0->code () != type1->code ())
4801 if ((type0->code () == TYPE_CODE_STRUCT
4802 || type0->code () == TYPE_CODE_ENUM)
4803 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4804 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4810 /* True iff SYM0 represents the same entity as SYM1, or one that is
4811 no more defined than that of SYM1. */
4814 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4818 if (sym0->domain () != sym1->domain ()
4819 || sym0->aclass () != sym1->aclass ())
4822 switch (sym0->aclass ())
4828 struct type *type0 = sym0->type ();
4829 struct type *type1 = sym1->type ();
4830 const char *name0 = sym0->linkage_name ();
4831 const char *name1 = sym1->linkage_name ();
4832 int len0 = strlen (name0);
4835 type0->code () == type1->code ()
4836 && (equiv_types (type0, type1)
4837 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4838 && startswith (name1 + len0, "___XV")));
4841 return sym0->value_longest () == sym1->value_longest ()
4842 && equiv_types (sym0->type (), sym1->type ());
4846 const char *name0 = sym0->linkage_name ();
4847 const char *name1 = sym1->linkage_name ();
4848 return (strcmp (name0, name1) == 0
4849 && sym0->value_address () == sym1->value_address ());
4857 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4858 records in RESULT. Do nothing if SYM is a duplicate. */
4861 add_defn_to_vec (std::vector<struct block_symbol> &result,
4863 const struct block *block)
4865 /* Do not try to complete stub types, as the debugger is probably
4866 already scanning all symbols matching a certain name at the
4867 time when this function is called. Trying to replace the stub
4868 type by its associated full type will cause us to restart a scan
4869 which may lead to an infinite recursion. Instead, the client
4870 collecting the matching symbols will end up collecting several
4871 matches, with at least one of them complete. It can then filter
4872 out the stub ones if needed. */
4874 for (int i = result.size () - 1; i >= 0; i -= 1)
4876 if (lesseq_defined_than (sym, result[i].symbol))
4878 else if (lesseq_defined_than (result[i].symbol, sym))
4880 result[i].symbol = sym;
4881 result[i].block = block;
4886 struct block_symbol info;
4889 result.push_back (info);
4892 /* Return a bound minimal symbol matching NAME according to Ada
4893 decoding rules. Returns an invalid symbol if there is no such
4894 minimal symbol. Names prefixed with "standard__" are handled
4895 specially: "standard__" is first stripped off, and only static and
4896 global symbols are searched. */
4898 struct bound_minimal_symbol
4899 ada_lookup_simple_minsym (const char *name)
4901 struct bound_minimal_symbol result;
4903 symbol_name_match_type match_type = name_match_type_from_name (name);
4904 lookup_name_info lookup_name (name, match_type);
4906 symbol_name_matcher_ftype *match_name
4907 = ada_get_symbol_name_matcher (lookup_name);
4909 for (objfile *objfile : current_program_space->objfiles ())
4911 for (minimal_symbol *msymbol : objfile->msymbols ())
4913 if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4914 && msymbol->type () != mst_solib_trampoline)
4916 result.minsym = msymbol;
4917 result.objfile = objfile;
4926 /* True if TYPE is definitely an artificial type supplied to a symbol
4927 for which no debugging information was given in the symbol file. */
4930 is_nondebugging_type (struct type *type)
4932 const char *name = ada_type_name (type);
4934 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4937 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4938 that are deemed "identical" for practical purposes.
4940 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4941 types and that their number of enumerals is identical (in other
4942 words, type1->num_fields () == type2->num_fields ()). */
4945 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4949 /* The heuristic we use here is fairly conservative. We consider
4950 that 2 enumerate types are identical if they have the same
4951 number of enumerals and that all enumerals have the same
4952 underlying value and name. */
4954 /* All enums in the type should have an identical underlying value. */
4955 for (i = 0; i < type1->num_fields (); i++)
4956 if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4959 /* All enumerals should also have the same name (modulo any numerical
4961 for (i = 0; i < type1->num_fields (); i++)
4963 const char *name_1 = type1->field (i).name ();
4964 const char *name_2 = type2->field (i).name ();
4965 int len_1 = strlen (name_1);
4966 int len_2 = strlen (name_2);
4968 ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4969 ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4971 || strncmp (type1->field (i).name (),
4972 type2->field (i).name (),
4980 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4981 that are deemed "identical" for practical purposes. Sometimes,
4982 enumerals are not strictly identical, but their types are so similar
4983 that they can be considered identical.
4985 For instance, consider the following code:
4987 type Color is (Black, Red, Green, Blue, White);
4988 type RGB_Color is new Color range Red .. Blue;
4990 Type RGB_Color is a subrange of an implicit type which is a copy
4991 of type Color. If we call that implicit type RGB_ColorB ("B" is
4992 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4993 As a result, when an expression references any of the enumeral
4994 by name (Eg. "print green"), the expression is technically
4995 ambiguous and the user should be asked to disambiguate. But
4996 doing so would only hinder the user, since it wouldn't matter
4997 what choice he makes, the outcome would always be the same.
4998 So, for practical purposes, we consider them as the same. */
5001 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5005 /* Before performing a thorough comparison check of each type,
5006 we perform a series of inexpensive checks. We expect that these
5007 checks will quickly fail in the vast majority of cases, and thus
5008 help prevent the unnecessary use of a more expensive comparison.
5009 Said comparison also expects us to make some of these checks
5010 (see ada_identical_enum_types_p). */
5012 /* Quick check: All symbols should have an enum type. */
5013 for (i = 0; i < syms.size (); i++)
5014 if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5017 /* Quick check: They should all have the same value. */
5018 for (i = 1; i < syms.size (); i++)
5019 if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5022 /* Quick check: They should all have the same number of enumerals. */
5023 for (i = 1; i < syms.size (); i++)
5024 if (syms[i].symbol->type ()->num_fields ()
5025 != syms[0].symbol->type ()->num_fields ())
5028 /* All the sanity checks passed, so we might have a set of
5029 identical enumeration types. Perform a more complete
5030 comparison of the type of each symbol. */
5031 for (i = 1; i < syms.size (); i++)
5032 if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5033 syms[0].symbol->type ()))
5039 /* Remove any non-debugging symbols in SYMS that definitely
5040 duplicate other symbols in the list (The only case I know of where
5041 this happens is when object files containing stabs-in-ecoff are
5042 linked with files containing ordinary ecoff debugging symbols (or no
5043 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
5046 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5050 /* We should never be called with less than 2 symbols, as there
5051 cannot be any extra symbol in that case. But it's easy to
5052 handle, since we have nothing to do in that case. */
5053 if (syms->size () < 2)
5057 while (i < syms->size ())
5061 /* If two symbols have the same name and one of them is a stub type,
5062 the get rid of the stub. */
5064 if ((*syms)[i].symbol->type ()->is_stub ()
5065 && (*syms)[i].symbol->linkage_name () != NULL)
5067 for (j = 0; j < syms->size (); j++)
5070 && !(*syms)[j].symbol->type ()->is_stub ()
5071 && (*syms)[j].symbol->linkage_name () != NULL
5072 && strcmp ((*syms)[i].symbol->linkage_name (),
5073 (*syms)[j].symbol->linkage_name ()) == 0)
5078 /* Two symbols with the same name, same class and same address
5079 should be identical. */
5081 else if ((*syms)[i].symbol->linkage_name () != NULL
5082 && (*syms)[i].symbol->aclass () == LOC_STATIC
5083 && is_nondebugging_type ((*syms)[i].symbol->type ()))
5085 for (j = 0; j < syms->size (); j += 1)
5088 && (*syms)[j].symbol->linkage_name () != NULL
5089 && strcmp ((*syms)[i].symbol->linkage_name (),
5090 (*syms)[j].symbol->linkage_name ()) == 0
5091 && ((*syms)[i].symbol->aclass ()
5092 == (*syms)[j].symbol->aclass ())
5093 && (*syms)[i].symbol->value_address ()
5094 == (*syms)[j].symbol->value_address ())
5100 syms->erase (syms->begin () + i);
5105 /* If all the remaining symbols are identical enumerals, then
5106 just keep the first one and discard the rest.
5108 Unlike what we did previously, we do not discard any entry
5109 unless they are ALL identical. This is because the symbol
5110 comparison is not a strict comparison, but rather a practical
5111 comparison. If all symbols are considered identical, then
5112 we can just go ahead and use the first one and discard the rest.
5113 But if we cannot reduce the list to a single element, we have
5114 to ask the user to disambiguate anyways. And if we have to
5115 present a multiple-choice menu, it's less confusing if the list
5116 isn't missing some choices that were identical and yet distinct. */
5117 if (symbols_are_identical_enums (*syms))
5121 /* Given a type that corresponds to a renaming entity, use the type name
5122 to extract the scope (package name or function name, fully qualified,
5123 and following the GNAT encoding convention) where this renaming has been
5127 xget_renaming_scope (struct type *renaming_type)
5129 /* The renaming types adhere to the following convention:
5130 <scope>__<rename>___<XR extension>.
5131 So, to extract the scope, we search for the "___XR" extension,
5132 and then backtrack until we find the first "__". */
5134 const char *name = renaming_type->name ();
5135 const char *suffix = strstr (name, "___XR");
5138 /* Now, backtrack a bit until we find the first "__". Start looking
5139 at suffix - 3, as the <rename> part is at least one character long. */
5141 for (last = suffix - 3; last > name; last--)
5142 if (last[0] == '_' && last[1] == '_')
5145 /* Make a copy of scope and return it. */
5146 return std::string (name, last);
5149 /* Return nonzero if NAME corresponds to a package name. */
5152 is_package_name (const char *name)
5154 /* Here, We take advantage of the fact that no symbols are generated
5155 for packages, while symbols are generated for each function.
5156 So the condition for NAME represent a package becomes equivalent
5157 to NAME not existing in our list of symbols. There is only one
5158 small complication with library-level functions (see below). */
5160 /* If it is a function that has not been defined at library level,
5161 then we should be able to look it up in the symbols. */
5162 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5165 /* Library-level function names start with "_ada_". See if function
5166 "_ada_" followed by NAME can be found. */
5168 /* Do a quick check that NAME does not contain "__", since library-level
5169 functions names cannot contain "__" in them. */
5170 if (strstr (name, "__") != NULL)
5173 std::string fun_name = string_printf ("_ada_%s", name);
5175 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5178 /* Return nonzero if SYM corresponds to a renaming entity that is
5179 not visible from FUNCTION_NAME. */
5182 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5184 if (sym->aclass () != LOC_TYPEDEF)
5187 std::string scope = xget_renaming_scope (sym->type ());
5189 /* If the rename has been defined in a package, then it is visible. */
5190 if (is_package_name (scope.c_str ()))
5193 /* Check that the rename is in the current function scope by checking
5194 that its name starts with SCOPE. */
5196 /* If the function name starts with "_ada_", it means that it is
5197 a library-level function. Strip this prefix before doing the
5198 comparison, as the encoding for the renaming does not contain
5200 if (startswith (function_name, "_ada_"))
5203 return !startswith (function_name, scope.c_str ());
5206 /* Remove entries from SYMS that corresponds to a renaming entity that
5207 is not visible from the function associated with CURRENT_BLOCK or
5208 that is superfluous due to the presence of more specific renaming
5209 information. Places surviving symbols in the initial entries of
5213 First, in cases where an object renaming is implemented as a
5214 reference variable, GNAT may produce both the actual reference
5215 variable and the renaming encoding. In this case, we discard the
5218 Second, GNAT emits a type following a specified encoding for each renaming
5219 entity. Unfortunately, STABS currently does not support the definition
5220 of types that are local to a given lexical block, so all renamings types
5221 are emitted at library level. As a consequence, if an application
5222 contains two renaming entities using the same name, and a user tries to
5223 print the value of one of these entities, the result of the ada symbol
5224 lookup will also contain the wrong renaming type.
5226 This function partially covers for this limitation by attempting to
5227 remove from the SYMS list renaming symbols that should be visible
5228 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5229 method with the current information available. The implementation
5230 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5232 - When the user tries to print a rename in a function while there
5233 is another rename entity defined in a package: Normally, the
5234 rename in the function has precedence over the rename in the
5235 package, so the latter should be removed from the list. This is
5236 currently not the case.
5238 - This function will incorrectly remove valid renames if
5239 the CURRENT_BLOCK corresponds to a function which symbol name
5240 has been changed by an "Export" pragma. As a consequence,
5241 the user will be unable to print such rename entities. */
5244 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5245 const struct block *current_block)
5247 struct symbol *current_function;
5248 const char *current_function_name;
5250 int is_new_style_renaming;
5252 /* If there is both a renaming foo___XR... encoded as a variable and
5253 a simple variable foo in the same block, discard the latter.
5254 First, zero out such symbols, then compress. */
5255 is_new_style_renaming = 0;
5256 for (i = 0; i < syms->size (); i += 1)
5258 struct symbol *sym = (*syms)[i].symbol;
5259 const struct block *block = (*syms)[i].block;
5263 if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5265 name = sym->linkage_name ();
5266 suffix = strstr (name, "___XR");
5270 int name_len = suffix - name;
5273 is_new_style_renaming = 1;
5274 for (j = 0; j < syms->size (); j += 1)
5275 if (i != j && (*syms)[j].symbol != NULL
5276 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5278 && block == (*syms)[j].block)
5279 (*syms)[j].symbol = NULL;
5282 if (is_new_style_renaming)
5286 for (j = k = 0; j < syms->size (); j += 1)
5287 if ((*syms)[j].symbol != NULL)
5289 (*syms)[k] = (*syms)[j];
5296 /* Extract the function name associated to CURRENT_BLOCK.
5297 Abort if unable to do so. */
5299 if (current_block == NULL)
5302 current_function = block_linkage_function (current_block);
5303 if (current_function == NULL)
5306 current_function_name = current_function->linkage_name ();
5307 if (current_function_name == NULL)
5310 /* Check each of the symbols, and remove it from the list if it is
5311 a type corresponding to a renaming that is out of the scope of
5312 the current block. */
5315 while (i < syms->size ())
5317 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5318 == ADA_OBJECT_RENAMING
5319 && old_renaming_is_invisible ((*syms)[i].symbol,
5320 current_function_name))
5321 syms->erase (syms->begin () + i);
5327 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5328 whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5330 Note: This function assumes that RESULT is empty. */
5333 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5334 const lookup_name_info &lookup_name,
5335 const struct block *block, domain_enum domain)
5337 while (block != NULL)
5339 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5341 /* If we found a non-function match, assume that's the one. We
5342 only check this when finding a function boundary, so that we
5343 can accumulate all results from intervening blocks first. */
5344 if (block->function () != nullptr && is_nonfunction (result))
5347 block = block->superblock ();
5351 /* An object of this type is used as the callback argument when
5352 calling the map_matching_symbols method. */
5356 explicit match_data (std::vector<struct block_symbol> *rp)
5360 DISABLE_COPY_AND_ASSIGN (match_data);
5362 bool operator() (struct block_symbol *bsym);
5364 struct objfile *objfile = nullptr;
5365 std::vector<struct block_symbol> *resultp;
5366 struct symbol *arg_sym = nullptr;
5367 bool found_sym = false;
5370 /* A callback for add_nonlocal_symbols that adds symbol, found in
5371 BSYM, to a list of symbols. */
5374 match_data::operator() (struct block_symbol *bsym)
5376 const struct block *block = bsym->block;
5377 struct symbol *sym = bsym->symbol;
5381 if (!found_sym && arg_sym != NULL)
5382 add_defn_to_vec (*resultp,
5383 fixup_symbol_section (arg_sym, objfile),
5390 if (sym->aclass () == LOC_UNRESOLVED)
5392 else if (sym->is_argument ())
5397 add_defn_to_vec (*resultp,
5398 fixup_symbol_section (sym, objfile),
5405 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5406 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5407 symbols to RESULT. Return whether we found such symbols. */
5410 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5411 const struct block *block,
5412 const lookup_name_info &lookup_name,
5415 struct using_direct *renaming;
5416 int defns_mark = result.size ();
5418 symbol_name_matcher_ftype *name_match
5419 = ada_get_symbol_name_matcher (lookup_name);
5421 for (renaming = block_using (block);
5423 renaming = renaming->next)
5427 /* Avoid infinite recursions: skip this renaming if we are actually
5428 already traversing it.
5430 Currently, symbol lookup in Ada don't use the namespace machinery from
5431 C++/Fortran support: skip namespace imports that use them. */
5432 if (renaming->searched
5433 || (renaming->import_src != NULL
5434 && renaming->import_src[0] != '\0')
5435 || (renaming->import_dest != NULL
5436 && renaming->import_dest[0] != '\0'))
5438 renaming->searched = 1;
5440 /* TODO: here, we perform another name-based symbol lookup, which can
5441 pull its own multiple overloads. In theory, we should be able to do
5442 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5443 not a simple name. But in order to do this, we would need to enhance
5444 the DWARF reader to associate a symbol to this renaming, instead of a
5445 name. So, for now, we do something simpler: re-use the C++/Fortran
5446 namespace machinery. */
5447 r_name = (renaming->alias != NULL
5449 : renaming->declaration);
5450 if (name_match (r_name, lookup_name, NULL))
5452 lookup_name_info decl_lookup_name (renaming->declaration,
5453 lookup_name.match_type ());
5454 ada_add_all_symbols (result, block, decl_lookup_name, domain,
5457 renaming->searched = 0;
5459 return result.size () != defns_mark;
5462 /* Implements compare_names, but only applying the comparision using
5463 the given CASING. */
5466 compare_names_with_case (const char *string1, const char *string2,
5467 enum case_sensitivity casing)
5469 while (*string1 != '\0' && *string2 != '\0')
5473 if (isspace (*string1) || isspace (*string2))
5474 return strcmp_iw_ordered (string1, string2);
5476 if (casing == case_sensitive_off)
5478 c1 = tolower (*string1);
5479 c2 = tolower (*string2);
5496 return strcmp_iw_ordered (string1, string2);
5498 if (*string2 == '\0')
5500 if (is_name_suffix (string1))
5507 if (*string2 == '(')
5508 return strcmp_iw_ordered (string1, string2);
5511 if (casing == case_sensitive_off)
5512 return tolower (*string1) - tolower (*string2);
5514 return *string1 - *string2;
5519 /* Compare STRING1 to STRING2, with results as for strcmp.
5520 Compatible with strcmp_iw_ordered in that...
5522 strcmp_iw_ordered (STRING1, STRING2) <= 0
5526 compare_names (STRING1, STRING2) <= 0
5528 (they may differ as to what symbols compare equal). */
5531 compare_names (const char *string1, const char *string2)
5535 /* Similar to what strcmp_iw_ordered does, we need to perform
5536 a case-insensitive comparison first, and only resort to
5537 a second, case-sensitive, comparison if the first one was
5538 not sufficient to differentiate the two strings. */
5540 result = compare_names_with_case (string1, string2, case_sensitive_off);
5542 result = compare_names_with_case (string1, string2, case_sensitive_on);
5547 /* Convenience function to get at the Ada encoded lookup name for
5548 LOOKUP_NAME, as a C string. */
5551 ada_lookup_name (const lookup_name_info &lookup_name)
5553 return lookup_name.ada ().lookup_name ().c_str ();
5556 /* A helper for add_nonlocal_symbols. Call expand_matching_symbols
5557 for OBJFILE, then walk the objfile's symtabs and update the
5561 map_matching_symbols (struct objfile *objfile,
5562 const lookup_name_info &lookup_name,
5568 data.objfile = objfile;
5569 objfile->expand_matching_symbols (lookup_name, domain, global,
5570 is_wild_match ? nullptr : compare_names);
5572 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5573 for (compunit_symtab *symtab : objfile->compunits ())
5575 const struct block *block
5576 = symtab->blockvector ()->block (block_kind);
5577 if (!iterate_over_symbols_terminated (block, lookup_name,
5583 /* Add to RESULT all non-local symbols whose name and domain match
5584 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5585 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5586 symbols otherwise. */
5589 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5590 const lookup_name_info &lookup_name,
5591 domain_enum domain, int global)
5593 struct match_data data (&result);
5595 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5597 for (objfile *objfile : current_program_space->objfiles ())
5599 map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5602 for (compunit_symtab *cu : objfile->compunits ())
5604 const struct block *global_block
5605 = cu->blockvector ()->global_block ();
5607 if (ada_add_block_renamings (result, global_block, lookup_name,
5609 data.found_sym = true;
5613 if (result.empty () && global && !is_wild_match)
5615 const char *name = ada_lookup_name (lookup_name);
5616 std::string bracket_name = std::string ("<_ada_") + name + '>';
5617 lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5619 for (objfile *objfile : current_program_space->objfiles ())
5620 map_matching_symbols (objfile, name1, false, domain, global, data);
5624 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5625 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5626 returning the number of matches. Add these to RESULT.
5628 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5629 symbol match within the nest of blocks whose innermost member is BLOCK,
5630 is the one match returned (no other matches in that or
5631 enclosing blocks is returned). If there are any matches in or
5632 surrounding BLOCK, then these alone are returned.
5634 Names prefixed with "standard__" are handled specially:
5635 "standard__" is first stripped off (by the lookup_name
5636 constructor), and only static and global symbols are searched.
5638 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5639 to lookup global symbols. */
5642 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5643 const struct block *block,
5644 const lookup_name_info &lookup_name,
5647 int *made_global_lookup_p)
5651 if (made_global_lookup_p)
5652 *made_global_lookup_p = 0;
5654 /* Special case: If the user specifies a symbol name inside package
5655 Standard, do a non-wild matching of the symbol name without
5656 the "standard__" prefix. This was primarily introduced in order
5657 to allow the user to specifically access the standard exceptions
5658 using, for instance, Standard.Constraint_Error when Constraint_Error
5659 is ambiguous (due to the user defining its own Constraint_Error
5660 entity inside its program). */
5661 if (lookup_name.ada ().standard_p ())
5664 /* Check the non-global symbols. If we have ANY match, then we're done. */
5669 ada_add_local_symbols (result, lookup_name, block, domain);
5672 /* In the !full_search case we're are being called by
5673 iterate_over_symbols, and we don't want to search
5675 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5677 if (!result.empty () || !full_search)
5681 /* No non-global symbols found. Check our cache to see if we have
5682 already performed this search before. If we have, then return
5685 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5686 domain, &sym, &block))
5689 add_defn_to_vec (result, sym, block);
5693 if (made_global_lookup_p)
5694 *made_global_lookup_p = 1;
5696 /* Search symbols from all global blocks. */
5698 add_nonlocal_symbols (result, lookup_name, domain, 1);
5700 /* Now add symbols from all per-file blocks if we've gotten no hits
5701 (not strictly correct, but perhaps better than an error). */
5703 if (result.empty ())
5704 add_nonlocal_symbols (result, lookup_name, domain, 0);
5707 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5708 is non-zero, enclosing scope and in global scopes.
5710 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5711 blocks and symbol tables (if any) in which they were found.
5713 When full_search is non-zero, any non-function/non-enumeral
5714 symbol match within the nest of blocks whose innermost member is BLOCK,
5715 is the one match returned (no other matches in that or
5716 enclosing blocks is returned). If there are any matches in or
5717 surrounding BLOCK, then these alone are returned.
5719 Names prefixed with "standard__" are handled specially: "standard__"
5720 is first stripped off, and only static and global symbols are searched. */
5722 static std::vector<struct block_symbol>
5723 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5724 const struct block *block,
5728 int syms_from_global_search;
5729 std::vector<struct block_symbol> results;
5731 ada_add_all_symbols (results, block, lookup_name,
5732 domain, full_search, &syms_from_global_search);
5734 remove_extra_symbols (&results);
5736 if (results.empty () && full_search && syms_from_global_search)
5737 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5739 if (results.size () == 1 && full_search && syms_from_global_search)
5740 cache_symbol (ada_lookup_name (lookup_name), domain,
5741 results[0].symbol, results[0].block);
5743 remove_irrelevant_renamings (&results, block);
5747 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5748 in global scopes, returning (SYM,BLOCK) tuples.
5750 See ada_lookup_symbol_list_worker for further details. */
5752 std::vector<struct block_symbol>
5753 ada_lookup_symbol_list (const char *name, const struct block *block,
5756 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5757 lookup_name_info lookup_name (name, name_match_type);
5759 return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5762 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5763 to 1, but choosing the first symbol found if there are multiple
5766 The result is stored in *INFO, which must be non-NULL.
5767 If no match is found, INFO->SYM is set to NULL. */
5770 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5772 struct block_symbol *info)
5774 /* Since we already have an encoded name, wrap it in '<>' to force a
5775 verbatim match. Otherwise, if the name happens to not look like
5776 an encoded name (because it doesn't include a "__"),
5777 ada_lookup_name_info would re-encode/fold it again, and that
5778 would e.g., incorrectly lowercase object renaming names like
5779 "R28b" -> "r28b". */
5780 std::string verbatim = add_angle_brackets (name);
5782 gdb_assert (info != NULL);
5783 *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5786 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5787 scope and in global scopes, or NULL if none. NAME is folded and
5788 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5789 choosing the first symbol if there are multiple choices. */
5792 ada_lookup_symbol (const char *name, const struct block *block0,
5795 std::vector<struct block_symbol> candidates
5796 = ada_lookup_symbol_list (name, block0, domain);
5798 if (candidates.empty ())
5801 block_symbol info = candidates[0];
5802 info.symbol = fixup_symbol_section (info.symbol, NULL);
5807 /* True iff STR is a possible encoded suffix of a normal Ada name
5808 that is to be ignored for matching purposes. Suffixes of parallel
5809 names (e.g., XVE) are not included here. Currently, the possible suffixes
5810 are given by any of the regular expressions:
5812 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5813 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5814 TKB [subprogram suffix for task bodies]
5815 _E[0-9]+[bs]$ [protected object entry suffixes]
5816 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5818 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5819 match is performed. This sequence is used to differentiate homonyms,
5820 is an optional part of a valid name suffix. */
5823 is_name_suffix (const char *str)
5826 const char *matching;
5827 const int len = strlen (str);
5829 /* Skip optional leading __[0-9]+. */
5831 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5834 while (isdigit (str[0]))
5840 if (str[0] == '.' || str[0] == '$')
5843 while (isdigit (matching[0]))
5845 if (matching[0] == '\0')
5851 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5854 while (isdigit (matching[0]))
5856 if (matching[0] == '\0')
5860 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5862 if (strcmp (str, "TKB") == 0)
5866 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5867 with a N at the end. Unfortunately, the compiler uses the same
5868 convention for other internal types it creates. So treating
5869 all entity names that end with an "N" as a name suffix causes
5870 some regressions. For instance, consider the case of an enumerated
5871 type. To support the 'Image attribute, it creates an array whose
5873 Having a single character like this as a suffix carrying some
5874 information is a bit risky. Perhaps we should change the encoding
5875 to be something like "_N" instead. In the meantime, do not do
5876 the following check. */
5877 /* Protected Object Subprograms */
5878 if (len == 1 && str [0] == 'N')
5883 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5886 while (isdigit (matching[0]))
5888 if ((matching[0] == 'b' || matching[0] == 's')
5889 && matching [1] == '\0')
5893 /* ??? We should not modify STR directly, as we are doing below. This
5894 is fine in this case, but may become problematic later if we find
5895 that this alternative did not work, and want to try matching
5896 another one from the begining of STR. Since we modified it, we
5897 won't be able to find the begining of the string anymore! */
5901 while (str[0] != '_' && str[0] != '\0')
5903 if (str[0] != 'n' && str[0] != 'b')
5909 if (str[0] == '\000')
5914 if (str[1] != '_' || str[2] == '\000')
5918 if (strcmp (str + 3, "JM") == 0)
5920 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5921 the LJM suffix in favor of the JM one. But we will
5922 still accept LJM as a valid suffix for a reasonable
5923 amount of time, just to allow ourselves to debug programs
5924 compiled using an older version of GNAT. */
5925 if (strcmp (str + 3, "LJM") == 0)
5929 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5930 || str[4] == 'U' || str[4] == 'P')
5932 if (str[4] == 'R' && str[5] != 'T')
5936 if (!isdigit (str[2]))
5938 for (k = 3; str[k] != '\0'; k += 1)
5939 if (!isdigit (str[k]) && str[k] != '_')
5943 if (str[0] == '$' && isdigit (str[1]))
5945 for (k = 2; str[k] != '\0'; k += 1)
5946 if (!isdigit (str[k]) && str[k] != '_')
5953 /* Return non-zero if the string starting at NAME and ending before
5954 NAME_END contains no capital letters. */
5957 is_valid_name_for_wild_match (const char *name0)
5959 std::string decoded_name = ada_decode (name0);
5962 /* If the decoded name starts with an angle bracket, it means that
5963 NAME0 does not follow the GNAT encoding format. It should then
5964 not be allowed as a possible wild match. */
5965 if (decoded_name[0] == '<')
5968 for (i=0; decoded_name[i] != '\0'; i++)
5969 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5975 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5976 character which could start a simple name. Assumes that *NAMEP points
5977 somewhere inside the string beginning at NAME0. */
5980 advance_wild_match (const char **namep, const char *name0, char target0)
5982 const char *name = *namep;
5992 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5995 if (name == name0 + 5 && startswith (name0, "_ada"))
6000 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6001 || name[2] == target0))
6006 else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6008 /* Names like "pkg__B_N__name", where N is a number, are
6009 block-local. We can handle these by simply skipping
6016 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6026 /* Return true iff NAME encodes a name of the form prefix.PATN.
6027 Ignores any informational suffixes of NAME (i.e., for which
6028 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6032 wild_match (const char *name, const char *patn)
6035 const char *name0 = name;
6037 if (startswith (name, "___ghost_"))
6042 const char *match = name;
6046 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6049 if (*p == '\0' && is_name_suffix (name))
6050 return match == name0 || is_valid_name_for_wild_match (name0);
6052 if (name[-1] == '_')
6055 if (!advance_wild_match (&name, name0, *patn))
6060 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6061 necessary). OBJFILE is the section containing BLOCK. */
6064 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6065 const struct block *block,
6066 const lookup_name_info &lookup_name,
6067 domain_enum domain, struct objfile *objfile)
6069 struct block_iterator iter;
6070 /* A matching argument symbol, if any. */
6071 struct symbol *arg_sym;
6072 /* Set true when we find a matching non-argument symbol. */
6078 for (sym = block_iter_match_first (block, lookup_name, &iter);
6080 sym = block_iter_match_next (lookup_name, &iter))
6082 if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6084 if (sym->aclass () != LOC_UNRESOLVED)
6086 if (sym->is_argument ())
6091 add_defn_to_vec (result,
6092 fixup_symbol_section (sym, objfile),
6099 /* Handle renamings. */
6101 if (ada_add_block_renamings (result, block, lookup_name, domain))
6104 if (!found_sym && arg_sym != NULL)
6106 add_defn_to_vec (result,
6107 fixup_symbol_section (arg_sym, objfile),
6111 if (!lookup_name.ada ().wild_match_p ())
6115 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6116 const char *name = ada_lookup_name.c_str ();
6117 size_t name_len = ada_lookup_name.size ();
6119 ALL_BLOCK_SYMBOLS (block, iter, sym)
6121 if (symbol_matches_domain (sym->language (),
6122 sym->domain (), domain))
6126 cmp = (int) '_' - (int) sym->linkage_name ()[0];
6129 cmp = !startswith (sym->linkage_name (), "_ada_");
6131 cmp = strncmp (name, sym->linkage_name () + 5,
6136 && is_name_suffix (sym->linkage_name () + name_len + 5))
6138 if (sym->aclass () != LOC_UNRESOLVED)
6140 if (sym->is_argument ())
6145 add_defn_to_vec (result,
6146 fixup_symbol_section (sym, objfile),
6154 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6155 They aren't parameters, right? */
6156 if (!found_sym && arg_sym != NULL)
6158 add_defn_to_vec (result,
6159 fixup_symbol_section (arg_sym, objfile),
6166 /* Symbol Completion */
6171 ada_lookup_name_info::matches
6172 (const char *sym_name,
6173 symbol_name_match_type match_type,
6174 completion_match_result *comp_match_res) const
6177 const char *text = m_encoded_name.c_str ();
6178 size_t text_len = m_encoded_name.size ();
6180 /* First, test against the fully qualified name of the symbol. */
6182 if (strncmp (sym_name, text, text_len) == 0)
6185 std::string decoded_name = ada_decode (sym_name);
6186 if (match && !m_encoded_p)
6188 /* One needed check before declaring a positive match is to verify
6189 that iff we are doing a verbatim match, the decoded version
6190 of the symbol name starts with '<'. Otherwise, this symbol name
6191 is not a suitable completion. */
6193 bool has_angle_bracket = (decoded_name[0] == '<');
6194 match = (has_angle_bracket == m_verbatim_p);
6197 if (match && !m_verbatim_p)
6199 /* When doing non-verbatim match, another check that needs to
6200 be done is to verify that the potentially matching symbol name
6201 does not include capital letters, because the ada-mode would
6202 not be able to understand these symbol names without the
6203 angle bracket notation. */
6206 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6211 /* Second: Try wild matching... */
6213 if (!match && m_wild_match_p)
6215 /* Since we are doing wild matching, this means that TEXT
6216 may represent an unqualified symbol name. We therefore must
6217 also compare TEXT against the unqualified name of the symbol. */
6218 sym_name = ada_unqualified_name (decoded_name.c_str ());
6220 if (strncmp (sym_name, text, text_len) == 0)
6224 /* Finally: If we found a match, prepare the result to return. */
6229 if (comp_match_res != NULL)
6231 std::string &match_str = comp_match_res->match.storage ();
6234 match_str = ada_decode (sym_name);
6238 match_str = add_angle_brackets (sym_name);
6240 match_str = sym_name;
6244 comp_match_res->set_match (match_str.c_str ());
6252 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6253 for tagged types. */
6256 ada_is_dispatch_table_ptr_type (struct type *type)
6260 if (type->code () != TYPE_CODE_PTR)
6263 name = type->target_type ()->name ();
6267 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6270 /* Return non-zero if TYPE is an interface tag. */
6273 ada_is_interface_tag (struct type *type)
6275 const char *name = type->name ();
6280 return (strcmp (name, "ada__tags__interface_tag") == 0);
6283 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6284 to be invisible to users. */
6287 ada_is_ignored_field (struct type *type, int field_num)
6289 if (field_num < 0 || field_num > type->num_fields ())
6292 /* Check the name of that field. */
6294 const char *name = type->field (field_num).name ();
6296 /* Anonymous field names should not be printed.
6297 brobecker/2007-02-20: I don't think this can actually happen
6298 but we don't want to print the value of anonymous fields anyway. */
6302 /* Normally, fields whose name start with an underscore ("_")
6303 are fields that have been internally generated by the compiler,
6304 and thus should not be printed. The "_parent" field is special,
6305 however: This is a field internally generated by the compiler
6306 for tagged types, and it contains the components inherited from
6307 the parent type. This field should not be printed as is, but
6308 should not be ignored either. */
6309 if (name[0] == '_' && !startswith (name, "_parent"))
6312 /* The compiler doesn't document this, but sometimes it emits
6313 a field whose name starts with a capital letter, like 'V148s'.
6314 These aren't marked as artificial in any way, but we know they
6315 should be ignored. However, wrapper fields should not be
6317 if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6319 /* Wrapper field. */
6321 else if (isupper (name[0]))
6325 /* If this is the dispatch table of a tagged type or an interface tag,
6327 if (ada_is_tagged_type (type, 1)
6328 && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6329 || ada_is_interface_tag (type->field (field_num).type ())))
6332 /* Not a special field, so it should not be ignored. */
6336 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6337 pointer or reference type whose ultimate target has a tag field. */
6340 ada_is_tagged_type (struct type *type, int refok)
6342 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6345 /* True iff TYPE represents the type of X'Tag */
6348 ada_is_tag_type (struct type *type)
6350 type = ada_check_typedef (type);
6352 if (type == NULL || type->code () != TYPE_CODE_PTR)
6356 const char *name = ada_type_name (type->target_type ());
6358 return (name != NULL
6359 && strcmp (name, "ada__tags__dispatch_table") == 0);
6363 /* The type of the tag on VAL. */
6365 static struct type *
6366 ada_tag_type (struct value *val)
6368 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6371 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6372 retired at Ada 05). */
6375 is_ada95_tag (struct value *tag)
6377 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6380 /* The value of the tag on VAL. */
6382 static struct value *
6383 ada_value_tag (struct value *val)
6385 return ada_value_struct_elt (val, "_tag", 0);
6388 /* The value of the tag on the object of type TYPE whose contents are
6389 saved at VALADDR, if it is non-null, or is at memory address
6392 static struct value *
6393 value_tag_from_contents_and_address (struct type *type,
6394 const gdb_byte *valaddr,
6397 int tag_byte_offset;
6398 struct type *tag_type;
6400 gdb::array_view<const gdb_byte> contents;
6401 if (valaddr != nullptr)
6402 contents = gdb::make_array_view (valaddr, type->length ());
6403 struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6404 if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6407 const gdb_byte *valaddr1 = ((valaddr == NULL)
6409 : valaddr + tag_byte_offset);
6410 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6412 return value_from_contents_and_address (tag_type, valaddr1, address1);
6417 static struct type *
6418 type_from_tag (struct value *tag)
6420 gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6422 if (type_name != NULL)
6423 return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6427 /* Given a value OBJ of a tagged type, return a value of this
6428 type at the base address of the object. The base address, as
6429 defined in Ada.Tags, it is the address of the primary tag of
6430 the object, and therefore where the field values of its full
6431 view can be fetched. */
6434 ada_tag_value_at_base_address (struct value *obj)
6437 LONGEST offset_to_top = 0;
6438 struct type *ptr_type, *obj_type;
6440 CORE_ADDR base_address;
6442 obj_type = value_type (obj);
6444 /* It is the responsability of the caller to deref pointers. */
6446 if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6449 tag = ada_value_tag (obj);
6453 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6455 if (is_ada95_tag (tag))
6458 struct type *offset_type
6459 = language_lookup_primitive_type (language_def (language_ada),
6460 target_gdbarch(), "storage_offset");
6461 ptr_type = lookup_pointer_type (offset_type);
6462 val = value_cast (ptr_type, tag);
6466 /* It is perfectly possible that an exception be raised while
6467 trying to determine the base address, just like for the tag;
6468 see ada_tag_name for more details. We do not print the error
6469 message for the same reason. */
6473 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6476 catch (const gdb_exception_error &e)
6481 /* If offset is null, nothing to do. */
6483 if (offset_to_top == 0)
6486 /* -1 is a special case in Ada.Tags; however, what should be done
6487 is not quite clear from the documentation. So do nothing for
6490 if (offset_to_top == -1)
6493 /* Storage_Offset'Last is used to indicate that a dynamic offset to
6494 top is used. In this situation the offset is stored just after
6495 the tag, in the object itself. */
6496 ULONGEST last = (((ULONGEST) 1) << (8 * offset_type->length () - 1)) - 1;
6497 if (offset_to_top == last)
6499 struct value *tem = value_addr (tag);
6500 tem = value_ptradd (tem, 1);
6501 tem = value_cast (ptr_type, tem);
6502 offset_to_top = value_as_long (value_ind (tem));
6505 if (offset_to_top > 0)
6507 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6508 from the base address. This was however incompatible with
6509 C++ dispatch table: C++ uses a *negative* value to *add*
6510 to the base address. Ada's convention has therefore been
6511 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6512 use the same convention. Here, we support both cases by
6513 checking the sign of OFFSET_TO_TOP. */
6514 offset_to_top = -offset_to_top;
6517 base_address = value_address (obj) + offset_to_top;
6518 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6520 /* Make sure that we have a proper tag at the new address.
6521 Otherwise, offset_to_top is bogus (which can happen when
6522 the object is not initialized yet). */
6527 obj_type = type_from_tag (tag);
6532 return value_from_contents_and_address (obj_type, NULL, base_address);
6535 /* Return the "ada__tags__type_specific_data" type. */
6537 static struct type *
6538 ada_get_tsd_type (struct inferior *inf)
6540 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6542 if (data->tsd_type == 0)
6543 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6544 return data->tsd_type;
6547 /* Return the TSD (type-specific data) associated to the given TAG.
6548 TAG is assumed to be the tag of a tagged-type entity.
6550 May return NULL if we are unable to get the TSD. */
6552 static struct value *
6553 ada_get_tsd_from_tag (struct value *tag)
6558 /* First option: The TSD is simply stored as a field of our TAG.
6559 Only older versions of GNAT would use this format, but we have
6560 to test it first, because there are no visible markers for
6561 the current approach except the absence of that field. */
6563 val = ada_value_struct_elt (tag, "tsd", 1);
6567 /* Try the second representation for the dispatch table (in which
6568 there is no explicit 'tsd' field in the referent of the tag pointer,
6569 and instead the tsd pointer is stored just before the dispatch
6572 type = ada_get_tsd_type (current_inferior());
6575 type = lookup_pointer_type (lookup_pointer_type (type));
6576 val = value_cast (type, tag);
6579 return value_ind (value_ptradd (val, -1));
6582 /* Given the TSD of a tag (type-specific data), return a string
6583 containing the name of the associated type.
6585 May return NULL if we are unable to determine the tag name. */
6587 static gdb::unique_xmalloc_ptr<char>
6588 ada_tag_name_from_tsd (struct value *tsd)
6592 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6595 gdb::unique_xmalloc_ptr<char> buffer
6596 = target_read_string (value_as_address (val), INT_MAX);
6597 if (buffer == nullptr)
6602 /* Let this throw an exception on error. If the data is
6603 uninitialized, we'd rather not have the user see a
6605 const char *folded = ada_fold_name (buffer.get (), true);
6606 return make_unique_xstrdup (folded);
6608 catch (const gdb_exception &)
6614 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6617 Return NULL if the TAG is not an Ada tag, or if we were unable to
6618 determine the name of that tag. */
6620 gdb::unique_xmalloc_ptr<char>
6621 ada_tag_name (struct value *tag)
6623 gdb::unique_xmalloc_ptr<char> name;
6625 if (!ada_is_tag_type (value_type (tag)))
6628 /* It is perfectly possible that an exception be raised while trying
6629 to determine the TAG's name, even under normal circumstances:
6630 The associated variable may be uninitialized or corrupted, for
6631 instance. We do not let any exception propagate past this point.
6632 instead we return NULL.
6634 We also do not print the error message either (which often is very
6635 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6636 the caller print a more meaningful message if necessary. */
6639 struct value *tsd = ada_get_tsd_from_tag (tag);
6642 name = ada_tag_name_from_tsd (tsd);
6644 catch (const gdb_exception_error &e)
6651 /* The parent type of TYPE, or NULL if none. */
6654 ada_parent_type (struct type *type)
6658 type = ada_check_typedef (type);
6660 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6663 for (i = 0; i < type->num_fields (); i += 1)
6664 if (ada_is_parent_field (type, i))
6666 struct type *parent_type = type->field (i).type ();
6668 /* If the _parent field is a pointer, then dereference it. */
6669 if (parent_type->code () == TYPE_CODE_PTR)
6670 parent_type = parent_type->target_type ();
6671 /* If there is a parallel XVS type, get the actual base type. */
6672 parent_type = ada_get_base_type (parent_type);
6674 return ada_check_typedef (parent_type);
6680 /* True iff field number FIELD_NUM of structure type TYPE contains the
6681 parent-type (inherited) fields of a derived type. Assumes TYPE is
6682 a structure type with at least FIELD_NUM+1 fields. */
6685 ada_is_parent_field (struct type *type, int field_num)
6687 const char *name = ada_check_typedef (type)->field (field_num).name ();
6689 return (name != NULL
6690 && (startswith (name, "PARENT")
6691 || startswith (name, "_parent")));
6694 /* True iff field number FIELD_NUM of structure type TYPE is a
6695 transparent wrapper field (which should be silently traversed when doing
6696 field selection and flattened when printing). Assumes TYPE is a
6697 structure type with at least FIELD_NUM+1 fields. Such fields are always
6701 ada_is_wrapper_field (struct type *type, int field_num)
6703 const char *name = type->field (field_num).name ();
6705 if (name != NULL && strcmp (name, "RETVAL") == 0)
6707 /* This happens in functions with "out" or "in out" parameters
6708 which are passed by copy. For such functions, GNAT describes
6709 the function's return type as being a struct where the return
6710 value is in a field called RETVAL, and where the other "out"
6711 or "in out" parameters are fields of that struct. This is not
6716 return (name != NULL
6717 && (startswith (name, "PARENT")
6718 || strcmp (name, "REP") == 0
6719 || startswith (name, "_parent")
6720 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6723 /* True iff field number FIELD_NUM of structure or union type TYPE
6724 is a variant wrapper. Assumes TYPE is a structure type with at least
6725 FIELD_NUM+1 fields. */
6728 ada_is_variant_part (struct type *type, int field_num)
6730 /* Only Ada types are eligible. */
6731 if (!ADA_TYPE_P (type))
6734 struct type *field_type = type->field (field_num).type ();
6736 return (field_type->code () == TYPE_CODE_UNION
6737 || (is_dynamic_field (type, field_num)
6738 && (field_type->target_type ()->code ()
6739 == TYPE_CODE_UNION)));
6742 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6743 whose discriminants are contained in the record type OUTER_TYPE,
6744 returns the type of the controlling discriminant for the variant.
6745 May return NULL if the type could not be found. */
6748 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6750 const char *name = ada_variant_discrim_name (var_type);
6752 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6755 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6756 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6757 represents a 'when others' clause; otherwise 0. */
6760 ada_is_others_clause (struct type *type, int field_num)
6762 const char *name = type->field (field_num).name ();
6764 return (name != NULL && name[0] == 'O');
6767 /* Assuming that TYPE0 is the type of the variant part of a record,
6768 returns the name of the discriminant controlling the variant.
6769 The value is valid until the next call to ada_variant_discrim_name. */
6772 ada_variant_discrim_name (struct type *type0)
6774 static std::string result;
6777 const char *discrim_end;
6778 const char *discrim_start;
6780 if (type0->code () == TYPE_CODE_PTR)
6781 type = type0->target_type ();
6785 name = ada_type_name (type);
6787 if (name == NULL || name[0] == '\000')
6790 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6793 if (startswith (discrim_end, "___XVN"))
6796 if (discrim_end == name)
6799 for (discrim_start = discrim_end; discrim_start != name + 3;
6802 if (discrim_start == name + 1)
6804 if ((discrim_start > name + 3
6805 && startswith (discrim_start - 3, "___"))
6806 || discrim_start[-1] == '.')
6810 result = std::string (discrim_start, discrim_end - discrim_start);
6811 return result.c_str ();
6814 /* Scan STR for a subtype-encoded number, beginning at position K.
6815 Put the position of the character just past the number scanned in
6816 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6817 Return 1 if there was a valid number at the given position, and 0
6818 otherwise. A "subtype-encoded" number consists of the absolute value
6819 in decimal, followed by the letter 'm' to indicate a negative number.
6820 Assumes 0m does not occur. */
6823 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6827 if (!isdigit (str[k]))
6830 /* Do it the hard way so as not to make any assumption about
6831 the relationship of unsigned long (%lu scan format code) and
6834 while (isdigit (str[k]))
6836 RU = RU * 10 + (str[k] - '0');
6843 *R = (-(LONGEST) (RU - 1)) - 1;
6849 /* NOTE on the above: Technically, C does not say what the results of
6850 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6851 number representable as a LONGEST (although either would probably work
6852 in most implementations). When RU>0, the locution in the then branch
6853 above is always equivalent to the negative of RU. */
6860 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6861 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6862 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6865 ada_in_variant (LONGEST val, struct type *type, int field_num)
6867 const char *name = type->field (field_num).name ();
6881 if (!ada_scan_number (name, p + 1, &W, &p))
6891 if (!ada_scan_number (name, p + 1, &L, &p)
6892 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6894 if (val >= L && val <= U)
6906 /* FIXME: Lots of redundancy below. Try to consolidate. */
6908 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6909 ARG_TYPE, extract and return the value of one of its (non-static)
6910 fields. FIELDNO says which field. Differs from value_primitive_field
6911 only in that it can handle packed values of arbitrary type. */
6914 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6915 struct type *arg_type)
6919 arg_type = ada_check_typedef (arg_type);
6920 type = arg_type->field (fieldno).type ();
6922 /* Handle packed fields. It might be that the field is not packed
6923 relative to its containing structure, but the structure itself is
6924 packed; in this case we must take the bit-field path. */
6925 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6927 int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6928 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6930 return ada_value_primitive_packed_val (arg1,
6931 value_contents (arg1).data (),
6932 offset + bit_pos / 8,
6933 bit_pos % 8, bit_size, type);
6936 return value_primitive_field (arg1, offset, fieldno, arg_type);
6939 /* Find field with name NAME in object of type TYPE. If found,
6940 set the following for each argument that is non-null:
6941 - *FIELD_TYPE_P to the field's type;
6942 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6943 an object of that type;
6944 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6945 - *BIT_SIZE_P to its size in bits if the field is packed, and
6947 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6948 fields up to but not including the desired field, or by the total
6949 number of fields if not found. A NULL value of NAME never
6950 matches; the function just counts visible fields in this case.
6952 Notice that we need to handle when a tagged record hierarchy
6953 has some components with the same name, like in this scenario:
6955 type Top_T is tagged record
6961 type Middle_T is new Top.Top_T with record
6962 N : Character := 'a';
6966 type Bottom_T is new Middle.Middle_T with record
6968 C : Character := '5';
6970 A : Character := 'J';
6973 Let's say we now have a variable declared and initialized as follow:
6975 TC : Top_A := new Bottom_T;
6977 And then we use this variable to call this function
6979 procedure Assign (Obj: in out Top_T; TV : Integer);
6983 Assign (Top_T (B), 12);
6985 Now, we're in the debugger, and we're inside that procedure
6986 then and we want to print the value of obj.c:
6988 Usually, the tagged record or one of the parent type owns the
6989 component to print and there's no issue but in this particular
6990 case, what does it mean to ask for Obj.C? Since the actual
6991 type for object is type Bottom_T, it could mean two things: type
6992 component C from the Middle_T view, but also component C from
6993 Bottom_T. So in that "undefined" case, when the component is
6994 not found in the non-resolved type (which includes all the
6995 components of the parent type), then resolve it and see if we
6996 get better luck once expanded.
6998 In the case of homonyms in the derived tagged type, we don't
6999 guaranty anything, and pick the one that's easiest for us
7002 Returns 1 if found, 0 otherwise. */
7005 find_struct_field (const char *name, struct type *type, int offset,
7006 struct type **field_type_p,
7007 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7011 int parent_offset = -1;
7013 type = ada_check_typedef (type);
7015 if (field_type_p != NULL)
7016 *field_type_p = NULL;
7017 if (byte_offset_p != NULL)
7019 if (bit_offset_p != NULL)
7021 if (bit_size_p != NULL)
7024 for (i = 0; i < type->num_fields (); i += 1)
7026 /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7027 type. However, we only need the values to be correct when
7028 the caller asks for them. */
7029 int bit_pos = 0, fld_offset = 0;
7030 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7032 bit_pos = type->field (i).loc_bitpos ();
7033 fld_offset = offset + bit_pos / 8;
7036 const char *t_field_name = type->field (i).name ();
7038 if (t_field_name == NULL)
7041 else if (ada_is_parent_field (type, i))
7043 /* This is a field pointing us to the parent type of a tagged
7044 type. As hinted in this function's documentation, we give
7045 preference to fields in the current record first, so what
7046 we do here is just record the index of this field before
7047 we skip it. If it turns out we couldn't find our field
7048 in the current record, then we'll get back to it and search
7049 inside it whether the field might exist in the parent. */
7055 else if (name != NULL && field_name_match (t_field_name, name))
7057 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7059 if (field_type_p != NULL)
7060 *field_type_p = type->field (i).type ();
7061 if (byte_offset_p != NULL)
7062 *byte_offset_p = fld_offset;
7063 if (bit_offset_p != NULL)
7064 *bit_offset_p = bit_pos % 8;
7065 if (bit_size_p != NULL)
7066 *bit_size_p = bit_size;
7069 else if (ada_is_wrapper_field (type, i))
7071 if (find_struct_field (name, type->field (i).type (), fld_offset,
7072 field_type_p, byte_offset_p, bit_offset_p,
7073 bit_size_p, index_p))
7076 else if (ada_is_variant_part (type, i))
7078 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7081 struct type *field_type
7082 = ada_check_typedef (type->field (i).type ());
7084 for (j = 0; j < field_type->num_fields (); j += 1)
7086 if (find_struct_field (name, field_type->field (j).type (),
7088 + field_type->field (j).loc_bitpos () / 8,
7089 field_type_p, byte_offset_p,
7090 bit_offset_p, bit_size_p, index_p))
7094 else if (index_p != NULL)
7098 /* Field not found so far. If this is a tagged type which
7099 has a parent, try finding that field in the parent now. */
7101 if (parent_offset != -1)
7103 /* As above, only compute the offset when truly needed. */
7104 int fld_offset = offset;
7105 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7107 int bit_pos = type->field (parent_offset).loc_bitpos ();
7108 fld_offset += bit_pos / 8;
7111 if (find_struct_field (name, type->field (parent_offset).type (),
7112 fld_offset, field_type_p, byte_offset_p,
7113 bit_offset_p, bit_size_p, index_p))
7120 /* Number of user-visible fields in record type TYPE. */
7123 num_visible_fields (struct type *type)
7128 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7132 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7133 and search in it assuming it has (class) type TYPE.
7134 If found, return value, else return NULL.
7136 Searches recursively through wrapper fields (e.g., '_parent').
7138 In the case of homonyms in the tagged types, please refer to the
7139 long explanation in find_struct_field's function documentation. */
7141 static struct value *
7142 ada_search_struct_field (const char *name, struct value *arg, int offset,
7146 int parent_offset = -1;
7148 type = ada_check_typedef (type);
7149 for (i = 0; i < type->num_fields (); i += 1)
7151 const char *t_field_name = type->field (i).name ();
7153 if (t_field_name == NULL)
7156 else if (ada_is_parent_field (type, i))
7158 /* This is a field pointing us to the parent type of a tagged
7159 type. As hinted in this function's documentation, we give
7160 preference to fields in the current record first, so what
7161 we do here is just record the index of this field before
7162 we skip it. If it turns out we couldn't find our field
7163 in the current record, then we'll get back to it and search
7164 inside it whether the field might exist in the parent. */
7170 else if (field_name_match (t_field_name, name))
7171 return ada_value_primitive_field (arg, offset, i, type);
7173 else if (ada_is_wrapper_field (type, i))
7175 struct value *v = /* Do not let indent join lines here. */
7176 ada_search_struct_field (name, arg,
7177 offset + type->field (i).loc_bitpos () / 8,
7178 type->field (i).type ());
7184 else if (ada_is_variant_part (type, i))
7186 /* PNH: Do we ever get here? See find_struct_field. */
7188 struct type *field_type = ada_check_typedef (type->field (i).type ());
7189 int var_offset = offset + type->field (i).loc_bitpos () / 8;
7191 for (j = 0; j < field_type->num_fields (); j += 1)
7193 struct value *v = ada_search_struct_field /* Force line
7196 var_offset + field_type->field (j).loc_bitpos () / 8,
7197 field_type->field (j).type ());
7205 /* Field not found so far. If this is a tagged type which
7206 has a parent, try finding that field in the parent now. */
7208 if (parent_offset != -1)
7210 struct value *v = ada_search_struct_field (
7211 name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7212 type->field (parent_offset).type ());
7221 static struct value *ada_index_struct_field_1 (int *, struct value *,
7222 int, struct type *);
7225 /* Return field #INDEX in ARG, where the index is that returned by
7226 * find_struct_field through its INDEX_P argument. Adjust the address
7227 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7228 * If found, return value, else return NULL. */
7230 static struct value *
7231 ada_index_struct_field (int index, struct value *arg, int offset,
7234 return ada_index_struct_field_1 (&index, arg, offset, type);
7238 /* Auxiliary function for ada_index_struct_field. Like
7239 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7242 static struct value *
7243 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7247 type = ada_check_typedef (type);
7249 for (i = 0; i < type->num_fields (); i += 1)
7251 if (type->field (i).name () == NULL)
7253 else if (ada_is_wrapper_field (type, i))
7255 struct value *v = /* Do not let indent join lines here. */
7256 ada_index_struct_field_1 (index_p, arg,
7257 offset + type->field (i).loc_bitpos () / 8,
7258 type->field (i).type ());
7264 else if (ada_is_variant_part (type, i))
7266 /* PNH: Do we ever get here? See ada_search_struct_field,
7267 find_struct_field. */
7268 error (_("Cannot assign this kind of variant record"));
7270 else if (*index_p == 0)
7271 return ada_value_primitive_field (arg, offset, i, type);
7278 /* Return a string representation of type TYPE. */
7281 type_as_string (struct type *type)
7283 string_file tmp_stream;
7285 type_print (type, "", &tmp_stream, -1);
7287 return tmp_stream.release ();
7290 /* Given a type TYPE, look up the type of the component of type named NAME.
7291 If DISPP is non-null, add its byte displacement from the beginning of a
7292 structure (pointed to by a value) of type TYPE to *DISPP (does not
7293 work for packed fields).
7295 Matches any field whose name has NAME as a prefix, possibly
7298 TYPE can be either a struct or union. If REFOK, TYPE may also
7299 be a (pointer or reference)+ to a struct or union, and the
7300 ultimate target type will be searched.
7302 Looks recursively into variant clauses and parent types.
7304 In the case of homonyms in the tagged types, please refer to the
7305 long explanation in find_struct_field's function documentation.
7307 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7308 TYPE is not a type of the right kind. */
7310 static struct type *
7311 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7315 int parent_offset = -1;
7320 if (refok && type != NULL)
7323 type = ada_check_typedef (type);
7324 if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7326 type = type->target_type ();
7330 || (type->code () != TYPE_CODE_STRUCT
7331 && type->code () != TYPE_CODE_UNION))
7336 error (_("Type %s is not a structure or union type"),
7337 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7340 type = to_static_fixed_type (type);
7342 for (i = 0; i < type->num_fields (); i += 1)
7344 const char *t_field_name = type->field (i).name ();
7347 if (t_field_name == NULL)
7350 else if (ada_is_parent_field (type, i))
7352 /* This is a field pointing us to the parent type of a tagged
7353 type. As hinted in this function's documentation, we give
7354 preference to fields in the current record first, so what
7355 we do here is just record the index of this field before
7356 we skip it. If it turns out we couldn't find our field
7357 in the current record, then we'll get back to it and search
7358 inside it whether the field might exist in the parent. */
7364 else if (field_name_match (t_field_name, name))
7365 return type->field (i).type ();
7367 else if (ada_is_wrapper_field (type, i))
7369 t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7375 else if (ada_is_variant_part (type, i))
7378 struct type *field_type = ada_check_typedef (type->field (i).type ());
7380 for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7382 /* FIXME pnh 2008/01/26: We check for a field that is
7383 NOT wrapped in a struct, since the compiler sometimes
7384 generates these for unchecked variant types. Revisit
7385 if the compiler changes this practice. */
7386 const char *v_field_name = field_type->field (j).name ();
7388 if (v_field_name != NULL
7389 && field_name_match (v_field_name, name))
7390 t = field_type->field (j).type ();
7392 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7402 /* Field not found so far. If this is a tagged type which
7403 has a parent, try finding that field in the parent now. */
7405 if (parent_offset != -1)
7409 t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7418 const char *name_str = name != NULL ? name : _("<null>");
7420 error (_("Type %s has no component named %s"),
7421 type_as_string (type).c_str (), name_str);
7427 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7428 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7429 represents an unchecked union (that is, the variant part of a
7430 record that is named in an Unchecked_Union pragma). */
7433 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7435 const char *discrim_name = ada_variant_discrim_name (var_type);
7437 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7441 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7442 within OUTER, determine which variant clause (field number in VAR_TYPE,
7443 numbering from 0) is applicable. Returns -1 if none are. */
7446 ada_which_variant_applies (struct type *var_type, struct value *outer)
7450 const char *discrim_name = ada_variant_discrim_name (var_type);
7451 struct value *discrim;
7452 LONGEST discrim_val;
7454 /* Using plain value_from_contents_and_address here causes problems
7455 because we will end up trying to resolve a type that is currently
7456 being constructed. */
7457 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7458 if (discrim == NULL)
7460 discrim_val = value_as_long (discrim);
7463 for (i = 0; i < var_type->num_fields (); i += 1)
7465 if (ada_is_others_clause (var_type, i))
7467 else if (ada_in_variant (discrim_val, var_type, i))
7471 return others_clause;
7476 /* Dynamic-Sized Records */
7478 /* Strategy: The type ostensibly attached to a value with dynamic size
7479 (i.e., a size that is not statically recorded in the debugging
7480 data) does not accurately reflect the size or layout of the value.
7481 Our strategy is to convert these values to values with accurate,
7482 conventional types that are constructed on the fly. */
7484 /* There is a subtle and tricky problem here. In general, we cannot
7485 determine the size of dynamic records without its data. However,
7486 the 'struct value' data structure, which GDB uses to represent
7487 quantities in the inferior process (the target), requires the size
7488 of the type at the time of its allocation in order to reserve space
7489 for GDB's internal copy of the data. That's why the
7490 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7491 rather than struct value*s.
7493 However, GDB's internal history variables ($1, $2, etc.) are
7494 struct value*s containing internal copies of the data that are not, in
7495 general, the same as the data at their corresponding addresses in
7496 the target. Fortunately, the types we give to these values are all
7497 conventional, fixed-size types (as per the strategy described
7498 above), so that we don't usually have to perform the
7499 'to_fixed_xxx_type' conversions to look at their values.
7500 Unfortunately, there is one exception: if one of the internal
7501 history variables is an array whose elements are unconstrained
7502 records, then we will need to create distinct fixed types for each
7503 element selected. */
7505 /* The upshot of all of this is that many routines take a (type, host
7506 address, target address) triple as arguments to represent a value.
7507 The host address, if non-null, is supposed to contain an internal
7508 copy of the relevant data; otherwise, the program is to consult the
7509 target at the target address. */
7511 /* Assuming that VAL0 represents a pointer value, the result of
7512 dereferencing it. Differs from value_ind in its treatment of
7513 dynamic-sized types. */
7516 ada_value_ind (struct value *val0)
7518 struct value *val = value_ind (val0);
7520 if (ada_is_tagged_type (value_type (val), 0))
7521 val = ada_tag_value_at_base_address (val);
7523 return ada_to_fixed_value (val);
7526 /* The value resulting from dereferencing any "reference to"
7527 qualifiers on VAL0. */
7529 static struct value *
7530 ada_coerce_ref (struct value *val0)
7532 if (value_type (val0)->code () == TYPE_CODE_REF)
7534 struct value *val = val0;
7536 val = coerce_ref (val);
7538 if (ada_is_tagged_type (value_type (val), 0))
7539 val = ada_tag_value_at_base_address (val);
7541 return ada_to_fixed_value (val);
7547 /* Return the bit alignment required for field #F of template type TYPE. */
7550 field_alignment (struct type *type, int f)
7552 const char *name = type->field (f).name ();
7556 /* The field name should never be null, unless the debugging information
7557 is somehow malformed. In this case, we assume the field does not
7558 require any alignment. */
7562 len = strlen (name);
7564 if (!isdigit (name[len - 1]))
7567 if (isdigit (name[len - 2]))
7568 align_offset = len - 2;
7570 align_offset = len - 1;
7572 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7573 return TARGET_CHAR_BIT;
7575 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7578 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7580 static struct symbol *
7581 ada_find_any_type_symbol (const char *name)
7585 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7586 if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7589 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7593 /* Find a type named NAME. Ignores ambiguity. This routine will look
7594 solely for types defined by debug info, it will not search the GDB
7597 static struct type *
7598 ada_find_any_type (const char *name)
7600 struct symbol *sym = ada_find_any_type_symbol (name);
7603 return sym->type ();
7608 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7609 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7610 symbol, in which case it is returned. Otherwise, this looks for
7611 symbols whose name is that of NAME_SYM suffixed with "___XR".
7612 Return symbol if found, and NULL otherwise. */
7615 ada_is_renaming_symbol (struct symbol *name_sym)
7617 const char *name = name_sym->linkage_name ();
7618 return strstr (name, "___XR") != NULL;
7621 /* Because of GNAT encoding conventions, several GDB symbols may match a
7622 given type name. If the type denoted by TYPE0 is to be preferred to
7623 that of TYPE1 for purposes of type printing, return non-zero;
7624 otherwise return 0. */
7627 ada_prefer_type (struct type *type0, struct type *type1)
7631 else if (type0 == NULL)
7633 else if (type1->code () == TYPE_CODE_VOID)
7635 else if (type0->code () == TYPE_CODE_VOID)
7637 else if (type1->name () == NULL && type0->name () != NULL)
7639 else if (ada_is_constrained_packed_array_type (type0))
7641 else if (ada_is_array_descriptor_type (type0)
7642 && !ada_is_array_descriptor_type (type1))
7646 const char *type0_name = type0->name ();
7647 const char *type1_name = type1->name ();
7649 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7650 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7656 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7660 ada_type_name (struct type *type)
7664 return type->name ();
7667 /* Search the list of "descriptive" types associated to TYPE for a type
7668 whose name is NAME. */
7670 static struct type *
7671 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7673 struct type *result, *tmp;
7675 if (ada_ignore_descriptive_types_p)
7678 /* If there no descriptive-type info, then there is no parallel type
7680 if (!HAVE_GNAT_AUX_INFO (type))
7683 result = TYPE_DESCRIPTIVE_TYPE (type);
7684 while (result != NULL)
7686 const char *result_name = ada_type_name (result);
7688 if (result_name == NULL)
7690 warning (_("unexpected null name on descriptive type"));
7694 /* If the names match, stop. */
7695 if (strcmp (result_name, name) == 0)
7698 /* Otherwise, look at the next item on the list, if any. */
7699 if (HAVE_GNAT_AUX_INFO (result))
7700 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7704 /* If not found either, try after having resolved the typedef. */
7709 result = check_typedef (result);
7710 if (HAVE_GNAT_AUX_INFO (result))
7711 result = TYPE_DESCRIPTIVE_TYPE (result);
7717 /* If we didn't find a match, see whether this is a packed array. With
7718 older compilers, the descriptive type information is either absent or
7719 irrelevant when it comes to packed arrays so the above lookup fails.
7720 Fall back to using a parallel lookup by name in this case. */
7721 if (result == NULL && ada_is_constrained_packed_array_type (type))
7722 return ada_find_any_type (name);
7727 /* Find a parallel type to TYPE with the specified NAME, using the
7728 descriptive type taken from the debugging information, if available,
7729 and otherwise using the (slower) name-based method. */
7731 static struct type *
7732 ada_find_parallel_type_with_name (struct type *type, const char *name)
7734 struct type *result = NULL;
7736 if (HAVE_GNAT_AUX_INFO (type))
7737 result = find_parallel_type_by_descriptive_type (type, name);
7739 result = ada_find_any_type (name);
7744 /* Same as above, but specify the name of the parallel type by appending
7745 SUFFIX to the name of TYPE. */
7748 ada_find_parallel_type (struct type *type, const char *suffix)
7751 const char *type_name = ada_type_name (type);
7754 if (type_name == NULL)
7757 len = strlen (type_name);
7759 name = (char *) alloca (len + strlen (suffix) + 1);
7761 strcpy (name, type_name);
7762 strcpy (name + len, suffix);
7764 return ada_find_parallel_type_with_name (type, name);
7767 /* If TYPE is a variable-size record type, return the corresponding template
7768 type describing its fields. Otherwise, return NULL. */
7770 static struct type *
7771 dynamic_template_type (struct type *type)
7773 type = ada_check_typedef (type);
7775 if (type == NULL || type->code () != TYPE_CODE_STRUCT
7776 || ada_type_name (type) == NULL)
7780 int len = strlen (ada_type_name (type));
7782 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7785 return ada_find_parallel_type (type, "___XVE");
7789 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7790 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7793 is_dynamic_field (struct type *templ_type, int field_num)
7795 const char *name = templ_type->field (field_num).name ();
7798 && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7799 && strstr (name, "___XVL") != NULL;
7802 /* The index of the variant field of TYPE, or -1 if TYPE does not
7803 represent a variant record type. */
7806 variant_field_index (struct type *type)
7810 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7813 for (f = 0; f < type->num_fields (); f += 1)
7815 if (ada_is_variant_part (type, f))
7821 /* A record type with no fields. */
7823 static struct type *
7824 empty_record (struct type *templ)
7826 struct type *type = alloc_type_copy (templ);
7828 type->set_code (TYPE_CODE_STRUCT);
7829 INIT_NONE_SPECIFIC (type);
7830 type->set_name ("<empty>");
7831 type->set_length (0);
7835 /* An ordinary record type (with fixed-length fields) that describes
7836 the value of type TYPE at VALADDR or ADDRESS (see comments at
7837 the beginning of this section) VAL according to GNAT conventions.
7838 DVAL0 should describe the (portion of a) record that contains any
7839 necessary discriminants. It should be NULL if value_type (VAL) is
7840 an outer-level type (i.e., as opposed to a branch of a variant.) A
7841 variant field (unless unchecked) is replaced by a particular branch
7844 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7845 length are not statically known are discarded. As a consequence,
7846 VALADDR, ADDRESS and DVAL0 are ignored.
7848 NOTE: Limitations: For now, we assume that dynamic fields and
7849 variants occupy whole numbers of bytes. However, they need not be
7853 ada_template_to_fixed_record_type_1 (struct type *type,
7854 const gdb_byte *valaddr,
7855 CORE_ADDR address, struct value *dval0,
7856 int keep_dynamic_fields)
7858 struct value *mark = value_mark ();
7861 int nfields, bit_len;
7867 /* Compute the number of fields in this record type that are going
7868 to be processed: unless keep_dynamic_fields, this includes only
7869 fields whose position and length are static will be processed. */
7870 if (keep_dynamic_fields)
7871 nfields = type->num_fields ();
7875 while (nfields < type->num_fields ()
7876 && !ada_is_variant_part (type, nfields)
7877 && !is_dynamic_field (type, nfields))
7881 rtype = alloc_type_copy (type);
7882 rtype->set_code (TYPE_CODE_STRUCT);
7883 INIT_NONE_SPECIFIC (rtype);
7884 rtype->set_num_fields (nfields);
7886 ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7887 rtype->set_name (ada_type_name (type));
7888 rtype->set_is_fixed_instance (true);
7894 for (f = 0; f < nfields; f += 1)
7896 off = align_up (off, field_alignment (type, f))
7897 + type->field (f).loc_bitpos ();
7898 rtype->field (f).set_loc_bitpos (off);
7899 TYPE_FIELD_BITSIZE (rtype, f) = 0;
7901 if (ada_is_variant_part (type, f))
7906 else if (is_dynamic_field (type, f))
7908 const gdb_byte *field_valaddr = valaddr;
7909 CORE_ADDR field_address = address;
7910 struct type *field_type = type->field (f).type ()->target_type ();
7914 /* Using plain value_from_contents_and_address here
7915 causes problems because we will end up trying to
7916 resolve a type that is currently being
7918 dval = value_from_contents_and_address_unresolved (rtype,
7921 rtype = value_type (dval);
7926 /* If the type referenced by this field is an aligner type, we need
7927 to unwrap that aligner type, because its size might not be set.
7928 Keeping the aligner type would cause us to compute the wrong
7929 size for this field, impacting the offset of the all the fields
7930 that follow this one. */
7931 if (ada_is_aligner_type (field_type))
7933 long field_offset = type->field (f).loc_bitpos ();
7935 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7936 field_address = cond_offset_target (field_address, field_offset);
7937 field_type = ada_aligned_type (field_type);
7940 field_valaddr = cond_offset_host (field_valaddr,
7941 off / TARGET_CHAR_BIT);
7942 field_address = cond_offset_target (field_address,
7943 off / TARGET_CHAR_BIT);
7945 /* Get the fixed type of the field. Note that, in this case,
7946 we do not want to get the real type out of the tag: if
7947 the current field is the parent part of a tagged record,
7948 we will get the tag of the object. Clearly wrong: the real
7949 type of the parent is not the real type of the child. We
7950 would end up in an infinite loop. */
7951 field_type = ada_get_base_type (field_type);
7952 field_type = ada_to_fixed_type (field_type, field_valaddr,
7953 field_address, dval, 0);
7955 rtype->field (f).set_type (field_type);
7956 rtype->field (f).set_name (type->field (f).name ());
7957 /* The multiplication can potentially overflow. But because
7958 the field length has been size-checked just above, and
7959 assuming that the maximum size is a reasonable value,
7960 an overflow should not happen in practice. So rather than
7961 adding overflow recovery code to this already complex code,
7962 we just assume that it's not going to happen. */
7963 fld_bit_len = rtype->field (f).type ()->length () * TARGET_CHAR_BIT;
7967 /* Note: If this field's type is a typedef, it is important
7968 to preserve the typedef layer.
7970 Otherwise, we might be transforming a typedef to a fat
7971 pointer (encoding a pointer to an unconstrained array),
7972 into a basic fat pointer (encoding an unconstrained
7973 array). As both types are implemented using the same
7974 structure, the typedef is the only clue which allows us
7975 to distinguish between the two options. Stripping it
7976 would prevent us from printing this field appropriately. */
7977 rtype->field (f).set_type (type->field (f).type ());
7978 rtype->field (f).set_name (type->field (f).name ());
7979 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7981 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7984 struct type *field_type = type->field (f).type ();
7986 /* We need to be careful of typedefs when computing
7987 the length of our field. If this is a typedef,
7988 get the length of the target type, not the length
7990 if (field_type->code () == TYPE_CODE_TYPEDEF)
7991 field_type = ada_typedef_target_type (field_type);
7994 ada_check_typedef (field_type)->length () * TARGET_CHAR_BIT;
7997 if (off + fld_bit_len > bit_len)
7998 bit_len = off + fld_bit_len;
8000 rtype->set_length (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8003 /* We handle the variant part, if any, at the end because of certain
8004 odd cases in which it is re-ordered so as NOT to be the last field of
8005 the record. This can happen in the presence of representation
8007 if (variant_field >= 0)
8009 struct type *branch_type;
8011 off = rtype->field (variant_field).loc_bitpos ();
8015 /* Using plain value_from_contents_and_address here causes
8016 problems because we will end up trying to resolve a type
8017 that is currently being constructed. */
8018 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8020 rtype = value_type (dval);
8026 to_fixed_variant_branch_type
8027 (type->field (variant_field).type (),
8028 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8029 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8030 if (branch_type == NULL)
8032 for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8033 rtype->field (f - 1) = rtype->field (f);
8034 rtype->set_num_fields (rtype->num_fields () - 1);
8038 rtype->field (variant_field).set_type (branch_type);
8039 rtype->field (variant_field).set_name ("S");
8041 rtype->field (variant_field).type ()->length () * TARGET_CHAR_BIT;
8042 if (off + fld_bit_len > bit_len)
8043 bit_len = off + fld_bit_len;
8046 (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8050 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8051 should contain the alignment of that record, which should be a strictly
8052 positive value. If null or negative, then something is wrong, most
8053 probably in the debug info. In that case, we don't round up the size
8054 of the resulting type. If this record is not part of another structure,
8055 the current RTYPE length might be good enough for our purposes. */
8056 if (type->length () <= 0)
8059 warning (_("Invalid type size for `%s' detected: %s."),
8060 rtype->name (), pulongest (type->length ()));
8062 warning (_("Invalid type size for <unnamed> detected: %s."),
8063 pulongest (type->length ()));
8066 rtype->set_length (align_up (rtype->length (), type->length ()));
8068 value_free_to_mark (mark);
8072 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8075 static struct type *
8076 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8077 CORE_ADDR address, struct value *dval0)
8079 return ada_template_to_fixed_record_type_1 (type, valaddr,
8083 /* An ordinary record type in which ___XVL-convention fields and
8084 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8085 static approximations, containing all possible fields. Uses
8086 no runtime values. Useless for use in values, but that's OK,
8087 since the results are used only for type determinations. Works on both
8088 structs and unions. Representation note: to save space, we memorize
8089 the result of this function in the type::target_type of the
8092 static struct type *
8093 template_to_static_fixed_type (struct type *type0)
8099 /* No need no do anything if the input type is already fixed. */
8100 if (type0->is_fixed_instance ())
8103 /* Likewise if we already have computed the static approximation. */
8104 if (type0->target_type () != NULL)
8105 return type0->target_type ();
8107 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8109 nfields = type0->num_fields ();
8111 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8112 recompute all over next time. */
8113 type0->set_target_type (type);
8115 for (f = 0; f < nfields; f += 1)
8117 struct type *field_type = type0->field (f).type ();
8118 struct type *new_type;
8120 if (is_dynamic_field (type0, f))
8122 field_type = ada_check_typedef (field_type);
8123 new_type = to_static_fixed_type (field_type->target_type ());
8126 new_type = static_unwrap_type (field_type);
8128 if (new_type != field_type)
8130 /* Clone TYPE0 only the first time we get a new field type. */
8133 type = alloc_type_copy (type0);
8134 type0->set_target_type (type);
8135 type->set_code (type0->code ());
8136 INIT_NONE_SPECIFIC (type);
8137 type->set_num_fields (nfields);
8141 TYPE_ALLOC (type, nfields * sizeof (struct field)));
8142 memcpy (fields, type0->fields (),
8143 sizeof (struct field) * nfields);
8144 type->set_fields (fields);
8146 type->set_name (ada_type_name (type0));
8147 type->set_is_fixed_instance (true);
8148 type->set_length (0);
8150 type->field (f).set_type (new_type);
8151 type->field (f).set_name (type0->field (f).name ());
8158 /* Given an object of type TYPE whose contents are at VALADDR and
8159 whose address in memory is ADDRESS, returns a revision of TYPE,
8160 which should be a non-dynamic-sized record, in which the variant
8161 part, if any, is replaced with the appropriate branch. Looks
8162 for discriminant values in DVAL0, which can be NULL if the record
8163 contains the necessary discriminant values. */
8165 static struct type *
8166 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8167 CORE_ADDR address, struct value *dval0)
8169 struct value *mark = value_mark ();
8172 struct type *branch_type;
8173 int nfields = type->num_fields ();
8174 int variant_field = variant_field_index (type);
8176 if (variant_field == -1)
8181 dval = value_from_contents_and_address (type, valaddr, address);
8182 type = value_type (dval);
8187 rtype = alloc_type_copy (type);
8188 rtype->set_code (TYPE_CODE_STRUCT);
8189 INIT_NONE_SPECIFIC (rtype);
8190 rtype->set_num_fields (nfields);
8193 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8194 memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8195 rtype->set_fields (fields);
8197 rtype->set_name (ada_type_name (type));
8198 rtype->set_is_fixed_instance (true);
8199 rtype->set_length (type->length ());
8201 branch_type = to_fixed_variant_branch_type
8202 (type->field (variant_field).type (),
8203 cond_offset_host (valaddr,
8204 type->field (variant_field).loc_bitpos ()
8206 cond_offset_target (address,
8207 type->field (variant_field).loc_bitpos ()
8208 / TARGET_CHAR_BIT), dval);
8209 if (branch_type == NULL)
8213 for (f = variant_field + 1; f < nfields; f += 1)
8214 rtype->field (f - 1) = rtype->field (f);
8215 rtype->set_num_fields (rtype->num_fields () - 1);
8219 rtype->field (variant_field).set_type (branch_type);
8220 rtype->field (variant_field).set_name ("S");
8221 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8222 rtype->set_length (rtype->length () + branch_type->length ());
8225 rtype->set_length (rtype->length ()
8226 - type->field (variant_field).type ()->length ());
8228 value_free_to_mark (mark);
8232 /* An ordinary record type (with fixed-length fields) that describes
8233 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8234 beginning of this section]. Any necessary discriminants' values
8235 should be in DVAL, a record value; it may be NULL if the object
8236 at ADDR itself contains any necessary discriminant values.
8237 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8238 values from the record are needed. Except in the case that DVAL,
8239 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8240 unchecked) is replaced by a particular branch of the variant.
8242 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8243 is questionable and may be removed. It can arise during the
8244 processing of an unconstrained-array-of-record type where all the
8245 variant branches have exactly the same size. This is because in
8246 such cases, the compiler does not bother to use the XVS convention
8247 when encoding the record. I am currently dubious of this
8248 shortcut and suspect the compiler should be altered. FIXME. */
8250 static struct type *
8251 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8252 CORE_ADDR address, struct value *dval)
8254 struct type *templ_type;
8256 if (type0->is_fixed_instance ())
8259 templ_type = dynamic_template_type (type0);
8261 if (templ_type != NULL)
8262 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8263 else if (variant_field_index (type0) >= 0)
8265 if (dval == NULL && valaddr == NULL && address == 0)
8267 return to_record_with_fixed_variant_part (type0, valaddr, address,
8272 type0->set_is_fixed_instance (true);
8278 /* An ordinary record type (with fixed-length fields) that describes
8279 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8280 union type. Any necessary discriminants' values should be in DVAL,
8281 a record value. That is, this routine selects the appropriate
8282 branch of the union at ADDR according to the discriminant value
8283 indicated in the union's type name. Returns VAR_TYPE0 itself if
8284 it represents a variant subject to a pragma Unchecked_Union. */
8286 static struct type *
8287 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8288 CORE_ADDR address, struct value *dval)
8291 struct type *templ_type;
8292 struct type *var_type;
8294 if (var_type0->code () == TYPE_CODE_PTR)
8295 var_type = var_type0->target_type ();
8297 var_type = var_type0;
8299 templ_type = ada_find_parallel_type (var_type, "___XVU");
8301 if (templ_type != NULL)
8302 var_type = templ_type;
8304 if (is_unchecked_variant (var_type, value_type (dval)))
8306 which = ada_which_variant_applies (var_type, dval);
8309 return empty_record (var_type);
8310 else if (is_dynamic_field (var_type, which))
8311 return to_fixed_record_type
8312 (var_type->field (which).type ()->target_type(), valaddr, address, dval);
8313 else if (variant_field_index (var_type->field (which).type ()) >= 0)
8315 to_fixed_record_type
8316 (var_type->field (which).type (), valaddr, address, dval);
8318 return var_type->field (which).type ();
8321 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8322 ENCODING_TYPE, a type following the GNAT conventions for discrete
8323 type encodings, only carries redundant information. */
8326 ada_is_redundant_range_encoding (struct type *range_type,
8327 struct type *encoding_type)
8329 const char *bounds_str;
8333 gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8335 if (get_base_type (range_type)->code ()
8336 != get_base_type (encoding_type)->code ())
8338 /* The compiler probably used a simple base type to describe
8339 the range type instead of the range's actual base type,
8340 expecting us to get the real base type from the encoding
8341 anyway. In this situation, the encoding cannot be ignored
8346 if (is_dynamic_type (range_type))
8349 if (encoding_type->name () == NULL)
8352 bounds_str = strstr (encoding_type->name (), "___XDLU_");
8353 if (bounds_str == NULL)
8356 n = 8; /* Skip "___XDLU_". */
8357 if (!ada_scan_number (bounds_str, n, &lo, &n))
8359 if (range_type->bounds ()->low.const_val () != lo)
8362 n += 2; /* Skip the "__" separator between the two bounds. */
8363 if (!ada_scan_number (bounds_str, n, &hi, &n))
8365 if (range_type->bounds ()->high.const_val () != hi)
8371 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8372 a type following the GNAT encoding for describing array type
8373 indices, only carries redundant information. */
8376 ada_is_redundant_index_type_desc (struct type *array_type,
8377 struct type *desc_type)
8379 struct type *this_layer = check_typedef (array_type);
8382 for (i = 0; i < desc_type->num_fields (); i++)
8384 if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8385 desc_type->field (i).type ()))
8387 this_layer = check_typedef (this_layer->target_type ());
8393 /* Assuming that TYPE0 is an array type describing the type of a value
8394 at ADDR, and that DVAL describes a record containing any
8395 discriminants used in TYPE0, returns a type for the value that
8396 contains no dynamic components (that is, no components whose sizes
8397 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8398 true, gives an error message if the resulting type's size is over
8401 static struct type *
8402 to_fixed_array_type (struct type *type0, struct value *dval,
8405 struct type *index_type_desc;
8406 struct type *result;
8407 int constrained_packed_array_p;
8408 static const char *xa_suffix = "___XA";
8410 type0 = ada_check_typedef (type0);
8411 if (type0->is_fixed_instance ())
8414 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8415 if (constrained_packed_array_p)
8417 type0 = decode_constrained_packed_array_type (type0);
8418 if (type0 == nullptr)
8419 error (_("could not decode constrained packed array type"));
8422 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8424 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8425 encoding suffixed with 'P' may still be generated. If so,
8426 it should be used to find the XA type. */
8428 if (index_type_desc == NULL)
8430 const char *type_name = ada_type_name (type0);
8432 if (type_name != NULL)
8434 const int len = strlen (type_name);
8435 char *name = (char *) alloca (len + strlen (xa_suffix));
8437 if (type_name[len - 1] == 'P')
8439 strcpy (name, type_name);
8440 strcpy (name + len - 1, xa_suffix);
8441 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8446 ada_fixup_array_indexes_type (index_type_desc);
8447 if (index_type_desc != NULL
8448 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8450 /* Ignore this ___XA parallel type, as it does not bring any
8451 useful information. This allows us to avoid creating fixed
8452 versions of the array's index types, which would be identical
8453 to the original ones. This, in turn, can also help avoid
8454 the creation of fixed versions of the array itself. */
8455 index_type_desc = NULL;
8458 if (index_type_desc == NULL)
8460 struct type *elt_type0 = ada_check_typedef (type0->target_type ());
8462 /* NOTE: elt_type---the fixed version of elt_type0---should never
8463 depend on the contents of the array in properly constructed
8465 /* Create a fixed version of the array element type.
8466 We're not providing the address of an element here,
8467 and thus the actual object value cannot be inspected to do
8468 the conversion. This should not be a problem, since arrays of
8469 unconstrained objects are not allowed. In particular, all
8470 the elements of an array of a tagged type should all be of
8471 the same type specified in the debugging info. No need to
8472 consult the object tag. */
8473 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8475 /* Make sure we always create a new array type when dealing with
8476 packed array types, since we're going to fix-up the array
8477 type length and element bitsize a little further down. */
8478 if (elt_type0 == elt_type && !constrained_packed_array_p)
8481 result = create_array_type (alloc_type_copy (type0),
8482 elt_type, type0->index_type ());
8487 struct type *elt_type0;
8490 for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8491 elt_type0 = elt_type0->target_type ();
8493 /* NOTE: result---the fixed version of elt_type0---should never
8494 depend on the contents of the array in properly constructed
8496 /* Create a fixed version of the array element type.
8497 We're not providing the address of an element here,
8498 and thus the actual object value cannot be inspected to do
8499 the conversion. This should not be a problem, since arrays of
8500 unconstrained objects are not allowed. In particular, all
8501 the elements of an array of a tagged type should all be of
8502 the same type specified in the debugging info. No need to
8503 consult the object tag. */
8505 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8508 for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8510 struct type *range_type =
8511 to_fixed_range_type (index_type_desc->field (i).type (), dval);
8513 result = create_array_type (alloc_type_copy (elt_type0),
8514 result, range_type);
8515 elt_type0 = elt_type0->target_type ();
8519 /* We want to preserve the type name. This can be useful when
8520 trying to get the type name of a value that has already been
8521 printed (for instance, if the user did "print VAR; whatis $". */
8522 result->set_name (type0->name ());
8524 if (constrained_packed_array_p)
8526 /* So far, the resulting type has been created as if the original
8527 type was a regular (non-packed) array type. As a result, the
8528 bitsize of the array elements needs to be set again, and the array
8529 length needs to be recomputed based on that bitsize. */
8530 int len = result->length () / result->target_type ()->length ();
8531 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8533 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8534 result->set_length (len * elt_bitsize / HOST_CHAR_BIT);
8535 if (result->length () * HOST_CHAR_BIT < len * elt_bitsize)
8536 result->set_length (result->length () + 1);
8539 result->set_is_fixed_instance (true);
8544 /* A standard type (containing no dynamically sized components)
8545 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8546 DVAL describes a record containing any discriminants used in TYPE0,
8547 and may be NULL if there are none, or if the object of type TYPE at
8548 ADDRESS or in VALADDR contains these discriminants.
8550 If CHECK_TAG is not null, in the case of tagged types, this function
8551 attempts to locate the object's tag and use it to compute the actual
8552 type. However, when ADDRESS is null, we cannot use it to determine the
8553 location of the tag, and therefore compute the tagged type's actual type.
8554 So we return the tagged type without consulting the tag. */
8556 static struct type *
8557 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8558 CORE_ADDR address, struct value *dval, int check_tag)
8560 type = ada_check_typedef (type);
8562 /* Only un-fixed types need to be handled here. */
8563 if (!HAVE_GNAT_AUX_INFO (type))
8566 switch (type->code ())
8570 case TYPE_CODE_STRUCT:
8572 struct type *static_type = to_static_fixed_type (type);
8573 struct type *fixed_record_type =
8574 to_fixed_record_type (type, valaddr, address, NULL);
8576 /* If STATIC_TYPE is a tagged type and we know the object's address,
8577 then we can determine its tag, and compute the object's actual
8578 type from there. Note that we have to use the fixed record
8579 type (the parent part of the record may have dynamic fields
8580 and the way the location of _tag is expressed may depend on
8583 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8586 value_tag_from_contents_and_address
8590 struct type *real_type = type_from_tag (tag);
8592 value_from_contents_and_address (fixed_record_type,
8595 fixed_record_type = value_type (obj);
8596 if (real_type != NULL)
8597 return to_fixed_record_type
8599 value_address (ada_tag_value_at_base_address (obj)), NULL);
8602 /* Check to see if there is a parallel ___XVZ variable.
8603 If there is, then it provides the actual size of our type. */
8604 else if (ada_type_name (fixed_record_type) != NULL)
8606 const char *name = ada_type_name (fixed_record_type);
8608 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8609 bool xvz_found = false;
8612 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8615 xvz_found = get_int_var_value (xvz_name, size);
8617 catch (const gdb_exception_error &except)
8619 /* We found the variable, but somehow failed to read
8620 its value. Rethrow the same error, but with a little
8621 bit more information, to help the user understand
8622 what went wrong (Eg: the variable might have been
8624 throw_error (except.error,
8625 _("unable to read value of %s (%s)"),
8626 xvz_name, except.what ());
8629 if (xvz_found && fixed_record_type->length () != size)
8631 fixed_record_type = copy_type (fixed_record_type);
8632 fixed_record_type->set_length (size);
8634 /* The FIXED_RECORD_TYPE may have be a stub. We have
8635 observed this when the debugging info is STABS, and
8636 apparently it is something that is hard to fix.
8638 In practice, we don't need the actual type definition
8639 at all, because the presence of the XVZ variable allows us
8640 to assume that there must be a XVS type as well, which we
8641 should be able to use later, when we need the actual type
8644 In the meantime, pretend that the "fixed" type we are
8645 returning is NOT a stub, because this can cause trouble
8646 when using this type to create new types targeting it.
8647 Indeed, the associated creation routines often check
8648 whether the target type is a stub and will try to replace
8649 it, thus using a type with the wrong size. This, in turn,
8650 might cause the new type to have the wrong size too.
8651 Consider the case of an array, for instance, where the size
8652 of the array is computed from the number of elements in
8653 our array multiplied by the size of its element. */
8654 fixed_record_type->set_is_stub (false);
8657 return fixed_record_type;
8659 case TYPE_CODE_ARRAY:
8660 return to_fixed_array_type (type, dval, 1);
8661 case TYPE_CODE_UNION:
8665 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8669 /* The same as ada_to_fixed_type_1, except that it preserves the type
8670 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8672 The typedef layer needs be preserved in order to differentiate between
8673 arrays and array pointers when both types are implemented using the same
8674 fat pointer. In the array pointer case, the pointer is encoded as
8675 a typedef of the pointer type. For instance, considering:
8677 type String_Access is access String;
8678 S1 : String_Access := null;
8680 To the debugger, S1 is defined as a typedef of type String. But
8681 to the user, it is a pointer. So if the user tries to print S1,
8682 we should not dereference the array, but print the array address
8685 If we didn't preserve the typedef layer, we would lose the fact that
8686 the type is to be presented as a pointer (needs de-reference before
8687 being printed). And we would also use the source-level type name. */
8690 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8691 CORE_ADDR address, struct value *dval, int check_tag)
8694 struct type *fixed_type =
8695 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8697 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8698 then preserve the typedef layer.
8700 Implementation note: We can only check the main-type portion of
8701 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8702 from TYPE now returns a type that has the same instance flags
8703 as TYPE. For instance, if TYPE is a "typedef const", and its
8704 target type is a "struct", then the typedef elimination will return
8705 a "const" version of the target type. See check_typedef for more
8706 details about how the typedef layer elimination is done.
8708 brobecker/2010-11-19: It seems to me that the only case where it is
8709 useful to preserve the typedef layer is when dealing with fat pointers.
8710 Perhaps, we could add a check for that and preserve the typedef layer
8711 only in that situation. But this seems unnecessary so far, probably
8712 because we call check_typedef/ada_check_typedef pretty much everywhere.
8714 if (type->code () == TYPE_CODE_TYPEDEF
8715 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8716 == TYPE_MAIN_TYPE (fixed_type)))
8722 /* A standard (static-sized) type corresponding as well as possible to
8723 TYPE0, but based on no runtime data. */
8725 static struct type *
8726 to_static_fixed_type (struct type *type0)
8733 if (type0->is_fixed_instance ())
8736 type0 = ada_check_typedef (type0);
8738 switch (type0->code ())
8742 case TYPE_CODE_STRUCT:
8743 type = dynamic_template_type (type0);
8745 return template_to_static_fixed_type (type);
8747 return template_to_static_fixed_type (type0);
8748 case TYPE_CODE_UNION:
8749 type = ada_find_parallel_type (type0, "___XVU");
8751 return template_to_static_fixed_type (type);
8753 return template_to_static_fixed_type (type0);
8757 /* A static approximation of TYPE with all type wrappers removed. */
8759 static struct type *
8760 static_unwrap_type (struct type *type)
8762 if (ada_is_aligner_type (type))
8764 struct type *type1 = ada_check_typedef (type)->field (0).type ();
8765 if (ada_type_name (type1) == NULL)
8766 type1->set_name (ada_type_name (type));
8768 return static_unwrap_type (type1);
8772 struct type *raw_real_type = ada_get_base_type (type);
8774 if (raw_real_type == type)
8777 return to_static_fixed_type (raw_real_type);
8781 /* In some cases, incomplete and private types require
8782 cross-references that are not resolved as records (for example,
8784 type FooP is access Foo;
8786 type Foo is array ...;
8787 ). In these cases, since there is no mechanism for producing
8788 cross-references to such types, we instead substitute for FooP a
8789 stub enumeration type that is nowhere resolved, and whose tag is
8790 the name of the actual type. Call these types "non-record stubs". */
8792 /* A type equivalent to TYPE that is not a non-record stub, if one
8793 exists, otherwise TYPE. */
8796 ada_check_typedef (struct type *type)
8801 /* If our type is an access to an unconstrained array, which is encoded
8802 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8803 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8804 what allows us to distinguish between fat pointers that represent
8805 array types, and fat pointers that represent array access types
8806 (in both cases, the compiler implements them as fat pointers). */
8807 if (ada_is_access_to_unconstrained_array (type))
8810 type = check_typedef (type);
8811 if (type == NULL || type->code () != TYPE_CODE_ENUM
8812 || !type->is_stub ()
8813 || type->name () == NULL)
8817 const char *name = type->name ();
8818 struct type *type1 = ada_find_any_type (name);
8823 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8824 stubs pointing to arrays, as we don't create symbols for array
8825 types, only for the typedef-to-array types). If that's the case,
8826 strip the typedef layer. */
8827 if (type1->code () == TYPE_CODE_TYPEDEF)
8828 type1 = ada_check_typedef (type1);
8834 /* A value representing the data at VALADDR/ADDRESS as described by
8835 type TYPE0, but with a standard (static-sized) type that correctly
8836 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8837 type, then return VAL0 [this feature is simply to avoid redundant
8838 creation of struct values]. */
8840 static struct value *
8841 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8844 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8846 if (type == type0 && val0 != NULL)
8849 if (VALUE_LVAL (val0) != lval_memory)
8851 /* Our value does not live in memory; it could be a convenience
8852 variable, for instance. Create a not_lval value using val0's
8854 return value_from_contents (type, value_contents (val0).data ());
8857 return value_from_contents_and_address (type, 0, address);
8860 /* A value representing VAL, but with a standard (static-sized) type
8861 that correctly describes it. Does not necessarily create a new
8865 ada_to_fixed_value (struct value *val)
8867 val = unwrap_value (val);
8868 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8875 /* Table mapping attribute numbers to names.
8876 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8878 static const char * const attribute_names[] = {
8896 ada_attribute_name (enum exp_opcode n)
8898 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8899 return attribute_names[n - OP_ATR_FIRST + 1];
8901 return attribute_names[0];
8904 /* Evaluate the 'POS attribute applied to ARG. */
8907 pos_atr (struct value *arg)
8909 struct value *val = coerce_ref (arg);
8910 struct type *type = value_type (val);
8912 if (!discrete_type_p (type))
8913 error (_("'POS only defined on discrete types"));
8915 gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8916 if (!result.has_value ())
8917 error (_("enumeration value is invalid: can't find 'POS"));
8923 ada_pos_atr (struct type *expect_type,
8924 struct expression *exp,
8925 enum noside noside, enum exp_opcode op,
8928 struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8929 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8930 return value_zero (type, not_lval);
8931 return value_from_longest (type, pos_atr (arg));
8934 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8936 static struct value *
8937 val_atr (struct type *type, LONGEST val)
8939 gdb_assert (discrete_type_p (type));
8940 if (type->code () == TYPE_CODE_RANGE)
8941 type = type->target_type ();
8942 if (type->code () == TYPE_CODE_ENUM)
8944 if (val < 0 || val >= type->num_fields ())
8945 error (_("argument to 'VAL out of range"));
8946 val = type->field (val).loc_enumval ();
8948 return value_from_longest (type, val);
8952 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8954 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8955 return value_zero (type, not_lval);
8957 if (!discrete_type_p (type))
8958 error (_("'VAL only defined on discrete types"));
8959 if (!integer_type_p (value_type (arg)))
8960 error (_("'VAL requires integral argument"));
8962 return val_atr (type, value_as_long (arg));
8968 /* True if TYPE appears to be an Ada character type.
8969 [At the moment, this is true only for Character and Wide_Character;
8970 It is a heuristic test that could stand improvement]. */
8973 ada_is_character_type (struct type *type)
8977 /* If the type code says it's a character, then assume it really is,
8978 and don't check any further. */
8979 if (type->code () == TYPE_CODE_CHAR)
8982 /* Otherwise, assume it's a character type iff it is a discrete type
8983 with a known character type name. */
8984 name = ada_type_name (type);
8985 return (name != NULL
8986 && (type->code () == TYPE_CODE_INT
8987 || type->code () == TYPE_CODE_RANGE)
8988 && (strcmp (name, "character") == 0
8989 || strcmp (name, "wide_character") == 0
8990 || strcmp (name, "wide_wide_character") == 0
8991 || strcmp (name, "unsigned char") == 0));
8994 /* True if TYPE appears to be an Ada string type. */
8997 ada_is_string_type (struct type *type)
8999 type = ada_check_typedef (type);
9001 && type->code () != TYPE_CODE_PTR
9002 && (ada_is_simple_array_type (type)
9003 || ada_is_array_descriptor_type (type))
9004 && ada_array_arity (type) == 1)
9006 struct type *elttype = ada_array_element_type (type, 1);
9008 return ada_is_character_type (elttype);
9014 /* The compiler sometimes provides a parallel XVS type for a given
9015 PAD type. Normally, it is safe to follow the PAD type directly,
9016 but older versions of the compiler have a bug that causes the offset
9017 of its "F" field to be wrong. Following that field in that case
9018 would lead to incorrect results, but this can be worked around
9019 by ignoring the PAD type and using the associated XVS type instead.
9021 Set to True if the debugger should trust the contents of PAD types.
9022 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9023 static bool trust_pad_over_xvs = true;
9025 /* True if TYPE is a struct type introduced by the compiler to force the
9026 alignment of a value. Such types have a single field with a
9027 distinctive name. */
9030 ada_is_aligner_type (struct type *type)
9032 type = ada_check_typedef (type);
9034 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9037 return (type->code () == TYPE_CODE_STRUCT
9038 && type->num_fields () == 1
9039 && strcmp (type->field (0).name (), "F") == 0);
9042 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9043 the parallel type. */
9046 ada_get_base_type (struct type *raw_type)
9048 struct type *real_type_namer;
9049 struct type *raw_real_type;
9051 if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9054 if (ada_is_aligner_type (raw_type))
9055 /* The encoding specifies that we should always use the aligner type.
9056 So, even if this aligner type has an associated XVS type, we should
9059 According to the compiler gurus, an XVS type parallel to an aligner
9060 type may exist because of a stabs limitation. In stabs, aligner
9061 types are empty because the field has a variable-sized type, and
9062 thus cannot actually be used as an aligner type. As a result,
9063 we need the associated parallel XVS type to decode the type.
9064 Since the policy in the compiler is to not change the internal
9065 representation based on the debugging info format, we sometimes
9066 end up having a redundant XVS type parallel to the aligner type. */
9069 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9070 if (real_type_namer == NULL
9071 || real_type_namer->code () != TYPE_CODE_STRUCT
9072 || real_type_namer->num_fields () != 1)
9075 if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9077 /* This is an older encoding form where the base type needs to be
9078 looked up by name. We prefer the newer encoding because it is
9080 raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9081 if (raw_real_type == NULL)
9084 return raw_real_type;
9087 /* The field in our XVS type is a reference to the base type. */
9088 return real_type_namer->field (0).type ()->target_type ();
9091 /* The type of value designated by TYPE, with all aligners removed. */
9094 ada_aligned_type (struct type *type)
9096 if (ada_is_aligner_type (type))
9097 return ada_aligned_type (type->field (0).type ());
9099 return ada_get_base_type (type);
9103 /* The address of the aligned value in an object at address VALADDR
9104 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9107 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9109 if (ada_is_aligner_type (type))
9110 return ada_aligned_value_addr
9111 (type->field (0).type (),
9112 valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9119 /* The printed representation of an enumeration literal with encoded
9120 name NAME. The value is good to the next call of ada_enum_name. */
9122 ada_enum_name (const char *name)
9124 static std::string storage;
9127 /* First, unqualify the enumeration name:
9128 1. Search for the last '.' character. If we find one, then skip
9129 all the preceding characters, the unqualified name starts
9130 right after that dot.
9131 2. Otherwise, we may be debugging on a target where the compiler
9132 translates dots into "__". Search forward for double underscores,
9133 but stop searching when we hit an overloading suffix, which is
9134 of the form "__" followed by digits. */
9136 tmp = strrchr (name, '.');
9141 while ((tmp = strstr (name, "__")) != NULL)
9143 if (isdigit (tmp[2]))
9154 if (name[1] == 'U' || name[1] == 'W')
9157 if (name[1] == 'W' && name[2] == 'W')
9159 /* Also handle the QWW case. */
9162 if (sscanf (name + offset, "%x", &v) != 1)
9165 else if (((name[1] >= '0' && name[1] <= '9')
9166 || (name[1] >= 'a' && name[1] <= 'z'))
9169 storage = string_printf ("'%c'", name[1]);
9170 return storage.c_str ();
9175 if (isascii (v) && isprint (v))
9176 storage = string_printf ("'%c'", v);
9177 else if (name[1] == 'U')
9178 storage = string_printf ("'[\"%02x\"]'", v);
9179 else if (name[2] != 'W')
9180 storage = string_printf ("'[\"%04x\"]'", v);
9182 storage = string_printf ("'[\"%06x\"]'", v);
9184 return storage.c_str ();
9188 tmp = strstr (name, "__");
9190 tmp = strstr (name, "$");
9193 storage = std::string (name, tmp - name);
9194 return storage.c_str ();
9201 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9204 static struct value *
9205 unwrap_value (struct value *val)
9207 struct type *type = ada_check_typedef (value_type (val));
9209 if (ada_is_aligner_type (type))
9211 struct value *v = ada_value_struct_elt (val, "F", 0);
9212 struct type *val_type = ada_check_typedef (value_type (v));
9214 if (ada_type_name (val_type) == NULL)
9215 val_type->set_name (ada_type_name (type));
9217 return unwrap_value (v);
9221 struct type *raw_real_type =
9222 ada_check_typedef (ada_get_base_type (type));
9224 /* If there is no parallel XVS or XVE type, then the value is
9225 already unwrapped. Return it without further modification. */
9226 if ((type == raw_real_type)
9227 && ada_find_parallel_type (type, "___XVE") == NULL)
9231 coerce_unspec_val_to_type
9232 (val, ada_to_fixed_type (raw_real_type, 0,
9233 value_address (val),
9238 /* Given two array types T1 and T2, return nonzero iff both arrays
9239 contain the same number of elements. */
9242 ada_same_array_size_p (struct type *t1, struct type *t2)
9244 LONGEST lo1, hi1, lo2, hi2;
9246 /* Get the array bounds in order to verify that the size of
9247 the two arrays match. */
9248 if (!get_array_bounds (t1, &lo1, &hi1)
9249 || !get_array_bounds (t2, &lo2, &hi2))
9250 error (_("unable to determine array bounds"));
9252 /* To make things easier for size comparison, normalize a bit
9253 the case of empty arrays by making sure that the difference
9254 between upper bound and lower bound is always -1. */
9260 return (hi1 - lo1 == hi2 - lo2);
9263 /* Assuming that VAL is an array of integrals, and TYPE represents
9264 an array with the same number of elements, but with wider integral
9265 elements, return an array "casted" to TYPE. In practice, this
9266 means that the returned array is built by casting each element
9267 of the original array into TYPE's (wider) element type. */
9269 static struct value *
9270 ada_promote_array_of_integrals (struct type *type, struct value *val)
9272 struct type *elt_type = type->target_type ();
9276 /* Verify that both val and type are arrays of scalars, and
9277 that the size of val's elements is smaller than the size
9278 of type's element. */
9279 gdb_assert (type->code () == TYPE_CODE_ARRAY);
9280 gdb_assert (is_integral_type (type->target_type ()));
9281 gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9282 gdb_assert (is_integral_type (value_type (val)->target_type ()));
9283 gdb_assert (type->target_type ()->length ()
9284 > value_type (val)->target_type ()->length ());
9286 if (!get_array_bounds (type, &lo, &hi))
9287 error (_("unable to determine array bounds"));
9289 value *res = allocate_value (type);
9290 gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9292 /* Promote each array element. */
9293 for (i = 0; i < hi - lo + 1; i++)
9295 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9296 int elt_len = elt_type->length ();
9298 copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9304 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9305 return the converted value. */
9307 static struct value *
9308 coerce_for_assign (struct type *type, struct value *val)
9310 struct type *type2 = value_type (val);
9315 type2 = ada_check_typedef (type2);
9316 type = ada_check_typedef (type);
9318 if (type2->code () == TYPE_CODE_PTR
9319 && type->code () == TYPE_CODE_ARRAY)
9321 val = ada_value_ind (val);
9322 type2 = value_type (val);
9325 if (type2->code () == TYPE_CODE_ARRAY
9326 && type->code () == TYPE_CODE_ARRAY)
9328 if (!ada_same_array_size_p (type, type2))
9329 error (_("cannot assign arrays of different length"));
9331 if (is_integral_type (type->target_type ())
9332 && is_integral_type (type2->target_type ())
9333 && type2->target_type ()->length () < type->target_type ()->length ())
9335 /* Allow implicit promotion of the array elements to
9337 return ada_promote_array_of_integrals (type, val);
9340 if (type2->target_type ()->length () != type->target_type ()->length ())
9341 error (_("Incompatible types in assignment"));
9342 deprecated_set_value_type (val, type);
9347 static struct value *
9348 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9351 struct type *type1, *type2;
9354 arg1 = coerce_ref (arg1);
9355 arg2 = coerce_ref (arg2);
9356 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9357 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9359 if (type1->code () != TYPE_CODE_INT
9360 || type2->code () != TYPE_CODE_INT)
9361 return value_binop (arg1, arg2, op);
9370 return value_binop (arg1, arg2, op);
9373 v2 = value_as_long (arg2);
9377 if (op == BINOP_MOD)
9379 else if (op == BINOP_DIV)
9383 gdb_assert (op == BINOP_REM);
9387 error (_("second operand of %s must not be zero."), name);
9390 if (type1->is_unsigned () || op == BINOP_MOD)
9391 return value_binop (arg1, arg2, op);
9393 v1 = value_as_long (arg1);
9398 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9399 v += v > 0 ? -1 : 1;
9407 /* Should not reach this point. */
9411 val = allocate_value (type1);
9412 store_unsigned_integer (value_contents_raw (val).data (),
9413 value_type (val)->length (),
9414 type_byte_order (type1), v);
9419 ada_value_equal (struct value *arg1, struct value *arg2)
9421 if (ada_is_direct_array_type (value_type (arg1))
9422 || ada_is_direct_array_type (value_type (arg2)))
9424 struct type *arg1_type, *arg2_type;
9426 /* Automatically dereference any array reference before
9427 we attempt to perform the comparison. */
9428 arg1 = ada_coerce_ref (arg1);
9429 arg2 = ada_coerce_ref (arg2);
9431 arg1 = ada_coerce_to_simple_array (arg1);
9432 arg2 = ada_coerce_to_simple_array (arg2);
9434 arg1_type = ada_check_typedef (value_type (arg1));
9435 arg2_type = ada_check_typedef (value_type (arg2));
9437 if (arg1_type->code () != TYPE_CODE_ARRAY
9438 || arg2_type->code () != TYPE_CODE_ARRAY)
9439 error (_("Attempt to compare array with non-array"));
9440 /* FIXME: The following works only for types whose
9441 representations use all bits (no padding or undefined bits)
9442 and do not have user-defined equality. */
9443 return (arg1_type->length () == arg2_type->length ()
9444 && memcmp (value_contents (arg1).data (),
9445 value_contents (arg2).data (),
9446 arg1_type->length ()) == 0);
9448 return value_equal (arg1, arg2);
9455 check_objfile (const std::unique_ptr<ada_component> &comp,
9456 struct objfile *objfile)
9458 return comp->uses_objfile (objfile);
9461 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9462 component of LHS (a simple array or a record). Does not modify the
9463 inferior's memory, nor does it modify LHS (unless LHS ==
9467 assign_component (struct value *container, struct value *lhs, LONGEST index,
9468 struct expression *exp, operation_up &arg)
9470 scoped_value_mark mark;
9473 struct type *lhs_type = check_typedef (value_type (lhs));
9475 if (lhs_type->code () == TYPE_CODE_ARRAY)
9477 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9478 struct value *index_val = value_from_longest (index_type, index);
9480 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9484 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9485 elt = ada_to_fixed_value (elt);
9488 ada_aggregate_operation *ag_op
9489 = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9490 if (ag_op != nullptr)
9491 ag_op->assign_aggregate (container, elt, exp);
9493 value_assign_to_component (container, elt,
9494 arg->evaluate (nullptr, exp,
9499 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9501 for (const auto &item : m_components)
9502 if (item->uses_objfile (objfile))
9508 ada_aggregate_component::dump (ui_file *stream, int depth)
9510 gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9511 for (const auto &item : m_components)
9512 item->dump (stream, depth + 1);
9516 ada_aggregate_component::assign (struct value *container,
9517 struct value *lhs, struct expression *exp,
9518 std::vector<LONGEST> &indices,
9519 LONGEST low, LONGEST high)
9521 for (auto &item : m_components)
9522 item->assign (container, lhs, exp, indices, low, high);
9525 /* See ada-exp.h. */
9528 ada_aggregate_operation::assign_aggregate (struct value *container,
9530 struct expression *exp)
9532 struct type *lhs_type;
9533 LONGEST low_index, high_index;
9535 container = ada_coerce_ref (container);
9536 if (ada_is_direct_array_type (value_type (container)))
9537 container = ada_coerce_to_simple_array (container);
9538 lhs = ada_coerce_ref (lhs);
9539 if (!deprecated_value_modifiable (lhs))
9540 error (_("Left operand of assignment is not a modifiable lvalue."));
9542 lhs_type = check_typedef (value_type (lhs));
9543 if (ada_is_direct_array_type (lhs_type))
9545 lhs = ada_coerce_to_simple_array (lhs);
9546 lhs_type = check_typedef (value_type (lhs));
9547 low_index = lhs_type->bounds ()->low.const_val ();
9548 high_index = lhs_type->bounds ()->high.const_val ();
9550 else if (lhs_type->code () == TYPE_CODE_STRUCT)
9553 high_index = num_visible_fields (lhs_type) - 1;
9556 error (_("Left-hand side must be array or record."));
9558 std::vector<LONGEST> indices (4);
9559 indices[0] = indices[1] = low_index - 1;
9560 indices[2] = indices[3] = high_index + 1;
9562 std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9563 low_index, high_index);
9569 ada_positional_component::uses_objfile (struct objfile *objfile)
9571 return m_op->uses_objfile (objfile);
9575 ada_positional_component::dump (ui_file *stream, int depth)
9577 gdb_printf (stream, _("%*sPositional, index = %d\n"),
9578 depth, "", m_index);
9579 m_op->dump (stream, depth + 1);
9582 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9583 construct, given that the positions are relative to lower bound
9584 LOW, where HIGH is the upper bound. Record the position in
9585 INDICES. CONTAINER is as for assign_aggregate. */
9587 ada_positional_component::assign (struct value *container,
9588 struct value *lhs, struct expression *exp,
9589 std::vector<LONGEST> &indices,
9590 LONGEST low, LONGEST high)
9592 LONGEST ind = m_index + low;
9594 if (ind - 1 == high)
9595 warning (_("Extra components in aggregate ignored."));
9598 add_component_interval (ind, ind, indices);
9599 assign_component (container, lhs, ind, exp, m_op);
9604 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9606 return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9610 ada_discrete_range_association::dump (ui_file *stream, int depth)
9612 gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9613 m_low->dump (stream, depth + 1);
9614 m_high->dump (stream, depth + 1);
9618 ada_discrete_range_association::assign (struct value *container,
9620 struct expression *exp,
9621 std::vector<LONGEST> &indices,
9622 LONGEST low, LONGEST high,
9625 LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9626 LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9628 if (lower <= upper && (lower < low || upper > high))
9629 error (_("Index in component association out of bounds."));
9631 add_component_interval (lower, upper, indices);
9632 while (lower <= upper)
9634 assign_component (container, lhs, lower, exp, op);
9640 ada_name_association::uses_objfile (struct objfile *objfile)
9642 return m_val->uses_objfile (objfile);
9646 ada_name_association::dump (ui_file *stream, int depth)
9648 gdb_printf (stream, _("%*sName:\n"), depth, "");
9649 m_val->dump (stream, depth + 1);
9653 ada_name_association::assign (struct value *container,
9655 struct expression *exp,
9656 std::vector<LONGEST> &indices,
9657 LONGEST low, LONGEST high,
9662 if (ada_is_direct_array_type (value_type (lhs)))
9663 index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9667 ada_string_operation *strop
9668 = dynamic_cast<ada_string_operation *> (m_val.get ());
9671 if (strop != nullptr)
9672 name = strop->get_name ();
9675 ada_var_value_operation *vvo
9676 = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9678 error (_("Invalid record component association."));
9679 name = vvo->get_symbol ()->natural_name ();
9683 if (! find_struct_field (name, value_type (lhs), 0,
9684 NULL, NULL, NULL, NULL, &index))
9685 error (_("Unknown component name: %s."), name);
9688 add_component_interval (index, index, indices);
9689 assign_component (container, lhs, index, exp, op);
9693 ada_choices_component::uses_objfile (struct objfile *objfile)
9695 if (m_op->uses_objfile (objfile))
9697 for (const auto &item : m_assocs)
9698 if (item->uses_objfile (objfile))
9704 ada_choices_component::dump (ui_file *stream, int depth)
9706 gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9707 m_op->dump (stream, depth + 1);
9708 for (const auto &item : m_assocs)
9709 item->dump (stream, depth + 1);
9712 /* Assign into the components of LHS indexed by the OP_CHOICES
9713 construct at *POS, updating *POS past the construct, given that
9714 the allowable indices are LOW..HIGH. Record the indices assigned
9715 to in INDICES. CONTAINER is as for assign_aggregate. */
9717 ada_choices_component::assign (struct value *container,
9718 struct value *lhs, struct expression *exp,
9719 std::vector<LONGEST> &indices,
9720 LONGEST low, LONGEST high)
9722 for (auto &item : m_assocs)
9723 item->assign (container, lhs, exp, indices, low, high, m_op);
9727 ada_others_component::uses_objfile (struct objfile *objfile)
9729 return m_op->uses_objfile (objfile);
9733 ada_others_component::dump (ui_file *stream, int depth)
9735 gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9736 m_op->dump (stream, depth + 1);
9739 /* Assign the value of the expression in the OP_OTHERS construct in
9740 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9741 have not been previously assigned. The index intervals already assigned
9742 are in INDICES. CONTAINER is as for assign_aggregate. */
9744 ada_others_component::assign (struct value *container,
9745 struct value *lhs, struct expression *exp,
9746 std::vector<LONGEST> &indices,
9747 LONGEST low, LONGEST high)
9749 int num_indices = indices.size ();
9750 for (int i = 0; i < num_indices - 2; i += 2)
9752 for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9753 assign_component (container, lhs, ind, exp, m_op);
9758 ada_assign_operation::evaluate (struct type *expect_type,
9759 struct expression *exp,
9762 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9764 ada_aggregate_operation *ag_op
9765 = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9766 if (ag_op != nullptr)
9768 if (noside != EVAL_NORMAL)
9771 arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9772 return ada_value_assign (arg1, arg1);
9774 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9775 except if the lhs of our assignment is a convenience variable.
9776 In the case of assigning to a convenience variable, the lhs
9777 should be exactly the result of the evaluation of the rhs. */
9778 struct type *type = value_type (arg1);
9779 if (VALUE_LVAL (arg1) == lval_internalvar)
9781 value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9782 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9784 if (VALUE_LVAL (arg1) == lval_internalvar)
9789 arg2 = coerce_for_assign (value_type (arg1), arg2);
9790 return ada_value_assign (arg1, arg2);
9793 } /* namespace expr */
9795 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9796 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9799 add_component_interval (LONGEST low, LONGEST high,
9800 std::vector<LONGEST> &indices)
9804 int size = indices.size ();
9805 for (i = 0; i < size; i += 2) {
9806 if (high >= indices[i] && low <= indices[i + 1])
9810 for (kh = i + 2; kh < size; kh += 2)
9811 if (high < indices[kh])
9813 if (low < indices[i])
9815 indices[i + 1] = indices[kh - 1];
9816 if (high > indices[i + 1])
9817 indices[i + 1] = high;
9818 memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9819 indices.resize (kh - i - 2);
9822 else if (high < indices[i])
9826 indices.resize (indices.size () + 2);
9827 for (j = indices.size () - 1; j >= i + 2; j -= 1)
9828 indices[j] = indices[j - 2];
9830 indices[i + 1] = high;
9833 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9836 static struct value *
9837 ada_value_cast (struct type *type, struct value *arg2)
9839 if (type == ada_check_typedef (value_type (arg2)))
9842 return value_cast (type, arg2);
9845 /* Evaluating Ada expressions, and printing their result.
9846 ------------------------------------------------------
9851 We usually evaluate an Ada expression in order to print its value.
9852 We also evaluate an expression in order to print its type, which
9853 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9854 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9855 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9856 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9859 Evaluating expressions is a little more complicated for Ada entities
9860 than it is for entities in languages such as C. The main reason for
9861 this is that Ada provides types whose definition might be dynamic.
9862 One example of such types is variant records. Or another example
9863 would be an array whose bounds can only be known at run time.
9865 The following description is a general guide as to what should be
9866 done (and what should NOT be done) in order to evaluate an expression
9867 involving such types, and when. This does not cover how the semantic
9868 information is encoded by GNAT as this is covered separatly. For the
9869 document used as the reference for the GNAT encoding, see exp_dbug.ads
9870 in the GNAT sources.
9872 Ideally, we should embed each part of this description next to its
9873 associated code. Unfortunately, the amount of code is so vast right
9874 now that it's hard to see whether the code handling a particular
9875 situation might be duplicated or not. One day, when the code is
9876 cleaned up, this guide might become redundant with the comments
9877 inserted in the code, and we might want to remove it.
9879 2. ``Fixing'' an Entity, the Simple Case:
9880 -----------------------------------------
9882 When evaluating Ada expressions, the tricky issue is that they may
9883 reference entities whose type contents and size are not statically
9884 known. Consider for instance a variant record:
9886 type Rec (Empty : Boolean := True) is record
9889 when False => Value : Integer;
9892 Yes : Rec := (Empty => False, Value => 1);
9893 No : Rec := (empty => True);
9895 The size and contents of that record depends on the value of the
9896 descriminant (Rec.Empty). At this point, neither the debugging
9897 information nor the associated type structure in GDB are able to
9898 express such dynamic types. So what the debugger does is to create
9899 "fixed" versions of the type that applies to the specific object.
9900 We also informally refer to this operation as "fixing" an object,
9901 which means creating its associated fixed type.
9903 Example: when printing the value of variable "Yes" above, its fixed
9904 type would look like this:
9911 On the other hand, if we printed the value of "No", its fixed type
9918 Things become a little more complicated when trying to fix an entity
9919 with a dynamic type that directly contains another dynamic type,
9920 such as an array of variant records, for instance. There are
9921 two possible cases: Arrays, and records.
9923 3. ``Fixing'' Arrays:
9924 ---------------------
9926 The type structure in GDB describes an array in terms of its bounds,
9927 and the type of its elements. By design, all elements in the array
9928 have the same type and we cannot represent an array of variant elements
9929 using the current type structure in GDB. When fixing an array,
9930 we cannot fix the array element, as we would potentially need one
9931 fixed type per element of the array. As a result, the best we can do
9932 when fixing an array is to produce an array whose bounds and size
9933 are correct (allowing us to read it from memory), but without having
9934 touched its element type. Fixing each element will be done later,
9935 when (if) necessary.
9937 Arrays are a little simpler to handle than records, because the same
9938 amount of memory is allocated for each element of the array, even if
9939 the amount of space actually used by each element differs from element
9940 to element. Consider for instance the following array of type Rec:
9942 type Rec_Array is array (1 .. 2) of Rec;
9944 The actual amount of memory occupied by each element might be different
9945 from element to element, depending on the value of their discriminant.
9946 But the amount of space reserved for each element in the array remains
9947 fixed regardless. So we simply need to compute that size using
9948 the debugging information available, from which we can then determine
9949 the array size (we multiply the number of elements of the array by
9950 the size of each element).
9952 The simplest case is when we have an array of a constrained element
9953 type. For instance, consider the following type declarations:
9955 type Bounded_String (Max_Size : Integer) is
9957 Buffer : String (1 .. Max_Size);
9959 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9961 In this case, the compiler describes the array as an array of
9962 variable-size elements (identified by its XVS suffix) for which
9963 the size can be read in the parallel XVZ variable.
9965 In the case of an array of an unconstrained element type, the compiler
9966 wraps the array element inside a private PAD type. This type should not
9967 be shown to the user, and must be "unwrap"'ed before printing. Note
9968 that we also use the adjective "aligner" in our code to designate
9969 these wrapper types.
9971 In some cases, the size allocated for each element is statically
9972 known. In that case, the PAD type already has the correct size,
9973 and the array element should remain unfixed.
9975 But there are cases when this size is not statically known.
9976 For instance, assuming that "Five" is an integer variable:
9978 type Dynamic is array (1 .. Five) of Integer;
9979 type Wrapper (Has_Length : Boolean := False) is record
9982 when True => Length : Integer;
9986 type Wrapper_Array is array (1 .. 2) of Wrapper;
9988 Hello : Wrapper_Array := (others => (Has_Length => True,
9989 Data => (others => 17),
9993 The debugging info would describe variable Hello as being an
9994 array of a PAD type. The size of that PAD type is not statically
9995 known, but can be determined using a parallel XVZ variable.
9996 In that case, a copy of the PAD type with the correct size should
9997 be used for the fixed array.
9999 3. ``Fixing'' record type objects:
10000 ----------------------------------
10002 Things are slightly different from arrays in the case of dynamic
10003 record types. In this case, in order to compute the associated
10004 fixed type, we need to determine the size and offset of each of
10005 its components. This, in turn, requires us to compute the fixed
10006 type of each of these components.
10008 Consider for instance the example:
10010 type Bounded_String (Max_Size : Natural) is record
10011 Str : String (1 .. Max_Size);
10014 My_String : Bounded_String (Max_Size => 10);
10016 In that case, the position of field "Length" depends on the size
10017 of field Str, which itself depends on the value of the Max_Size
10018 discriminant. In order to fix the type of variable My_String,
10019 we need to fix the type of field Str. Therefore, fixing a variant
10020 record requires us to fix each of its components.
10022 However, if a component does not have a dynamic size, the component
10023 should not be fixed. In particular, fields that use a PAD type
10024 should not fixed. Here is an example where this might happen
10025 (assuming type Rec above):
10027 type Container (Big : Boolean) is record
10031 when True => Another : Integer;
10032 when False => null;
10035 My_Container : Container := (Big => False,
10036 First => (Empty => True),
10039 In that example, the compiler creates a PAD type for component First,
10040 whose size is constant, and then positions the component After just
10041 right after it. The offset of component After is therefore constant
10044 The debugger computes the position of each field based on an algorithm
10045 that uses, among other things, the actual position and size of the field
10046 preceding it. Let's now imagine that the user is trying to print
10047 the value of My_Container. If the type fixing was recursive, we would
10048 end up computing the offset of field After based on the size of the
10049 fixed version of field First. And since in our example First has
10050 only one actual field, the size of the fixed type is actually smaller
10051 than the amount of space allocated to that field, and thus we would
10052 compute the wrong offset of field After.
10054 To make things more complicated, we need to watch out for dynamic
10055 components of variant records (identified by the ___XVL suffix in
10056 the component name). Even if the target type is a PAD type, the size
10057 of that type might not be statically known. So the PAD type needs
10058 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10059 we might end up with the wrong size for our component. This can be
10060 observed with the following type declarations:
10062 type Octal is new Integer range 0 .. 7;
10063 type Octal_Array is array (Positive range <>) of Octal;
10064 pragma Pack (Octal_Array);
10066 type Octal_Buffer (Size : Positive) is record
10067 Buffer : Octal_Array (1 .. Size);
10071 In that case, Buffer is a PAD type whose size is unset and needs
10072 to be computed by fixing the unwrapped type.
10074 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10075 ----------------------------------------------------------
10077 Lastly, when should the sub-elements of an entity that remained unfixed
10078 thus far, be actually fixed?
10080 The answer is: Only when referencing that element. For instance
10081 when selecting one component of a record, this specific component
10082 should be fixed at that point in time. Or when printing the value
10083 of a record, each component should be fixed before its value gets
10084 printed. Similarly for arrays, the element of the array should be
10085 fixed when printing each element of the array, or when extracting
10086 one element out of that array. On the other hand, fixing should
10087 not be performed on the elements when taking a slice of an array!
10089 Note that one of the side effects of miscomputing the offset and
10090 size of each field is that we end up also miscomputing the size
10091 of the containing type. This can have adverse results when computing
10092 the value of an entity. GDB fetches the value of an entity based
10093 on the size of its type, and thus a wrong size causes GDB to fetch
10094 the wrong amount of memory. In the case where the computed size is
10095 too small, GDB fetches too little data to print the value of our
10096 entity. Results in this case are unpredictable, as we usually read
10097 past the buffer containing the data =:-o. */
10099 /* A helper function for TERNOP_IN_RANGE. */
10102 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10103 enum noside noside,
10104 value *arg1, value *arg2, value *arg3)
10106 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10107 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10108 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10110 value_from_longest (type,
10111 (value_less (arg1, arg3)
10112 || value_equal (arg1, arg3))
10113 && (value_less (arg2, arg1)
10114 || value_equal (arg2, arg1)));
10117 /* A helper function for UNOP_NEG. */
10120 ada_unop_neg (struct type *expect_type,
10121 struct expression *exp,
10122 enum noside noside, enum exp_opcode op,
10123 struct value *arg1)
10125 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10126 return value_neg (arg1);
10129 /* A helper function for UNOP_IN_RANGE. */
10132 ada_unop_in_range (struct type *expect_type,
10133 struct expression *exp,
10134 enum noside noside, enum exp_opcode op,
10135 struct value *arg1, struct type *type)
10137 struct value *arg2, *arg3;
10138 switch (type->code ())
10141 lim_warning (_("Membership test incompletely implemented; "
10142 "always returns true"));
10143 type = language_bool_type (exp->language_defn, exp->gdbarch);
10144 return value_from_longest (type, (LONGEST) 1);
10146 case TYPE_CODE_RANGE:
10147 arg2 = value_from_longest (type,
10148 type->bounds ()->low.const_val ());
10149 arg3 = value_from_longest (type,
10150 type->bounds ()->high.const_val ());
10151 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10152 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10153 type = language_bool_type (exp->language_defn, exp->gdbarch);
10155 value_from_longest (type,
10156 (value_less (arg1, arg3)
10157 || value_equal (arg1, arg3))
10158 && (value_less (arg2, arg1)
10159 || value_equal (arg2, arg1)));
10163 /* A helper function for OP_ATR_TAG. */
10166 ada_atr_tag (struct type *expect_type,
10167 struct expression *exp,
10168 enum noside noside, enum exp_opcode op,
10169 struct value *arg1)
10171 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10172 return value_zero (ada_tag_type (arg1), not_lval);
10174 return ada_value_tag (arg1);
10177 /* A helper function for OP_ATR_SIZE. */
10180 ada_atr_size (struct type *expect_type,
10181 struct expression *exp,
10182 enum noside noside, enum exp_opcode op,
10183 struct value *arg1)
10185 struct type *type = value_type (arg1);
10187 /* If the argument is a reference, then dereference its type, since
10188 the user is really asking for the size of the actual object,
10189 not the size of the pointer. */
10190 if (type->code () == TYPE_CODE_REF)
10191 type = type->target_type ();
10193 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10194 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10196 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10197 TARGET_CHAR_BIT * type->length ());
10200 /* A helper function for UNOP_ABS. */
10203 ada_abs (struct type *expect_type,
10204 struct expression *exp,
10205 enum noside noside, enum exp_opcode op,
10206 struct value *arg1)
10208 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10209 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10210 return value_neg (arg1);
10215 /* A helper function for BINOP_MUL. */
10218 ada_mult_binop (struct type *expect_type,
10219 struct expression *exp,
10220 enum noside noside, enum exp_opcode op,
10221 struct value *arg1, struct value *arg2)
10223 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10225 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10226 return value_zero (value_type (arg1), not_lval);
10230 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10231 return ada_value_binop (arg1, arg2, op);
10235 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10238 ada_equal_binop (struct type *expect_type,
10239 struct expression *exp,
10240 enum noside noside, enum exp_opcode op,
10241 struct value *arg1, struct value *arg2)
10244 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10248 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10249 tem = ada_value_equal (arg1, arg2);
10251 if (op == BINOP_NOTEQUAL)
10253 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10254 return value_from_longest (type, (LONGEST) tem);
10257 /* A helper function for TERNOP_SLICE. */
10260 ada_ternop_slice (struct expression *exp,
10261 enum noside noside,
10262 struct value *array, struct value *low_bound_val,
10263 struct value *high_bound_val)
10266 LONGEST high_bound;
10268 low_bound_val = coerce_ref (low_bound_val);
10269 high_bound_val = coerce_ref (high_bound_val);
10270 low_bound = value_as_long (low_bound_val);
10271 high_bound = value_as_long (high_bound_val);
10273 /* If this is a reference to an aligner type, then remove all
10275 if (value_type (array)->code () == TYPE_CODE_REF
10276 && ada_is_aligner_type (value_type (array)->target_type ()))
10277 value_type (array)->set_target_type
10278 (ada_aligned_type (value_type (array)->target_type ()));
10280 if (ada_is_any_packed_array_type (value_type (array)))
10281 error (_("cannot slice a packed array"));
10283 /* If this is a reference to an array or an array lvalue,
10284 convert to a pointer. */
10285 if (value_type (array)->code () == TYPE_CODE_REF
10286 || (value_type (array)->code () == TYPE_CODE_ARRAY
10287 && VALUE_LVAL (array) == lval_memory))
10288 array = value_addr (array);
10290 if (noside == EVAL_AVOID_SIDE_EFFECTS
10291 && ada_is_array_descriptor_type (ada_check_typedef
10292 (value_type (array))))
10293 return empty_array (ada_type_of_array (array, 0), low_bound,
10296 array = ada_coerce_to_simple_array_ptr (array);
10298 /* If we have more than one level of pointer indirection,
10299 dereference the value until we get only one level. */
10300 while (value_type (array)->code () == TYPE_CODE_PTR
10301 && (value_type (array)->target_type ()->code ()
10303 array = value_ind (array);
10305 /* Make sure we really do have an array type before going further,
10306 to avoid a SEGV when trying to get the index type or the target
10307 type later down the road if the debug info generated by
10308 the compiler is incorrect or incomplete. */
10309 if (!ada_is_simple_array_type (value_type (array)))
10310 error (_("cannot take slice of non-array"));
10312 if (ada_check_typedef (value_type (array))->code ()
10315 struct type *type0 = ada_check_typedef (value_type (array));
10317 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10318 return empty_array (type0->target_type (), low_bound, high_bound);
10321 struct type *arr_type0 =
10322 to_fixed_array_type (type0->target_type (), NULL, 1);
10324 return ada_value_slice_from_ptr (array, arr_type0,
10325 longest_to_int (low_bound),
10326 longest_to_int (high_bound));
10329 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10331 else if (high_bound < low_bound)
10332 return empty_array (value_type (array), low_bound, high_bound);
10334 return ada_value_slice (array, longest_to_int (low_bound),
10335 longest_to_int (high_bound));
10338 /* A helper function for BINOP_IN_BOUNDS. */
10341 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10342 struct value *arg1, struct value *arg2, int n)
10344 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10346 struct type *type = language_bool_type (exp->language_defn,
10348 return value_zero (type, not_lval);
10351 struct type *type = ada_index_type (value_type (arg2), n, "range");
10353 type = value_type (arg1);
10355 value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10356 arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10358 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10359 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10360 type = language_bool_type (exp->language_defn, exp->gdbarch);
10361 return value_from_longest (type,
10362 (value_less (arg1, arg3)
10363 || value_equal (arg1, arg3))
10364 && (value_less (arg2, arg1)
10365 || value_equal (arg2, arg1)));
10368 /* A helper function for some attribute operations. */
10371 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10372 struct value *arg1, struct type *type_arg, int tem)
10374 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10376 if (type_arg == NULL)
10377 type_arg = value_type (arg1);
10379 if (ada_is_constrained_packed_array_type (type_arg))
10380 type_arg = decode_constrained_packed_array_type (type_arg);
10382 if (!discrete_type_p (type_arg))
10386 default: /* Should never happen. */
10387 error (_("unexpected attribute encountered"));
10390 type_arg = ada_index_type (type_arg, tem,
10391 ada_attribute_name (op));
10393 case OP_ATR_LENGTH:
10394 type_arg = builtin_type (exp->gdbarch)->builtin_int;
10399 return value_zero (type_arg, not_lval);
10401 else if (type_arg == NULL)
10403 arg1 = ada_coerce_ref (arg1);
10405 if (ada_is_constrained_packed_array_type (value_type (arg1)))
10406 arg1 = ada_coerce_to_simple_array (arg1);
10409 if (op == OP_ATR_LENGTH)
10410 type = builtin_type (exp->gdbarch)->builtin_int;
10413 type = ada_index_type (value_type (arg1), tem,
10414 ada_attribute_name (op));
10416 type = builtin_type (exp->gdbarch)->builtin_int;
10421 default: /* Should never happen. */
10422 error (_("unexpected attribute encountered"));
10424 return value_from_longest
10425 (type, ada_array_bound (arg1, tem, 0));
10427 return value_from_longest
10428 (type, ada_array_bound (arg1, tem, 1));
10429 case OP_ATR_LENGTH:
10430 return value_from_longest
10431 (type, ada_array_length (arg1, tem));
10434 else if (discrete_type_p (type_arg))
10436 struct type *range_type;
10437 const char *name = ada_type_name (type_arg);
10440 if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10441 range_type = to_fixed_range_type (type_arg, NULL);
10442 if (range_type == NULL)
10443 range_type = type_arg;
10447 error (_("unexpected attribute encountered"));
10449 return value_from_longest
10450 (range_type, ada_discrete_type_low_bound (range_type));
10452 return value_from_longest
10453 (range_type, ada_discrete_type_high_bound (range_type));
10454 case OP_ATR_LENGTH:
10455 error (_("the 'length attribute applies only to array types"));
10458 else if (type_arg->code () == TYPE_CODE_FLT)
10459 error (_("unimplemented type attribute"));
10464 if (ada_is_constrained_packed_array_type (type_arg))
10465 type_arg = decode_constrained_packed_array_type (type_arg);
10468 if (op == OP_ATR_LENGTH)
10469 type = builtin_type (exp->gdbarch)->builtin_int;
10472 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10474 type = builtin_type (exp->gdbarch)->builtin_int;
10480 error (_("unexpected attribute encountered"));
10482 low = ada_array_bound_from_type (type_arg, tem, 0);
10483 return value_from_longest (type, low);
10485 high = ada_array_bound_from_type (type_arg, tem, 1);
10486 return value_from_longest (type, high);
10487 case OP_ATR_LENGTH:
10488 low = ada_array_bound_from_type (type_arg, tem, 0);
10489 high = ada_array_bound_from_type (type_arg, tem, 1);
10490 return value_from_longest (type, high - low + 1);
10495 /* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
10498 ada_binop_minmax (struct type *expect_type,
10499 struct expression *exp,
10500 enum noside noside, enum exp_opcode op,
10501 struct value *arg1, struct value *arg2)
10503 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10504 return value_zero (value_type (arg1), not_lval);
10507 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10508 return value_binop (arg1, arg2, op);
10512 /* A helper function for BINOP_EXP. */
10515 ada_binop_exp (struct type *expect_type,
10516 struct expression *exp,
10517 enum noside noside, enum exp_opcode op,
10518 struct value *arg1, struct value *arg2)
10520 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10521 return value_zero (value_type (arg1), not_lval);
10524 /* For integer exponentiation operations,
10525 only promote the first argument. */
10526 if (is_integral_type (value_type (arg2)))
10527 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10529 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10531 return value_binop (arg1, arg2, op);
10538 /* See ada-exp.h. */
10541 ada_resolvable::replace (operation_up &&owner,
10542 struct expression *exp,
10543 bool deprocedure_p,
10544 bool parse_completion,
10545 innermost_block_tracker *tracker,
10546 struct type *context_type)
10548 if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10549 return (make_operation<ada_funcall_operation>
10550 (std::move (owner),
10551 std::vector<operation_up> ()));
10552 return std::move (owner);
10555 /* Convert the character literal whose value would be VAL to the
10556 appropriate value of type TYPE, if there is a translation.
10557 Otherwise return VAL. Hence, in an enumeration type ('A', 'B'),
10558 the literal 'A' (VAL == 65), returns 0. */
10561 convert_char_literal (struct type *type, LONGEST val)
10568 type = check_typedef (type);
10569 if (type->code () != TYPE_CODE_ENUM)
10572 if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10573 xsnprintf (name, sizeof (name), "Q%c", (int) val);
10574 else if (val >= 0 && val < 256)
10575 xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10576 else if (val >= 0 && val < 0x10000)
10577 xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10579 xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10580 size_t len = strlen (name);
10581 for (f = 0; f < type->num_fields (); f += 1)
10583 /* Check the suffix because an enum constant in a package will
10584 have a name like "pkg__QUxx". This is safe enough because we
10585 already have the correct type, and because mangling means
10586 there can't be clashes. */
10587 const char *ename = type->field (f).name ();
10588 size_t elen = strlen (ename);
10590 if (elen >= len && strcmp (name, ename + elen - len) == 0)
10591 return type->field (f).loc_enumval ();
10597 ada_char_operation::evaluate (struct type *expect_type,
10598 struct expression *exp,
10599 enum noside noside)
10601 value *result = long_const_operation::evaluate (expect_type, exp, noside);
10602 if (expect_type != nullptr)
10603 result = ada_value_cast (expect_type, result);
10607 /* See ada-exp.h. */
10610 ada_char_operation::replace (operation_up &&owner,
10611 struct expression *exp,
10612 bool deprocedure_p,
10613 bool parse_completion,
10614 innermost_block_tracker *tracker,
10615 struct type *context_type)
10617 operation_up result = std::move (owner);
10619 if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10621 gdb_assert (result.get () == this);
10622 std::get<0> (m_storage) = context_type;
10623 std::get<1> (m_storage)
10624 = convert_char_literal (context_type, std::get<1> (m_storage));
10631 ada_wrapped_operation::evaluate (struct type *expect_type,
10632 struct expression *exp,
10633 enum noside noside)
10635 value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10636 if (noside == EVAL_NORMAL)
10637 result = unwrap_value (result);
10639 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10640 then we need to perform the conversion manually, because
10641 evaluate_subexp_standard doesn't do it. This conversion is
10642 necessary in Ada because the different kinds of float/fixed
10643 types in Ada have different representations.
10645 Similarly, we need to perform the conversion from OP_LONG
10647 if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10648 result = ada_value_cast (expect_type, result);
10654 ada_string_operation::evaluate (struct type *expect_type,
10655 struct expression *exp,
10656 enum noside noside)
10658 struct type *char_type;
10659 if (expect_type != nullptr && ada_is_string_type (expect_type))
10660 char_type = ada_array_element_type (expect_type, 1);
10662 char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10664 const std::string &str = std::get<0> (m_storage);
10665 const char *encoding;
10666 switch (char_type->length ())
10670 /* Simply copy over the data -- this isn't perhaps strictly
10671 correct according to the encodings, but it is gdb's
10672 historical behavior. */
10673 struct type *stringtype
10674 = lookup_array_range_type (char_type, 1, str.length ());
10675 struct value *val = allocate_value (stringtype);
10676 memcpy (value_contents_raw (val).data (), str.c_str (),
10682 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10683 encoding = "UTF-16BE";
10685 encoding = "UTF-16LE";
10689 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10690 encoding = "UTF-32BE";
10692 encoding = "UTF-32LE";
10696 error (_("unexpected character type size %s"),
10697 pulongest (char_type->length ()));
10700 auto_obstack converted;
10701 convert_between_encodings (host_charset (), encoding,
10702 (const gdb_byte *) str.c_str (),
10704 &converted, translit_none);
10706 struct type *stringtype
10707 = lookup_array_range_type (char_type, 1,
10708 obstack_object_size (&converted)
10709 / char_type->length ());
10710 struct value *val = allocate_value (stringtype);
10711 memcpy (value_contents_raw (val).data (),
10712 obstack_base (&converted),
10713 obstack_object_size (&converted));
10718 ada_concat_operation::evaluate (struct type *expect_type,
10719 struct expression *exp,
10720 enum noside noside)
10722 /* If one side is a literal, evaluate the other side first so that
10723 the expected type can be set properly. */
10724 const operation_up &lhs_expr = std::get<0> (m_storage);
10725 const operation_up &rhs_expr = std::get<1> (m_storage);
10728 if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10730 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10731 lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10733 else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10735 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10736 struct type *rhs_type = check_typedef (value_type (rhs));
10737 struct type *elt_type = nullptr;
10738 if (rhs_type->code () == TYPE_CODE_ARRAY)
10739 elt_type = rhs_type->target_type ();
10740 lhs = lhs_expr->evaluate (elt_type, exp, noside);
10742 else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10744 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10745 rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10747 else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10749 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10750 struct type *lhs_type = check_typedef (value_type (lhs));
10751 struct type *elt_type = nullptr;
10752 if (lhs_type->code () == TYPE_CODE_ARRAY)
10753 elt_type = lhs_type->target_type ();
10754 rhs = rhs_expr->evaluate (elt_type, exp, noside);
10757 return concat_operation::evaluate (expect_type, exp, noside);
10759 return value_concat (lhs, rhs);
10763 ada_qual_operation::evaluate (struct type *expect_type,
10764 struct expression *exp,
10765 enum noside noside)
10767 struct type *type = std::get<1> (m_storage);
10768 return std::get<0> (m_storage)->evaluate (type, exp, noside);
10772 ada_ternop_range_operation::evaluate (struct type *expect_type,
10773 struct expression *exp,
10774 enum noside noside)
10776 value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10777 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10778 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10779 return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10783 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10784 struct expression *exp,
10785 enum noside noside)
10787 value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10788 value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10790 auto do_op = [=] (LONGEST x, LONGEST y)
10792 if (std::get<0> (m_storage) == BINOP_ADD)
10797 if (value_type (arg1)->code () == TYPE_CODE_PTR)
10798 return (value_from_longest
10799 (value_type (arg1),
10800 do_op (value_as_long (arg1), value_as_long (arg2))));
10801 if (value_type (arg2)->code () == TYPE_CODE_PTR)
10802 return (value_from_longest
10803 (value_type (arg2),
10804 do_op (value_as_long (arg1), value_as_long (arg2))));
10805 /* Preserve the original type for use by the range case below.
10806 We cannot cast the result to a reference type, so if ARG1 is
10807 a reference type, find its underlying type. */
10808 struct type *type = value_type (arg1);
10809 while (type->code () == TYPE_CODE_REF)
10810 type = type->target_type ();
10811 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10812 arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10813 /* We need to special-case the result with a range.
10814 This is done for the benefit of "ptype". gdb's Ada support
10815 historically used the LHS to set the result type here, so
10816 preserve this behavior. */
10817 if (type->code () == TYPE_CODE_RANGE)
10818 arg1 = value_cast (type, arg1);
10823 ada_unop_atr_operation::evaluate (struct type *expect_type,
10824 struct expression *exp,
10825 enum noside noside)
10827 struct type *type_arg = nullptr;
10828 value *val = nullptr;
10830 if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10832 value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10833 EVAL_AVOID_SIDE_EFFECTS);
10834 type_arg = value_type (tem);
10837 val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10839 return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10840 val, type_arg, std::get<2> (m_storage));
10844 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10845 struct expression *exp,
10846 enum noside noside)
10848 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10849 return value_zero (expect_type, not_lval);
10851 const bound_minimal_symbol &b = std::get<0> (m_storage);
10852 value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10854 val = ada_value_cast (expect_type, val);
10856 /* Follow the Ada language semantics that do not allow taking
10857 an address of the result of a cast (view conversion in Ada). */
10858 if (VALUE_LVAL (val) == lval_memory)
10860 if (value_lazy (val))
10861 value_fetch_lazy (val);
10862 VALUE_LVAL (val) = not_lval;
10868 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10869 struct expression *exp,
10870 enum noside noside)
10872 value *val = evaluate_var_value (noside,
10873 std::get<0> (m_storage).block,
10874 std::get<0> (m_storage).symbol);
10876 val = ada_value_cast (expect_type, val);
10878 /* Follow the Ada language semantics that do not allow taking
10879 an address of the result of a cast (view conversion in Ada). */
10880 if (VALUE_LVAL (val) == lval_memory)
10882 if (value_lazy (val))
10883 value_fetch_lazy (val);
10884 VALUE_LVAL (val) = not_lval;
10890 ada_var_value_operation::evaluate (struct type *expect_type,
10891 struct expression *exp,
10892 enum noside noside)
10894 symbol *sym = std::get<0> (m_storage).symbol;
10896 if (sym->domain () == UNDEF_DOMAIN)
10897 /* Only encountered when an unresolved symbol occurs in a
10898 context other than a function call, in which case, it is
10900 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10901 sym->print_name ());
10903 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10905 struct type *type = static_unwrap_type (sym->type ());
10906 /* Check to see if this is a tagged type. We also need to handle
10907 the case where the type is a reference to a tagged type, but
10908 we have to be careful to exclude pointers to tagged types.
10909 The latter should be shown as usual (as a pointer), whereas
10910 a reference should mostly be transparent to the user. */
10911 if (ada_is_tagged_type (type, 0)
10912 || (type->code () == TYPE_CODE_REF
10913 && ada_is_tagged_type (type->target_type (), 0)))
10915 /* Tagged types are a little special in the fact that the real
10916 type is dynamic and can only be determined by inspecting the
10917 object's tag. This means that we need to get the object's
10918 value first (EVAL_NORMAL) and then extract the actual object
10921 Note that we cannot skip the final step where we extract
10922 the object type from its tag, because the EVAL_NORMAL phase
10923 results in dynamic components being resolved into fixed ones.
10924 This can cause problems when trying to print the type
10925 description of tagged types whose parent has a dynamic size:
10926 We use the type name of the "_parent" component in order
10927 to print the name of the ancestor type in the type description.
10928 If that component had a dynamic size, the resolution into
10929 a fixed type would result in the loss of that type name,
10930 thus preventing us from printing the name of the ancestor
10931 type in the type description. */
10932 value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10934 if (type->code () != TYPE_CODE_REF)
10936 struct type *actual_type;
10938 actual_type = type_from_tag (ada_value_tag (arg1));
10939 if (actual_type == NULL)
10940 /* If, for some reason, we were unable to determine
10941 the actual type from the tag, then use the static
10942 approximation that we just computed as a fallback.
10943 This can happen if the debugging information is
10944 incomplete, for instance. */
10945 actual_type = type;
10946 return value_zero (actual_type, not_lval);
10950 /* In the case of a ref, ada_coerce_ref takes care
10951 of determining the actual type. But the evaluation
10952 should return a ref as it should be valid to ask
10953 for its address; so rebuild a ref after coerce. */
10954 arg1 = ada_coerce_ref (arg1);
10955 return value_ref (arg1, TYPE_CODE_REF);
10959 /* Records and unions for which GNAT encodings have been
10960 generated need to be statically fixed as well.
10961 Otherwise, non-static fixing produces a type where
10962 all dynamic properties are removed, which prevents "ptype"
10963 from being able to completely describe the type.
10964 For instance, a case statement in a variant record would be
10965 replaced by the relevant components based on the actual
10966 value of the discriminants. */
10967 if ((type->code () == TYPE_CODE_STRUCT
10968 && dynamic_template_type (type) != NULL)
10969 || (type->code () == TYPE_CODE_UNION
10970 && ada_find_parallel_type (type, "___XVU") != NULL))
10971 return value_zero (to_static_fixed_type (type), not_lval);
10974 value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10975 return ada_to_fixed_value (arg1);
10979 ada_var_value_operation::resolve (struct expression *exp,
10980 bool deprocedure_p,
10981 bool parse_completion,
10982 innermost_block_tracker *tracker,
10983 struct type *context_type)
10985 symbol *sym = std::get<0> (m_storage).symbol;
10986 if (sym->domain () == UNDEF_DOMAIN)
10988 block_symbol resolved
10989 = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10990 context_type, parse_completion,
10991 deprocedure_p, tracker);
10992 std::get<0> (m_storage) = resolved;
10996 && (std::get<0> (m_storage).symbol->type ()->code ()
10997 == TYPE_CODE_FUNC))
11004 ada_atr_val_operation::evaluate (struct type *expect_type,
11005 struct expression *exp,
11006 enum noside noside)
11008 value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11009 return ada_val_atr (noside, std::get<0> (m_storage), arg);
11013 ada_unop_ind_operation::evaluate (struct type *expect_type,
11014 struct expression *exp,
11015 enum noside noside)
11017 value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11019 struct type *type = ada_check_typedef (value_type (arg1));
11020 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11022 if (ada_is_array_descriptor_type (type))
11023 /* GDB allows dereferencing GNAT array descriptors. */
11025 struct type *arrType = ada_type_of_array (arg1, 0);
11027 if (arrType == NULL)
11028 error (_("Attempt to dereference null array pointer."));
11029 return value_at_lazy (arrType, 0);
11031 else if (type->code () == TYPE_CODE_PTR
11032 || type->code () == TYPE_CODE_REF
11033 /* In C you can dereference an array to get the 1st elt. */
11034 || type->code () == TYPE_CODE_ARRAY)
11036 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11037 only be determined by inspecting the object's tag.
11038 This means that we need to evaluate completely the
11039 expression in order to get its type. */
11041 if ((type->code () == TYPE_CODE_REF
11042 || type->code () == TYPE_CODE_PTR)
11043 && ada_is_tagged_type (type->target_type (), 0))
11045 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11047 type = value_type (ada_value_ind (arg1));
11051 type = to_static_fixed_type
11053 (ada_check_typedef (type->target_type ())));
11055 return value_zero (type, lval_memory);
11057 else if (type->code () == TYPE_CODE_INT)
11059 /* GDB allows dereferencing an int. */
11060 if (expect_type == NULL)
11061 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11066 to_static_fixed_type (ada_aligned_type (expect_type));
11067 return value_zero (expect_type, lval_memory);
11071 error (_("Attempt to take contents of a non-pointer value."));
11073 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11074 type = ada_check_typedef (value_type (arg1));
11076 if (type->code () == TYPE_CODE_INT)
11077 /* GDB allows dereferencing an int. If we were given
11078 the expect_type, then use that as the target type.
11079 Otherwise, assume that the target type is an int. */
11081 if (expect_type != NULL)
11082 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11085 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11086 (CORE_ADDR) value_as_address (arg1));
11089 if (ada_is_array_descriptor_type (type))
11090 /* GDB allows dereferencing GNAT array descriptors. */
11091 return ada_coerce_to_simple_array (arg1);
11093 return ada_value_ind (arg1);
11097 ada_structop_operation::evaluate (struct type *expect_type,
11098 struct expression *exp,
11099 enum noside noside)
11101 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11102 const char *str = std::get<1> (m_storage).c_str ();
11103 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11106 struct type *type1 = value_type (arg1);
11108 if (ada_is_tagged_type (type1, 1))
11110 type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11112 /* If the field is not found, check if it exists in the
11113 extension of this object's type. This means that we
11114 need to evaluate completely the expression. */
11118 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11120 arg1 = ada_value_struct_elt (arg1, str, 0);
11121 arg1 = unwrap_value (arg1);
11122 type = value_type (ada_to_fixed_value (arg1));
11126 type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11128 return value_zero (ada_aligned_type (type), lval_memory);
11132 arg1 = ada_value_struct_elt (arg1, str, 0);
11133 arg1 = unwrap_value (arg1);
11134 return ada_to_fixed_value (arg1);
11139 ada_funcall_operation::evaluate (struct type *expect_type,
11140 struct expression *exp,
11141 enum noside noside)
11143 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11144 int nargs = args_up.size ();
11145 std::vector<value *> argvec (nargs);
11146 operation_up &callee_op = std::get<0> (m_storage);
11148 ada_var_value_operation *avv
11149 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11151 && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11152 error (_("Unexpected unresolved symbol, %s, during evaluation"),
11153 avv->get_symbol ()->print_name ());
11155 value *callee = callee_op->evaluate (nullptr, exp, noside);
11156 for (int i = 0; i < args_up.size (); ++i)
11157 argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11159 if (ada_is_constrained_packed_array_type
11160 (desc_base_type (value_type (callee))))
11161 callee = ada_coerce_to_simple_array (callee);
11162 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11163 && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11164 /* This is a packed array that has already been fixed, and
11165 therefore already coerced to a simple array. Nothing further
11168 else if (value_type (callee)->code () == TYPE_CODE_REF)
11170 /* Make sure we dereference references so that all the code below
11171 feels like it's really handling the referenced value. Wrapping
11172 types (for alignment) may be there, so make sure we strip them as
11174 callee = ada_to_fixed_value (coerce_ref (callee));
11176 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11177 && VALUE_LVAL (callee) == lval_memory)
11178 callee = value_addr (callee);
11180 struct type *type = ada_check_typedef (value_type (callee));
11182 /* Ada allows us to implicitly dereference arrays when subscripting
11183 them. So, if this is an array typedef (encoding use for array
11184 access types encoded as fat pointers), strip it now. */
11185 if (type->code () == TYPE_CODE_TYPEDEF)
11186 type = ada_typedef_target_type (type);
11188 if (type->code () == TYPE_CODE_PTR)
11190 switch (ada_check_typedef (type->target_type ())->code ())
11192 case TYPE_CODE_FUNC:
11193 type = ada_check_typedef (type->target_type ());
11195 case TYPE_CODE_ARRAY:
11197 case TYPE_CODE_STRUCT:
11198 if (noside != EVAL_AVOID_SIDE_EFFECTS)
11199 callee = ada_value_ind (callee);
11200 type = ada_check_typedef (type->target_type ());
11203 error (_("cannot subscript or call something of type `%s'"),
11204 ada_type_name (value_type (callee)));
11209 switch (type->code ())
11211 case TYPE_CODE_FUNC:
11212 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11214 if (type->target_type () == NULL)
11215 error_call_unknown_return_type (NULL);
11216 return allocate_value (type->target_type ());
11218 return call_function_by_hand (callee, NULL, argvec);
11219 case TYPE_CODE_INTERNAL_FUNCTION:
11220 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11221 /* We don't know anything about what the internal
11222 function might return, but we have to return
11224 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11227 return call_internal_function (exp->gdbarch, exp->language_defn,
11231 case TYPE_CODE_STRUCT:
11235 arity = ada_array_arity (type);
11236 type = ada_array_element_type (type, nargs);
11238 error (_("cannot subscript or call a record"));
11239 if (arity != nargs)
11240 error (_("wrong number of subscripts; expecting %d"), arity);
11241 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11242 return value_zero (ada_aligned_type (type), lval_memory);
11244 unwrap_value (ada_value_subscript
11245 (callee, nargs, argvec.data ()));
11247 case TYPE_CODE_ARRAY:
11248 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11250 type = ada_array_element_type (type, nargs);
11252 error (_("element type of array unknown"));
11254 return value_zero (ada_aligned_type (type), lval_memory);
11257 unwrap_value (ada_value_subscript
11258 (ada_coerce_to_simple_array (callee),
11259 nargs, argvec.data ()));
11260 case TYPE_CODE_PTR: /* Pointer to array */
11261 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11263 type = to_fixed_array_type (type->target_type (), NULL, 1);
11264 type = ada_array_element_type (type, nargs);
11266 error (_("element type of array unknown"));
11268 return value_zero (ada_aligned_type (type), lval_memory);
11271 unwrap_value (ada_value_ptr_subscript (callee, nargs,
11275 error (_("Attempt to index or call something other than an "
11276 "array or function"));
11281 ada_funcall_operation::resolve (struct expression *exp,
11282 bool deprocedure_p,
11283 bool parse_completion,
11284 innermost_block_tracker *tracker,
11285 struct type *context_type)
11287 operation_up &callee_op = std::get<0> (m_storage);
11289 ada_var_value_operation *avv
11290 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11291 if (avv == nullptr)
11294 symbol *sym = avv->get_symbol ();
11295 if (sym->domain () != UNDEF_DOMAIN)
11298 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11299 int nargs = args_up.size ();
11300 std::vector<value *> argvec (nargs);
11302 for (int i = 0; i < args_up.size (); ++i)
11303 argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11305 const block *block = avv->get_block ();
11306 block_symbol resolved
11307 = ada_resolve_funcall (sym, block,
11308 context_type, parse_completion,
11309 nargs, argvec.data (),
11312 std::get<0> (m_storage)
11313 = make_operation<ada_var_value_operation> (resolved);
11318 ada_ternop_slice_operation::resolve (struct expression *exp,
11319 bool deprocedure_p,
11320 bool parse_completion,
11321 innermost_block_tracker *tracker,
11322 struct type *context_type)
11324 /* Historically this check was done during resolution, so we
11325 continue that here. */
11326 value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11327 EVAL_AVOID_SIDE_EFFECTS);
11328 if (ada_is_any_packed_array_type (value_type (v)))
11329 error (_("cannot slice a packed array"));
11337 /* Return non-zero iff TYPE represents a System.Address type. */
11340 ada_is_system_address_type (struct type *type)
11342 return (type->name () && strcmp (type->name (), "system__address") == 0);
11349 /* Scan STR beginning at position K for a discriminant name, and
11350 return the value of that discriminant field of DVAL in *PX. If
11351 PNEW_K is not null, put the position of the character beyond the
11352 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11353 not alter *PX and *PNEW_K if unsuccessful. */
11356 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11359 static std::string storage;
11360 const char *pstart, *pend, *bound;
11361 struct value *bound_val;
11363 if (dval == NULL || str == NULL || str[k] == '\0')
11367 pend = strstr (pstart, "__");
11371 k += strlen (bound);
11375 int len = pend - pstart;
11377 /* Strip __ and beyond. */
11378 storage = std::string (pstart, len);
11379 bound = storage.c_str ();
11383 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11384 if (bound_val == NULL)
11387 *px = value_as_long (bound_val);
11388 if (pnew_k != NULL)
11393 /* Value of variable named NAME. Only exact matches are considered.
11394 If no such variable found, then if ERR_MSG is null, returns 0, and
11395 otherwise causes an error with message ERR_MSG. */
11397 static struct value *
11398 get_var_value (const char *name, const char *err_msg)
11400 std::string quoted_name = add_angle_brackets (name);
11402 lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11404 std::vector<struct block_symbol> syms
11405 = ada_lookup_symbol_list_worker (lookup_name,
11406 get_selected_block (0),
11409 if (syms.size () != 1)
11411 if (err_msg == NULL)
11414 error (("%s"), err_msg);
11417 return value_of_variable (syms[0].symbol, syms[0].block);
11420 /* Value of integer variable named NAME in the current environment.
11421 If no such variable is found, returns false. Otherwise, sets VALUE
11422 to the variable's value and returns true. */
11425 get_int_var_value (const char *name, LONGEST &value)
11427 struct value *var_val = get_var_value (name, 0);
11432 value = value_as_long (var_val);
11437 /* Return a range type whose base type is that of the range type named
11438 NAME in the current environment, and whose bounds are calculated
11439 from NAME according to the GNAT range encoding conventions.
11440 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11441 corresponding range type from debug information; fall back to using it
11442 if symbol lookup fails. If a new type must be created, allocate it
11443 like ORIG_TYPE was. The bounds information, in general, is encoded
11444 in NAME, the base type given in the named range type. */
11446 static struct type *
11447 to_fixed_range_type (struct type *raw_type, struct value *dval)
11450 struct type *base_type;
11451 const char *subtype_info;
11453 gdb_assert (raw_type != NULL);
11454 gdb_assert (raw_type->name () != NULL);
11456 if (raw_type->code () == TYPE_CODE_RANGE)
11457 base_type = raw_type->target_type ();
11459 base_type = raw_type;
11461 name = raw_type->name ();
11462 subtype_info = strstr (name, "___XD");
11463 if (subtype_info == NULL)
11465 LONGEST L = ada_discrete_type_low_bound (raw_type);
11466 LONGEST U = ada_discrete_type_high_bound (raw_type);
11468 if (L < INT_MIN || U > INT_MAX)
11471 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11476 int prefix_len = subtype_info - name;
11479 const char *bounds_str;
11483 bounds_str = strchr (subtype_info, '_');
11486 if (*subtype_info == 'L')
11488 if (!ada_scan_number (bounds_str, n, &L, &n)
11489 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11491 if (bounds_str[n] == '_')
11493 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11499 std::string name_buf = std::string (name, prefix_len) + "___L";
11500 if (!get_int_var_value (name_buf.c_str (), L))
11502 lim_warning (_("Unknown lower bound, using 1."));
11507 if (*subtype_info == 'U')
11509 if (!ada_scan_number (bounds_str, n, &U, &n)
11510 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11515 std::string name_buf = std::string (name, prefix_len) + "___U";
11516 if (!get_int_var_value (name_buf.c_str (), U))
11518 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11523 type = create_static_range_type (alloc_type_copy (raw_type),
11525 /* create_static_range_type alters the resulting type's length
11526 to match the size of the base_type, which is not what we want.
11527 Set it back to the original range type's length. */
11528 type->set_length (raw_type->length ());
11529 type->set_name (name);
11534 /* True iff NAME is the name of a range type. */
11537 ada_is_range_type_name (const char *name)
11539 return (name != NULL && strstr (name, "___XD"));
11543 /* Modular types */
11545 /* True iff TYPE is an Ada modular type. */
11548 ada_is_modular_type (struct type *type)
11550 struct type *subranged_type = get_base_type (type);
11552 return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11553 && subranged_type->code () == TYPE_CODE_INT
11554 && subranged_type->is_unsigned ());
11557 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11560 ada_modulus (struct type *type)
11562 const dynamic_prop &high = type->bounds ()->high;
11564 if (high.kind () == PROP_CONST)
11565 return (ULONGEST) high.const_val () + 1;
11567 /* If TYPE is unresolved, the high bound might be a location list. Return
11568 0, for lack of a better value to return. */
11573 /* Ada exception catchpoint support:
11574 ---------------------------------
11576 We support 3 kinds of exception catchpoints:
11577 . catchpoints on Ada exceptions
11578 . catchpoints on unhandled Ada exceptions
11579 . catchpoints on failed assertions
11581 Exceptions raised during failed assertions, or unhandled exceptions
11582 could perfectly be caught with the general catchpoint on Ada exceptions.
11583 However, we can easily differentiate these two special cases, and having
11584 the option to distinguish these two cases from the rest can be useful
11585 to zero-in on certain situations.
11587 Exception catchpoints are a specialized form of breakpoint,
11588 since they rely on inserting breakpoints inside known routines
11589 of the GNAT runtime. The implementation therefore uses a standard
11590 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11593 Support in the runtime for exception catchpoints have been changed
11594 a few times already, and these changes affect the implementation
11595 of these catchpoints. In order to be able to support several
11596 variants of the runtime, we use a sniffer that will determine
11597 the runtime variant used by the program being debugged. */
11599 /* Ada's standard exceptions.
11601 The Ada 83 standard also defined Numeric_Error. But there so many
11602 situations where it was unclear from the Ada 83 Reference Manual
11603 (RM) whether Constraint_Error or Numeric_Error should be raised,
11604 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11605 Interpretation saying that anytime the RM says that Numeric_Error
11606 should be raised, the implementation may raise Constraint_Error.
11607 Ada 95 went one step further and pretty much removed Numeric_Error
11608 from the list of standard exceptions (it made it a renaming of
11609 Constraint_Error, to help preserve compatibility when compiling
11610 an Ada83 compiler). As such, we do not include Numeric_Error from
11611 this list of standard exceptions. */
11613 static const char * const standard_exc[] = {
11614 "constraint_error",
11620 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11622 /* A structure that describes how to support exception catchpoints
11623 for a given executable. */
11625 struct exception_support_info
11627 /* The name of the symbol to break on in order to insert
11628 a catchpoint on exceptions. */
11629 const char *catch_exception_sym;
11631 /* The name of the symbol to break on in order to insert
11632 a catchpoint on unhandled exceptions. */
11633 const char *catch_exception_unhandled_sym;
11635 /* The name of the symbol to break on in order to insert
11636 a catchpoint on failed assertions. */
11637 const char *catch_assert_sym;
11639 /* The name of the symbol to break on in order to insert
11640 a catchpoint on exception handling. */
11641 const char *catch_handlers_sym;
11643 /* Assuming that the inferior just triggered an unhandled exception
11644 catchpoint, this function is responsible for returning the address
11645 in inferior memory where the name of that exception is stored.
11646 Return zero if the address could not be computed. */
11647 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11650 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11651 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11653 /* The following exception support info structure describes how to
11654 implement exception catchpoints with the latest version of the
11655 Ada runtime (as of 2019-08-??). */
11657 static const struct exception_support_info default_exception_support_info =
11659 "__gnat_debug_raise_exception", /* catch_exception_sym */
11660 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11661 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11662 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11663 ada_unhandled_exception_name_addr
11666 /* The following exception support info structure describes how to
11667 implement exception catchpoints with an earlier version of the
11668 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11670 static const struct exception_support_info exception_support_info_v0 =
11672 "__gnat_debug_raise_exception", /* catch_exception_sym */
11673 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11674 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11675 "__gnat_begin_handler", /* catch_handlers_sym */
11676 ada_unhandled_exception_name_addr
11679 /* The following exception support info structure describes how to
11680 implement exception catchpoints with a slightly older version
11681 of the Ada runtime. */
11683 static const struct exception_support_info exception_support_info_fallback =
11685 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11686 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11687 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11688 "__gnat_begin_handler", /* catch_handlers_sym */
11689 ada_unhandled_exception_name_addr_from_raise
11692 /* Return nonzero if we can detect the exception support routines
11693 described in EINFO.
11695 This function errors out if an abnormal situation is detected
11696 (for instance, if we find the exception support routines, but
11697 that support is found to be incomplete). */
11700 ada_has_this_exception_support (const struct exception_support_info *einfo)
11702 struct symbol *sym;
11704 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11705 that should be compiled with debugging information. As a result, we
11706 expect to find that symbol in the symtabs. */
11708 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11711 /* Perhaps we did not find our symbol because the Ada runtime was
11712 compiled without debugging info, or simply stripped of it.
11713 It happens on some GNU/Linux distributions for instance, where
11714 users have to install a separate debug package in order to get
11715 the runtime's debugging info. In that situation, let the user
11716 know why we cannot insert an Ada exception catchpoint.
11718 Note: Just for the purpose of inserting our Ada exception
11719 catchpoint, we could rely purely on the associated minimal symbol.
11720 But we would be operating in degraded mode anyway, since we are
11721 still lacking the debugging info needed later on to extract
11722 the name of the exception being raised (this name is printed in
11723 the catchpoint message, and is also used when trying to catch
11724 a specific exception). We do not handle this case for now. */
11725 struct bound_minimal_symbol msym
11726 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11728 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11729 error (_("Your Ada runtime appears to be missing some debugging "
11730 "information.\nCannot insert Ada exception catchpoint "
11731 "in this configuration."));
11736 /* Make sure that the symbol we found corresponds to a function. */
11738 if (sym->aclass () != LOC_BLOCK)
11740 error (_("Symbol \"%s\" is not a function (class = %d)"),
11741 sym->linkage_name (), sym->aclass ());
11745 sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11748 struct bound_minimal_symbol msym
11749 = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11751 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11752 error (_("Your Ada runtime appears to be missing some debugging "
11753 "information.\nCannot insert Ada exception catchpoint "
11754 "in this configuration."));
11759 /* Make sure that the symbol we found corresponds to a function. */
11761 if (sym->aclass () != LOC_BLOCK)
11763 error (_("Symbol \"%s\" is not a function (class = %d)"),
11764 sym->linkage_name (), sym->aclass ());
11771 /* Inspect the Ada runtime and determine which exception info structure
11772 should be used to provide support for exception catchpoints.
11774 This function will always set the per-inferior exception_info,
11775 or raise an error. */
11778 ada_exception_support_info_sniffer (void)
11780 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11782 /* If the exception info is already known, then no need to recompute it. */
11783 if (data->exception_info != NULL)
11786 /* Check the latest (default) exception support info. */
11787 if (ada_has_this_exception_support (&default_exception_support_info))
11789 data->exception_info = &default_exception_support_info;
11793 /* Try the v0 exception suport info. */
11794 if (ada_has_this_exception_support (&exception_support_info_v0))
11796 data->exception_info = &exception_support_info_v0;
11800 /* Try our fallback exception suport info. */
11801 if (ada_has_this_exception_support (&exception_support_info_fallback))
11803 data->exception_info = &exception_support_info_fallback;
11807 /* Sometimes, it is normal for us to not be able to find the routine
11808 we are looking for. This happens when the program is linked with
11809 the shared version of the GNAT runtime, and the program has not been
11810 started yet. Inform the user of these two possible causes if
11813 if (ada_update_initial_language (language_unknown) != language_ada)
11814 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11816 /* If the symbol does not exist, then check that the program is
11817 already started, to make sure that shared libraries have been
11818 loaded. If it is not started, this may mean that the symbol is
11819 in a shared library. */
11821 if (inferior_ptid.pid () == 0)
11822 error (_("Unable to insert catchpoint. Try to start the program first."));
11824 /* At this point, we know that we are debugging an Ada program and
11825 that the inferior has been started, but we still are not able to
11826 find the run-time symbols. That can mean that we are in
11827 configurable run time mode, or that a-except as been optimized
11828 out by the linker... In any case, at this point it is not worth
11829 supporting this feature. */
11831 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11834 /* True iff FRAME is very likely to be that of a function that is
11835 part of the runtime system. This is all very heuristic, but is
11836 intended to be used as advice as to what frames are uninteresting
11840 is_known_support_routine (struct frame_info *frame)
11842 enum language func_lang;
11844 const char *fullname;
11846 /* If this code does not have any debugging information (no symtab),
11847 This cannot be any user code. */
11849 symtab_and_line sal = find_frame_sal (frame);
11850 if (sal.symtab == NULL)
11853 /* If there is a symtab, but the associated source file cannot be
11854 located, then assume this is not user code: Selecting a frame
11855 for which we cannot display the code would not be very helpful
11856 for the user. This should also take care of case such as VxWorks
11857 where the kernel has some debugging info provided for a few units. */
11859 fullname = symtab_to_fullname (sal.symtab);
11860 if (access (fullname, R_OK) != 0)
11863 /* Check the unit filename against the Ada runtime file naming.
11864 We also check the name of the objfile against the name of some
11865 known system libraries that sometimes come with debugging info
11868 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11870 re_comp (known_runtime_file_name_patterns[i]);
11871 if (re_exec (lbasename (sal.symtab->filename)))
11873 if (sal.symtab->compunit ()->objfile () != NULL
11874 && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11878 /* Check whether the function is a GNAT-generated entity. */
11880 gdb::unique_xmalloc_ptr<char> func_name
11881 = find_frame_funname (frame, &func_lang, NULL);
11882 if (func_name == NULL)
11885 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11887 re_comp (known_auxiliary_function_name_patterns[i]);
11888 if (re_exec (func_name.get ()))
11895 /* Find the first frame that contains debugging information and that is not
11896 part of the Ada run-time, starting from FI and moving upward. */
11899 ada_find_printable_frame (struct frame_info *fi)
11901 for (; fi != NULL; fi = get_prev_frame (fi))
11903 if (!is_known_support_routine (fi))
11912 /* Assuming that the inferior just triggered an unhandled exception
11913 catchpoint, return the address in inferior memory where the name
11914 of the exception is stored.
11916 Return zero if the address could not be computed. */
11919 ada_unhandled_exception_name_addr (void)
11921 return parse_and_eval_address ("e.full_name");
11924 /* Same as ada_unhandled_exception_name_addr, except that this function
11925 should be used when the inferior uses an older version of the runtime,
11926 where the exception name needs to be extracted from a specific frame
11927 several frames up in the callstack. */
11930 ada_unhandled_exception_name_addr_from_raise (void)
11933 struct frame_info *fi;
11934 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11936 /* To determine the name of this exception, we need to select
11937 the frame corresponding to RAISE_SYM_NAME. This frame is
11938 at least 3 levels up, so we simply skip the first 3 frames
11939 without checking the name of their associated function. */
11940 fi = get_current_frame ();
11941 for (frame_level = 0; frame_level < 3; frame_level += 1)
11943 fi = get_prev_frame (fi);
11947 enum language func_lang;
11949 gdb::unique_xmalloc_ptr<char> func_name
11950 = find_frame_funname (fi, &func_lang, NULL);
11951 if (func_name != NULL)
11953 if (strcmp (func_name.get (),
11954 data->exception_info->catch_exception_sym) == 0)
11955 break; /* We found the frame we were looking for... */
11957 fi = get_prev_frame (fi);
11964 return parse_and_eval_address ("id.full_name");
11967 /* Assuming the inferior just triggered an Ada exception catchpoint
11968 (of any type), return the address in inferior memory where the name
11969 of the exception is stored, if applicable.
11971 Assumes the selected frame is the current frame.
11973 Return zero if the address could not be computed, or if not relevant. */
11976 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11978 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11982 case ada_catch_exception:
11983 return (parse_and_eval_address ("e.full_name"));
11986 case ada_catch_exception_unhandled:
11987 return data->exception_info->unhandled_exception_name_addr ();
11990 case ada_catch_handlers:
11991 return 0; /* The runtimes does not provide access to the exception
11995 case ada_catch_assert:
11996 return 0; /* Exception name is not relevant in this case. */
12000 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12004 return 0; /* Should never be reached. */
12007 /* Assuming the inferior is stopped at an exception catchpoint,
12008 return the message which was associated to the exception, if
12009 available. Return NULL if the message could not be retrieved.
12011 Note: The exception message can be associated to an exception
12012 either through the use of the Raise_Exception function, or
12013 more simply (Ada 2005 and later), via:
12015 raise Exception_Name with "exception message";
12019 static gdb::unique_xmalloc_ptr<char>
12020 ada_exception_message_1 (void)
12022 struct value *e_msg_val;
12025 /* For runtimes that support this feature, the exception message
12026 is passed as an unbounded string argument called "message". */
12027 e_msg_val = parse_and_eval ("message");
12028 if (e_msg_val == NULL)
12029 return NULL; /* Exception message not supported. */
12031 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12032 gdb_assert (e_msg_val != NULL);
12033 e_msg_len = value_type (e_msg_val)->length ();
12035 /* If the message string is empty, then treat it as if there was
12036 no exception message. */
12037 if (e_msg_len <= 0)
12040 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12041 read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12043 e_msg.get ()[e_msg_len] = '\0';
12048 /* Same as ada_exception_message_1, except that all exceptions are
12049 contained here (returning NULL instead). */
12051 static gdb::unique_xmalloc_ptr<char>
12052 ada_exception_message (void)
12054 gdb::unique_xmalloc_ptr<char> e_msg;
12058 e_msg = ada_exception_message_1 ();
12060 catch (const gdb_exception_error &e)
12062 e_msg.reset (nullptr);
12068 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12069 any error that ada_exception_name_addr_1 might cause to be thrown.
12070 When an error is intercepted, a warning with the error message is printed,
12071 and zero is returned. */
12074 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12076 CORE_ADDR result = 0;
12080 result = ada_exception_name_addr_1 (ex);
12083 catch (const gdb_exception_error &e)
12085 warning (_("failed to get exception name: %s"), e.what ());
12092 static std::string ada_exception_catchpoint_cond_string
12093 (const char *excep_string,
12094 enum ada_exception_catchpoint_kind ex);
12096 /* Ada catchpoints.
12098 In the case of catchpoints on Ada exceptions, the catchpoint will
12099 stop the target on every exception the program throws. When a user
12100 specifies the name of a specific exception, we translate this
12101 request into a condition expression (in text form), and then parse
12102 it into an expression stored in each of the catchpoint's locations.
12103 We then use this condition to check whether the exception that was
12104 raised is the one the user is interested in. If not, then the
12105 target is resumed again. We store the name of the requested
12106 exception, in order to be able to re-set the condition expression
12107 when symbols change. */
12109 /* An instance of this type is used to represent an Ada catchpoint. */
12111 struct ada_catchpoint : public code_breakpoint
12113 ada_catchpoint (struct gdbarch *gdbarch_,
12114 enum ada_exception_catchpoint_kind kind,
12115 struct symtab_and_line sal,
12116 const char *addr_string_,
12120 : code_breakpoint (gdbarch_, bp_catchpoint),
12123 add_location (sal);
12125 /* Unlike most code_breakpoint types, Ada catchpoints are
12126 pspace-specific. */
12127 gdb_assert (sal.pspace != nullptr);
12128 this->pspace = sal.pspace;
12132 struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12134 loc_gdbarch = gdbarch;
12136 describe_other_breakpoints (loc_gdbarch,
12137 sal.pspace, sal.pc, sal.section, -1);
12138 /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12139 version for exception catchpoints, because two catchpoints
12140 used for different exception names will use the same address.
12141 In this case, a "breakpoint ... also set at..." warning is
12142 unproductive. Besides, the warning phrasing is also a bit
12143 inappropriate, we should use the word catchpoint, and tell
12144 the user what type of catchpoint it is. The above is good
12145 enough for now, though. */
12148 enable_state = enabled ? bp_enabled : bp_disabled;
12149 disposition = tempflag ? disp_del : disp_donttouch;
12150 locspec = string_to_location_spec (&addr_string_,
12151 language_def (language_ada));
12152 language = language_ada;
12155 struct bp_location *allocate_location () override;
12156 void re_set () override;
12157 void check_status (struct bpstat *bs) override;
12158 enum print_stop_action print_it (const bpstat *bs) const override;
12159 bool print_one (bp_location **) const override;
12160 void print_mention () const override;
12161 void print_recreate (struct ui_file *fp) const override;
12163 /* The name of the specific exception the user specified. */
12164 std::string excep_string;
12166 /* What kind of catchpoint this is. */
12167 enum ada_exception_catchpoint_kind m_kind;
12170 /* An instance of this type is used to represent an Ada catchpoint
12171 breakpoint location. */
12173 class ada_catchpoint_location : public bp_location
12176 explicit ada_catchpoint_location (ada_catchpoint *owner)
12177 : bp_location (owner, bp_loc_software_breakpoint)
12180 /* The condition that checks whether the exception that was raised
12181 is the specific exception the user specified on catchpoint
12183 expression_up excep_cond_expr;
12186 /* Parse the exception condition string in the context of each of the
12187 catchpoint's locations, and store them for later evaluation. */
12190 create_excep_cond_exprs (struct ada_catchpoint *c,
12191 enum ada_exception_catchpoint_kind ex)
12193 /* Nothing to do if there's no specific exception to catch. */
12194 if (c->excep_string.empty ())
12197 /* Same if there are no locations... */
12198 if (c->loc == NULL)
12201 /* Compute the condition expression in text form, from the specific
12202 expection we want to catch. */
12203 std::string cond_string
12204 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12206 /* Iterate over all the catchpoint's locations, and parse an
12207 expression for each. */
12208 for (bp_location *bl : c->locations ())
12210 struct ada_catchpoint_location *ada_loc
12211 = (struct ada_catchpoint_location *) bl;
12214 if (!bl->shlib_disabled)
12218 s = cond_string.c_str ();
12221 exp = parse_exp_1 (&s, bl->address,
12222 block_for_pc (bl->address),
12225 catch (const gdb_exception_error &e)
12227 warning (_("failed to reevaluate internal exception condition "
12228 "for catchpoint %d: %s"),
12229 c->number, e.what ());
12233 ada_loc->excep_cond_expr = std::move (exp);
12237 /* Implement the ALLOCATE_LOCATION method in the structure for all
12238 exception catchpoint kinds. */
12240 struct bp_location *
12241 ada_catchpoint::allocate_location ()
12243 return new ada_catchpoint_location (this);
12246 /* Implement the RE_SET method in the structure for all exception
12247 catchpoint kinds. */
12250 ada_catchpoint::re_set ()
12252 /* Call the base class's method. This updates the catchpoint's
12254 this->code_breakpoint::re_set ();
12256 /* Reparse the exception conditional expressions. One for each
12258 create_excep_cond_exprs (this, m_kind);
12261 /* Returns true if we should stop for this breakpoint hit. If the
12262 user specified a specific exception, we only want to cause a stop
12263 if the program thrown that exception. */
12266 should_stop_exception (const struct bp_location *bl)
12268 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12269 const struct ada_catchpoint_location *ada_loc
12270 = (const struct ada_catchpoint_location *) bl;
12273 struct internalvar *var = lookup_internalvar ("_ada_exception");
12274 if (c->m_kind == ada_catch_assert)
12275 clear_internalvar (var);
12282 if (c->m_kind == ada_catch_handlers)
12283 expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12284 ".all.occurrence.id");
12288 struct value *exc = parse_and_eval (expr);
12289 set_internalvar (var, exc);
12291 catch (const gdb_exception_error &ex)
12293 clear_internalvar (var);
12297 /* With no specific exception, should always stop. */
12298 if (c->excep_string.empty ())
12301 if (ada_loc->excep_cond_expr == NULL)
12303 /* We will have a NULL expression if back when we were creating
12304 the expressions, this location's had failed to parse. */
12311 struct value *mark;
12313 mark = value_mark ();
12314 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12315 value_free_to_mark (mark);
12317 catch (const gdb_exception &ex)
12319 exception_fprintf (gdb_stderr, ex,
12320 _("Error in testing exception condition:\n"));
12326 /* Implement the CHECK_STATUS method in the structure for all
12327 exception catchpoint kinds. */
12330 ada_catchpoint::check_status (bpstat *bs)
12332 bs->stop = should_stop_exception (bs->bp_location_at.get ());
12335 /* Implement the PRINT_IT method in the structure for all exception
12336 catchpoint kinds. */
12338 enum print_stop_action
12339 ada_catchpoint::print_it (const bpstat *bs) const
12341 struct ui_out *uiout = current_uiout;
12343 annotate_catchpoint (number);
12345 if (uiout->is_mi_like_p ())
12347 uiout->field_string ("reason",
12348 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12349 uiout->field_string ("disp", bpdisp_text (disposition));
12352 uiout->text (disposition == disp_del
12353 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12354 uiout->field_signed ("bkptno", number);
12355 uiout->text (", ");
12357 /* ada_exception_name_addr relies on the selected frame being the
12358 current frame. Need to do this here because this function may be
12359 called more than once when printing a stop, and below, we'll
12360 select the first frame past the Ada run-time (see
12361 ada_find_printable_frame). */
12362 select_frame (get_current_frame ());
12366 case ada_catch_exception:
12367 case ada_catch_exception_unhandled:
12368 case ada_catch_handlers:
12370 const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12371 char exception_name[256];
12375 read_memory (addr, (gdb_byte *) exception_name,
12376 sizeof (exception_name) - 1);
12377 exception_name [sizeof (exception_name) - 1] = '\0';
12381 /* For some reason, we were unable to read the exception
12382 name. This could happen if the Runtime was compiled
12383 without debugging info, for instance. In that case,
12384 just replace the exception name by the generic string
12385 "exception" - it will read as "an exception" in the
12386 notification we are about to print. */
12387 memcpy (exception_name, "exception", sizeof ("exception"));
12389 /* In the case of unhandled exception breakpoints, we print
12390 the exception name as "unhandled EXCEPTION_NAME", to make
12391 it clearer to the user which kind of catchpoint just got
12392 hit. We used ui_out_text to make sure that this extra
12393 info does not pollute the exception name in the MI case. */
12394 if (m_kind == ada_catch_exception_unhandled)
12395 uiout->text ("unhandled ");
12396 uiout->field_string ("exception-name", exception_name);
12399 case ada_catch_assert:
12400 /* In this case, the name of the exception is not really
12401 important. Just print "failed assertion" to make it clearer
12402 that his program just hit an assertion-failure catchpoint.
12403 We used ui_out_text because this info does not belong in
12405 uiout->text ("failed assertion");
12409 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12410 if (exception_message != NULL)
12412 uiout->text (" (");
12413 uiout->field_string ("exception-message", exception_message.get ());
12417 uiout->text (" at ");
12418 ada_find_printable_frame (get_current_frame ());
12420 return PRINT_SRC_AND_LOC;
12423 /* Implement the PRINT_ONE method in the structure for all exception
12424 catchpoint kinds. */
12427 ada_catchpoint::print_one (bp_location **last_loc) const
12429 struct ui_out *uiout = current_uiout;
12430 struct value_print_options opts;
12432 get_user_print_options (&opts);
12434 if (opts.addressprint)
12435 uiout->field_skip ("addr");
12437 annotate_field (5);
12440 case ada_catch_exception:
12441 if (!excep_string.empty ())
12443 std::string msg = string_printf (_("`%s' Ada exception"),
12444 excep_string.c_str ());
12446 uiout->field_string ("what", msg);
12449 uiout->field_string ("what", "all Ada exceptions");
12453 case ada_catch_exception_unhandled:
12454 uiout->field_string ("what", "unhandled Ada exceptions");
12457 case ada_catch_handlers:
12458 if (!excep_string.empty ())
12460 uiout->field_fmt ("what",
12461 _("`%s' Ada exception handlers"),
12462 excep_string.c_str ());
12465 uiout->field_string ("what", "all Ada exceptions handlers");
12468 case ada_catch_assert:
12469 uiout->field_string ("what", "failed Ada assertions");
12473 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12480 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12481 for all exception catchpoint kinds. */
12484 ada_catchpoint::print_mention () const
12486 struct ui_out *uiout = current_uiout;
12488 uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12489 : _("Catchpoint "));
12490 uiout->field_signed ("bkptno", number);
12491 uiout->text (": ");
12495 case ada_catch_exception:
12496 if (!excep_string.empty ())
12498 std::string info = string_printf (_("`%s' Ada exception"),
12499 excep_string.c_str ());
12500 uiout->text (info);
12503 uiout->text (_("all Ada exceptions"));
12506 case ada_catch_exception_unhandled:
12507 uiout->text (_("unhandled Ada exceptions"));
12510 case ada_catch_handlers:
12511 if (!excep_string.empty ())
12514 = string_printf (_("`%s' Ada exception handlers"),
12515 excep_string.c_str ());
12516 uiout->text (info);
12519 uiout->text (_("all Ada exceptions handlers"));
12522 case ada_catch_assert:
12523 uiout->text (_("failed Ada assertions"));
12527 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12532 /* Implement the PRINT_RECREATE method in the structure for all
12533 exception catchpoint kinds. */
12536 ada_catchpoint::print_recreate (struct ui_file *fp) const
12540 case ada_catch_exception:
12541 gdb_printf (fp, "catch exception");
12542 if (!excep_string.empty ())
12543 gdb_printf (fp, " %s", excep_string.c_str ());
12546 case ada_catch_exception_unhandled:
12547 gdb_printf (fp, "catch exception unhandled");
12550 case ada_catch_handlers:
12551 gdb_printf (fp, "catch handlers");
12554 case ada_catch_assert:
12555 gdb_printf (fp, "catch assert");
12559 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12561 print_recreate_thread (fp);
12564 /* See ada-lang.h. */
12567 is_ada_exception_catchpoint (breakpoint *bp)
12569 return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12572 /* Split the arguments specified in a "catch exception" command.
12573 Set EX to the appropriate catchpoint type.
12574 Set EXCEP_STRING to the name of the specific exception if
12575 specified by the user.
12576 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12577 "catch handlers" command. False otherwise.
12578 If a condition is found at the end of the arguments, the condition
12579 expression is stored in COND_STRING (memory must be deallocated
12580 after use). Otherwise COND_STRING is set to NULL. */
12583 catch_ada_exception_command_split (const char *args,
12584 bool is_catch_handlers_cmd,
12585 enum ada_exception_catchpoint_kind *ex,
12586 std::string *excep_string,
12587 std::string *cond_string)
12589 std::string exception_name;
12591 exception_name = extract_arg (&args);
12592 if (exception_name == "if")
12594 /* This is not an exception name; this is the start of a condition
12595 expression for a catchpoint on all exceptions. So, "un-get"
12596 this token, and set exception_name to NULL. */
12597 exception_name.clear ();
12601 /* Check to see if we have a condition. */
12603 args = skip_spaces (args);
12604 if (startswith (args, "if")
12605 && (isspace (args[2]) || args[2] == '\0'))
12608 args = skip_spaces (args);
12610 if (args[0] == '\0')
12611 error (_("Condition missing after `if' keyword"));
12612 *cond_string = args;
12614 args += strlen (args);
12617 /* Check that we do not have any more arguments. Anything else
12620 if (args[0] != '\0')
12621 error (_("Junk at end of expression"));
12623 if (is_catch_handlers_cmd)
12625 /* Catch handling of exceptions. */
12626 *ex = ada_catch_handlers;
12627 *excep_string = exception_name;
12629 else if (exception_name.empty ())
12631 /* Catch all exceptions. */
12632 *ex = ada_catch_exception;
12633 excep_string->clear ();
12635 else if (exception_name == "unhandled")
12637 /* Catch unhandled exceptions. */
12638 *ex = ada_catch_exception_unhandled;
12639 excep_string->clear ();
12643 /* Catch a specific exception. */
12644 *ex = ada_catch_exception;
12645 *excep_string = exception_name;
12649 /* Return the name of the symbol on which we should break in order to
12650 implement a catchpoint of the EX kind. */
12652 static const char *
12653 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12655 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12657 gdb_assert (data->exception_info != NULL);
12661 case ada_catch_exception:
12662 return (data->exception_info->catch_exception_sym);
12664 case ada_catch_exception_unhandled:
12665 return (data->exception_info->catch_exception_unhandled_sym);
12667 case ada_catch_assert:
12668 return (data->exception_info->catch_assert_sym);
12670 case ada_catch_handlers:
12671 return (data->exception_info->catch_handlers_sym);
12674 internal_error (__FILE__, __LINE__,
12675 _("unexpected catchpoint kind (%d)"), ex);
12679 /* Return the condition that will be used to match the current exception
12680 being raised with the exception that the user wants to catch. This
12681 assumes that this condition is used when the inferior just triggered
12682 an exception catchpoint.
12683 EX: the type of catchpoints used for catching Ada exceptions. */
12686 ada_exception_catchpoint_cond_string (const char *excep_string,
12687 enum ada_exception_catchpoint_kind ex)
12689 bool is_standard_exc = false;
12690 std::string result;
12692 if (ex == ada_catch_handlers)
12694 /* For exception handlers catchpoints, the condition string does
12695 not use the same parameter as for the other exceptions. */
12696 result = ("long_integer (GNAT_GCC_exception_Access"
12697 "(gcc_exception).all.occurrence.id)");
12700 result = "long_integer (e)";
12702 /* The standard exceptions are a special case. They are defined in
12703 runtime units that have been compiled without debugging info; if
12704 EXCEP_STRING is the not-fully-qualified name of a standard
12705 exception (e.g. "constraint_error") then, during the evaluation
12706 of the condition expression, the symbol lookup on this name would
12707 *not* return this standard exception. The catchpoint condition
12708 may then be set only on user-defined exceptions which have the
12709 same not-fully-qualified name (e.g. my_package.constraint_error).
12711 To avoid this unexcepted behavior, these standard exceptions are
12712 systematically prefixed by "standard". This means that "catch
12713 exception constraint_error" is rewritten into "catch exception
12714 standard.constraint_error".
12716 If an exception named constraint_error is defined in another package of
12717 the inferior program, then the only way to specify this exception as a
12718 breakpoint condition is to use its fully-qualified named:
12719 e.g. my_package.constraint_error. */
12721 for (const char *name : standard_exc)
12723 if (strcmp (name, excep_string) == 0)
12725 is_standard_exc = true;
12732 if (is_standard_exc)
12733 string_appendf (result, "long_integer (&standard.%s)", excep_string);
12735 string_appendf (result, "long_integer (&%s)", excep_string);
12740 /* Return the symtab_and_line that should be used to insert an exception
12741 catchpoint of the TYPE kind.
12743 ADDR_STRING returns the name of the function where the real
12744 breakpoint that implements the catchpoints is set, depending on the
12745 type of catchpoint we need to create. */
12747 static struct symtab_and_line
12748 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12749 std::string *addr_string)
12751 const char *sym_name;
12752 struct symbol *sym;
12754 /* First, find out which exception support info to use. */
12755 ada_exception_support_info_sniffer ();
12757 /* Then lookup the function on which we will break in order to catch
12758 the Ada exceptions requested by the user. */
12759 sym_name = ada_exception_sym_name (ex);
12760 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12763 error (_("Catchpoint symbol not found: %s"), sym_name);
12765 if (sym->aclass () != LOC_BLOCK)
12766 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12768 /* Set ADDR_STRING. */
12769 *addr_string = sym_name;
12771 return find_function_start_sal (sym, 1);
12774 /* Create an Ada exception catchpoint.
12776 EX_KIND is the kind of exception catchpoint to be created.
12778 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12779 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12780 of the exception to which this catchpoint applies.
12782 COND_STRING, if not empty, is the catchpoint condition.
12784 TEMPFLAG, if nonzero, means that the underlying breakpoint
12785 should be temporary.
12787 FROM_TTY is the usual argument passed to all commands implementations. */
12790 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12791 enum ada_exception_catchpoint_kind ex_kind,
12792 const std::string &excep_string,
12793 const std::string &cond_string,
12798 std::string addr_string;
12799 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12801 std::unique_ptr<ada_catchpoint> c
12802 (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12803 tempflag, disabled, from_tty));
12804 c->excep_string = excep_string;
12805 create_excep_cond_exprs (c.get (), ex_kind);
12806 if (!cond_string.empty ())
12807 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12808 install_breakpoint (0, std::move (c), 1);
12811 /* Implement the "catch exception" command. */
12814 catch_ada_exception_command (const char *arg_entry, int from_tty,
12815 struct cmd_list_element *command)
12817 const char *arg = arg_entry;
12818 struct gdbarch *gdbarch = get_current_arch ();
12820 enum ada_exception_catchpoint_kind ex_kind;
12821 std::string excep_string;
12822 std::string cond_string;
12824 tempflag = command->context () == CATCH_TEMPORARY;
12828 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12830 create_ada_exception_catchpoint (gdbarch, ex_kind,
12831 excep_string, cond_string,
12832 tempflag, 1 /* enabled */,
12836 /* Implement the "catch handlers" command. */
12839 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12840 struct cmd_list_element *command)
12842 const char *arg = arg_entry;
12843 struct gdbarch *gdbarch = get_current_arch ();
12845 enum ada_exception_catchpoint_kind ex_kind;
12846 std::string excep_string;
12847 std::string cond_string;
12849 tempflag = command->context () == CATCH_TEMPORARY;
12853 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12855 create_ada_exception_catchpoint (gdbarch, ex_kind,
12856 excep_string, cond_string,
12857 tempflag, 1 /* enabled */,
12861 /* Completion function for the Ada "catch" commands. */
12864 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12865 const char *text, const char *word)
12867 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12869 for (const ada_exc_info &info : exceptions)
12871 if (startswith (info.name, word))
12872 tracker.add_completion (make_unique_xstrdup (info.name));
12876 /* Split the arguments specified in a "catch assert" command.
12878 ARGS contains the command's arguments (or the empty string if
12879 no arguments were passed).
12881 If ARGS contains a condition, set COND_STRING to that condition
12882 (the memory needs to be deallocated after use). */
12885 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12887 args = skip_spaces (args);
12889 /* Check whether a condition was provided. */
12890 if (startswith (args, "if")
12891 && (isspace (args[2]) || args[2] == '\0'))
12894 args = skip_spaces (args);
12895 if (args[0] == '\0')
12896 error (_("condition missing after `if' keyword"));
12897 cond_string.assign (args);
12900 /* Otherwise, there should be no other argument at the end of
12902 else if (args[0] != '\0')
12903 error (_("Junk at end of arguments."));
12906 /* Implement the "catch assert" command. */
12909 catch_assert_command (const char *arg_entry, int from_tty,
12910 struct cmd_list_element *command)
12912 const char *arg = arg_entry;
12913 struct gdbarch *gdbarch = get_current_arch ();
12915 std::string cond_string;
12917 tempflag = command->context () == CATCH_TEMPORARY;
12921 catch_ada_assert_command_split (arg, cond_string);
12922 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12924 tempflag, 1 /* enabled */,
12928 /* Return non-zero if the symbol SYM is an Ada exception object. */
12931 ada_is_exception_sym (struct symbol *sym)
12933 const char *type_name = sym->type ()->name ();
12935 return (sym->aclass () != LOC_TYPEDEF
12936 && sym->aclass () != LOC_BLOCK
12937 && sym->aclass () != LOC_CONST
12938 && sym->aclass () != LOC_UNRESOLVED
12939 && type_name != NULL && strcmp (type_name, "exception") == 0);
12942 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12943 Ada exception object. This matches all exceptions except the ones
12944 defined by the Ada language. */
12947 ada_is_non_standard_exception_sym (struct symbol *sym)
12949 if (!ada_is_exception_sym (sym))
12952 for (const char *name : standard_exc)
12953 if (strcmp (sym->linkage_name (), name) == 0)
12954 return 0; /* A standard exception. */
12956 /* Numeric_Error is also a standard exception, so exclude it.
12957 See the STANDARD_EXC description for more details as to why
12958 this exception is not listed in that array. */
12959 if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12965 /* A helper function for std::sort, comparing two struct ada_exc_info
12968 The comparison is determined first by exception name, and then
12969 by exception address. */
12972 ada_exc_info::operator< (const ada_exc_info &other) const
12976 result = strcmp (name, other.name);
12979 if (result == 0 && addr < other.addr)
12985 ada_exc_info::operator== (const ada_exc_info &other) const
12987 return addr == other.addr && strcmp (name, other.name) == 0;
12990 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12991 routine, but keeping the first SKIP elements untouched.
12993 All duplicates are also removed. */
12996 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12999 std::sort (exceptions->begin () + skip, exceptions->end ());
13000 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13001 exceptions->end ());
13004 /* Add all exceptions defined by the Ada standard whose name match
13005 a regular expression.
13007 If PREG is not NULL, then this regexp_t object is used to
13008 perform the symbol name matching. Otherwise, no name-based
13009 filtering is performed.
13011 EXCEPTIONS is a vector of exceptions to which matching exceptions
13015 ada_add_standard_exceptions (compiled_regex *preg,
13016 std::vector<ada_exc_info> *exceptions)
13018 for (const char *name : standard_exc)
13020 if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13022 struct bound_minimal_symbol msymbol
13023 = ada_lookup_simple_minsym (name);
13025 if (msymbol.minsym != NULL)
13027 struct ada_exc_info info
13028 = {name, msymbol.value_address ()};
13030 exceptions->push_back (info);
13036 /* Add all Ada exceptions defined locally and accessible from the given
13039 If PREG is not NULL, then this regexp_t object is used to
13040 perform the symbol name matching. Otherwise, no name-based
13041 filtering is performed.
13043 EXCEPTIONS is a vector of exceptions to which matching exceptions
13047 ada_add_exceptions_from_frame (compiled_regex *preg,
13048 struct frame_info *frame,
13049 std::vector<ada_exc_info> *exceptions)
13051 const struct block *block = get_frame_block (frame, 0);
13055 struct block_iterator iter;
13056 struct symbol *sym;
13058 ALL_BLOCK_SYMBOLS (block, iter, sym)
13060 switch (sym->aclass ())
13067 if (ada_is_exception_sym (sym))
13069 struct ada_exc_info info = {sym->print_name (),
13070 sym->value_address ()};
13072 exceptions->push_back (info);
13076 if (block->function () != NULL)
13078 block = block->superblock ();
13082 /* Return true if NAME matches PREG or if PREG is NULL. */
13085 name_matches_regex (const char *name, compiled_regex *preg)
13087 return (preg == NULL
13088 || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13091 /* Add all exceptions defined globally whose name name match
13092 a regular expression, excluding standard exceptions.
13094 The reason we exclude standard exceptions is that they need
13095 to be handled separately: Standard exceptions are defined inside
13096 a runtime unit which is normally not compiled with debugging info,
13097 and thus usually do not show up in our symbol search. However,
13098 if the unit was in fact built with debugging info, we need to
13099 exclude them because they would duplicate the entry we found
13100 during the special loop that specifically searches for those
13101 standard exceptions.
13103 If PREG is not NULL, then this regexp_t object is used to
13104 perform the symbol name matching. Otherwise, no name-based
13105 filtering is performed.
13107 EXCEPTIONS is a vector of exceptions to which matching exceptions
13111 ada_add_global_exceptions (compiled_regex *preg,
13112 std::vector<ada_exc_info> *exceptions)
13114 /* In Ada, the symbol "search name" is a linkage name, whereas the
13115 regular expression used to do the matching refers to the natural
13116 name. So match against the decoded name. */
13117 expand_symtabs_matching (NULL,
13118 lookup_name_info::match_any (),
13119 [&] (const char *search_name)
13121 std::string decoded = ada_decode (search_name);
13122 return name_matches_regex (decoded.c_str (), preg);
13125 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13128 for (objfile *objfile : current_program_space->objfiles ())
13130 for (compunit_symtab *s : objfile->compunits ())
13132 const struct blockvector *bv = s->blockvector ();
13135 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13137 const struct block *b = bv->block (i);
13138 struct block_iterator iter;
13139 struct symbol *sym;
13141 ALL_BLOCK_SYMBOLS (b, iter, sym)
13142 if (ada_is_non_standard_exception_sym (sym)
13143 && name_matches_regex (sym->natural_name (), preg))
13145 struct ada_exc_info info
13146 = {sym->print_name (), sym->value_address ()};
13148 exceptions->push_back (info);
13155 /* Implements ada_exceptions_list with the regular expression passed
13156 as a regex_t, rather than a string.
13158 If not NULL, PREG is used to filter out exceptions whose names
13159 do not match. Otherwise, all exceptions are listed. */
13161 static std::vector<ada_exc_info>
13162 ada_exceptions_list_1 (compiled_regex *preg)
13164 std::vector<ada_exc_info> result;
13167 /* First, list the known standard exceptions. These exceptions
13168 need to be handled separately, as they are usually defined in
13169 runtime units that have been compiled without debugging info. */
13171 ada_add_standard_exceptions (preg, &result);
13173 /* Next, find all exceptions whose scope is local and accessible
13174 from the currently selected frame. */
13176 if (has_stack_frames ())
13178 prev_len = result.size ();
13179 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13181 if (result.size () > prev_len)
13182 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13185 /* Add all exceptions whose scope is global. */
13187 prev_len = result.size ();
13188 ada_add_global_exceptions (preg, &result);
13189 if (result.size () > prev_len)
13190 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13195 /* Return a vector of ada_exc_info.
13197 If REGEXP is NULL, all exceptions are included in the result.
13198 Otherwise, it should contain a valid regular expression,
13199 and only the exceptions whose names match that regular expression
13200 are included in the result.
13202 The exceptions are sorted in the following order:
13203 - Standard exceptions (defined by the Ada language), in
13204 alphabetical order;
13205 - Exceptions only visible from the current frame, in
13206 alphabetical order;
13207 - Exceptions whose scope is global, in alphabetical order. */
13209 std::vector<ada_exc_info>
13210 ada_exceptions_list (const char *regexp)
13212 if (regexp == NULL)
13213 return ada_exceptions_list_1 (NULL);
13215 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13216 return ada_exceptions_list_1 (®);
13219 /* Implement the "info exceptions" command. */
13222 info_exceptions_command (const char *regexp, int from_tty)
13224 struct gdbarch *gdbarch = get_current_arch ();
13226 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13228 if (regexp != NULL)
13230 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13232 gdb_printf (_("All defined Ada exceptions:\n"));
13234 for (const ada_exc_info &info : exceptions)
13235 gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13239 /* Language vector */
13241 /* symbol_name_matcher_ftype adapter for wild_match. */
13244 do_wild_match (const char *symbol_search_name,
13245 const lookup_name_info &lookup_name,
13246 completion_match_result *comp_match_res)
13248 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13251 /* symbol_name_matcher_ftype adapter for full_match. */
13254 do_full_match (const char *symbol_search_name,
13255 const lookup_name_info &lookup_name,
13256 completion_match_result *comp_match_res)
13258 const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13260 /* If both symbols start with "_ada_", just let the loop below
13261 handle the comparison. However, if only the symbol name starts
13262 with "_ada_", skip the prefix and let the match proceed as
13264 if (startswith (symbol_search_name, "_ada_")
13265 && !startswith (lname, "_ada"))
13266 symbol_search_name += 5;
13267 /* Likewise for ghost entities. */
13268 if (startswith (symbol_search_name, "___ghost_")
13269 && !startswith (lname, "___ghost_"))
13270 symbol_search_name += 9;
13272 int uscore_count = 0;
13273 while (*lname != '\0')
13275 if (*symbol_search_name != *lname)
13277 if (*symbol_search_name == 'B' && uscore_count == 2
13278 && symbol_search_name[1] == '_')
13280 symbol_search_name += 2;
13281 while (isdigit (*symbol_search_name))
13282 ++symbol_search_name;
13283 if (symbol_search_name[0] == '_'
13284 && symbol_search_name[1] == '_')
13286 symbol_search_name += 2;
13293 if (*symbol_search_name == '_')
13298 ++symbol_search_name;
13302 return is_name_suffix (symbol_search_name);
13305 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13308 do_exact_match (const char *symbol_search_name,
13309 const lookup_name_info &lookup_name,
13310 completion_match_result *comp_match_res)
13312 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13315 /* Build the Ada lookup name for LOOKUP_NAME. */
13317 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13319 gdb::string_view user_name = lookup_name.name ();
13321 if (!user_name.empty () && user_name[0] == '<')
13323 if (user_name.back () == '>')
13325 = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13328 = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13329 m_encoded_p = true;
13330 m_verbatim_p = true;
13331 m_wild_match_p = false;
13332 m_standard_p = false;
13336 m_verbatim_p = false;
13338 m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13342 const char *folded = ada_fold_name (user_name);
13343 m_encoded_name = ada_encode_1 (folded, false);
13344 if (m_encoded_name.empty ())
13345 m_encoded_name = gdb::to_string (user_name);
13348 m_encoded_name = gdb::to_string (user_name);
13350 /* Handle the 'package Standard' special case. See description
13351 of m_standard_p. */
13352 if (startswith (m_encoded_name.c_str (), "standard__"))
13354 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13355 m_standard_p = true;
13358 m_standard_p = false;
13360 /* If the name contains a ".", then the user is entering a fully
13361 qualified entity name, and the match must not be done in wild
13362 mode. Similarly, if the user wants to complete what looks
13363 like an encoded name, the match must not be done in wild
13364 mode. Also, in the standard__ special case always do
13365 non-wild matching. */
13367 = (lookup_name.match_type () != symbol_name_match_type::FULL
13370 && user_name.find ('.') == std::string::npos);
13374 /* symbol_name_matcher_ftype method for Ada. This only handles
13375 completion mode. */
13378 ada_symbol_name_matches (const char *symbol_search_name,
13379 const lookup_name_info &lookup_name,
13380 completion_match_result *comp_match_res)
13382 return lookup_name.ada ().matches (symbol_search_name,
13383 lookup_name.match_type (),
13387 /* A name matcher that matches the symbol name exactly, with
13391 literal_symbol_name_matcher (const char *symbol_search_name,
13392 const lookup_name_info &lookup_name,
13393 completion_match_result *comp_match_res)
13395 gdb::string_view name_view = lookup_name.name ();
13397 if (lookup_name.completion_mode ()
13398 ? (strncmp (symbol_search_name, name_view.data (),
13399 name_view.size ()) == 0)
13400 : symbol_search_name == name_view)
13402 if (comp_match_res != NULL)
13403 comp_match_res->set_match (symbol_search_name);
13410 /* Implement the "get_symbol_name_matcher" language_defn method for
13413 static symbol_name_matcher_ftype *
13414 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13416 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13417 return literal_symbol_name_matcher;
13419 if (lookup_name.completion_mode ())
13420 return ada_symbol_name_matches;
13423 if (lookup_name.ada ().wild_match_p ())
13424 return do_wild_match;
13425 else if (lookup_name.ada ().verbatim_p ())
13426 return do_exact_match;
13428 return do_full_match;
13432 /* Class representing the Ada language. */
13434 class ada_language : public language_defn
13438 : language_defn (language_ada)
13441 /* See language.h. */
13443 const char *name () const override
13446 /* See language.h. */
13448 const char *natural_name () const override
13451 /* See language.h. */
13453 const std::vector<const char *> &filename_extensions () const override
13455 static const std::vector<const char *> extensions
13456 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13460 /* Print an array element index using the Ada syntax. */
13462 void print_array_index (struct type *index_type,
13464 struct ui_file *stream,
13465 const value_print_options *options) const override
13467 struct value *index_value = val_atr (index_type, index);
13469 value_print (index_value, stream, options);
13470 gdb_printf (stream, " => ");
13473 /* Implement the "read_var_value" language_defn method for Ada. */
13475 struct value *read_var_value (struct symbol *var,
13476 const struct block *var_block,
13477 struct frame_info *frame) const override
13479 /* The only case where default_read_var_value is not sufficient
13480 is when VAR is a renaming... */
13481 if (frame != nullptr)
13483 const struct block *frame_block = get_frame_block (frame, NULL);
13484 if (frame_block != nullptr && ada_is_renaming_symbol (var))
13485 return ada_read_renaming_var_value (var, frame_block);
13488 /* This is a typical case where we expect the default_read_var_value
13489 function to work. */
13490 return language_defn::read_var_value (var, var_block, frame);
13493 /* See language.h. */
13494 bool symbol_printing_suppressed (struct symbol *symbol) const override
13496 return symbol->is_artificial ();
13499 /* See language.h. */
13500 void language_arch_info (struct gdbarch *gdbarch,
13501 struct language_arch_info *lai) const override
13503 const struct builtin_type *builtin = builtin_type (gdbarch);
13505 /* Helper function to allow shorter lines below. */
13506 auto add = [&] (struct type *t)
13508 lai->add_primitive_type (t);
13511 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13513 add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13514 0, "long_integer"));
13515 add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13516 0, "short_integer"));
13517 struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13519 lai->set_string_char_type (char_type);
13521 add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13522 add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13523 add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13524 "float", gdbarch_float_format (gdbarch)));
13525 add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13526 "long_float", gdbarch_double_format (gdbarch)));
13527 add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13528 0, "long_long_integer"));
13529 add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13531 gdbarch_long_double_format (gdbarch)));
13532 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13534 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13536 add (builtin->builtin_void);
13538 struct type *system_addr_ptr
13539 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13541 system_addr_ptr->set_name ("system__address");
13542 add (system_addr_ptr);
13544 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13545 type. This is a signed integral type whose size is the same as
13546 the size of addresses. */
13547 unsigned int addr_length = system_addr_ptr->length ();
13548 add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13549 "storage_offset"));
13551 lai->set_bool_type (builtin->builtin_bool);
13554 /* See language.h. */
13556 bool iterate_over_symbols
13557 (const struct block *block, const lookup_name_info &name,
13558 domain_enum domain,
13559 gdb::function_view<symbol_found_callback_ftype> callback) const override
13561 std::vector<struct block_symbol> results
13562 = ada_lookup_symbol_list_worker (name, block, domain, 0);
13563 for (block_symbol &sym : results)
13565 if (!callback (&sym))
13572 /* See language.h. */
13573 bool sniff_from_mangled_name
13574 (const char *mangled,
13575 gdb::unique_xmalloc_ptr<char> *out) const override
13577 std::string demangled = ada_decode (mangled);
13581 if (demangled != mangled && demangled[0] != '<')
13583 /* Set the gsymbol language to Ada, but still return 0.
13584 Two reasons for that:
13586 1. For Ada, we prefer computing the symbol's decoded name
13587 on the fly rather than pre-compute it, in order to save
13588 memory (Ada projects are typically very large).
13590 2. There are some areas in the definition of the GNAT
13591 encoding where, with a bit of bad luck, we might be able
13592 to decode a non-Ada symbol, generating an incorrect
13593 demangled name (Eg: names ending with "TB" for instance
13594 are identified as task bodies and so stripped from
13595 the decoded name returned).
13597 Returning true, here, but not setting *DEMANGLED, helps us get
13598 a little bit of the best of both worlds. Because we're last,
13599 we should not affect any of the other languages that were
13600 able to demangle the symbol before us; we get to correctly
13601 tag Ada symbols as such; and even if we incorrectly tagged a
13602 non-Ada symbol, which should be rare, any routing through the
13603 Ada language should be transparent (Ada tries to behave much
13604 like C/C++ with non-Ada symbols). */
13611 /* See language.h. */
13613 gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13614 int options) const override
13616 return make_unique_xstrdup (ada_decode (mangled).c_str ());
13619 /* See language.h. */
13621 void print_type (struct type *type, const char *varstring,
13622 struct ui_file *stream, int show, int level,
13623 const struct type_print_options *flags) const override
13625 ada_print_type (type, varstring, stream, show, level, flags);
13628 /* See language.h. */
13630 const char *word_break_characters (void) const override
13632 return ada_completer_word_break_characters;
13635 /* See language.h. */
13637 void collect_symbol_completion_matches (completion_tracker &tracker,
13638 complete_symbol_mode mode,
13639 symbol_name_match_type name_match_type,
13640 const char *text, const char *word,
13641 enum type_code code) const override
13643 struct symbol *sym;
13644 const struct block *b, *surrounding_static_block = 0;
13645 struct block_iterator iter;
13647 gdb_assert (code == TYPE_CODE_UNDEF);
13649 lookup_name_info lookup_name (text, name_match_type, true);
13651 /* First, look at the partial symtab symbols. */
13652 expand_symtabs_matching (NULL,
13656 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13659 /* At this point scan through the misc symbol vectors and add each
13660 symbol you find to the list. Eventually we want to ignore
13661 anything that isn't a text symbol (everything else will be
13662 handled by the psymtab code above). */
13664 for (objfile *objfile : current_program_space->objfiles ())
13666 for (minimal_symbol *msymbol : objfile->msymbols ())
13670 if (completion_skip_symbol (mode, msymbol))
13673 language symbol_language = msymbol->language ();
13675 /* Ada minimal symbols won't have their language set to Ada. If
13676 we let completion_list_add_name compare using the
13677 default/C-like matcher, then when completing e.g., symbols in a
13678 package named "pck", we'd match internal Ada symbols like
13679 "pckS", which are invalid in an Ada expression, unless you wrap
13680 them in '<' '>' to request a verbatim match.
13682 Unfortunately, some Ada encoded names successfully demangle as
13683 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13684 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13685 with the wrong language set. Paper over that issue here. */
13686 if (symbol_language == language_auto
13687 || symbol_language == language_cplus)
13688 symbol_language = language_ada;
13690 completion_list_add_name (tracker,
13692 msymbol->linkage_name (),
13693 lookup_name, text, word);
13697 /* Search upwards from currently selected frame (so that we can
13698 complete on local vars. */
13700 for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13702 if (!b->superblock ())
13703 surrounding_static_block = b; /* For elmin of dups */
13705 ALL_BLOCK_SYMBOLS (b, iter, sym)
13707 if (completion_skip_symbol (mode, sym))
13710 completion_list_add_name (tracker,
13712 sym->linkage_name (),
13713 lookup_name, text, word);
13717 /* Go through the symtabs and check the externs and statics for
13718 symbols which match. */
13720 for (objfile *objfile : current_program_space->objfiles ())
13722 for (compunit_symtab *s : objfile->compunits ())
13725 b = s->blockvector ()->global_block ();
13726 ALL_BLOCK_SYMBOLS (b, iter, sym)
13728 if (completion_skip_symbol (mode, sym))
13731 completion_list_add_name (tracker,
13733 sym->linkage_name (),
13734 lookup_name, text, word);
13739 for (objfile *objfile : current_program_space->objfiles ())
13741 for (compunit_symtab *s : objfile->compunits ())
13744 b = s->blockvector ()->static_block ();
13745 /* Don't do this block twice. */
13746 if (b == surrounding_static_block)
13748 ALL_BLOCK_SYMBOLS (b, iter, sym)
13750 if (completion_skip_symbol (mode, sym))
13753 completion_list_add_name (tracker,
13755 sym->linkage_name (),
13756 lookup_name, text, word);
13762 /* See language.h. */
13764 gdb::unique_xmalloc_ptr<char> watch_location_expression
13765 (struct type *type, CORE_ADDR addr) const override
13767 type = check_typedef (check_typedef (type)->target_type ());
13768 std::string name = type_to_string (type);
13769 return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13772 /* See language.h. */
13774 void value_print (struct value *val, struct ui_file *stream,
13775 const struct value_print_options *options) const override
13777 return ada_value_print (val, stream, options);
13780 /* See language.h. */
13782 void value_print_inner
13783 (struct value *val, struct ui_file *stream, int recurse,
13784 const struct value_print_options *options) const override
13786 return ada_value_print_inner (val, stream, recurse, options);
13789 /* See language.h. */
13791 struct block_symbol lookup_symbol_nonlocal
13792 (const char *name, const struct block *block,
13793 const domain_enum domain) const override
13795 struct block_symbol sym;
13797 sym = ada_lookup_symbol (name, block_static_block (block), domain);
13798 if (sym.symbol != NULL)
13801 /* If we haven't found a match at this point, try the primitive
13802 types. In other languages, this search is performed before
13803 searching for global symbols in order to short-circuit that
13804 global-symbol search if it happens that the name corresponds
13805 to a primitive type. But we cannot do the same in Ada, because
13806 it is perfectly legitimate for a program to declare a type which
13807 has the same name as a standard type. If looking up a type in
13808 that situation, we have traditionally ignored the primitive type
13809 in favor of user-defined types. This is why, unlike most other
13810 languages, we search the primitive types this late and only after
13811 having searched the global symbols without success. */
13813 if (domain == VAR_DOMAIN)
13815 struct gdbarch *gdbarch;
13818 gdbarch = target_gdbarch ();
13820 gdbarch = block_gdbarch (block);
13822 = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13823 if (sym.symbol != NULL)
13830 /* See language.h. */
13832 int parser (struct parser_state *ps) const override
13834 warnings_issued = 0;
13835 return ada_parse (ps);
13838 /* See language.h. */
13840 void emitchar (int ch, struct type *chtype,
13841 struct ui_file *stream, int quoter) const override
13843 ada_emit_char (ch, chtype, stream, quoter, 1);
13846 /* See language.h. */
13848 void printchar (int ch, struct type *chtype,
13849 struct ui_file *stream) const override
13851 ada_printchar (ch, chtype, stream);
13854 /* See language.h. */
13856 void printstr (struct ui_file *stream, struct type *elttype,
13857 const gdb_byte *string, unsigned int length,
13858 const char *encoding, int force_ellipses,
13859 const struct value_print_options *options) const override
13861 ada_printstr (stream, elttype, string, length, encoding,
13862 force_ellipses, options);
13865 /* See language.h. */
13867 void print_typedef (struct type *type, struct symbol *new_symbol,
13868 struct ui_file *stream) const override
13870 ada_print_typedef (type, new_symbol, stream);
13873 /* See language.h. */
13875 bool is_string_type_p (struct type *type) const override
13877 return ada_is_string_type (type);
13880 /* See language.h. */
13882 const char *struct_too_deep_ellipsis () const override
13883 { return "(...)"; }
13885 /* See language.h. */
13887 bool c_style_arrays_p () const override
13890 /* See language.h. */
13892 bool store_sym_names_in_linkage_form_p () const override
13895 /* See language.h. */
13897 const struct lang_varobj_ops *varobj_ops () const override
13898 { return &ada_varobj_ops; }
13901 /* See language.h. */
13903 symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13904 (const lookup_name_info &lookup_name) const override
13906 return ada_get_symbol_name_matcher (lookup_name);
13910 /* Single instance of the Ada language class. */
13912 static ada_language ada_language_defn;
13914 /* Command-list for the "set/show ada" prefix command. */
13915 static struct cmd_list_element *set_ada_list;
13916 static struct cmd_list_element *show_ada_list;
13918 /* This module's 'new_objfile' observer. */
13921 ada_new_objfile_observer (struct objfile *objfile)
13923 ada_clear_symbol_cache ();
13926 /* This module's 'free_objfile' observer. */
13929 ada_free_objfile_observer (struct objfile *objfile)
13931 ada_clear_symbol_cache ();
13934 /* Charsets known to GNAT. */
13935 static const char * const gnat_source_charsets[] =
13937 /* Note that code below assumes that the default comes first.
13938 Latin-1 is the default here, because that is also GNAT's
13948 /* Note that this value is special-cased in the encoder and
13954 void _initialize_ada_language ();
13956 _initialize_ada_language ()
13958 add_setshow_prefix_cmd
13960 _("Prefix command for changing Ada-specific settings."),
13961 _("Generic command for showing Ada-specific settings."),
13962 &set_ada_list, &show_ada_list,
13963 &setlist, &showlist);
13965 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13966 &trust_pad_over_xvs, _("\
13967 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13968 Show whether an optimization trusting PAD types over XVS types is activated."),
13970 This is related to the encoding used by the GNAT compiler. The debugger\n\
13971 should normally trust the contents of PAD types, but certain older versions\n\
13972 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13973 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13974 work around this bug. It is always safe to turn this option \"off\", but\n\
13975 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13976 this option to \"off\" unless necessary."),
13977 NULL, NULL, &set_ada_list, &show_ada_list);
13979 add_setshow_boolean_cmd ("print-signatures", class_vars,
13980 &print_signatures, _("\
13981 Enable or disable the output of formal and return types for functions in the \
13982 overloads selection menu."), _("\
13983 Show whether the output of formal and return types for functions in the \
13984 overloads selection menu is activated."),
13985 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13987 ada_source_charset = gnat_source_charsets[0];
13988 add_setshow_enum_cmd ("source-charset", class_files,
13989 gnat_source_charsets,
13990 &ada_source_charset, _("\
13991 Set the Ada source character set."), _("\
13992 Show the Ada source character set."), _("\
13993 The character set used for Ada source files.\n\
13994 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
13996 &set_ada_list, &show_ada_list);
13998 add_catch_command ("exception", _("\
13999 Catch Ada exceptions, when raised.\n\
14000 Usage: catch exception [ARG] [if CONDITION]\n\
14001 Without any argument, stop when any Ada exception is raised.\n\
14002 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14003 being raised does not have a handler (and will therefore lead to the task's\n\
14005 Otherwise, the catchpoint only stops when the name of the exception being\n\
14006 raised is the same as ARG.\n\
14007 CONDITION is a boolean expression that is evaluated to see whether the\n\
14008 exception should cause a stop."),
14009 catch_ada_exception_command,
14010 catch_ada_completer,
14014 add_catch_command ("handlers", _("\
14015 Catch Ada exceptions, when handled.\n\
14016 Usage: catch handlers [ARG] [if CONDITION]\n\
14017 Without any argument, stop when any Ada exception is handled.\n\
14018 With an argument, catch only exceptions with the given name.\n\
14019 CONDITION is a boolean expression that is evaluated to see whether the\n\
14020 exception should cause a stop."),
14021 catch_ada_handlers_command,
14022 catch_ada_completer,
14025 add_catch_command ("assert", _("\
14026 Catch failed Ada assertions, when raised.\n\
14027 Usage: catch assert [if CONDITION]\n\
14028 CONDITION is a boolean expression that is evaluated to see whether the\n\
14029 exception should cause a stop."),
14030 catch_assert_command,
14035 add_info ("exceptions", info_exceptions_command,
14037 List all Ada exception names.\n\
14038 Usage: info exceptions [REGEXP]\n\
14039 If a regular expression is passed as an argument, only those matching\n\
14040 the regular expression are listed."));
14042 add_setshow_prefix_cmd ("ada", class_maintenance,
14043 _("Set Ada maintenance-related variables."),
14044 _("Show Ada maintenance-related variables."),
14045 &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14046 &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14048 add_setshow_boolean_cmd
14049 ("ignore-descriptive-types", class_maintenance,
14050 &ada_ignore_descriptive_types_p,
14051 _("Set whether descriptive types generated by GNAT should be ignored."),
14052 _("Show whether descriptive types generated by GNAT should be ignored."),
14054 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14055 DWARF attribute."),
14056 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14058 decoded_names_store = htab_create_alloc (256, htab_hash_string,
14060 NULL, xcalloc, xfree);
14062 /* The ada-lang observers. */
14063 gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14064 gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14065 gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");