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. If
1150 FOLD is true (the default), case-fold any ordinary symbol. Symbols
1151 with <...> quoting are not folded in any case. */
1154 ada_encode (const char *decoded, bool fold)
1156 if (fold && decoded[0] != '<')
1157 decoded = ada_fold_name (decoded);
1158 return ada_encode_1 (decoded, true);
1161 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1164 is_lower_alphanum (const char c)
1166 return (isdigit (c) || (isalpha (c) && islower (c)));
1169 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1170 This function saves in LEN the length of that same symbol name but
1171 without either of these suffixes:
1177 These are suffixes introduced by the compiler for entities such as
1178 nested subprogram for instance, in order to avoid name clashes.
1179 They do not serve any purpose for the debugger. */
1182 ada_remove_trailing_digits (const char *encoded, int *len)
1184 if (*len > 1 && isdigit (encoded[*len - 1]))
1188 while (i > 0 && isdigit (encoded[i]))
1190 if (i >= 0 && encoded[i] == '.')
1192 else if (i >= 0 && encoded[i] == '$')
1194 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1196 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1201 /* Remove the suffix introduced by the compiler for protected object
1205 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1207 /* Remove trailing N. */
1209 /* Protected entry subprograms are broken into two
1210 separate subprograms: The first one is unprotected, and has
1211 a 'N' suffix; the second is the protected version, and has
1212 the 'P' suffix. The second calls the first one after handling
1213 the protection. Since the P subprograms are internally generated,
1214 we leave these names undecoded, giving the user a clue that this
1215 entity is internal. */
1218 && encoded[*len - 1] == 'N'
1219 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1223 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1224 then update *LEN to remove the suffix and return the offset of the
1225 character just past the ".". Otherwise, return -1. */
1228 remove_compiler_suffix (const char *encoded, int *len)
1230 int offset = *len - 1;
1231 while (offset > 0 && isalpha (encoded[offset]))
1233 if (offset > 0 && encoded[offset] == '.')
1241 /* Convert an ASCII hex string to a number. Reads exactly N
1242 characters from STR. Returns true on success, false if one of the
1243 digits was not a hex digit. */
1245 convert_hex (const char *str, int n, uint32_t *out)
1247 uint32_t result = 0;
1249 for (int i = 0; i < n; ++i)
1251 if (!isxdigit (str[i]))
1254 result |= fromhex (str[i]);
1261 /* Convert a wide character from its ASCII hex representation in STR
1262 (consisting of exactly N characters) to the host encoding,
1263 appending the resulting bytes to OUT. If N==2 and the Ada source
1264 charset is not UTF-8, then hex refers to an encoding in the
1265 ADA_SOURCE_CHARSET; otherwise, use UTF-32. Return true on success.
1266 Return false and do not modify OUT on conversion failure. */
1268 convert_from_hex_encoded (std::string &out, const char *str, int n)
1272 if (!convert_hex (str, n, &value))
1277 /* In the 'U' case, the hex digits encode the character in the
1278 Ada source charset. However, if the source charset is UTF-8,
1279 this really means it is a single-byte UTF-32 character. */
1280 if (n == 2 && ada_source_charset != ada_utf8)
1282 gdb_byte one_char = (gdb_byte) value;
1284 convert_between_encodings (ada_source_charset, host_charset (),
1286 sizeof (one_char), sizeof (one_char),
1287 &bytes, translit_none);
1290 convert_between_encodings (HOST_UTF32, host_charset (),
1291 (const gdb_byte *) &value,
1292 sizeof (value), sizeof (value),
1293 &bytes, translit_none);
1294 obstack_1grow (&bytes, '\0');
1295 out.append ((const char *) obstack_base (&bytes));
1297 catch (const gdb_exception &)
1299 /* On failure, the caller will just let the encoded form
1300 through, which seems basically reasonable. */
1307 /* See ada-lang.h. */
1310 ada_decode (const char *encoded, bool wrap, bool operators)
1316 std::string decoded;
1319 /* With function descriptors on PPC64, the value of a symbol named
1320 ".FN", if it exists, is the entry point of the function "FN". */
1321 if (encoded[0] == '.')
1324 /* The name of the Ada main procedure starts with "_ada_".
1325 This prefix is not part of the decoded name, so skip this part
1326 if we see this prefix. */
1327 if (startswith (encoded, "_ada_"))
1329 /* The "___ghost_" prefix is used for ghost entities. Normally
1330 these aren't preserved but when they are, it's useful to see
1332 if (startswith (encoded, "___ghost_"))
1335 /* If the name starts with '_', then it is not a properly encoded
1336 name, so do not attempt to decode it. Similarly, if the name
1337 starts with '<', the name should not be decoded. */
1338 if (encoded[0] == '_' || encoded[0] == '<')
1341 len0 = strlen (encoded);
1343 suffix = remove_compiler_suffix (encoded, &len0);
1345 ada_remove_trailing_digits (encoded, &len0);
1346 ada_remove_po_subprogram_suffix (encoded, &len0);
1348 /* Remove the ___X.* suffix if present. Do not forget to verify that
1349 the suffix is located before the current "end" of ENCODED. We want
1350 to avoid re-matching parts of ENCODED that have previously been
1351 marked as discarded (by decrementing LEN0). */
1352 p = strstr (encoded, "___");
1353 if (p != NULL && p - encoded < len0 - 3)
1361 /* Remove any trailing TKB suffix. It tells us that this symbol
1362 is for the body of a task, but that information does not actually
1363 appear in the decoded name. */
1365 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1368 /* Remove any trailing TB suffix. The TB suffix is slightly different
1369 from the TKB suffix because it is used for non-anonymous task
1372 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1375 /* Remove trailing "B" suffixes. */
1376 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1378 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1381 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1383 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1386 while ((i >= 0 && isdigit (encoded[i]))
1387 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1389 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1391 else if (encoded[i] == '$')
1395 /* The first few characters that are not alphabetic are not part
1396 of any encoding we use, so we can copy them over verbatim. */
1398 for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1399 decoded.push_back (encoded[i]);
1404 /* Is this a symbol function? */
1405 if (operators && at_start_name && encoded[i] == 'O')
1409 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1411 int op_len = strlen (ada_opname_table[k].encoded);
1412 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1414 && !isalnum (encoded[i + op_len]))
1416 decoded.append (ada_opname_table[k].decoded);
1422 if (ada_opname_table[k].encoded != NULL)
1427 /* Replace "TK__" with "__", which will eventually be translated
1428 into "." (just below). */
1430 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1433 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1434 be translated into "." (just below). These are internal names
1435 generated for anonymous blocks inside which our symbol is nested. */
1437 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1438 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1439 && isdigit (encoded [i+4]))
1443 while (k < len0 && isdigit (encoded[k]))
1444 k++; /* Skip any extra digit. */
1446 /* Double-check that the "__B_{DIGITS}+" sequence we found
1447 is indeed followed by "__". */
1448 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1452 /* Remove _E{DIGITS}+[sb] */
1454 /* Just as for protected object subprograms, there are 2 categories
1455 of subprograms created by the compiler for each entry. The first
1456 one implements the actual entry code, and has a suffix following
1457 the convention above; the second one implements the barrier and
1458 uses the same convention as above, except that the 'E' is replaced
1461 Just as above, we do not decode the name of barrier functions
1462 to give the user a clue that the code he is debugging has been
1463 internally generated. */
1465 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1466 && isdigit (encoded[i+2]))
1470 while (k < len0 && isdigit (encoded[k]))
1474 && (encoded[k] == 'b' || encoded[k] == 's'))
1477 /* Just as an extra precaution, make sure that if this
1478 suffix is followed by anything else, it is a '_'.
1479 Otherwise, we matched this sequence by accident. */
1481 || (k < len0 && encoded[k] == '_'))
1486 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1487 the GNAT front-end in protected object subprograms. */
1490 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1492 /* Backtrack a bit up until we reach either the begining of
1493 the encoded name, or "__". Make sure that we only find
1494 digits or lowercase characters. */
1495 const char *ptr = encoded + i - 1;
1497 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1500 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1504 if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1506 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1512 else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1514 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1520 else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1521 && isxdigit (encoded[i + 2]))
1523 if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1530 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1532 /* This is a X[bn]* sequence not separated from the previous
1533 part of the name with a non-alpha-numeric character (in other
1534 words, immediately following an alpha-numeric character), then
1535 verify that it is placed at the end of the encoded name. If
1536 not, then the encoding is not valid and we should abort the
1537 decoding. Otherwise, just skip it, it is used in body-nested
1541 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1545 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1547 /* Replace '__' by '.'. */
1548 decoded.push_back ('.');
1554 /* It's a character part of the decoded name, so just copy it
1556 decoded.push_back (encoded[i]);
1561 /* Decoded names should never contain any uppercase character.
1562 Double-check this, and abort the decoding if we find one. */
1566 for (i = 0; i < decoded.length(); ++i)
1567 if (isupper (decoded[i]) || decoded[i] == ' ')
1571 /* If the compiler added a suffix, append it now. */
1573 decoded = decoded + "[" + &encoded[suffix] + "]";
1581 if (encoded[0] == '<')
1584 decoded = '<' + std::string(encoded) + '>';
1588 /* Table for keeping permanent unique copies of decoded names. Once
1589 allocated, names in this table are never released. While this is a
1590 storage leak, it should not be significant unless there are massive
1591 changes in the set of decoded names in successive versions of a
1592 symbol table loaded during a single session. */
1593 static struct htab *decoded_names_store;
1595 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1596 in the language-specific part of GSYMBOL, if it has not been
1597 previously computed. Tries to save the decoded name in the same
1598 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1599 in any case, the decoded symbol has a lifetime at least that of
1601 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1602 const, but nevertheless modified to a semantically equivalent form
1603 when a decoded name is cached in it. */
1606 ada_decode_symbol (const struct general_symbol_info *arg)
1608 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1609 const char **resultp =
1610 &gsymbol->language_specific.demangled_name;
1612 if (!gsymbol->ada_mangled)
1614 std::string decoded = ada_decode (gsymbol->linkage_name ());
1615 struct obstack *obstack = gsymbol->language_specific.obstack;
1617 gsymbol->ada_mangled = 1;
1619 if (obstack != NULL)
1620 *resultp = obstack_strdup (obstack, decoded.c_str ());
1623 /* Sometimes, we can't find a corresponding objfile, in
1624 which case, we put the result on the heap. Since we only
1625 decode when needed, we hope this usually does not cause a
1626 significant memory leak (FIXME). */
1628 char **slot = (char **) htab_find_slot (decoded_names_store,
1629 decoded.c_str (), INSERT);
1632 *slot = xstrdup (decoded.c_str ());
1644 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1645 generated by the GNAT compiler to describe the index type used
1646 for each dimension of an array, check whether it follows the latest
1647 known encoding. If not, fix it up to conform to the latest encoding.
1648 Otherwise, do nothing. This function also does nothing if
1649 INDEX_DESC_TYPE is NULL.
1651 The GNAT encoding used to describe the array index type evolved a bit.
1652 Initially, the information would be provided through the name of each
1653 field of the structure type only, while the type of these fields was
1654 described as unspecified and irrelevant. The debugger was then expected
1655 to perform a global type lookup using the name of that field in order
1656 to get access to the full index type description. Because these global
1657 lookups can be very expensive, the encoding was later enhanced to make
1658 the global lookup unnecessary by defining the field type as being
1659 the full index type description.
1661 The purpose of this routine is to allow us to support older versions
1662 of the compiler by detecting the use of the older encoding, and by
1663 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1664 we essentially replace each field's meaningless type by the associated
1668 ada_fixup_array_indexes_type (struct type *index_desc_type)
1672 if (index_desc_type == NULL)
1674 gdb_assert (index_desc_type->num_fields () > 0);
1676 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1677 to check one field only, no need to check them all). If not, return
1680 If our INDEX_DESC_TYPE was generated using the older encoding,
1681 the field type should be a meaningless integer type whose name
1682 is not equal to the field name. */
1683 if (index_desc_type->field (0).type ()->name () != NULL
1684 && strcmp (index_desc_type->field (0).type ()->name (),
1685 index_desc_type->field (0).name ()) == 0)
1688 /* Fixup each field of INDEX_DESC_TYPE. */
1689 for (i = 0; i < index_desc_type->num_fields (); i++)
1691 const char *name = index_desc_type->field (i).name ();
1692 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1695 index_desc_type->field (i).set_type (raw_type);
1699 /* The desc_* routines return primitive portions of array descriptors
1702 /* The descriptor or array type, if any, indicated by TYPE; removes
1703 level of indirection, if needed. */
1705 static struct type *
1706 desc_base_type (struct type *type)
1710 type = ada_check_typedef (type);
1711 if (type->code () == TYPE_CODE_TYPEDEF)
1712 type = ada_typedef_target_type (type);
1715 && (type->code () == TYPE_CODE_PTR
1716 || type->code () == TYPE_CODE_REF))
1717 return ada_check_typedef (type->target_type ());
1722 /* True iff TYPE indicates a "thin" array pointer type. */
1725 is_thin_pntr (struct type *type)
1728 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1729 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1732 /* The descriptor type for thin pointer type TYPE. */
1734 static struct type *
1735 thin_descriptor_type (struct type *type)
1737 struct type *base_type = desc_base_type (type);
1739 if (base_type == NULL)
1741 if (is_suffix (ada_type_name (base_type), "___XVE"))
1745 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1747 if (alt_type == NULL)
1754 /* A pointer to the array data for thin-pointer value VAL. */
1756 static struct value *
1757 thin_data_pntr (struct value *val)
1759 struct type *type = ada_check_typedef (value_type (val));
1760 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1762 data_type = lookup_pointer_type (data_type);
1764 if (type->code () == TYPE_CODE_PTR)
1765 return value_cast (data_type, value_copy (val));
1767 return value_from_longest (data_type, value_address (val));
1770 /* True iff TYPE indicates a "thick" array pointer type. */
1773 is_thick_pntr (struct type *type)
1775 type = desc_base_type (type);
1776 return (type != NULL && type->code () == TYPE_CODE_STRUCT
1777 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1780 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1781 pointer to one, the type of its bounds data; otherwise, NULL. */
1783 static struct type *
1784 desc_bounds_type (struct type *type)
1788 type = desc_base_type (type);
1792 else if (is_thin_pntr (type))
1794 type = thin_descriptor_type (type);
1797 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1799 return ada_check_typedef (r);
1801 else if (type->code () == TYPE_CODE_STRUCT)
1803 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1805 return ada_check_typedef (ada_check_typedef (r)->target_type ());
1810 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1811 one, a pointer to its bounds data. Otherwise NULL. */
1813 static struct value *
1814 desc_bounds (struct value *arr)
1816 struct type *type = ada_check_typedef (value_type (arr));
1818 if (is_thin_pntr (type))
1820 struct type *bounds_type =
1821 desc_bounds_type (thin_descriptor_type (type));
1824 if (bounds_type == NULL)
1825 error (_("Bad GNAT array descriptor"));
1827 /* NOTE: The following calculation is not really kosher, but
1828 since desc_type is an XVE-encoded type (and shouldn't be),
1829 the correct calculation is a real pain. FIXME (and fix GCC). */
1830 if (type->code () == TYPE_CODE_PTR)
1831 addr = value_as_long (arr);
1833 addr = value_address (arr);
1836 value_from_longest (lookup_pointer_type (bounds_type),
1837 addr - bounds_type->length ());
1840 else if (is_thick_pntr (type))
1842 struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1843 _("Bad GNAT array descriptor"));
1844 struct type *p_bounds_type = value_type (p_bounds);
1847 && p_bounds_type->code () == TYPE_CODE_PTR)
1849 struct type *target_type = p_bounds_type->target_type ();
1851 if (target_type->is_stub ())
1852 p_bounds = value_cast (lookup_pointer_type
1853 (ada_check_typedef (target_type)),
1857 error (_("Bad GNAT array descriptor"));
1865 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1866 position of the field containing the address of the bounds data. */
1869 fat_pntr_bounds_bitpos (struct type *type)
1871 return desc_base_type (type)->field (1).loc_bitpos ();
1874 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1875 size of the field containing the address of the bounds data. */
1878 fat_pntr_bounds_bitsize (struct type *type)
1880 type = desc_base_type (type);
1882 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1883 return TYPE_FIELD_BITSIZE (type, 1);
1885 return 8 * ada_check_typedef (type->field (1).type ())->length ();
1888 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1889 pointer to one, the type of its array data (a array-with-no-bounds type);
1890 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1893 static struct type *
1894 desc_data_target_type (struct type *type)
1896 type = desc_base_type (type);
1898 /* NOTE: The following is bogus; see comment in desc_bounds. */
1899 if (is_thin_pntr (type))
1900 return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1901 else if (is_thick_pntr (type))
1903 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1906 && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1907 return ada_check_typedef (data_type->target_type ());
1913 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1916 static struct value *
1917 desc_data (struct value *arr)
1919 struct type *type = value_type (arr);
1921 if (is_thin_pntr (type))
1922 return thin_data_pntr (arr);
1923 else if (is_thick_pntr (type))
1924 return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1925 _("Bad GNAT array descriptor"));
1931 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1932 position of the field containing the address of the data. */
1935 fat_pntr_data_bitpos (struct type *type)
1937 return desc_base_type (type)->field (0).loc_bitpos ();
1940 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1941 size of the field containing the address of the data. */
1944 fat_pntr_data_bitsize (struct type *type)
1946 type = desc_base_type (type);
1948 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1949 return TYPE_FIELD_BITSIZE (type, 0);
1951 return TARGET_CHAR_BIT * type->field (0).type ()->length ();
1954 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1955 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1956 bound, if WHICH is 1. The first bound is I=1. */
1958 static struct value *
1959 desc_one_bound (struct value *bounds, int i, int which)
1961 char bound_name[20];
1962 xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1963 which ? 'U' : 'L', i - 1);
1964 return value_struct_elt (&bounds, {}, bound_name, NULL,
1965 _("Bad GNAT array descriptor bounds"));
1968 /* If BOUNDS is an array-bounds structure type, return the bit position
1969 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1970 bound, if WHICH is 1. The first bound is I=1. */
1973 desc_bound_bitpos (struct type *type, int i, int which)
1975 return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1978 /* If BOUNDS is an array-bounds structure type, return the bit field size
1979 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1980 bound, if WHICH is 1. The first bound is I=1. */
1983 desc_bound_bitsize (struct type *type, int i, int which)
1985 type = desc_base_type (type);
1987 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1988 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1990 return 8 * type->field (2 * i + which - 2).type ()->length ();
1993 /* If TYPE is the type of an array-bounds structure, the type of its
1994 Ith bound (numbering from 1). Otherwise, NULL. */
1996 static struct type *
1997 desc_index_type (struct type *type, int i)
1999 type = desc_base_type (type);
2001 if (type->code () == TYPE_CODE_STRUCT)
2003 char bound_name[20];
2004 xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2005 return lookup_struct_elt_type (type, bound_name, 1);
2011 /* The number of index positions in the array-bounds type TYPE.
2012 Return 0 if TYPE is NULL. */
2015 desc_arity (struct type *type)
2017 type = desc_base_type (type);
2020 return type->num_fields () / 2;
2024 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
2025 an array descriptor type (representing an unconstrained array
2029 ada_is_direct_array_type (struct type *type)
2033 type = ada_check_typedef (type);
2034 return (type->code () == TYPE_CODE_ARRAY
2035 || ada_is_array_descriptor_type (type));
2038 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2042 ada_is_array_type (struct type *type)
2045 && (type->code () == TYPE_CODE_PTR
2046 || type->code () == TYPE_CODE_REF))
2047 type = type->target_type ();
2048 return ada_is_direct_array_type (type);
2051 /* Non-zero iff TYPE is a simple array type or pointer to one. */
2054 ada_is_simple_array_type (struct type *type)
2058 type = ada_check_typedef (type);
2059 return (type->code () == TYPE_CODE_ARRAY
2060 || (type->code () == TYPE_CODE_PTR
2061 && (ada_check_typedef (type->target_type ())->code ()
2062 == TYPE_CODE_ARRAY)));
2065 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
2068 ada_is_array_descriptor_type (struct type *type)
2070 struct type *data_type = desc_data_target_type (type);
2074 type = ada_check_typedef (type);
2075 return (data_type != NULL
2076 && data_type->code () == TYPE_CODE_ARRAY
2077 && desc_arity (desc_bounds_type (type)) > 0);
2080 /* Non-zero iff type is a partially mal-formed GNAT array
2081 descriptor. FIXME: This is to compensate for some problems with
2082 debugging output from GNAT. Re-examine periodically to see if it
2086 ada_is_bogus_array_descriptor (struct type *type)
2090 && type->code () == TYPE_CODE_STRUCT
2091 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2092 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2093 && !ada_is_array_descriptor_type (type);
2097 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2098 (fat pointer) returns the type of the array data described---specifically,
2099 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
2100 in from the descriptor; otherwise, they are left unspecified. If
2101 the ARR denotes a null array descriptor and BOUNDS is non-zero,
2102 returns NULL. The result is simply the type of ARR if ARR is not
2105 static struct type *
2106 ada_type_of_array (struct value *arr, int bounds)
2108 if (ada_is_constrained_packed_array_type (value_type (arr)))
2109 return decode_constrained_packed_array_type (value_type (arr));
2111 if (!ada_is_array_descriptor_type (value_type (arr)))
2112 return value_type (arr);
2116 struct type *array_type =
2117 ada_check_typedef (desc_data_target_type (value_type (arr)));
2119 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2120 TYPE_FIELD_BITSIZE (array_type, 0) =
2121 decode_packed_array_bitsize (value_type (arr));
2127 struct type *elt_type;
2129 struct value *descriptor;
2131 elt_type = ada_array_element_type (value_type (arr), -1);
2132 arity = ada_array_arity (value_type (arr));
2134 if (elt_type == NULL || arity == 0)
2135 return ada_check_typedef (value_type (arr));
2137 descriptor = desc_bounds (arr);
2138 if (value_as_long (descriptor) == 0)
2142 struct type *range_type = alloc_type_copy (value_type (arr));
2143 struct type *array_type = alloc_type_copy (value_type (arr));
2144 struct value *low = desc_one_bound (descriptor, arity, 0);
2145 struct value *high = desc_one_bound (descriptor, arity, 1);
2148 create_static_range_type (range_type, value_type (low),
2149 longest_to_int (value_as_long (low)),
2150 longest_to_int (value_as_long (high)));
2151 elt_type = create_array_type (array_type, elt_type, range_type);
2153 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2155 /* We need to store the element packed bitsize, as well as
2156 recompute the array size, because it was previously
2157 computed based on the unpacked element size. */
2158 LONGEST lo = value_as_long (low);
2159 LONGEST hi = value_as_long (high);
2161 TYPE_FIELD_BITSIZE (elt_type, 0) =
2162 decode_packed_array_bitsize (value_type (arr));
2163 /* If the array has no element, then the size is already
2164 zero, and does not need to be recomputed. */
2168 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2170 array_type->set_length ((array_bitsize + 7) / 8);
2175 return lookup_pointer_type (elt_type);
2179 /* If ARR does not represent an array, returns ARR unchanged.
2180 Otherwise, returns either a standard GDB array with bounds set
2181 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2182 GDB array. Returns NULL if ARR is a null fat pointer. */
2185 ada_coerce_to_simple_array_ptr (struct value *arr)
2187 if (ada_is_array_descriptor_type (value_type (arr)))
2189 struct type *arrType = ada_type_of_array (arr, 1);
2191 if (arrType == NULL)
2193 return value_cast (arrType, value_copy (desc_data (arr)));
2195 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2196 return decode_constrained_packed_array (arr);
2201 /* If ARR does not represent an array, returns ARR unchanged.
2202 Otherwise, returns a standard GDB array describing ARR (which may
2203 be ARR itself if it already is in the proper form). */
2206 ada_coerce_to_simple_array (struct value *arr)
2208 if (ada_is_array_descriptor_type (value_type (arr)))
2210 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2213 error (_("Bounds unavailable for null array pointer."));
2214 return value_ind (arrVal);
2216 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2217 return decode_constrained_packed_array (arr);
2222 /* If TYPE represents a GNAT array type, return it translated to an
2223 ordinary GDB array type (possibly with BITSIZE fields indicating
2224 packing). For other types, is the identity. */
2227 ada_coerce_to_simple_array_type (struct type *type)
2229 if (ada_is_constrained_packed_array_type (type))
2230 return decode_constrained_packed_array_type (type);
2232 if (ada_is_array_descriptor_type (type))
2233 return ada_check_typedef (desc_data_target_type (type));
2238 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2241 ada_is_gnat_encoded_packed_array_type (struct type *type)
2245 type = desc_base_type (type);
2246 type = ada_check_typedef (type);
2248 ada_type_name (type) != NULL
2249 && strstr (ada_type_name (type), "___XP") != NULL;
2252 /* Non-zero iff TYPE represents a standard GNAT constrained
2253 packed-array type. */
2256 ada_is_constrained_packed_array_type (struct type *type)
2258 return ada_is_gnat_encoded_packed_array_type (type)
2259 && !ada_is_array_descriptor_type (type);
2262 /* Non-zero iff TYPE represents an array descriptor for a
2263 unconstrained packed-array type. */
2266 ada_is_unconstrained_packed_array_type (struct type *type)
2268 if (!ada_is_array_descriptor_type (type))
2271 if (ada_is_gnat_encoded_packed_array_type (type))
2274 /* If we saw GNAT encodings, then the above code is sufficient.
2275 However, with minimal encodings, we will just have a thick
2277 if (is_thick_pntr (type))
2279 type = desc_base_type (type);
2280 /* The structure's first field is a pointer to an array, so this
2281 fetches the array type. */
2282 type = type->field (0).type ()->target_type ();
2283 if (type->code () == TYPE_CODE_TYPEDEF)
2284 type = ada_typedef_target_type (type);
2285 /* Now we can see if the array elements are packed. */
2286 return TYPE_FIELD_BITSIZE (type, 0) > 0;
2292 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2293 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2296 ada_is_any_packed_array_type (struct type *type)
2298 return (ada_is_constrained_packed_array_type (type)
2299 || (type->code () == TYPE_CODE_ARRAY
2300 && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2303 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2304 return the size of its elements in bits. */
2307 decode_packed_array_bitsize (struct type *type)
2309 const char *raw_name;
2313 /* Access to arrays implemented as fat pointers are encoded as a typedef
2314 of the fat pointer type. We need the name of the fat pointer type
2315 to do the decoding, so strip the typedef layer. */
2316 if (type->code () == TYPE_CODE_TYPEDEF)
2317 type = ada_typedef_target_type (type);
2319 raw_name = ada_type_name (ada_check_typedef (type));
2321 raw_name = ada_type_name (desc_base_type (type));
2326 tail = strstr (raw_name, "___XP");
2327 if (tail == nullptr)
2329 gdb_assert (is_thick_pntr (type));
2330 /* The structure's first field is a pointer to an array, so this
2331 fetches the array type. */
2332 type = type->field (0).type ()->target_type ();
2333 /* Now we can see if the array elements are packed. */
2334 return TYPE_FIELD_BITSIZE (type, 0);
2337 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2340 (_("could not understand bit size information on packed array"));
2347 /* Given that TYPE is a standard GDB array type with all bounds filled
2348 in, and that the element size of its ultimate scalar constituents
2349 (that is, either its elements, or, if it is an array of arrays, its
2350 elements' elements, etc.) is *ELT_BITS, return an identical type,
2351 but with the bit sizes of its elements (and those of any
2352 constituent arrays) recorded in the BITSIZE components of its
2353 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2356 Note that, for arrays whose index type has an XA encoding where
2357 a bound references a record discriminant, getting that discriminant,
2358 and therefore the actual value of that bound, is not possible
2359 because none of the given parameters gives us access to the record.
2360 This function assumes that it is OK in the context where it is being
2361 used to return an array whose bounds are still dynamic and where
2362 the length is arbitrary. */
2364 static struct type *
2365 constrained_packed_array_type (struct type *type, long *elt_bits)
2367 struct type *new_elt_type;
2368 struct type *new_type;
2369 struct type *index_type_desc;
2370 struct type *index_type;
2371 LONGEST low_bound, high_bound;
2373 type = ada_check_typedef (type);
2374 if (type->code () != TYPE_CODE_ARRAY)
2377 index_type_desc = ada_find_parallel_type (type, "___XA");
2378 if (index_type_desc)
2379 index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2382 index_type = type->index_type ();
2384 new_type = alloc_type_copy (type);
2386 constrained_packed_array_type (ada_check_typedef (type->target_type ()),
2388 create_array_type (new_type, new_elt_type, index_type);
2389 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2390 new_type->set_name (ada_type_name (type));
2392 if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2393 && is_dynamic_type (check_typedef (index_type)))
2394 || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2395 low_bound = high_bound = 0;
2396 if (high_bound < low_bound)
2399 new_type->set_length (0);
2403 *elt_bits *= (high_bound - low_bound + 1);
2404 new_type->set_length ((*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT);
2407 new_type->set_is_fixed_instance (true);
2411 /* The array type encoded by TYPE, where
2412 ada_is_constrained_packed_array_type (TYPE). */
2414 static struct type *
2415 decode_constrained_packed_array_type (struct type *type)
2417 const char *raw_name = ada_type_name (ada_check_typedef (type));
2420 struct type *shadow_type;
2424 raw_name = ada_type_name (desc_base_type (type));
2429 name = (char *) alloca (strlen (raw_name) + 1);
2430 tail = strstr (raw_name, "___XP");
2431 type = desc_base_type (type);
2433 memcpy (name, raw_name, tail - raw_name);
2434 name[tail - raw_name] = '\000';
2436 shadow_type = ada_find_parallel_type_with_name (type, name);
2438 if (shadow_type == NULL)
2440 lim_warning (_("could not find bounds information on packed array"));
2443 shadow_type = check_typedef (shadow_type);
2445 if (shadow_type->code () != TYPE_CODE_ARRAY)
2447 lim_warning (_("could not understand bounds "
2448 "information on packed array"));
2452 bits = decode_packed_array_bitsize (type);
2453 return constrained_packed_array_type (shadow_type, &bits);
2456 /* Helper function for decode_constrained_packed_array. Set the field
2457 bitsize on a series of packed arrays. Returns the number of
2458 elements in TYPE. */
2461 recursively_update_array_bitsize (struct type *type)
2463 gdb_assert (type->code () == TYPE_CODE_ARRAY);
2466 if (!get_discrete_bounds (type->index_type (), &low, &high)
2469 LONGEST our_len = high - low + 1;
2471 struct type *elt_type = type->target_type ();
2472 if (elt_type->code () == TYPE_CODE_ARRAY)
2474 LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2475 LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2476 TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2478 type->set_length (((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2485 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2486 array, returns a simple array that denotes that array. Its type is a
2487 standard GDB array type except that the BITSIZEs of the array
2488 target types are set to the number of bits in each element, and the
2489 type length is set appropriately. */
2491 static struct value *
2492 decode_constrained_packed_array (struct value *arr)
2496 /* If our value is a pointer, then dereference it. Likewise if
2497 the value is a reference. Make sure that this operation does not
2498 cause the target type to be fixed, as this would indirectly cause
2499 this array to be decoded. The rest of the routine assumes that
2500 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2501 and "value_ind" routines to perform the dereferencing, as opposed
2502 to using "ada_coerce_ref" or "ada_value_ind". */
2503 arr = coerce_ref (arr);
2504 if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2505 arr = value_ind (arr);
2507 type = decode_constrained_packed_array_type (value_type (arr));
2510 error (_("can't unpack array"));
2514 /* Decoding the packed array type could not correctly set the field
2515 bitsizes for any dimension except the innermost, because the
2516 bounds may be variable and were not passed to that function. So,
2517 we further resolve the array bounds here and then update the
2519 const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2520 CORE_ADDR address = value_address (arr);
2521 gdb::array_view<const gdb_byte> view
2522 = gdb::make_array_view (valaddr, type->length ());
2523 type = resolve_dynamic_type (type, view, address);
2524 recursively_update_array_bitsize (type);
2526 if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2527 && ada_is_modular_type (value_type (arr)))
2529 /* This is a (right-justified) modular type representing a packed
2530 array with no wrapper. In order to interpret the value through
2531 the (left-justified) packed array type we just built, we must
2532 first left-justify it. */
2533 int bit_size, bit_pos;
2536 mod = ada_modulus (value_type (arr)) - 1;
2543 bit_pos = HOST_CHAR_BIT * value_type (arr)->length () - bit_size;
2544 arr = ada_value_primitive_packed_val (arr, NULL,
2545 bit_pos / HOST_CHAR_BIT,
2546 bit_pos % HOST_CHAR_BIT,
2551 return coerce_unspec_val_to_type (arr, type);
2555 /* The value of the element of packed array ARR at the ARITY indices
2556 given in IND. ARR must be a simple array. */
2558 static struct value *
2559 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2562 int bits, elt_off, bit_off;
2563 long elt_total_bit_offset;
2564 struct type *elt_type;
2568 elt_total_bit_offset = 0;
2569 elt_type = ada_check_typedef (value_type (arr));
2570 for (i = 0; i < arity; i += 1)
2572 if (elt_type->code () != TYPE_CODE_ARRAY
2573 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2575 (_("attempt to do packed indexing of "
2576 "something other than a packed array"));
2579 struct type *range_type = elt_type->index_type ();
2580 LONGEST lowerbound, upperbound;
2583 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2585 lim_warning (_("don't know bounds of array"));
2586 lowerbound = upperbound = 0;
2589 idx = pos_atr (ind[i]);
2590 if (idx < lowerbound || idx > upperbound)
2591 lim_warning (_("packed array index %ld out of bounds"),
2593 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2594 elt_total_bit_offset += (idx - lowerbound) * bits;
2595 elt_type = ada_check_typedef (elt_type->target_type ());
2598 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2599 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2601 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2606 /* Non-zero iff TYPE includes negative integer values. */
2609 has_negatives (struct type *type)
2611 switch (type->code ())
2616 return !type->is_unsigned ();
2617 case TYPE_CODE_RANGE:
2618 return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2622 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2623 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2624 the unpacked buffer.
2626 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2627 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2629 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2632 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2634 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2637 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2638 gdb_byte *unpacked, int unpacked_len,
2639 int is_big_endian, int is_signed_type,
2642 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2643 int src_idx; /* Index into the source area */
2644 int src_bytes_left; /* Number of source bytes left to process. */
2645 int srcBitsLeft; /* Number of source bits left to move */
2646 int unusedLS; /* Number of bits in next significant
2647 byte of source that are unused */
2649 int unpacked_idx; /* Index into the unpacked buffer */
2650 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2652 unsigned long accum; /* Staging area for bits being transferred */
2653 int accumSize; /* Number of meaningful bits in accum */
2656 /* Transmit bytes from least to most significant; delta is the direction
2657 the indices move. */
2658 int delta = is_big_endian ? -1 : 1;
2660 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2662 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2663 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2664 bit_size, unpacked_len);
2666 srcBitsLeft = bit_size;
2667 src_bytes_left = src_len;
2668 unpacked_bytes_left = unpacked_len;
2673 src_idx = src_len - 1;
2675 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2679 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2685 unpacked_idx = unpacked_len - 1;
2689 /* Non-scalar values must be aligned at a byte boundary... */
2691 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2692 /* ... And are placed at the beginning (most-significant) bytes
2694 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2695 unpacked_bytes_left = unpacked_idx + 1;
2700 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2702 src_idx = unpacked_idx = 0;
2703 unusedLS = bit_offset;
2706 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2711 while (src_bytes_left > 0)
2713 /* Mask for removing bits of the next source byte that are not
2714 part of the value. */
2715 unsigned int unusedMSMask =
2716 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2718 /* Sign-extend bits for this byte. */
2719 unsigned int signMask = sign & ~unusedMSMask;
2722 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2723 accumSize += HOST_CHAR_BIT - unusedLS;
2724 if (accumSize >= HOST_CHAR_BIT)
2726 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2727 accumSize -= HOST_CHAR_BIT;
2728 accum >>= HOST_CHAR_BIT;
2729 unpacked_bytes_left -= 1;
2730 unpacked_idx += delta;
2732 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2734 src_bytes_left -= 1;
2737 while (unpacked_bytes_left > 0)
2739 accum |= sign << accumSize;
2740 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2741 accumSize -= HOST_CHAR_BIT;
2744 accum >>= HOST_CHAR_BIT;
2745 unpacked_bytes_left -= 1;
2746 unpacked_idx += delta;
2750 /* Create a new value of type TYPE from the contents of OBJ starting
2751 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2752 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2753 assigning through the result will set the field fetched from.
2754 VALADDR is ignored unless OBJ is NULL, in which case,
2755 VALADDR+OFFSET must address the start of storage containing the
2756 packed value. The value returned in this case is never an lval.
2757 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2760 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2761 long offset, int bit_offset, int bit_size,
2765 const gdb_byte *src; /* First byte containing data to unpack */
2767 const int is_scalar = is_scalar_type (type);
2768 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2769 gdb::byte_vector staging;
2771 type = ada_check_typedef (type);
2774 src = valaddr + offset;
2776 src = value_contents (obj).data () + offset;
2778 if (is_dynamic_type (type))
2780 /* The length of TYPE might by dynamic, so we need to resolve
2781 TYPE in order to know its actual size, which we then use
2782 to create the contents buffer of the value we return.
2783 The difficulty is that the data containing our object is
2784 packed, and therefore maybe not at a byte boundary. So, what
2785 we do, is unpack the data into a byte-aligned buffer, and then
2786 use that buffer as our object's value for resolving the type. */
2787 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2788 staging.resize (staging_len);
2790 ada_unpack_from_contents (src, bit_offset, bit_size,
2791 staging.data (), staging.size (),
2792 is_big_endian, has_negatives (type),
2794 type = resolve_dynamic_type (type, staging, 0);
2795 if (type->length () < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2797 /* This happens when the length of the object is dynamic,
2798 and is actually smaller than the space reserved for it.
2799 For instance, in an array of variant records, the bit_size
2800 we're given is the array stride, which is constant and
2801 normally equal to the maximum size of its element.
2802 But, in reality, each element only actually spans a portion
2804 bit_size = type->length () * HOST_CHAR_BIT;
2810 v = allocate_value (type);
2811 src = valaddr + offset;
2813 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2815 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2818 v = value_at (type, value_address (obj) + offset);
2819 buf = (gdb_byte *) alloca (src_len);
2820 read_memory (value_address (v), buf, src_len);
2825 v = allocate_value (type);
2826 src = value_contents (obj).data () + offset;
2831 long new_offset = offset;
2833 set_value_component_location (v, obj);
2834 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2835 set_value_bitsize (v, bit_size);
2836 if (value_bitpos (v) >= HOST_CHAR_BIT)
2839 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2841 set_value_offset (v, new_offset);
2843 /* Also set the parent value. This is needed when trying to
2844 assign a new value (in inferior memory). */
2845 set_value_parent (v, obj);
2848 set_value_bitsize (v, bit_size);
2849 unpacked = value_contents_writeable (v).data ();
2853 memset (unpacked, 0, type->length ());
2857 if (staging.size () == type->length ())
2859 /* Small short-cut: If we've unpacked the data into a buffer
2860 of the same size as TYPE's length, then we can reuse that,
2861 instead of doing the unpacking again. */
2862 memcpy (unpacked, staging.data (), staging.size ());
2865 ada_unpack_from_contents (src, bit_offset, bit_size,
2866 unpacked, type->length (),
2867 is_big_endian, has_negatives (type), is_scalar);
2872 /* Store the contents of FROMVAL into the location of TOVAL.
2873 Return a new value with the location of TOVAL and contents of
2874 FROMVAL. Handles assignment into packed fields that have
2875 floating-point or non-scalar types. */
2877 static struct value *
2878 ada_value_assign (struct value *toval, struct value *fromval)
2880 struct type *type = value_type (toval);
2881 int bits = value_bitsize (toval);
2883 toval = ada_coerce_ref (toval);
2884 fromval = ada_coerce_ref (fromval);
2886 if (ada_is_direct_array_type (value_type (toval)))
2887 toval = ada_coerce_to_simple_array (toval);
2888 if (ada_is_direct_array_type (value_type (fromval)))
2889 fromval = ada_coerce_to_simple_array (fromval);
2891 if (!deprecated_value_modifiable (toval))
2892 error (_("Left operand of assignment is not a modifiable lvalue."));
2894 if (VALUE_LVAL (toval) == lval_memory
2896 && (type->code () == TYPE_CODE_FLT
2897 || type->code () == TYPE_CODE_STRUCT))
2899 int len = (value_bitpos (toval)
2900 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2902 gdb_byte *buffer = (gdb_byte *) alloca (len);
2904 CORE_ADDR to_addr = value_address (toval);
2906 if (type->code () == TYPE_CODE_FLT)
2907 fromval = value_cast (type, fromval);
2909 read_memory (to_addr, buffer, len);
2910 from_size = value_bitsize (fromval);
2912 from_size = value_type (fromval)->length () * TARGET_CHAR_BIT;
2914 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2915 ULONGEST from_offset = 0;
2916 if (is_big_endian && is_scalar_type (value_type (fromval)))
2917 from_offset = from_size - bits;
2918 copy_bitwise (buffer, value_bitpos (toval),
2919 value_contents (fromval).data (), from_offset,
2920 bits, is_big_endian);
2921 write_memory_with_notification (to_addr, buffer, len);
2923 val = value_copy (toval);
2924 memcpy (value_contents_raw (val).data (),
2925 value_contents (fromval).data (),
2927 deprecated_set_value_type (val, type);
2932 return value_assign (toval, fromval);
2936 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2937 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2938 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2939 COMPONENT, and not the inferior's memory. The current contents
2940 of COMPONENT are ignored.
2942 Although not part of the initial design, this function also works
2943 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2944 had a null address, and COMPONENT had an address which is equal to
2945 its offset inside CONTAINER. */
2948 value_assign_to_component (struct value *container, struct value *component,
2951 LONGEST offset_in_container =
2952 (LONGEST) (value_address (component) - value_address (container));
2953 int bit_offset_in_container =
2954 value_bitpos (component) - value_bitpos (container);
2957 val = value_cast (value_type (component), val);
2959 if (value_bitsize (component) == 0)
2960 bits = TARGET_CHAR_BIT * value_type (component)->length ();
2962 bits = value_bitsize (component);
2964 if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2968 if (is_scalar_type (check_typedef (value_type (component))))
2970 = value_type (component)->length () * TARGET_CHAR_BIT - bits;
2973 copy_bitwise ((value_contents_writeable (container).data ()
2974 + offset_in_container),
2975 value_bitpos (container) + bit_offset_in_container,
2976 value_contents (val).data (), src_offset, bits, 1);
2979 copy_bitwise ((value_contents_writeable (container).data ()
2980 + offset_in_container),
2981 value_bitpos (container) + bit_offset_in_container,
2982 value_contents (val).data (), 0, bits, 0);
2985 /* Determine if TYPE is an access to an unconstrained array. */
2988 ada_is_access_to_unconstrained_array (struct type *type)
2990 return (type->code () == TYPE_CODE_TYPEDEF
2991 && is_thick_pntr (ada_typedef_target_type (type)));
2994 /* The value of the element of array ARR at the ARITY indices given in IND.
2995 ARR may be either a simple array, GNAT array descriptor, or pointer
2999 ada_value_subscript (struct value *arr, int arity, struct value **ind)
3003 struct type *elt_type;
3005 elt = ada_coerce_to_simple_array (arr);
3007 elt_type = ada_check_typedef (value_type (elt));
3008 if (elt_type->code () == TYPE_CODE_ARRAY
3009 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3010 return value_subscript_packed (elt, arity, ind);
3012 for (k = 0; k < arity; k += 1)
3014 struct type *saved_elt_type = elt_type->target_type ();
3016 if (elt_type->code () != TYPE_CODE_ARRAY)
3017 error (_("too many subscripts (%d expected)"), k);
3019 elt = value_subscript (elt, pos_atr (ind[k]));
3021 if (ada_is_access_to_unconstrained_array (saved_elt_type)
3022 && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3024 /* The element is a typedef to an unconstrained array,
3025 except that the value_subscript call stripped the
3026 typedef layer. The typedef layer is GNAT's way to
3027 specify that the element is, at the source level, an
3028 access to the unconstrained array, rather than the
3029 unconstrained array. So, we need to restore that
3030 typedef layer, which we can do by forcing the element's
3031 type back to its original type. Otherwise, the returned
3032 value is going to be printed as the array, rather
3033 than as an access. Another symptom of the same issue
3034 would be that an expression trying to dereference the
3035 element would also be improperly rejected. */
3036 deprecated_set_value_type (elt, saved_elt_type);
3039 elt_type = ada_check_typedef (value_type (elt));
3045 /* Assuming ARR is a pointer to a GDB array, the value of the element
3046 of *ARR at the ARITY indices given in IND.
3047 Does not read the entire array into memory.
3049 Note: Unlike what one would expect, this function is used instead of
3050 ada_value_subscript for basically all non-packed array types. The reason
3051 for this is that a side effect of doing our own pointer arithmetics instead
3052 of relying on value_subscript is that there is no implicit typedef peeling.
3053 This is important for arrays of array accesses, where it allows us to
3054 preserve the fact that the array's element is an array access, where the
3055 access part os encoded in a typedef layer. */
3057 static struct value *
3058 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3061 struct value *array_ind = ada_value_ind (arr);
3063 = check_typedef (value_enclosing_type (array_ind));
3065 if (type->code () == TYPE_CODE_ARRAY
3066 && TYPE_FIELD_BITSIZE (type, 0) > 0)
3067 return value_subscript_packed (array_ind, arity, ind);
3069 for (k = 0; k < arity; k += 1)
3073 if (type->code () != TYPE_CODE_ARRAY)
3074 error (_("too many subscripts (%d expected)"), k);
3075 arr = value_cast (lookup_pointer_type (type->target_type ()),
3077 get_discrete_bounds (type->index_type (), &lwb, &upb);
3078 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3079 type = type->target_type ();
3082 return value_ind (arr);
3085 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3086 actual type of ARRAY_PTR is ignored), returns the Ada slice of
3087 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
3088 this array is LOW, as per Ada rules. */
3089 static struct value *
3090 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3093 struct type *type0 = ada_check_typedef (type);
3094 struct type *base_index_type = type0->index_type ()->target_type ();
3095 struct type *index_type
3096 = create_static_range_type (NULL, base_index_type, low, high);
3097 struct type *slice_type = create_array_type_with_stride
3098 (NULL, type0->target_type (), index_type,
3099 type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3100 TYPE_FIELD_BITSIZE (type0, 0));
3101 int base_low = ada_discrete_type_low_bound (type0->index_type ());
3102 gdb::optional<LONGEST> base_low_pos, low_pos;
3105 low_pos = discrete_position (base_index_type, low);
3106 base_low_pos = discrete_position (base_index_type, base_low);
3108 if (!low_pos.has_value () || !base_low_pos.has_value ())
3110 warning (_("unable to get positions in slice, use bounds instead"));
3112 base_low_pos = base_low;
3115 ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3117 stride = type0->target_type ()->length ();
3119 base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3120 return value_at_lazy (slice_type, base);
3124 static struct value *
3125 ada_value_slice (struct value *array, int low, int high)
3127 struct type *type = ada_check_typedef (value_type (array));
3128 struct type *base_index_type = type->index_type ()->target_type ();
3129 struct type *index_type
3130 = create_static_range_type (NULL, type->index_type (), low, high);
3131 struct type *slice_type = create_array_type_with_stride
3132 (NULL, type->target_type (), index_type,
3133 type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3134 TYPE_FIELD_BITSIZE (type, 0));
3135 gdb::optional<LONGEST> low_pos, high_pos;
3138 low_pos = discrete_position (base_index_type, low);
3139 high_pos = discrete_position (base_index_type, high);
3141 if (!low_pos.has_value () || !high_pos.has_value ())
3143 warning (_("unable to get positions in slice, use bounds instead"));
3148 return value_cast (slice_type,
3149 value_slice (array, low, *high_pos - *low_pos + 1));
3152 /* If type is a record type in the form of a standard GNAT array
3153 descriptor, returns the number of dimensions for type. If arr is a
3154 simple array, returns the number of "array of"s that prefix its
3155 type designation. Otherwise, returns 0. */
3158 ada_array_arity (struct type *type)
3165 type = desc_base_type (type);
3168 if (type->code () == TYPE_CODE_STRUCT)
3169 return desc_arity (desc_bounds_type (type));
3171 while (type->code () == TYPE_CODE_ARRAY)
3174 type = ada_check_typedef (type->target_type ());
3180 /* If TYPE is a record type in the form of a standard GNAT array
3181 descriptor or a simple array type, returns the element type for
3182 TYPE after indexing by NINDICES indices, or by all indices if
3183 NINDICES is -1. Otherwise, returns NULL. */
3186 ada_array_element_type (struct type *type, int nindices)
3188 type = desc_base_type (type);
3190 if (type->code () == TYPE_CODE_STRUCT)
3193 struct type *p_array_type;
3195 p_array_type = desc_data_target_type (type);
3197 k = ada_array_arity (type);
3201 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3202 if (nindices >= 0 && k > nindices)
3204 while (k > 0 && p_array_type != NULL)
3206 p_array_type = ada_check_typedef (p_array_type->target_type ());
3209 return p_array_type;
3211 else if (type->code () == TYPE_CODE_ARRAY)
3213 while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3215 type = type->target_type ();
3216 /* A multi-dimensional array is represented using a sequence
3217 of array types. If one of these types has a name, then
3218 it is not another dimension of the outer array, but
3219 rather the element type of the outermost array. */
3220 if (type->name () != nullptr)
3230 /* See ada-lang.h. */
3233 ada_index_type (struct type *type, int n, const char *name)
3235 struct type *result_type;
3237 type = desc_base_type (type);
3239 if (n < 0 || n > ada_array_arity (type))
3240 error (_("invalid dimension number to '%s"), name);
3242 if (ada_is_simple_array_type (type))
3246 for (i = 1; i < n; i += 1)
3248 type = ada_check_typedef (type);
3249 type = type->target_type ();
3251 result_type = ada_check_typedef (type)->index_type ()->target_type ();
3252 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3253 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3254 perhaps stabsread.c would make more sense. */
3255 if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3260 result_type = desc_index_type (desc_bounds_type (type), n);
3261 if (result_type == NULL)
3262 error (_("attempt to take bound of something that is not an array"));
3268 /* Given that arr is an array type, returns the lower bound of the
3269 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3270 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3271 array-descriptor type. It works for other arrays with bounds supplied
3272 by run-time quantities other than discriminants. */
3275 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3277 struct type *type, *index_type_desc, *index_type;
3280 gdb_assert (which == 0 || which == 1);
3282 if (ada_is_constrained_packed_array_type (arr_type))
3283 arr_type = decode_constrained_packed_array_type (arr_type);
3285 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3286 return (LONGEST) - which;
3288 if (arr_type->code () == TYPE_CODE_PTR)
3289 type = arr_type->target_type ();
3293 if (type->is_fixed_instance ())
3295 /* The array has already been fixed, so we do not need to
3296 check the parallel ___XA type again. That encoding has
3297 already been applied, so ignore it now. */
3298 index_type_desc = NULL;
3302 index_type_desc = ada_find_parallel_type (type, "___XA");
3303 ada_fixup_array_indexes_type (index_type_desc);
3306 if (index_type_desc != NULL)
3307 index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3311 struct type *elt_type = check_typedef (type);
3313 for (i = 1; i < n; i++)
3314 elt_type = check_typedef (elt_type->target_type ());
3316 index_type = elt_type->index_type ();
3320 (LONGEST) (which == 0
3321 ? ada_discrete_type_low_bound (index_type)
3322 : ada_discrete_type_high_bound (index_type));
3325 /* Given that arr is an array value, returns the lower bound of the
3326 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3327 WHICH is 1. This routine will also work for arrays with bounds
3328 supplied by run-time quantities other than discriminants. */
3331 ada_array_bound (struct value *arr, int n, int which)
3333 struct type *arr_type;
3335 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3336 arr = value_ind (arr);
3337 arr_type = value_enclosing_type (arr);
3339 if (ada_is_constrained_packed_array_type (arr_type))
3340 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3341 else if (ada_is_simple_array_type (arr_type))
3342 return ada_array_bound_from_type (arr_type, n, which);
3344 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3347 /* Given that arr is an array value, returns the length of the
3348 nth index. This routine will also work for arrays with bounds
3349 supplied by run-time quantities other than discriminants.
3350 Does not work for arrays indexed by enumeration types with representation
3351 clauses at the moment. */
3354 ada_array_length (struct value *arr, int n)
3356 struct type *arr_type, *index_type;
3359 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3360 arr = value_ind (arr);
3361 arr_type = value_enclosing_type (arr);
3363 if (ada_is_constrained_packed_array_type (arr_type))
3364 return ada_array_length (decode_constrained_packed_array (arr), n);
3366 if (ada_is_simple_array_type (arr_type))
3368 low = ada_array_bound_from_type (arr_type, n, 0);
3369 high = ada_array_bound_from_type (arr_type, n, 1);
3373 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3374 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3377 arr_type = check_typedef (arr_type);
3378 index_type = ada_index_type (arr_type, n, "length");
3379 if (index_type != NULL)
3381 struct type *base_type;
3382 if (index_type->code () == TYPE_CODE_RANGE)
3383 base_type = index_type->target_type ();
3385 base_type = index_type;
3387 low = pos_atr (value_from_longest (base_type, low));
3388 high = pos_atr (value_from_longest (base_type, high));
3390 return high - low + 1;
3393 /* An array whose type is that of ARR_TYPE (an array type), with
3394 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3395 less than LOW, then LOW-1 is used. */
3397 static struct value *
3398 empty_array (struct type *arr_type, int low, int high)
3400 struct type *arr_type0 = ada_check_typedef (arr_type);
3401 struct type *index_type
3402 = create_static_range_type
3403 (NULL, arr_type0->index_type ()->target_type (), low,
3404 high < low ? low - 1 : high);
3405 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3407 return allocate_value (create_array_type (NULL, elt_type, index_type));
3411 /* Name resolution */
3413 /* The "decoded" name for the user-definable Ada operator corresponding
3417 ada_decoded_op_name (enum exp_opcode op)
3421 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3423 if (ada_opname_table[i].op == op)
3424 return ada_opname_table[i].decoded;
3426 error (_("Could not find operator name for opcode"));
3429 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3430 in a listing of choices during disambiguation (see sort_choices, below).
3431 The idea is that overloadings of a subprogram name from the
3432 same package should sort in their source order. We settle for ordering
3433 such symbols by their trailing number (__N or $N). */
3436 encoded_ordered_before (const char *N0, const char *N1)
3440 else if (N0 == NULL)
3446 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3448 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3450 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3451 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3456 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3459 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3461 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3462 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3464 return (strcmp (N0, N1) < 0);
3468 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3472 sort_choices (struct block_symbol syms[], int nsyms)
3476 for (i = 1; i < nsyms; i += 1)
3478 struct block_symbol sym = syms[i];
3481 for (j = i - 1; j >= 0; j -= 1)
3483 if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3484 sym.symbol->linkage_name ()))
3486 syms[j + 1] = syms[j];
3492 /* Whether GDB should display formals and return types for functions in the
3493 overloads selection menu. */
3494 static bool print_signatures = true;
3496 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3497 all but functions, the signature is just the name of the symbol. For
3498 functions, this is the name of the function, the list of types for formals
3499 and the return type (if any). */
3502 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3503 const struct type_print_options *flags)
3505 struct type *type = sym->type ();
3507 gdb_printf (stream, "%s", sym->print_name ());
3508 if (!print_signatures
3510 || type->code () != TYPE_CODE_FUNC)
3513 if (type->num_fields () > 0)
3517 gdb_printf (stream, " (");
3518 for (i = 0; i < type->num_fields (); ++i)
3521 gdb_printf (stream, "; ");
3522 ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3525 gdb_printf (stream, ")");
3527 if (type->target_type () != NULL
3528 && type->target_type ()->code () != TYPE_CODE_VOID)
3530 gdb_printf (stream, " return ");
3531 ada_print_type (type->target_type (), NULL, stream, -1, 0, flags);
3535 /* Read and validate a set of numeric choices from the user in the
3536 range 0 .. N_CHOICES-1. Place the results in increasing
3537 order in CHOICES[0 .. N-1], and return N.
3539 The user types choices as a sequence of numbers on one line
3540 separated by blanks, encoding them as follows:
3542 + A choice of 0 means to cancel the selection, throwing an error.
3543 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3544 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3546 The user is not allowed to choose more than MAX_RESULTS values.
3548 ANNOTATION_SUFFIX, if present, is used to annotate the input
3549 prompts (for use with the -f switch). */
3552 get_selections (int *choices, int n_choices, int max_results,
3553 int is_all_choice, const char *annotation_suffix)
3558 int first_choice = is_all_choice ? 2 : 1;
3560 prompt = getenv ("PS2");
3564 args = command_line_input (prompt, annotation_suffix);
3567 error_no_arg (_("one or more choice numbers"));
3571 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3572 order, as given in args. Choices are validated. */
3578 args = skip_spaces (args);
3579 if (*args == '\0' && n_chosen == 0)
3580 error_no_arg (_("one or more choice numbers"));
3581 else if (*args == '\0')
3584 choice = strtol (args, &args2, 10);
3585 if (args == args2 || choice < 0
3586 || choice > n_choices + first_choice - 1)
3587 error (_("Argument must be choice number"));
3591 error (_("cancelled"));
3593 if (choice < first_choice)
3595 n_chosen = n_choices;
3596 for (j = 0; j < n_choices; j += 1)
3600 choice -= first_choice;
3602 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3606 if (j < 0 || choice != choices[j])
3610 for (k = n_chosen - 1; k > j; k -= 1)
3611 choices[k + 1] = choices[k];
3612 choices[j + 1] = choice;
3617 if (n_chosen > max_results)
3618 error (_("Select no more than %d of the above"), max_results);
3623 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3624 by asking the user (if necessary), returning the number selected,
3625 and setting the first elements of SYMS items. Error if no symbols
3628 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3629 to be re-integrated one of these days. */
3632 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3635 int *chosen = XALLOCAVEC (int , nsyms);
3637 int first_choice = (max_results == 1) ? 1 : 2;
3638 const char *select_mode = multiple_symbols_select_mode ();
3640 if (max_results < 1)
3641 error (_("Request to select 0 symbols!"));
3645 if (select_mode == multiple_symbols_cancel)
3647 canceled because the command is ambiguous\n\
3648 See set/show multiple-symbol."));
3650 /* If select_mode is "all", then return all possible symbols.
3651 Only do that if more than one symbol can be selected, of course.
3652 Otherwise, display the menu as usual. */
3653 if (select_mode == multiple_symbols_all && max_results > 1)
3656 gdb_printf (_("[0] cancel\n"));
3657 if (max_results > 1)
3658 gdb_printf (_("[1] all\n"));
3660 sort_choices (syms, nsyms);
3662 for (i = 0; i < nsyms; i += 1)
3664 if (syms[i].symbol == NULL)
3667 if (syms[i].symbol->aclass () == LOC_BLOCK)
3669 struct symtab_and_line sal =
3670 find_function_start_sal (syms[i].symbol, 1);
3672 gdb_printf ("[%d] ", i + first_choice);
3673 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3674 &type_print_raw_options);
3675 if (sal.symtab == NULL)
3676 gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3677 metadata_style.style ().ptr (), nullptr, sal.line);
3681 styled_string (file_name_style.style (),
3682 symtab_to_filename_for_display (sal.symtab)),
3689 (syms[i].symbol->aclass () == LOC_CONST
3690 && syms[i].symbol->type () != NULL
3691 && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3692 struct symtab *symtab = NULL;
3694 if (syms[i].symbol->is_objfile_owned ())
3695 symtab = syms[i].symbol->symtab ();
3697 if (syms[i].symbol->line () != 0 && symtab != NULL)
3699 gdb_printf ("[%d] ", i + first_choice);
3700 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3701 &type_print_raw_options);
3702 gdb_printf (_(" at %s:%d\n"),
3703 symtab_to_filename_for_display (symtab),
3704 syms[i].symbol->line ());
3706 else if (is_enumeral
3707 && syms[i].symbol->type ()->name () != NULL)
3709 gdb_printf (("[%d] "), i + first_choice);
3710 ada_print_type (syms[i].symbol->type (), NULL,
3711 gdb_stdout, -1, 0, &type_print_raw_options);
3712 gdb_printf (_("'(%s) (enumeral)\n"),
3713 syms[i].symbol->print_name ());
3717 gdb_printf ("[%d] ", i + first_choice);
3718 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3719 &type_print_raw_options);
3722 gdb_printf (is_enumeral
3723 ? _(" in %s (enumeral)\n")
3725 symtab_to_filename_for_display (symtab));
3727 gdb_printf (is_enumeral
3728 ? _(" (enumeral)\n")
3734 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3737 for (i = 0; i < n_chosen; i += 1)
3738 syms[i] = syms[chosen[i]];
3743 /* See ada-lang.h. */
3746 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3747 int nargs, value *argvec[])
3749 if (possible_user_operator_p (op, argvec))
3751 std::vector<struct block_symbol> candidates
3752 = ada_lookup_symbol_list (ada_decoded_op_name (op),
3755 int i = ada_resolve_function (candidates, argvec,
3756 nargs, ada_decoded_op_name (op), NULL,
3759 return candidates[i];
3764 /* See ada-lang.h. */
3767 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3768 struct type *context_type,
3769 bool parse_completion,
3770 int nargs, value *argvec[],
3771 innermost_block_tracker *tracker)
3773 std::vector<struct block_symbol> candidates
3774 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3777 if (candidates.size () == 1)
3781 i = ada_resolve_function
3784 sym->linkage_name (),
3785 context_type, parse_completion);
3787 error (_("Could not find a match for %s"), sym->print_name ());
3790 tracker->update (candidates[i]);
3791 return candidates[i];
3794 /* Resolve a mention of a name where the context type is an
3795 enumeration type. */
3798 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3799 const char *name, struct type *context_type,
3800 bool parse_completion)
3802 gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3803 context_type = ada_check_typedef (context_type);
3805 for (int i = 0; i < syms.size (); ++i)
3807 /* We already know the name matches, so we're just looking for
3808 an element of the correct enum type. */
3809 if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3813 error (_("No name '%s' in enumeration type '%s'"), name,
3814 ada_type_name (context_type));
3817 /* See ada-lang.h. */
3820 ada_resolve_variable (struct symbol *sym, const struct block *block,
3821 struct type *context_type,
3822 bool parse_completion,
3824 innermost_block_tracker *tracker)
3826 std::vector<struct block_symbol> candidates
3827 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3829 if (std::any_of (candidates.begin (),
3831 [] (block_symbol &bsym)
3833 switch (bsym.symbol->aclass ())
3838 case LOC_REGPARM_ADDR:
3847 /* Types tend to get re-introduced locally, so if there
3848 are any local symbols that are not types, first filter
3852 (candidates.begin (),
3854 [] (block_symbol &bsym)
3856 return bsym.symbol->aclass () == LOC_TYPEDEF;
3861 /* Filter out artificial symbols. */
3864 (candidates.begin (),
3866 [] (block_symbol &bsym)
3868 return bsym.symbol->is_artificial ();
3873 if (candidates.empty ())
3874 error (_("No definition found for %s"), sym->print_name ());
3875 else if (candidates.size () == 1)
3877 else if (context_type != nullptr
3878 && context_type->code () == TYPE_CODE_ENUM)
3879 i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3881 else if (deprocedure_p && !is_nonfunction (candidates))
3883 i = ada_resolve_function
3884 (candidates, NULL, 0,
3885 sym->linkage_name (),
3886 context_type, parse_completion);
3888 error (_("Could not find a match for %s"), sym->print_name ());
3892 gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3893 user_select_syms (candidates.data (), candidates.size (), 1);
3897 tracker->update (candidates[i]);
3898 return candidates[i];
3901 /* Return non-zero if formal type FTYPE matches actual type ATYPE. */
3902 /* The term "match" here is rather loose. The match is heuristic and
3906 ada_type_match (struct type *ftype, struct type *atype)
3908 ftype = ada_check_typedef (ftype);
3909 atype = ada_check_typedef (atype);
3911 if (ftype->code () == TYPE_CODE_REF)
3912 ftype = ftype->target_type ();
3913 if (atype->code () == TYPE_CODE_REF)
3914 atype = atype->target_type ();
3916 switch (ftype->code ())
3919 return ftype->code () == atype->code ();
3921 if (atype->code () != TYPE_CODE_PTR)
3923 atype = atype->target_type ();
3924 /* This can only happen if the actual argument is 'null'. */
3925 if (atype->code () == TYPE_CODE_INT && atype->length () == 0)
3927 return ada_type_match (ftype->target_type (), atype);
3929 case TYPE_CODE_ENUM:
3930 case TYPE_CODE_RANGE:
3931 switch (atype->code ())
3934 case TYPE_CODE_ENUM:
3935 case TYPE_CODE_RANGE:
3941 case TYPE_CODE_ARRAY:
3942 return (atype->code () == TYPE_CODE_ARRAY
3943 || ada_is_array_descriptor_type (atype));
3945 case TYPE_CODE_STRUCT:
3946 if (ada_is_array_descriptor_type (ftype))
3947 return (atype->code () == TYPE_CODE_ARRAY
3948 || ada_is_array_descriptor_type (atype));
3950 return (atype->code () == TYPE_CODE_STRUCT
3951 && !ada_is_array_descriptor_type (atype));
3953 case TYPE_CODE_UNION:
3955 return (atype->code () == ftype->code ());
3959 /* Return non-zero if the formals of FUNC "sufficiently match" the
3960 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3961 may also be an enumeral, in which case it is treated as a 0-
3962 argument function. */
3965 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3968 struct type *func_type = func->type ();
3970 if (func->aclass () == LOC_CONST
3971 && func_type->code () == TYPE_CODE_ENUM)
3972 return (n_actuals == 0);
3973 else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3976 if (func_type->num_fields () != n_actuals)
3979 for (i = 0; i < n_actuals; i += 1)
3981 if (actuals[i] == NULL)
3985 struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3986 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3988 if (!ada_type_match (ftype, atype))
3995 /* False iff function type FUNC_TYPE definitely does not produce a value
3996 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3997 FUNC_TYPE is not a valid function type with a non-null return type
3998 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
4001 return_match (struct type *func_type, struct type *context_type)
4003 struct type *return_type;
4005 if (func_type == NULL)
4008 if (func_type->code () == TYPE_CODE_FUNC)
4009 return_type = get_base_type (func_type->target_type ());
4011 return_type = get_base_type (func_type);
4012 if (return_type == NULL)
4015 context_type = get_base_type (context_type);
4017 if (return_type->code () == TYPE_CODE_ENUM)
4018 return context_type == NULL || return_type == context_type;
4019 else if (context_type == NULL)
4020 return return_type->code () != TYPE_CODE_VOID;
4022 return return_type->code () == context_type->code ();
4026 /* Returns the index in SYMS that contains the symbol for the
4027 function (if any) that matches the types of the NARGS arguments in
4028 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
4029 that returns that type, then eliminate matches that don't. If
4030 CONTEXT_TYPE is void and there is at least one match that does not
4031 return void, eliminate all matches that do.
4033 Asks the user if there is more than one match remaining. Returns -1
4034 if there is no such symbol or none is selected. NAME is used
4035 solely for messages. May re-arrange and modify SYMS in
4036 the process; the index returned is for the modified vector. */
4039 ada_resolve_function (std::vector<struct block_symbol> &syms,
4040 struct value **args, int nargs,
4041 const char *name, struct type *context_type,
4042 bool parse_completion)
4046 int m; /* Number of hits */
4049 /* In the first pass of the loop, we only accept functions matching
4050 context_type. If none are found, we add a second pass of the loop
4051 where every function is accepted. */
4052 for (fallback = 0; m == 0 && fallback < 2; fallback++)
4054 for (k = 0; k < syms.size (); k += 1)
4056 struct type *type = ada_check_typedef (syms[k].symbol->type ());
4058 if (ada_args_match (syms[k].symbol, args, nargs)
4059 && (fallback || return_match (type, context_type)))
4067 /* If we got multiple matches, ask the user which one to use. Don't do this
4068 interactive thing during completion, though, as the purpose of the
4069 completion is providing a list of all possible matches. Prompting the
4070 user to filter it down would be completely unexpected in this case. */
4073 else if (m > 1 && !parse_completion)
4075 gdb_printf (_("Multiple matches for %s\n"), name);
4076 user_select_syms (syms.data (), m, 1);
4082 /* Type-class predicates */
4084 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4088 numeric_type_p (struct type *type)
4094 switch (type->code ())
4098 case TYPE_CODE_FIXED_POINT:
4100 case TYPE_CODE_RANGE:
4101 return (type == type->target_type ()
4102 || numeric_type_p (type->target_type ()));
4109 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4112 integer_type_p (struct type *type)
4118 switch (type->code ())
4122 case TYPE_CODE_RANGE:
4123 return (type == type->target_type ()
4124 || integer_type_p (type->target_type ()));
4131 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4134 scalar_type_p (struct type *type)
4140 switch (type->code ())
4143 case TYPE_CODE_RANGE:
4144 case TYPE_CODE_ENUM:
4146 case TYPE_CODE_FIXED_POINT:
4154 /* True iff TYPE is discrete, as defined in the Ada Reference Manual.
4155 This essentially means one of (INT, RANGE, ENUM) -- but note that
4156 "enum" includes character and boolean as well. */
4159 discrete_type_p (struct type *type)
4165 switch (type->code ())
4168 case TYPE_CODE_RANGE:
4169 case TYPE_CODE_ENUM:
4170 case TYPE_CODE_BOOL:
4171 case TYPE_CODE_CHAR:
4179 /* Returns non-zero if OP with operands in the vector ARGS could be
4180 a user-defined function. Errs on the side of pre-defined operators
4181 (i.e., result 0). */
4184 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4186 struct type *type0 =
4187 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4188 struct type *type1 =
4189 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4203 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4207 case BINOP_BITWISE_AND:
4208 case BINOP_BITWISE_IOR:
4209 case BINOP_BITWISE_XOR:
4210 return (!(integer_type_p (type0) && integer_type_p (type1)));
4213 case BINOP_NOTEQUAL:
4218 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4221 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4224 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4228 case UNOP_LOGICAL_NOT:
4230 return (!numeric_type_p (type0));
4239 1. In the following, we assume that a renaming type's name may
4240 have an ___XD suffix. It would be nice if this went away at some
4242 2. We handle both the (old) purely type-based representation of
4243 renamings and the (new) variable-based encoding. At some point,
4244 it is devoutly to be hoped that the former goes away
4245 (FIXME: hilfinger-2007-07-09).
4246 3. Subprogram renamings are not implemented, although the XRS
4247 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4249 /* If SYM encodes a renaming,
4251 <renaming> renames <renamed entity>,
4253 sets *LEN to the length of the renamed entity's name,
4254 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4255 the string describing the subcomponent selected from the renamed
4256 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4257 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4258 are undefined). Otherwise, returns a value indicating the category
4259 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4260 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4261 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4262 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4263 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4264 may be NULL, in which case they are not assigned.
4266 [Currently, however, GCC does not generate subprogram renamings.] */
4268 enum ada_renaming_category
4269 ada_parse_renaming (struct symbol *sym,
4270 const char **renamed_entity, int *len,
4271 const char **renaming_expr)
4273 enum ada_renaming_category kind;
4278 return ADA_NOT_RENAMING;
4279 switch (sym->aclass ())
4282 return ADA_NOT_RENAMING;
4286 case LOC_OPTIMIZED_OUT:
4287 info = strstr (sym->linkage_name (), "___XR");
4289 return ADA_NOT_RENAMING;
4293 kind = ADA_OBJECT_RENAMING;
4297 kind = ADA_EXCEPTION_RENAMING;
4301 kind = ADA_PACKAGE_RENAMING;
4305 kind = ADA_SUBPROGRAM_RENAMING;
4309 return ADA_NOT_RENAMING;
4313 if (renamed_entity != NULL)
4314 *renamed_entity = info;
4315 suffix = strstr (info, "___XE");
4316 if (suffix == NULL || suffix == info)
4317 return ADA_NOT_RENAMING;
4319 *len = strlen (info) - strlen (suffix);
4321 if (renaming_expr != NULL)
4322 *renaming_expr = suffix;
4326 /* Compute the value of the given RENAMING_SYM, which is expected to
4327 be a symbol encoding a renaming expression. BLOCK is the block
4328 used to evaluate the renaming. */
4330 static struct value *
4331 ada_read_renaming_var_value (struct symbol *renaming_sym,
4332 const struct block *block)
4334 const char *sym_name;
4336 sym_name = renaming_sym->linkage_name ();
4337 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4338 return evaluate_expression (expr.get ());
4342 /* Evaluation: Function Calls */
4344 /* Return an lvalue containing the value VAL. This is the identity on
4345 lvalues, and otherwise has the side-effect of allocating memory
4346 in the inferior where a copy of the value contents is copied. */
4348 static struct value *
4349 ensure_lval (struct value *val)
4351 if (VALUE_LVAL (val) == not_lval
4352 || VALUE_LVAL (val) == lval_internalvar)
4354 int len = ada_check_typedef (value_type (val))->length ();
4355 const CORE_ADDR addr =
4356 value_as_long (value_allocate_space_in_inferior (len));
4358 VALUE_LVAL (val) = lval_memory;
4359 set_value_address (val, addr);
4360 write_memory (addr, value_contents (val).data (), len);
4366 /* Given ARG, a value of type (pointer or reference to a)*
4367 structure/union, extract the component named NAME from the ultimate
4368 target structure/union and return it as a value with its
4371 The routine searches for NAME among all members of the structure itself
4372 and (recursively) among all members of any wrapper members
4375 If NO_ERR, then simply return NULL in case of error, rather than
4378 static struct value *
4379 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4381 struct type *t, *t1;
4386 t1 = t = ada_check_typedef (value_type (arg));
4387 if (t->code () == TYPE_CODE_REF)
4389 t1 = t->target_type ();
4392 t1 = ada_check_typedef (t1);
4393 if (t1->code () == TYPE_CODE_PTR)
4395 arg = coerce_ref (arg);
4400 while (t->code () == TYPE_CODE_PTR)
4402 t1 = t->target_type ();
4405 t1 = ada_check_typedef (t1);
4406 if (t1->code () == TYPE_CODE_PTR)
4408 arg = value_ind (arg);
4415 if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4419 v = ada_search_struct_field (name, arg, 0, t);
4422 int bit_offset, bit_size, byte_offset;
4423 struct type *field_type;
4426 if (t->code () == TYPE_CODE_PTR)
4427 address = value_address (ada_value_ind (arg));
4429 address = value_address (ada_coerce_ref (arg));
4431 /* Check to see if this is a tagged type. We also need to handle
4432 the case where the type is a reference to a tagged type, but
4433 we have to be careful to exclude pointers to tagged types.
4434 The latter should be shown as usual (as a pointer), whereas
4435 a reference should mostly be transparent to the user. */
4437 if (ada_is_tagged_type (t1, 0)
4438 || (t1->code () == TYPE_CODE_REF
4439 && ada_is_tagged_type (t1->target_type (), 0)))
4441 /* We first try to find the searched field in the current type.
4442 If not found then let's look in the fixed type. */
4444 if (!find_struct_field (name, t1, 0,
4445 nullptr, nullptr, nullptr,
4454 /* Convert to fixed type in all cases, so that we have proper
4455 offsets to each field in unconstrained record types. */
4456 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4457 address, NULL, check_tag);
4459 /* Resolve the dynamic type as well. */
4460 arg = value_from_contents_and_address (t1, nullptr, address);
4461 t1 = value_type (arg);
4463 if (find_struct_field (name, t1, 0,
4464 &field_type, &byte_offset, &bit_offset,
4469 if (t->code () == TYPE_CODE_REF)
4470 arg = ada_coerce_ref (arg);
4472 arg = ada_value_ind (arg);
4473 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4474 bit_offset, bit_size,
4478 v = value_at_lazy (field_type, address + byte_offset);
4482 if (v != NULL || no_err)
4485 error (_("There is no member named %s."), name);
4491 error (_("Attempt to extract a component of "
4492 "a value that is not a record."));
4495 /* Return the value ACTUAL, converted to be an appropriate value for a
4496 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4497 allocating any necessary descriptors (fat pointers), or copies of
4498 values not residing in memory, updating it as needed. */
4501 ada_convert_actual (struct value *actual, struct type *formal_type0)
4503 struct type *actual_type = ada_check_typedef (value_type (actual));
4504 struct type *formal_type = ada_check_typedef (formal_type0);
4505 struct type *formal_target =
4506 formal_type->code () == TYPE_CODE_PTR
4507 ? ada_check_typedef (formal_type->target_type ()) : formal_type;
4508 struct type *actual_target =
4509 actual_type->code () == TYPE_CODE_PTR
4510 ? ada_check_typedef (actual_type->target_type ()) : actual_type;
4512 if (ada_is_array_descriptor_type (formal_target)
4513 && actual_target->code () == TYPE_CODE_ARRAY)
4514 return make_array_descriptor (formal_type, actual);
4515 else if (formal_type->code () == TYPE_CODE_PTR
4516 || formal_type->code () == TYPE_CODE_REF)
4518 struct value *result;
4520 if (formal_target->code () == TYPE_CODE_ARRAY
4521 && ada_is_array_descriptor_type (actual_target))
4522 result = desc_data (actual);
4523 else if (formal_type->code () != TYPE_CODE_PTR)
4525 if (VALUE_LVAL (actual) != lval_memory)
4529 actual_type = ada_check_typedef (value_type (actual));
4530 val = allocate_value (actual_type);
4531 copy (value_contents (actual), value_contents_raw (val));
4532 actual = ensure_lval (val);
4534 result = value_addr (actual);
4538 return value_cast_pointers (formal_type, result, 0);
4540 else if (actual_type->code () == TYPE_CODE_PTR)
4541 return ada_value_ind (actual);
4542 else if (ada_is_aligner_type (formal_type))
4544 /* We need to turn this parameter into an aligner type
4546 struct value *aligner = allocate_value (formal_type);
4547 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4549 value_assign_to_component (aligner, component, actual);
4556 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4557 type TYPE. This is usually an inefficient no-op except on some targets
4558 (such as AVR) where the representation of a pointer and an address
4562 value_pointer (struct value *value, struct type *type)
4564 unsigned len = type->length ();
4565 gdb_byte *buf = (gdb_byte *) alloca (len);
4568 addr = value_address (value);
4569 gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4570 addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4575 /* Push a descriptor of type TYPE for array value ARR on the stack at
4576 *SP, updating *SP to reflect the new descriptor. Return either
4577 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4578 to-descriptor type rather than a descriptor type), a struct value *
4579 representing a pointer to this descriptor. */
4581 static struct value *
4582 make_array_descriptor (struct type *type, struct value *arr)
4584 struct type *bounds_type = desc_bounds_type (type);
4585 struct type *desc_type = desc_base_type (type);
4586 struct value *descriptor = allocate_value (desc_type);
4587 struct value *bounds = allocate_value (bounds_type);
4590 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4593 modify_field (value_type (bounds),
4594 value_contents_writeable (bounds).data (),
4595 ada_array_bound (arr, i, 0),
4596 desc_bound_bitpos (bounds_type, i, 0),
4597 desc_bound_bitsize (bounds_type, i, 0));
4598 modify_field (value_type (bounds),
4599 value_contents_writeable (bounds).data (),
4600 ada_array_bound (arr, i, 1),
4601 desc_bound_bitpos (bounds_type, i, 1),
4602 desc_bound_bitsize (bounds_type, i, 1));
4605 bounds = ensure_lval (bounds);
4607 modify_field (value_type (descriptor),
4608 value_contents_writeable (descriptor).data (),
4609 value_pointer (ensure_lval (arr),
4610 desc_type->field (0).type ()),
4611 fat_pntr_data_bitpos (desc_type),
4612 fat_pntr_data_bitsize (desc_type));
4614 modify_field (value_type (descriptor),
4615 value_contents_writeable (descriptor).data (),
4616 value_pointer (bounds,
4617 desc_type->field (1).type ()),
4618 fat_pntr_bounds_bitpos (desc_type),
4619 fat_pntr_bounds_bitsize (desc_type));
4621 descriptor = ensure_lval (descriptor);
4623 if (type->code () == TYPE_CODE_PTR)
4624 return value_addr (descriptor);
4629 /* Symbol Cache Module */
4631 /* Performance measurements made as of 2010-01-15 indicate that
4632 this cache does bring some noticeable improvements. Depending
4633 on the type of entity being printed, the cache can make it as much
4634 as an order of magnitude faster than without it.
4636 The descriptive type DWARF extension has significantly reduced
4637 the need for this cache, at least when DWARF is being used. However,
4638 even in this case, some expensive name-based symbol searches are still
4639 sometimes necessary - to find an XVZ variable, mostly. */
4641 /* Return the symbol cache associated to the given program space PSPACE.
4642 If not allocated for this PSPACE yet, allocate and initialize one. */
4644 static struct ada_symbol_cache *
4645 ada_get_symbol_cache (struct program_space *pspace)
4647 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4649 if (pspace_data->sym_cache == nullptr)
4650 pspace_data->sym_cache.reset (new ada_symbol_cache);
4652 return pspace_data->sym_cache.get ();
4655 /* Clear all entries from the symbol cache. */
4658 ada_clear_symbol_cache ()
4660 struct ada_pspace_data *pspace_data
4661 = get_ada_pspace_data (current_program_space);
4663 if (pspace_data->sym_cache != nullptr)
4664 pspace_data->sym_cache.reset ();
4667 /* Search our cache for an entry matching NAME and DOMAIN.
4668 Return it if found, or NULL otherwise. */
4670 static struct cache_entry **
4671 find_entry (const char *name, domain_enum domain)
4673 struct ada_symbol_cache *sym_cache
4674 = ada_get_symbol_cache (current_program_space);
4675 int h = msymbol_hash (name) % HASH_SIZE;
4676 struct cache_entry **e;
4678 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4680 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4686 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4687 Return 1 if found, 0 otherwise.
4689 If an entry was found and SYM is not NULL, set *SYM to the entry's
4690 SYM. Same principle for BLOCK if not NULL. */
4693 lookup_cached_symbol (const char *name, domain_enum domain,
4694 struct symbol **sym, const struct block **block)
4696 struct cache_entry **e = find_entry (name, domain);
4703 *block = (*e)->block;
4707 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4708 in domain DOMAIN, save this result in our symbol cache. */
4711 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4712 const struct block *block)
4714 struct ada_symbol_cache *sym_cache
4715 = ada_get_symbol_cache (current_program_space);
4717 struct cache_entry *e;
4719 /* Symbols for builtin types don't have a block.
4720 For now don't cache such symbols. */
4721 if (sym != NULL && !sym->is_objfile_owned ())
4724 /* If the symbol is a local symbol, then do not cache it, as a search
4725 for that symbol depends on the context. To determine whether
4726 the symbol is local or not, we check the block where we found it
4727 against the global and static blocks of its associated symtab. */
4730 const blockvector &bv = *sym->symtab ()->compunit ()->blockvector ();
4732 if (bv.global_block () != block && bv.static_block () != block)
4736 h = msymbol_hash (name) % HASH_SIZE;
4737 e = XOBNEW (&sym_cache->cache_space, cache_entry);
4738 e->next = sym_cache->root[h];
4739 sym_cache->root[h] = e;
4740 e->name = obstack_strdup (&sym_cache->cache_space, name);
4748 /* Return the symbol name match type that should be used used when
4749 searching for all symbols matching LOOKUP_NAME.
4751 LOOKUP_NAME is expected to be a symbol name after transformation
4754 static symbol_name_match_type
4755 name_match_type_from_name (const char *lookup_name)
4757 return (strstr (lookup_name, "__") == NULL
4758 ? symbol_name_match_type::WILD
4759 : symbol_name_match_type::FULL);
4762 /* Return the result of a standard (literal, C-like) lookup of NAME in
4763 given DOMAIN, visible from lexical block BLOCK. */
4765 static struct symbol *
4766 standard_lookup (const char *name, const struct block *block,
4769 /* Initialize it just to avoid a GCC false warning. */
4770 struct block_symbol sym = {};
4772 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4774 ada_lookup_encoded_symbol (name, block, domain, &sym);
4775 cache_symbol (name, domain, sym.symbol, sym.block);
4780 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4781 in the symbol fields of SYMS. We treat enumerals as functions,
4782 since they contend in overloading in the same way. */
4784 is_nonfunction (const std::vector<struct block_symbol> &syms)
4786 for (const block_symbol &sym : syms)
4787 if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4788 && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4789 || sym.symbol->aclass () != LOC_CONST))
4795 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4796 struct types. Otherwise, they may not. */
4799 equiv_types (struct type *type0, struct type *type1)
4803 if (type0 == NULL || type1 == NULL
4804 || type0->code () != type1->code ())
4806 if ((type0->code () == TYPE_CODE_STRUCT
4807 || type0->code () == TYPE_CODE_ENUM)
4808 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4809 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4815 /* True iff SYM0 represents the same entity as SYM1, or one that is
4816 no more defined than that of SYM1. */
4819 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4823 if (sym0->domain () != sym1->domain ()
4824 || sym0->aclass () != sym1->aclass ())
4827 switch (sym0->aclass ())
4833 struct type *type0 = sym0->type ();
4834 struct type *type1 = sym1->type ();
4835 const char *name0 = sym0->linkage_name ();
4836 const char *name1 = sym1->linkage_name ();
4837 int len0 = strlen (name0);
4840 type0->code () == type1->code ()
4841 && (equiv_types (type0, type1)
4842 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4843 && startswith (name1 + len0, "___XV")));
4846 return sym0->value_longest () == sym1->value_longest ()
4847 && equiv_types (sym0->type (), sym1->type ());
4851 const char *name0 = sym0->linkage_name ();
4852 const char *name1 = sym1->linkage_name ();
4853 return (strcmp (name0, name1) == 0
4854 && sym0->value_address () == sym1->value_address ());
4862 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4863 records in RESULT. Do nothing if SYM is a duplicate. */
4866 add_defn_to_vec (std::vector<struct block_symbol> &result,
4868 const struct block *block)
4870 /* Do not try to complete stub types, as the debugger is probably
4871 already scanning all symbols matching a certain name at the
4872 time when this function is called. Trying to replace the stub
4873 type by its associated full type will cause us to restart a scan
4874 which may lead to an infinite recursion. Instead, the client
4875 collecting the matching symbols will end up collecting several
4876 matches, with at least one of them complete. It can then filter
4877 out the stub ones if needed. */
4879 for (int i = result.size () - 1; i >= 0; i -= 1)
4881 if (lesseq_defined_than (sym, result[i].symbol))
4883 else if (lesseq_defined_than (result[i].symbol, sym))
4885 result[i].symbol = sym;
4886 result[i].block = block;
4891 struct block_symbol info;
4894 result.push_back (info);
4897 /* Return a bound minimal symbol matching NAME according to Ada
4898 decoding rules. Returns an invalid symbol if there is no such
4899 minimal symbol. Names prefixed with "standard__" are handled
4900 specially: "standard__" is first stripped off, and only static and
4901 global symbols are searched. */
4903 struct bound_minimal_symbol
4904 ada_lookup_simple_minsym (const char *name)
4906 struct bound_minimal_symbol result;
4908 symbol_name_match_type match_type = name_match_type_from_name (name);
4909 lookup_name_info lookup_name (name, match_type);
4911 symbol_name_matcher_ftype *match_name
4912 = ada_get_symbol_name_matcher (lookup_name);
4914 for (objfile *objfile : current_program_space->objfiles ())
4916 for (minimal_symbol *msymbol : objfile->msymbols ())
4918 if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4919 && msymbol->type () != mst_solib_trampoline)
4921 result.minsym = msymbol;
4922 result.objfile = objfile;
4931 /* True if TYPE is definitely an artificial type supplied to a symbol
4932 for which no debugging information was given in the symbol file. */
4935 is_nondebugging_type (struct type *type)
4937 const char *name = ada_type_name (type);
4939 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4942 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4943 that are deemed "identical" for practical purposes.
4945 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4946 types and that their number of enumerals is identical (in other
4947 words, type1->num_fields () == type2->num_fields ()). */
4950 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4954 /* The heuristic we use here is fairly conservative. We consider
4955 that 2 enumerate types are identical if they have the same
4956 number of enumerals and that all enumerals have the same
4957 underlying value and name. */
4959 /* All enums in the type should have an identical underlying value. */
4960 for (i = 0; i < type1->num_fields (); i++)
4961 if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4964 /* All enumerals should also have the same name (modulo any numerical
4966 for (i = 0; i < type1->num_fields (); i++)
4968 const char *name_1 = type1->field (i).name ();
4969 const char *name_2 = type2->field (i).name ();
4970 int len_1 = strlen (name_1);
4971 int len_2 = strlen (name_2);
4973 ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4974 ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4976 || strncmp (type1->field (i).name (),
4977 type2->field (i).name (),
4985 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4986 that are deemed "identical" for practical purposes. Sometimes,
4987 enumerals are not strictly identical, but their types are so similar
4988 that they can be considered identical.
4990 For instance, consider the following code:
4992 type Color is (Black, Red, Green, Blue, White);
4993 type RGB_Color is new Color range Red .. Blue;
4995 Type RGB_Color is a subrange of an implicit type which is a copy
4996 of type Color. If we call that implicit type RGB_ColorB ("B" is
4997 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4998 As a result, when an expression references any of the enumeral
4999 by name (Eg. "print green"), the expression is technically
5000 ambiguous and the user should be asked to disambiguate. But
5001 doing so would only hinder the user, since it wouldn't matter
5002 what choice he makes, the outcome would always be the same.
5003 So, for practical purposes, we consider them as the same. */
5006 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5010 /* Before performing a thorough comparison check of each type,
5011 we perform a series of inexpensive checks. We expect that these
5012 checks will quickly fail in the vast majority of cases, and thus
5013 help prevent the unnecessary use of a more expensive comparison.
5014 Said comparison also expects us to make some of these checks
5015 (see ada_identical_enum_types_p). */
5017 /* Quick check: All symbols should have an enum type. */
5018 for (i = 0; i < syms.size (); i++)
5019 if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5022 /* Quick check: They should all have the same value. */
5023 for (i = 1; i < syms.size (); i++)
5024 if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5027 /* Quick check: They should all have the same number of enumerals. */
5028 for (i = 1; i < syms.size (); i++)
5029 if (syms[i].symbol->type ()->num_fields ()
5030 != syms[0].symbol->type ()->num_fields ())
5033 /* All the sanity checks passed, so we might have a set of
5034 identical enumeration types. Perform a more complete
5035 comparison of the type of each symbol. */
5036 for (i = 1; i < syms.size (); i++)
5037 if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5038 syms[0].symbol->type ()))
5044 /* Remove any non-debugging symbols in SYMS that definitely
5045 duplicate other symbols in the list (The only case I know of where
5046 this happens is when object files containing stabs-in-ecoff are
5047 linked with files containing ordinary ecoff debugging symbols (or no
5048 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
5051 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5055 /* We should never be called with less than 2 symbols, as there
5056 cannot be any extra symbol in that case. But it's easy to
5057 handle, since we have nothing to do in that case. */
5058 if (syms->size () < 2)
5062 while (i < syms->size ())
5066 /* If two symbols have the same name and one of them is a stub type,
5067 the get rid of the stub. */
5069 if ((*syms)[i].symbol->type ()->is_stub ()
5070 && (*syms)[i].symbol->linkage_name () != NULL)
5072 for (j = 0; j < syms->size (); j++)
5075 && !(*syms)[j].symbol->type ()->is_stub ()
5076 && (*syms)[j].symbol->linkage_name () != NULL
5077 && strcmp ((*syms)[i].symbol->linkage_name (),
5078 (*syms)[j].symbol->linkage_name ()) == 0)
5083 /* Two symbols with the same name, same class and same address
5084 should be identical. */
5086 else if ((*syms)[i].symbol->linkage_name () != NULL
5087 && (*syms)[i].symbol->aclass () == LOC_STATIC
5088 && is_nondebugging_type ((*syms)[i].symbol->type ()))
5090 for (j = 0; j < syms->size (); j += 1)
5093 && (*syms)[j].symbol->linkage_name () != NULL
5094 && strcmp ((*syms)[i].symbol->linkage_name (),
5095 (*syms)[j].symbol->linkage_name ()) == 0
5096 && ((*syms)[i].symbol->aclass ()
5097 == (*syms)[j].symbol->aclass ())
5098 && (*syms)[i].symbol->value_address ()
5099 == (*syms)[j].symbol->value_address ())
5105 syms->erase (syms->begin () + i);
5110 /* If all the remaining symbols are identical enumerals, then
5111 just keep the first one and discard the rest.
5113 Unlike what we did previously, we do not discard any entry
5114 unless they are ALL identical. This is because the symbol
5115 comparison is not a strict comparison, but rather a practical
5116 comparison. If all symbols are considered identical, then
5117 we can just go ahead and use the first one and discard the rest.
5118 But if we cannot reduce the list to a single element, we have
5119 to ask the user to disambiguate anyways. And if we have to
5120 present a multiple-choice menu, it's less confusing if the list
5121 isn't missing some choices that were identical and yet distinct. */
5122 if (symbols_are_identical_enums (*syms))
5126 /* Given a type that corresponds to a renaming entity, use the type name
5127 to extract the scope (package name or function name, fully qualified,
5128 and following the GNAT encoding convention) where this renaming has been
5132 xget_renaming_scope (struct type *renaming_type)
5134 /* The renaming types adhere to the following convention:
5135 <scope>__<rename>___<XR extension>.
5136 So, to extract the scope, we search for the "___XR" extension,
5137 and then backtrack until we find the first "__". */
5139 const char *name = renaming_type->name ();
5140 const char *suffix = strstr (name, "___XR");
5143 /* Now, backtrack a bit until we find the first "__". Start looking
5144 at suffix - 3, as the <rename> part is at least one character long. */
5146 for (last = suffix - 3; last > name; last--)
5147 if (last[0] == '_' && last[1] == '_')
5150 /* Make a copy of scope and return it. */
5151 return std::string (name, last);
5154 /* Return nonzero if NAME corresponds to a package name. */
5157 is_package_name (const char *name)
5159 /* Here, We take advantage of the fact that no symbols are generated
5160 for packages, while symbols are generated for each function.
5161 So the condition for NAME represent a package becomes equivalent
5162 to NAME not existing in our list of symbols. There is only one
5163 small complication with library-level functions (see below). */
5165 /* If it is a function that has not been defined at library level,
5166 then we should be able to look it up in the symbols. */
5167 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5170 /* Library-level function names start with "_ada_". See if function
5171 "_ada_" followed by NAME can be found. */
5173 /* Do a quick check that NAME does not contain "__", since library-level
5174 functions names cannot contain "__" in them. */
5175 if (strstr (name, "__") != NULL)
5178 std::string fun_name = string_printf ("_ada_%s", name);
5180 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5183 /* Return nonzero if SYM corresponds to a renaming entity that is
5184 not visible from FUNCTION_NAME. */
5187 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5189 if (sym->aclass () != LOC_TYPEDEF)
5192 std::string scope = xget_renaming_scope (sym->type ());
5194 /* If the rename has been defined in a package, then it is visible. */
5195 if (is_package_name (scope.c_str ()))
5198 /* Check that the rename is in the current function scope by checking
5199 that its name starts with SCOPE. */
5201 /* If the function name starts with "_ada_", it means that it is
5202 a library-level function. Strip this prefix before doing the
5203 comparison, as the encoding for the renaming does not contain
5205 if (startswith (function_name, "_ada_"))
5208 return !startswith (function_name, scope.c_str ());
5211 /* Remove entries from SYMS that corresponds to a renaming entity that
5212 is not visible from the function associated with CURRENT_BLOCK or
5213 that is superfluous due to the presence of more specific renaming
5214 information. Places surviving symbols in the initial entries of
5218 First, in cases where an object renaming is implemented as a
5219 reference variable, GNAT may produce both the actual reference
5220 variable and the renaming encoding. In this case, we discard the
5223 Second, GNAT emits a type following a specified encoding for each renaming
5224 entity. Unfortunately, STABS currently does not support the definition
5225 of types that are local to a given lexical block, so all renamings types
5226 are emitted at library level. As a consequence, if an application
5227 contains two renaming entities using the same name, and a user tries to
5228 print the value of one of these entities, the result of the ada symbol
5229 lookup will also contain the wrong renaming type.
5231 This function partially covers for this limitation by attempting to
5232 remove from the SYMS list renaming symbols that should be visible
5233 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5234 method with the current information available. The implementation
5235 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5237 - When the user tries to print a rename in a function while there
5238 is another rename entity defined in a package: Normally, the
5239 rename in the function has precedence over the rename in the
5240 package, so the latter should be removed from the list. This is
5241 currently not the case.
5243 - This function will incorrectly remove valid renames if
5244 the CURRENT_BLOCK corresponds to a function which symbol name
5245 has been changed by an "Export" pragma. As a consequence,
5246 the user will be unable to print such rename entities. */
5249 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5250 const struct block *current_block)
5252 struct symbol *current_function;
5253 const char *current_function_name;
5255 int is_new_style_renaming;
5257 /* If there is both a renaming foo___XR... encoded as a variable and
5258 a simple variable foo in the same block, discard the latter.
5259 First, zero out such symbols, then compress. */
5260 is_new_style_renaming = 0;
5261 for (i = 0; i < syms->size (); i += 1)
5263 struct symbol *sym = (*syms)[i].symbol;
5264 const struct block *block = (*syms)[i].block;
5268 if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5270 name = sym->linkage_name ();
5271 suffix = strstr (name, "___XR");
5275 int name_len = suffix - name;
5278 is_new_style_renaming = 1;
5279 for (j = 0; j < syms->size (); j += 1)
5280 if (i != j && (*syms)[j].symbol != NULL
5281 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5283 && block == (*syms)[j].block)
5284 (*syms)[j].symbol = NULL;
5287 if (is_new_style_renaming)
5291 for (j = k = 0; j < syms->size (); j += 1)
5292 if ((*syms)[j].symbol != NULL)
5294 (*syms)[k] = (*syms)[j];
5301 /* Extract the function name associated to CURRENT_BLOCK.
5302 Abort if unable to do so. */
5304 if (current_block == NULL)
5307 current_function = block_linkage_function (current_block);
5308 if (current_function == NULL)
5311 current_function_name = current_function->linkage_name ();
5312 if (current_function_name == NULL)
5315 /* Check each of the symbols, and remove it from the list if it is
5316 a type corresponding to a renaming that is out of the scope of
5317 the current block. */
5320 while (i < syms->size ())
5322 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5323 == ADA_OBJECT_RENAMING
5324 && old_renaming_is_invisible ((*syms)[i].symbol,
5325 current_function_name))
5326 syms->erase (syms->begin () + i);
5332 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5333 whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5335 Note: This function assumes that RESULT is empty. */
5338 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5339 const lookup_name_info &lookup_name,
5340 const struct block *block, domain_enum domain)
5342 while (block != NULL)
5344 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5346 /* If we found a non-function match, assume that's the one. We
5347 only check this when finding a function boundary, so that we
5348 can accumulate all results from intervening blocks first. */
5349 if (block->function () != nullptr && is_nonfunction (result))
5352 block = block->superblock ();
5356 /* An object of this type is used as the callback argument when
5357 calling the map_matching_symbols method. */
5361 explicit match_data (std::vector<struct block_symbol> *rp)
5365 DISABLE_COPY_AND_ASSIGN (match_data);
5367 bool operator() (struct block_symbol *bsym);
5369 struct objfile *objfile = nullptr;
5370 std::vector<struct block_symbol> *resultp;
5371 struct symbol *arg_sym = nullptr;
5372 bool found_sym = false;
5375 /* A callback for add_nonlocal_symbols that adds symbol, found in
5376 BSYM, to a list of symbols. */
5379 match_data::operator() (struct block_symbol *bsym)
5381 const struct block *block = bsym->block;
5382 struct symbol *sym = bsym->symbol;
5386 if (!found_sym && arg_sym != NULL)
5387 add_defn_to_vec (*resultp,
5388 fixup_symbol_section (arg_sym, objfile),
5395 if (sym->aclass () == LOC_UNRESOLVED)
5397 else if (sym->is_argument ())
5402 add_defn_to_vec (*resultp,
5403 fixup_symbol_section (sym, objfile),
5410 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5411 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5412 symbols to RESULT. Return whether we found such symbols. */
5415 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5416 const struct block *block,
5417 const lookup_name_info &lookup_name,
5420 struct using_direct *renaming;
5421 int defns_mark = result.size ();
5423 symbol_name_matcher_ftype *name_match
5424 = ada_get_symbol_name_matcher (lookup_name);
5426 for (renaming = block_using (block);
5428 renaming = renaming->next)
5432 /* Avoid infinite recursions: skip this renaming if we are actually
5433 already traversing it.
5435 Currently, symbol lookup in Ada don't use the namespace machinery from
5436 C++/Fortran support: skip namespace imports that use them. */
5437 if (renaming->searched
5438 || (renaming->import_src != NULL
5439 && renaming->import_src[0] != '\0')
5440 || (renaming->import_dest != NULL
5441 && renaming->import_dest[0] != '\0'))
5443 renaming->searched = 1;
5445 /* TODO: here, we perform another name-based symbol lookup, which can
5446 pull its own multiple overloads. In theory, we should be able to do
5447 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5448 not a simple name. But in order to do this, we would need to enhance
5449 the DWARF reader to associate a symbol to this renaming, instead of a
5450 name. So, for now, we do something simpler: re-use the C++/Fortran
5451 namespace machinery. */
5452 r_name = (renaming->alias != NULL
5454 : renaming->declaration);
5455 if (name_match (r_name, lookup_name, NULL))
5457 lookup_name_info decl_lookup_name (renaming->declaration,
5458 lookup_name.match_type ());
5459 ada_add_all_symbols (result, block, decl_lookup_name, domain,
5462 renaming->searched = 0;
5464 return result.size () != defns_mark;
5467 /* Implements compare_names, but only applying the comparision using
5468 the given CASING. */
5471 compare_names_with_case (const char *string1, const char *string2,
5472 enum case_sensitivity casing)
5474 while (*string1 != '\0' && *string2 != '\0')
5478 if (isspace (*string1) || isspace (*string2))
5479 return strcmp_iw_ordered (string1, string2);
5481 if (casing == case_sensitive_off)
5483 c1 = tolower (*string1);
5484 c2 = tolower (*string2);
5501 return strcmp_iw_ordered (string1, string2);
5503 if (*string2 == '\0')
5505 if (is_name_suffix (string1))
5512 if (*string2 == '(')
5513 return strcmp_iw_ordered (string1, string2);
5516 if (casing == case_sensitive_off)
5517 return tolower (*string1) - tolower (*string2);
5519 return *string1 - *string2;
5524 /* Compare STRING1 to STRING2, with results as for strcmp.
5525 Compatible with strcmp_iw_ordered in that...
5527 strcmp_iw_ordered (STRING1, STRING2) <= 0
5531 compare_names (STRING1, STRING2) <= 0
5533 (they may differ as to what symbols compare equal). */
5536 compare_names (const char *string1, const char *string2)
5540 /* Similar to what strcmp_iw_ordered does, we need to perform
5541 a case-insensitive comparison first, and only resort to
5542 a second, case-sensitive, comparison if the first one was
5543 not sufficient to differentiate the two strings. */
5545 result = compare_names_with_case (string1, string2, case_sensitive_off);
5547 result = compare_names_with_case (string1, string2, case_sensitive_on);
5552 /* Convenience function to get at the Ada encoded lookup name for
5553 LOOKUP_NAME, as a C string. */
5556 ada_lookup_name (const lookup_name_info &lookup_name)
5558 return lookup_name.ada ().lookup_name ().c_str ();
5561 /* A helper for add_nonlocal_symbols. Call expand_matching_symbols
5562 for OBJFILE, then walk the objfile's symtabs and update the
5566 map_matching_symbols (struct objfile *objfile,
5567 const lookup_name_info &lookup_name,
5573 data.objfile = objfile;
5574 objfile->expand_matching_symbols (lookup_name, domain, global,
5575 is_wild_match ? nullptr : compare_names);
5577 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5578 for (compunit_symtab *symtab : objfile->compunits ())
5580 const struct block *block
5581 = symtab->blockvector ()->block (block_kind);
5582 if (!iterate_over_symbols_terminated (block, lookup_name,
5588 /* Add to RESULT all non-local symbols whose name and domain match
5589 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5590 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5591 symbols otherwise. */
5594 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5595 const lookup_name_info &lookup_name,
5596 domain_enum domain, int global)
5598 struct match_data data (&result);
5600 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5602 for (objfile *objfile : current_program_space->objfiles ())
5604 map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5607 for (compunit_symtab *cu : objfile->compunits ())
5609 const struct block *global_block
5610 = cu->blockvector ()->global_block ();
5612 if (ada_add_block_renamings (result, global_block, lookup_name,
5614 data.found_sym = true;
5618 if (result.empty () && global && !is_wild_match)
5620 const char *name = ada_lookup_name (lookup_name);
5621 std::string bracket_name = std::string ("<_ada_") + name + '>';
5622 lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5624 for (objfile *objfile : current_program_space->objfiles ())
5625 map_matching_symbols (objfile, name1, false, domain, global, data);
5629 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5630 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5631 returning the number of matches. Add these to RESULT.
5633 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5634 symbol match within the nest of blocks whose innermost member is BLOCK,
5635 is the one match returned (no other matches in that or
5636 enclosing blocks is returned). If there are any matches in or
5637 surrounding BLOCK, then these alone are returned.
5639 Names prefixed with "standard__" are handled specially:
5640 "standard__" is first stripped off (by the lookup_name
5641 constructor), and only static and global symbols are searched.
5643 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5644 to lookup global symbols. */
5647 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5648 const struct block *block,
5649 const lookup_name_info &lookup_name,
5652 int *made_global_lookup_p)
5656 if (made_global_lookup_p)
5657 *made_global_lookup_p = 0;
5659 /* Special case: If the user specifies a symbol name inside package
5660 Standard, do a non-wild matching of the symbol name without
5661 the "standard__" prefix. This was primarily introduced in order
5662 to allow the user to specifically access the standard exceptions
5663 using, for instance, Standard.Constraint_Error when Constraint_Error
5664 is ambiguous (due to the user defining its own Constraint_Error
5665 entity inside its program). */
5666 if (lookup_name.ada ().standard_p ())
5669 /* Check the non-global symbols. If we have ANY match, then we're done. */
5674 ada_add_local_symbols (result, lookup_name, block, domain);
5677 /* In the !full_search case we're are being called by
5678 iterate_over_symbols, and we don't want to search
5680 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5682 if (!result.empty () || !full_search)
5686 /* No non-global symbols found. Check our cache to see if we have
5687 already performed this search before. If we have, then return
5690 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5691 domain, &sym, &block))
5694 add_defn_to_vec (result, sym, block);
5698 if (made_global_lookup_p)
5699 *made_global_lookup_p = 1;
5701 /* Search symbols from all global blocks. */
5703 add_nonlocal_symbols (result, lookup_name, domain, 1);
5705 /* Now add symbols from all per-file blocks if we've gotten no hits
5706 (not strictly correct, but perhaps better than an error). */
5708 if (result.empty ())
5709 add_nonlocal_symbols (result, lookup_name, domain, 0);
5712 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5713 is non-zero, enclosing scope and in global scopes.
5715 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5716 blocks and symbol tables (if any) in which they were found.
5718 When full_search is non-zero, any non-function/non-enumeral
5719 symbol match within the nest of blocks whose innermost member is BLOCK,
5720 is the one match returned (no other matches in that or
5721 enclosing blocks is returned). If there are any matches in or
5722 surrounding BLOCK, then these alone are returned.
5724 Names prefixed with "standard__" are handled specially: "standard__"
5725 is first stripped off, and only static and global symbols are searched. */
5727 static std::vector<struct block_symbol>
5728 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5729 const struct block *block,
5733 int syms_from_global_search;
5734 std::vector<struct block_symbol> results;
5736 ada_add_all_symbols (results, block, lookup_name,
5737 domain, full_search, &syms_from_global_search);
5739 remove_extra_symbols (&results);
5741 if (results.empty () && full_search && syms_from_global_search)
5742 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5744 if (results.size () == 1 && full_search && syms_from_global_search)
5745 cache_symbol (ada_lookup_name (lookup_name), domain,
5746 results[0].symbol, results[0].block);
5748 remove_irrelevant_renamings (&results, block);
5752 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5753 in global scopes, returning (SYM,BLOCK) tuples.
5755 See ada_lookup_symbol_list_worker for further details. */
5757 std::vector<struct block_symbol>
5758 ada_lookup_symbol_list (const char *name, const struct block *block,
5761 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5762 lookup_name_info lookup_name (name, name_match_type);
5764 return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5767 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5768 to 1, but choosing the first symbol found if there are multiple
5771 The result is stored in *INFO, which must be non-NULL.
5772 If no match is found, INFO->SYM is set to NULL. */
5775 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5777 struct block_symbol *info)
5779 /* Since we already have an encoded name, wrap it in '<>' to force a
5780 verbatim match. Otherwise, if the name happens to not look like
5781 an encoded name (because it doesn't include a "__"),
5782 ada_lookup_name_info would re-encode/fold it again, and that
5783 would e.g., incorrectly lowercase object renaming names like
5784 "R28b" -> "r28b". */
5785 std::string verbatim = add_angle_brackets (name);
5787 gdb_assert (info != NULL);
5788 *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5791 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5792 scope and in global scopes, or NULL if none. NAME is folded and
5793 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5794 choosing the first symbol if there are multiple choices. */
5797 ada_lookup_symbol (const char *name, const struct block *block0,
5800 std::vector<struct block_symbol> candidates
5801 = ada_lookup_symbol_list (name, block0, domain);
5803 if (candidates.empty ())
5806 block_symbol info = candidates[0];
5807 info.symbol = fixup_symbol_section (info.symbol, NULL);
5812 /* True iff STR is a possible encoded suffix of a normal Ada name
5813 that is to be ignored for matching purposes. Suffixes of parallel
5814 names (e.g., XVE) are not included here. Currently, the possible suffixes
5815 are given by any of the regular expressions:
5817 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5818 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5819 TKB [subprogram suffix for task bodies]
5820 _E[0-9]+[bs]$ [protected object entry suffixes]
5821 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5823 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5824 match is performed. This sequence is used to differentiate homonyms,
5825 is an optional part of a valid name suffix. */
5828 is_name_suffix (const char *str)
5831 const char *matching;
5832 const int len = strlen (str);
5834 /* Skip optional leading __[0-9]+. */
5836 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5839 while (isdigit (str[0]))
5845 if (str[0] == '.' || str[0] == '$')
5848 while (isdigit (matching[0]))
5850 if (matching[0] == '\0')
5856 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5859 while (isdigit (matching[0]))
5861 if (matching[0] == '\0')
5865 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5867 if (strcmp (str, "TKB") == 0)
5871 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5872 with a N at the end. Unfortunately, the compiler uses the same
5873 convention for other internal types it creates. So treating
5874 all entity names that end with an "N" as a name suffix causes
5875 some regressions. For instance, consider the case of an enumerated
5876 type. To support the 'Image attribute, it creates an array whose
5878 Having a single character like this as a suffix carrying some
5879 information is a bit risky. Perhaps we should change the encoding
5880 to be something like "_N" instead. In the meantime, do not do
5881 the following check. */
5882 /* Protected Object Subprograms */
5883 if (len == 1 && str [0] == 'N')
5888 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5891 while (isdigit (matching[0]))
5893 if ((matching[0] == 'b' || matching[0] == 's')
5894 && matching [1] == '\0')
5898 /* ??? We should not modify STR directly, as we are doing below. This
5899 is fine in this case, but may become problematic later if we find
5900 that this alternative did not work, and want to try matching
5901 another one from the begining of STR. Since we modified it, we
5902 won't be able to find the begining of the string anymore! */
5906 while (str[0] != '_' && str[0] != '\0')
5908 if (str[0] != 'n' && str[0] != 'b')
5914 if (str[0] == '\000')
5919 if (str[1] != '_' || str[2] == '\000')
5923 if (strcmp (str + 3, "JM") == 0)
5925 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5926 the LJM suffix in favor of the JM one. But we will
5927 still accept LJM as a valid suffix for a reasonable
5928 amount of time, just to allow ourselves to debug programs
5929 compiled using an older version of GNAT. */
5930 if (strcmp (str + 3, "LJM") == 0)
5934 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5935 || str[4] == 'U' || str[4] == 'P')
5937 if (str[4] == 'R' && str[5] != 'T')
5941 if (!isdigit (str[2]))
5943 for (k = 3; str[k] != '\0'; k += 1)
5944 if (!isdigit (str[k]) && str[k] != '_')
5948 if (str[0] == '$' && isdigit (str[1]))
5950 for (k = 2; str[k] != '\0'; k += 1)
5951 if (!isdigit (str[k]) && str[k] != '_')
5958 /* Return non-zero if the string starting at NAME and ending before
5959 NAME_END contains no capital letters. */
5962 is_valid_name_for_wild_match (const char *name0)
5964 std::string decoded_name = ada_decode (name0);
5967 /* If the decoded name starts with an angle bracket, it means that
5968 NAME0 does not follow the GNAT encoding format. It should then
5969 not be allowed as a possible wild match. */
5970 if (decoded_name[0] == '<')
5973 for (i=0; decoded_name[i] != '\0'; i++)
5974 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5980 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5981 character which could start a simple name. Assumes that *NAMEP points
5982 somewhere inside the string beginning at NAME0. */
5985 advance_wild_match (const char **namep, const char *name0, char target0)
5987 const char *name = *namep;
5997 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6000 if (name == name0 + 5 && startswith (name0, "_ada"))
6005 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6006 || name[2] == target0))
6011 else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6013 /* Names like "pkg__B_N__name", where N is a number, are
6014 block-local. We can handle these by simply skipping
6021 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6031 /* Return true iff NAME encodes a name of the form prefix.PATN.
6032 Ignores any informational suffixes of NAME (i.e., for which
6033 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6037 wild_match (const char *name, const char *patn)
6040 const char *name0 = name;
6042 if (startswith (name, "___ghost_"))
6047 const char *match = name;
6051 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6054 if (*p == '\0' && is_name_suffix (name))
6055 return match == name0 || is_valid_name_for_wild_match (name0);
6057 if (name[-1] == '_')
6060 if (!advance_wild_match (&name, name0, *patn))
6065 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6066 necessary). OBJFILE is the section containing BLOCK. */
6069 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6070 const struct block *block,
6071 const lookup_name_info &lookup_name,
6072 domain_enum domain, struct objfile *objfile)
6074 struct block_iterator iter;
6075 /* A matching argument symbol, if any. */
6076 struct symbol *arg_sym;
6077 /* Set true when we find a matching non-argument symbol. */
6083 for (sym = block_iter_match_first (block, lookup_name, &iter);
6085 sym = block_iter_match_next (lookup_name, &iter))
6087 if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6089 if (sym->aclass () != LOC_UNRESOLVED)
6091 if (sym->is_argument ())
6096 add_defn_to_vec (result,
6097 fixup_symbol_section (sym, objfile),
6104 /* Handle renamings. */
6106 if (ada_add_block_renamings (result, block, lookup_name, domain))
6109 if (!found_sym && arg_sym != NULL)
6111 add_defn_to_vec (result,
6112 fixup_symbol_section (arg_sym, objfile),
6116 if (!lookup_name.ada ().wild_match_p ())
6120 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6121 const char *name = ada_lookup_name.c_str ();
6122 size_t name_len = ada_lookup_name.size ();
6124 ALL_BLOCK_SYMBOLS (block, iter, sym)
6126 if (symbol_matches_domain (sym->language (),
6127 sym->domain (), domain))
6131 cmp = (int) '_' - (int) sym->linkage_name ()[0];
6134 cmp = !startswith (sym->linkage_name (), "_ada_");
6136 cmp = strncmp (name, sym->linkage_name () + 5,
6141 && is_name_suffix (sym->linkage_name () + name_len + 5))
6143 if (sym->aclass () != LOC_UNRESOLVED)
6145 if (sym->is_argument ())
6150 add_defn_to_vec (result,
6151 fixup_symbol_section (sym, objfile),
6159 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6160 They aren't parameters, right? */
6161 if (!found_sym && arg_sym != NULL)
6163 add_defn_to_vec (result,
6164 fixup_symbol_section (arg_sym, objfile),
6171 /* Symbol Completion */
6176 ada_lookup_name_info::matches
6177 (const char *sym_name,
6178 symbol_name_match_type match_type,
6179 completion_match_result *comp_match_res) const
6182 const char *text = m_encoded_name.c_str ();
6183 size_t text_len = m_encoded_name.size ();
6185 /* First, test against the fully qualified name of the symbol. */
6187 if (strncmp (sym_name, text, text_len) == 0)
6190 std::string decoded_name = ada_decode (sym_name);
6191 if (match && !m_encoded_p)
6193 /* One needed check before declaring a positive match is to verify
6194 that iff we are doing a verbatim match, the decoded version
6195 of the symbol name starts with '<'. Otherwise, this symbol name
6196 is not a suitable completion. */
6198 bool has_angle_bracket = (decoded_name[0] == '<');
6199 match = (has_angle_bracket == m_verbatim_p);
6202 if (match && !m_verbatim_p)
6204 /* When doing non-verbatim match, another check that needs to
6205 be done is to verify that the potentially matching symbol name
6206 does not include capital letters, because the ada-mode would
6207 not be able to understand these symbol names without the
6208 angle bracket notation. */
6211 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6216 /* Second: Try wild matching... */
6218 if (!match && m_wild_match_p)
6220 /* Since we are doing wild matching, this means that TEXT
6221 may represent an unqualified symbol name. We therefore must
6222 also compare TEXT against the unqualified name of the symbol. */
6223 sym_name = ada_unqualified_name (decoded_name.c_str ());
6225 if (strncmp (sym_name, text, text_len) == 0)
6229 /* Finally: If we found a match, prepare the result to return. */
6234 if (comp_match_res != NULL)
6236 std::string &match_str = comp_match_res->match.storage ();
6239 match_str = ada_decode (sym_name);
6243 match_str = add_angle_brackets (sym_name);
6245 match_str = sym_name;
6249 comp_match_res->set_match (match_str.c_str ());
6257 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6258 for tagged types. */
6261 ada_is_dispatch_table_ptr_type (struct type *type)
6265 if (type->code () != TYPE_CODE_PTR)
6268 name = type->target_type ()->name ();
6272 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6275 /* Return non-zero if TYPE is an interface tag. */
6278 ada_is_interface_tag (struct type *type)
6280 const char *name = type->name ();
6285 return (strcmp (name, "ada__tags__interface_tag") == 0);
6288 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6289 to be invisible to users. */
6292 ada_is_ignored_field (struct type *type, int field_num)
6294 if (field_num < 0 || field_num > type->num_fields ())
6297 /* Check the name of that field. */
6299 const char *name = type->field (field_num).name ();
6301 /* Anonymous field names should not be printed.
6302 brobecker/2007-02-20: I don't think this can actually happen
6303 but we don't want to print the value of anonymous fields anyway. */
6307 /* Normally, fields whose name start with an underscore ("_")
6308 are fields that have been internally generated by the compiler,
6309 and thus should not be printed. The "_parent" field is special,
6310 however: This is a field internally generated by the compiler
6311 for tagged types, and it contains the components inherited from
6312 the parent type. This field should not be printed as is, but
6313 should not be ignored either. */
6314 if (name[0] == '_' && !startswith (name, "_parent"))
6317 /* The compiler doesn't document this, but sometimes it emits
6318 a field whose name starts with a capital letter, like 'V148s'.
6319 These aren't marked as artificial in any way, but we know they
6320 should be ignored. However, wrapper fields should not be
6322 if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6324 /* Wrapper field. */
6326 else if (isupper (name[0]))
6330 /* If this is the dispatch table of a tagged type or an interface tag,
6332 if (ada_is_tagged_type (type, 1)
6333 && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6334 || ada_is_interface_tag (type->field (field_num).type ())))
6337 /* Not a special field, so it should not be ignored. */
6341 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6342 pointer or reference type whose ultimate target has a tag field. */
6345 ada_is_tagged_type (struct type *type, int refok)
6347 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6350 /* True iff TYPE represents the type of X'Tag */
6353 ada_is_tag_type (struct type *type)
6355 type = ada_check_typedef (type);
6357 if (type == NULL || type->code () != TYPE_CODE_PTR)
6361 const char *name = ada_type_name (type->target_type ());
6363 return (name != NULL
6364 && strcmp (name, "ada__tags__dispatch_table") == 0);
6368 /* The type of the tag on VAL. */
6370 static struct type *
6371 ada_tag_type (struct value *val)
6373 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6376 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6377 retired at Ada 05). */
6380 is_ada95_tag (struct value *tag)
6382 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6385 /* The value of the tag on VAL. */
6387 static struct value *
6388 ada_value_tag (struct value *val)
6390 return ada_value_struct_elt (val, "_tag", 0);
6393 /* The value of the tag on the object of type TYPE whose contents are
6394 saved at VALADDR, if it is non-null, or is at memory address
6397 static struct value *
6398 value_tag_from_contents_and_address (struct type *type,
6399 const gdb_byte *valaddr,
6402 int tag_byte_offset;
6403 struct type *tag_type;
6405 gdb::array_view<const gdb_byte> contents;
6406 if (valaddr != nullptr)
6407 contents = gdb::make_array_view (valaddr, type->length ());
6408 struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6409 if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6412 const gdb_byte *valaddr1 = ((valaddr == NULL)
6414 : valaddr + tag_byte_offset);
6415 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6417 return value_from_contents_and_address (tag_type, valaddr1, address1);
6422 static struct type *
6423 type_from_tag (struct value *tag)
6425 gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6427 if (type_name != NULL)
6428 return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6432 /* Given a value OBJ of a tagged type, return a value of this
6433 type at the base address of the object. The base address, as
6434 defined in Ada.Tags, it is the address of the primary tag of
6435 the object, and therefore where the field values of its full
6436 view can be fetched. */
6439 ada_tag_value_at_base_address (struct value *obj)
6442 LONGEST offset_to_top = 0;
6443 struct type *ptr_type, *obj_type;
6445 CORE_ADDR base_address;
6447 obj_type = value_type (obj);
6449 /* It is the responsability of the caller to deref pointers. */
6451 if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6454 tag = ada_value_tag (obj);
6458 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6460 if (is_ada95_tag (tag))
6463 struct type *offset_type
6464 = language_lookup_primitive_type (language_def (language_ada),
6465 target_gdbarch(), "storage_offset");
6466 ptr_type = lookup_pointer_type (offset_type);
6467 val = value_cast (ptr_type, tag);
6471 /* It is perfectly possible that an exception be raised while
6472 trying to determine the base address, just like for the tag;
6473 see ada_tag_name for more details. We do not print the error
6474 message for the same reason. */
6478 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6481 catch (const gdb_exception_error &e)
6486 /* If offset is null, nothing to do. */
6488 if (offset_to_top == 0)
6491 /* -1 is a special case in Ada.Tags; however, what should be done
6492 is not quite clear from the documentation. So do nothing for
6495 if (offset_to_top == -1)
6498 /* Storage_Offset'Last is used to indicate that a dynamic offset to
6499 top is used. In this situation the offset is stored just after
6500 the tag, in the object itself. */
6501 ULONGEST last = (((ULONGEST) 1) << (8 * offset_type->length () - 1)) - 1;
6502 if (offset_to_top == last)
6504 struct value *tem = value_addr (tag);
6505 tem = value_ptradd (tem, 1);
6506 tem = value_cast (ptr_type, tem);
6507 offset_to_top = value_as_long (value_ind (tem));
6510 if (offset_to_top > 0)
6512 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6513 from the base address. This was however incompatible with
6514 C++ dispatch table: C++ uses a *negative* value to *add*
6515 to the base address. Ada's convention has therefore been
6516 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6517 use the same convention. Here, we support both cases by
6518 checking the sign of OFFSET_TO_TOP. */
6519 offset_to_top = -offset_to_top;
6522 base_address = value_address (obj) + offset_to_top;
6523 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6525 /* Make sure that we have a proper tag at the new address.
6526 Otherwise, offset_to_top is bogus (which can happen when
6527 the object is not initialized yet). */
6532 obj_type = type_from_tag (tag);
6537 return value_from_contents_and_address (obj_type, NULL, base_address);
6540 /* Return the "ada__tags__type_specific_data" type. */
6542 static struct type *
6543 ada_get_tsd_type (struct inferior *inf)
6545 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6547 if (data->tsd_type == 0)
6548 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6549 return data->tsd_type;
6552 /* Return the TSD (type-specific data) associated to the given TAG.
6553 TAG is assumed to be the tag of a tagged-type entity.
6555 May return NULL if we are unable to get the TSD. */
6557 static struct value *
6558 ada_get_tsd_from_tag (struct value *tag)
6563 /* First option: The TSD is simply stored as a field of our TAG.
6564 Only older versions of GNAT would use this format, but we have
6565 to test it first, because there are no visible markers for
6566 the current approach except the absence of that field. */
6568 val = ada_value_struct_elt (tag, "tsd", 1);
6572 /* Try the second representation for the dispatch table (in which
6573 there is no explicit 'tsd' field in the referent of the tag pointer,
6574 and instead the tsd pointer is stored just before the dispatch
6577 type = ada_get_tsd_type (current_inferior());
6580 type = lookup_pointer_type (lookup_pointer_type (type));
6581 val = value_cast (type, tag);
6584 return value_ind (value_ptradd (val, -1));
6587 /* Given the TSD of a tag (type-specific data), return a string
6588 containing the name of the associated type.
6590 May return NULL if we are unable to determine the tag name. */
6592 static gdb::unique_xmalloc_ptr<char>
6593 ada_tag_name_from_tsd (struct value *tsd)
6597 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6600 gdb::unique_xmalloc_ptr<char> buffer
6601 = target_read_string (value_as_address (val), INT_MAX);
6602 if (buffer == nullptr)
6607 /* Let this throw an exception on error. If the data is
6608 uninitialized, we'd rather not have the user see a
6610 const char *folded = ada_fold_name (buffer.get (), true);
6611 return make_unique_xstrdup (folded);
6613 catch (const gdb_exception &)
6619 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6622 Return NULL if the TAG is not an Ada tag, or if we were unable to
6623 determine the name of that tag. */
6625 gdb::unique_xmalloc_ptr<char>
6626 ada_tag_name (struct value *tag)
6628 gdb::unique_xmalloc_ptr<char> name;
6630 if (!ada_is_tag_type (value_type (tag)))
6633 /* It is perfectly possible that an exception be raised while trying
6634 to determine the TAG's name, even under normal circumstances:
6635 The associated variable may be uninitialized or corrupted, for
6636 instance. We do not let any exception propagate past this point.
6637 instead we return NULL.
6639 We also do not print the error message either (which often is very
6640 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6641 the caller print a more meaningful message if necessary. */
6644 struct value *tsd = ada_get_tsd_from_tag (tag);
6647 name = ada_tag_name_from_tsd (tsd);
6649 catch (const gdb_exception_error &e)
6656 /* The parent type of TYPE, or NULL if none. */
6659 ada_parent_type (struct type *type)
6663 type = ada_check_typedef (type);
6665 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6668 for (i = 0; i < type->num_fields (); i += 1)
6669 if (ada_is_parent_field (type, i))
6671 struct type *parent_type = type->field (i).type ();
6673 /* If the _parent field is a pointer, then dereference it. */
6674 if (parent_type->code () == TYPE_CODE_PTR)
6675 parent_type = parent_type->target_type ();
6676 /* If there is a parallel XVS type, get the actual base type. */
6677 parent_type = ada_get_base_type (parent_type);
6679 return ada_check_typedef (parent_type);
6685 /* True iff field number FIELD_NUM of structure type TYPE contains the
6686 parent-type (inherited) fields of a derived type. Assumes TYPE is
6687 a structure type with at least FIELD_NUM+1 fields. */
6690 ada_is_parent_field (struct type *type, int field_num)
6692 const char *name = ada_check_typedef (type)->field (field_num).name ();
6694 return (name != NULL
6695 && (startswith (name, "PARENT")
6696 || startswith (name, "_parent")));
6699 /* True iff field number FIELD_NUM of structure type TYPE is a
6700 transparent wrapper field (which should be silently traversed when doing
6701 field selection and flattened when printing). Assumes TYPE is a
6702 structure type with at least FIELD_NUM+1 fields. Such fields are always
6706 ada_is_wrapper_field (struct type *type, int field_num)
6708 const char *name = type->field (field_num).name ();
6710 if (name != NULL && strcmp (name, "RETVAL") == 0)
6712 /* This happens in functions with "out" or "in out" parameters
6713 which are passed by copy. For such functions, GNAT describes
6714 the function's return type as being a struct where the return
6715 value is in a field called RETVAL, and where the other "out"
6716 or "in out" parameters are fields of that struct. This is not
6721 return (name != NULL
6722 && (startswith (name, "PARENT")
6723 || strcmp (name, "REP") == 0
6724 || startswith (name, "_parent")
6725 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6728 /* True iff field number FIELD_NUM of structure or union type TYPE
6729 is a variant wrapper. Assumes TYPE is a structure type with at least
6730 FIELD_NUM+1 fields. */
6733 ada_is_variant_part (struct type *type, int field_num)
6735 /* Only Ada types are eligible. */
6736 if (!ADA_TYPE_P (type))
6739 struct type *field_type = type->field (field_num).type ();
6741 return (field_type->code () == TYPE_CODE_UNION
6742 || (is_dynamic_field (type, field_num)
6743 && (field_type->target_type ()->code ()
6744 == TYPE_CODE_UNION)));
6747 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6748 whose discriminants are contained in the record type OUTER_TYPE,
6749 returns the type of the controlling discriminant for the variant.
6750 May return NULL if the type could not be found. */
6753 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6755 const char *name = ada_variant_discrim_name (var_type);
6757 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6760 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6761 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6762 represents a 'when others' clause; otherwise 0. */
6765 ada_is_others_clause (struct type *type, int field_num)
6767 const char *name = type->field (field_num).name ();
6769 return (name != NULL && name[0] == 'O');
6772 /* Assuming that TYPE0 is the type of the variant part of a record,
6773 returns the name of the discriminant controlling the variant.
6774 The value is valid until the next call to ada_variant_discrim_name. */
6777 ada_variant_discrim_name (struct type *type0)
6779 static std::string result;
6782 const char *discrim_end;
6783 const char *discrim_start;
6785 if (type0->code () == TYPE_CODE_PTR)
6786 type = type0->target_type ();
6790 name = ada_type_name (type);
6792 if (name == NULL || name[0] == '\000')
6795 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6798 if (startswith (discrim_end, "___XVN"))
6801 if (discrim_end == name)
6804 for (discrim_start = discrim_end; discrim_start != name + 3;
6807 if (discrim_start == name + 1)
6809 if ((discrim_start > name + 3
6810 && startswith (discrim_start - 3, "___"))
6811 || discrim_start[-1] == '.')
6815 result = std::string (discrim_start, discrim_end - discrim_start);
6816 return result.c_str ();
6819 /* Scan STR for a subtype-encoded number, beginning at position K.
6820 Put the position of the character just past the number scanned in
6821 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6822 Return 1 if there was a valid number at the given position, and 0
6823 otherwise. A "subtype-encoded" number consists of the absolute value
6824 in decimal, followed by the letter 'm' to indicate a negative number.
6825 Assumes 0m does not occur. */
6828 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6832 if (!isdigit (str[k]))
6835 /* Do it the hard way so as not to make any assumption about
6836 the relationship of unsigned long (%lu scan format code) and
6839 while (isdigit (str[k]))
6841 RU = RU * 10 + (str[k] - '0');
6848 *R = (-(LONGEST) (RU - 1)) - 1;
6854 /* NOTE on the above: Technically, C does not say what the results of
6855 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6856 number representable as a LONGEST (although either would probably work
6857 in most implementations). When RU>0, the locution in the then branch
6858 above is always equivalent to the negative of RU. */
6865 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6866 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6867 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6870 ada_in_variant (LONGEST val, struct type *type, int field_num)
6872 const char *name = type->field (field_num).name ();
6886 if (!ada_scan_number (name, p + 1, &W, &p))
6896 if (!ada_scan_number (name, p + 1, &L, &p)
6897 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6899 if (val >= L && val <= U)
6911 /* FIXME: Lots of redundancy below. Try to consolidate. */
6913 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6914 ARG_TYPE, extract and return the value of one of its (non-static)
6915 fields. FIELDNO says which field. Differs from value_primitive_field
6916 only in that it can handle packed values of arbitrary type. */
6919 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6920 struct type *arg_type)
6924 arg_type = ada_check_typedef (arg_type);
6925 type = arg_type->field (fieldno).type ();
6927 /* Handle packed fields. It might be that the field is not packed
6928 relative to its containing structure, but the structure itself is
6929 packed; in this case we must take the bit-field path. */
6930 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6932 int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6933 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6935 return ada_value_primitive_packed_val (arg1,
6936 value_contents (arg1).data (),
6937 offset + bit_pos / 8,
6938 bit_pos % 8, bit_size, type);
6941 return value_primitive_field (arg1, offset, fieldno, arg_type);
6944 /* Find field with name NAME in object of type TYPE. If found,
6945 set the following for each argument that is non-null:
6946 - *FIELD_TYPE_P to the field's type;
6947 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6948 an object of that type;
6949 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6950 - *BIT_SIZE_P to its size in bits if the field is packed, and
6952 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6953 fields up to but not including the desired field, or by the total
6954 number of fields if not found. A NULL value of NAME never
6955 matches; the function just counts visible fields in this case.
6957 Notice that we need to handle when a tagged record hierarchy
6958 has some components with the same name, like in this scenario:
6960 type Top_T is tagged record
6966 type Middle_T is new Top.Top_T with record
6967 N : Character := 'a';
6971 type Bottom_T is new Middle.Middle_T with record
6973 C : Character := '5';
6975 A : Character := 'J';
6978 Let's say we now have a variable declared and initialized as follow:
6980 TC : Top_A := new Bottom_T;
6982 And then we use this variable to call this function
6984 procedure Assign (Obj: in out Top_T; TV : Integer);
6988 Assign (Top_T (B), 12);
6990 Now, we're in the debugger, and we're inside that procedure
6991 then and we want to print the value of obj.c:
6993 Usually, the tagged record or one of the parent type owns the
6994 component to print and there's no issue but in this particular
6995 case, what does it mean to ask for Obj.C? Since the actual
6996 type for object is type Bottom_T, it could mean two things: type
6997 component C from the Middle_T view, but also component C from
6998 Bottom_T. So in that "undefined" case, when the component is
6999 not found in the non-resolved type (which includes all the
7000 components of the parent type), then resolve it and see if we
7001 get better luck once expanded.
7003 In the case of homonyms in the derived tagged type, we don't
7004 guaranty anything, and pick the one that's easiest for us
7007 Returns 1 if found, 0 otherwise. */
7010 find_struct_field (const char *name, struct type *type, int offset,
7011 struct type **field_type_p,
7012 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7016 int parent_offset = -1;
7018 type = ada_check_typedef (type);
7020 if (field_type_p != NULL)
7021 *field_type_p = NULL;
7022 if (byte_offset_p != NULL)
7024 if (bit_offset_p != NULL)
7026 if (bit_size_p != NULL)
7029 for (i = 0; i < type->num_fields (); i += 1)
7031 /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7032 type. However, we only need the values to be correct when
7033 the caller asks for them. */
7034 int bit_pos = 0, fld_offset = 0;
7035 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7037 bit_pos = type->field (i).loc_bitpos ();
7038 fld_offset = offset + bit_pos / 8;
7041 const char *t_field_name = type->field (i).name ();
7043 if (t_field_name == NULL)
7046 else if (ada_is_parent_field (type, i))
7048 /* This is a field pointing us to the parent type of a tagged
7049 type. As hinted in this function's documentation, we give
7050 preference to fields in the current record first, so what
7051 we do here is just record the index of this field before
7052 we skip it. If it turns out we couldn't find our field
7053 in the current record, then we'll get back to it and search
7054 inside it whether the field might exist in the parent. */
7060 else if (name != NULL && field_name_match (t_field_name, name))
7062 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7064 if (field_type_p != NULL)
7065 *field_type_p = type->field (i).type ();
7066 if (byte_offset_p != NULL)
7067 *byte_offset_p = fld_offset;
7068 if (bit_offset_p != NULL)
7069 *bit_offset_p = bit_pos % 8;
7070 if (bit_size_p != NULL)
7071 *bit_size_p = bit_size;
7074 else if (ada_is_wrapper_field (type, i))
7076 if (find_struct_field (name, type->field (i).type (), fld_offset,
7077 field_type_p, byte_offset_p, bit_offset_p,
7078 bit_size_p, index_p))
7081 else if (ada_is_variant_part (type, i))
7083 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7086 struct type *field_type
7087 = ada_check_typedef (type->field (i).type ());
7089 for (j = 0; j < field_type->num_fields (); j += 1)
7091 if (find_struct_field (name, field_type->field (j).type (),
7093 + field_type->field (j).loc_bitpos () / 8,
7094 field_type_p, byte_offset_p,
7095 bit_offset_p, bit_size_p, index_p))
7099 else if (index_p != NULL)
7103 /* Field not found so far. If this is a tagged type which
7104 has a parent, try finding that field in the parent now. */
7106 if (parent_offset != -1)
7108 /* As above, only compute the offset when truly needed. */
7109 int fld_offset = offset;
7110 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7112 int bit_pos = type->field (parent_offset).loc_bitpos ();
7113 fld_offset += bit_pos / 8;
7116 if (find_struct_field (name, type->field (parent_offset).type (),
7117 fld_offset, field_type_p, byte_offset_p,
7118 bit_offset_p, bit_size_p, index_p))
7125 /* Number of user-visible fields in record type TYPE. */
7128 num_visible_fields (struct type *type)
7133 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7137 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7138 and search in it assuming it has (class) type TYPE.
7139 If found, return value, else return NULL.
7141 Searches recursively through wrapper fields (e.g., '_parent').
7143 In the case of homonyms in the tagged types, please refer to the
7144 long explanation in find_struct_field's function documentation. */
7146 static struct value *
7147 ada_search_struct_field (const char *name, struct value *arg, int offset,
7151 int parent_offset = -1;
7153 type = ada_check_typedef (type);
7154 for (i = 0; i < type->num_fields (); i += 1)
7156 const char *t_field_name = type->field (i).name ();
7158 if (t_field_name == NULL)
7161 else if (ada_is_parent_field (type, i))
7163 /* This is a field pointing us to the parent type of a tagged
7164 type. As hinted in this function's documentation, we give
7165 preference to fields in the current record first, so what
7166 we do here is just record the index of this field before
7167 we skip it. If it turns out we couldn't find our field
7168 in the current record, then we'll get back to it and search
7169 inside it whether the field might exist in the parent. */
7175 else if (field_name_match (t_field_name, name))
7176 return ada_value_primitive_field (arg, offset, i, type);
7178 else if (ada_is_wrapper_field (type, i))
7180 struct value *v = /* Do not let indent join lines here. */
7181 ada_search_struct_field (name, arg,
7182 offset + type->field (i).loc_bitpos () / 8,
7183 type->field (i).type ());
7189 else if (ada_is_variant_part (type, i))
7191 /* PNH: Do we ever get here? See find_struct_field. */
7193 struct type *field_type = ada_check_typedef (type->field (i).type ());
7194 int var_offset = offset + type->field (i).loc_bitpos () / 8;
7196 for (j = 0; j < field_type->num_fields (); j += 1)
7198 struct value *v = ada_search_struct_field /* Force line
7201 var_offset + field_type->field (j).loc_bitpos () / 8,
7202 field_type->field (j).type ());
7210 /* Field not found so far. If this is a tagged type which
7211 has a parent, try finding that field in the parent now. */
7213 if (parent_offset != -1)
7215 struct value *v = ada_search_struct_field (
7216 name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7217 type->field (parent_offset).type ());
7226 static struct value *ada_index_struct_field_1 (int *, struct value *,
7227 int, struct type *);
7230 /* Return field #INDEX in ARG, where the index is that returned by
7231 * find_struct_field through its INDEX_P argument. Adjust the address
7232 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7233 * If found, return value, else return NULL. */
7235 static struct value *
7236 ada_index_struct_field (int index, struct value *arg, int offset,
7239 return ada_index_struct_field_1 (&index, arg, offset, type);
7243 /* Auxiliary function for ada_index_struct_field. Like
7244 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7247 static struct value *
7248 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7252 type = ada_check_typedef (type);
7254 for (i = 0; i < type->num_fields (); i += 1)
7256 if (type->field (i).name () == NULL)
7258 else if (ada_is_wrapper_field (type, i))
7260 struct value *v = /* Do not let indent join lines here. */
7261 ada_index_struct_field_1 (index_p, arg,
7262 offset + type->field (i).loc_bitpos () / 8,
7263 type->field (i).type ());
7269 else if (ada_is_variant_part (type, i))
7271 /* PNH: Do we ever get here? See ada_search_struct_field,
7272 find_struct_field. */
7273 error (_("Cannot assign this kind of variant record"));
7275 else if (*index_p == 0)
7276 return ada_value_primitive_field (arg, offset, i, type);
7283 /* Return a string representation of type TYPE. */
7286 type_as_string (struct type *type)
7288 string_file tmp_stream;
7290 type_print (type, "", &tmp_stream, -1);
7292 return tmp_stream.release ();
7295 /* Given a type TYPE, look up the type of the component of type named NAME.
7296 If DISPP is non-null, add its byte displacement from the beginning of a
7297 structure (pointed to by a value) of type TYPE to *DISPP (does not
7298 work for packed fields).
7300 Matches any field whose name has NAME as a prefix, possibly
7303 TYPE can be either a struct or union. If REFOK, TYPE may also
7304 be a (pointer or reference)+ to a struct or union, and the
7305 ultimate target type will be searched.
7307 Looks recursively into variant clauses and parent types.
7309 In the case of homonyms in the tagged types, please refer to the
7310 long explanation in find_struct_field's function documentation.
7312 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7313 TYPE is not a type of the right kind. */
7315 static struct type *
7316 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7320 int parent_offset = -1;
7325 if (refok && type != NULL)
7328 type = ada_check_typedef (type);
7329 if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7331 type = type->target_type ();
7335 || (type->code () != TYPE_CODE_STRUCT
7336 && type->code () != TYPE_CODE_UNION))
7341 error (_("Type %s is not a structure or union type"),
7342 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7345 type = to_static_fixed_type (type);
7347 for (i = 0; i < type->num_fields (); i += 1)
7349 const char *t_field_name = type->field (i).name ();
7352 if (t_field_name == NULL)
7355 else if (ada_is_parent_field (type, i))
7357 /* This is a field pointing us to the parent type of a tagged
7358 type. As hinted in this function's documentation, we give
7359 preference to fields in the current record first, so what
7360 we do here is just record the index of this field before
7361 we skip it. If it turns out we couldn't find our field
7362 in the current record, then we'll get back to it and search
7363 inside it whether the field might exist in the parent. */
7369 else if (field_name_match (t_field_name, name))
7370 return type->field (i).type ();
7372 else if (ada_is_wrapper_field (type, i))
7374 t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7380 else if (ada_is_variant_part (type, i))
7383 struct type *field_type = ada_check_typedef (type->field (i).type ());
7385 for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7387 /* FIXME pnh 2008/01/26: We check for a field that is
7388 NOT wrapped in a struct, since the compiler sometimes
7389 generates these for unchecked variant types. Revisit
7390 if the compiler changes this practice. */
7391 const char *v_field_name = field_type->field (j).name ();
7393 if (v_field_name != NULL
7394 && field_name_match (v_field_name, name))
7395 t = field_type->field (j).type ();
7397 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7407 /* Field not found so far. If this is a tagged type which
7408 has a parent, try finding that field in the parent now. */
7410 if (parent_offset != -1)
7414 t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7423 const char *name_str = name != NULL ? name : _("<null>");
7425 error (_("Type %s has no component named %s"),
7426 type_as_string (type).c_str (), name_str);
7432 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7433 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7434 represents an unchecked union (that is, the variant part of a
7435 record that is named in an Unchecked_Union pragma). */
7438 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7440 const char *discrim_name = ada_variant_discrim_name (var_type);
7442 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7446 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7447 within OUTER, determine which variant clause (field number in VAR_TYPE,
7448 numbering from 0) is applicable. Returns -1 if none are. */
7451 ada_which_variant_applies (struct type *var_type, struct value *outer)
7455 const char *discrim_name = ada_variant_discrim_name (var_type);
7456 struct value *discrim;
7457 LONGEST discrim_val;
7459 /* Using plain value_from_contents_and_address here causes problems
7460 because we will end up trying to resolve a type that is currently
7461 being constructed. */
7462 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7463 if (discrim == NULL)
7465 discrim_val = value_as_long (discrim);
7468 for (i = 0; i < var_type->num_fields (); i += 1)
7470 if (ada_is_others_clause (var_type, i))
7472 else if (ada_in_variant (discrim_val, var_type, i))
7476 return others_clause;
7481 /* Dynamic-Sized Records */
7483 /* Strategy: The type ostensibly attached to a value with dynamic size
7484 (i.e., a size that is not statically recorded in the debugging
7485 data) does not accurately reflect the size or layout of the value.
7486 Our strategy is to convert these values to values with accurate,
7487 conventional types that are constructed on the fly. */
7489 /* There is a subtle and tricky problem here. In general, we cannot
7490 determine the size of dynamic records without its data. However,
7491 the 'struct value' data structure, which GDB uses to represent
7492 quantities in the inferior process (the target), requires the size
7493 of the type at the time of its allocation in order to reserve space
7494 for GDB's internal copy of the data. That's why the
7495 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7496 rather than struct value*s.
7498 However, GDB's internal history variables ($1, $2, etc.) are
7499 struct value*s containing internal copies of the data that are not, in
7500 general, the same as the data at their corresponding addresses in
7501 the target. Fortunately, the types we give to these values are all
7502 conventional, fixed-size types (as per the strategy described
7503 above), so that we don't usually have to perform the
7504 'to_fixed_xxx_type' conversions to look at their values.
7505 Unfortunately, there is one exception: if one of the internal
7506 history variables is an array whose elements are unconstrained
7507 records, then we will need to create distinct fixed types for each
7508 element selected. */
7510 /* The upshot of all of this is that many routines take a (type, host
7511 address, target address) triple as arguments to represent a value.
7512 The host address, if non-null, is supposed to contain an internal
7513 copy of the relevant data; otherwise, the program is to consult the
7514 target at the target address. */
7516 /* Assuming that VAL0 represents a pointer value, the result of
7517 dereferencing it. Differs from value_ind in its treatment of
7518 dynamic-sized types. */
7521 ada_value_ind (struct value *val0)
7523 struct value *val = value_ind (val0);
7525 if (ada_is_tagged_type (value_type (val), 0))
7526 val = ada_tag_value_at_base_address (val);
7528 return ada_to_fixed_value (val);
7531 /* The value resulting from dereferencing any "reference to"
7532 qualifiers on VAL0. */
7534 static struct value *
7535 ada_coerce_ref (struct value *val0)
7537 if (value_type (val0)->code () == TYPE_CODE_REF)
7539 struct value *val = val0;
7541 val = coerce_ref (val);
7543 if (ada_is_tagged_type (value_type (val), 0))
7544 val = ada_tag_value_at_base_address (val);
7546 return ada_to_fixed_value (val);
7552 /* Return the bit alignment required for field #F of template type TYPE. */
7555 field_alignment (struct type *type, int f)
7557 const char *name = type->field (f).name ();
7561 /* The field name should never be null, unless the debugging information
7562 is somehow malformed. In this case, we assume the field does not
7563 require any alignment. */
7567 len = strlen (name);
7569 if (!isdigit (name[len - 1]))
7572 if (isdigit (name[len - 2]))
7573 align_offset = len - 2;
7575 align_offset = len - 1;
7577 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7578 return TARGET_CHAR_BIT;
7580 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7583 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7585 static struct symbol *
7586 ada_find_any_type_symbol (const char *name)
7590 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7591 if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7594 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7598 /* Find a type named NAME. Ignores ambiguity. This routine will look
7599 solely for types defined by debug info, it will not search the GDB
7602 static struct type *
7603 ada_find_any_type (const char *name)
7605 struct symbol *sym = ada_find_any_type_symbol (name);
7608 return sym->type ();
7613 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7614 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7615 symbol, in which case it is returned. Otherwise, this looks for
7616 symbols whose name is that of NAME_SYM suffixed with "___XR".
7617 Return symbol if found, and NULL otherwise. */
7620 ada_is_renaming_symbol (struct symbol *name_sym)
7622 const char *name = name_sym->linkage_name ();
7623 return strstr (name, "___XR") != NULL;
7626 /* Because of GNAT encoding conventions, several GDB symbols may match a
7627 given type name. If the type denoted by TYPE0 is to be preferred to
7628 that of TYPE1 for purposes of type printing, return non-zero;
7629 otherwise return 0. */
7632 ada_prefer_type (struct type *type0, struct type *type1)
7636 else if (type0 == NULL)
7638 else if (type1->code () == TYPE_CODE_VOID)
7640 else if (type0->code () == TYPE_CODE_VOID)
7642 else if (type1->name () == NULL && type0->name () != NULL)
7644 else if (ada_is_constrained_packed_array_type (type0))
7646 else if (ada_is_array_descriptor_type (type0)
7647 && !ada_is_array_descriptor_type (type1))
7651 const char *type0_name = type0->name ();
7652 const char *type1_name = type1->name ();
7654 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7655 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7661 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7665 ada_type_name (struct type *type)
7669 return type->name ();
7672 /* Search the list of "descriptive" types associated to TYPE for a type
7673 whose name is NAME. */
7675 static struct type *
7676 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7678 struct type *result, *tmp;
7680 if (ada_ignore_descriptive_types_p)
7683 /* If there no descriptive-type info, then there is no parallel type
7685 if (!HAVE_GNAT_AUX_INFO (type))
7688 result = TYPE_DESCRIPTIVE_TYPE (type);
7689 while (result != NULL)
7691 const char *result_name = ada_type_name (result);
7693 if (result_name == NULL)
7695 warning (_("unexpected null name on descriptive type"));
7699 /* If the names match, stop. */
7700 if (strcmp (result_name, name) == 0)
7703 /* Otherwise, look at the next item on the list, if any. */
7704 if (HAVE_GNAT_AUX_INFO (result))
7705 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7709 /* If not found either, try after having resolved the typedef. */
7714 result = check_typedef (result);
7715 if (HAVE_GNAT_AUX_INFO (result))
7716 result = TYPE_DESCRIPTIVE_TYPE (result);
7722 /* If we didn't find a match, see whether this is a packed array. With
7723 older compilers, the descriptive type information is either absent or
7724 irrelevant when it comes to packed arrays so the above lookup fails.
7725 Fall back to using a parallel lookup by name in this case. */
7726 if (result == NULL && ada_is_constrained_packed_array_type (type))
7727 return ada_find_any_type (name);
7732 /* Find a parallel type to TYPE with the specified NAME, using the
7733 descriptive type taken from the debugging information, if available,
7734 and otherwise using the (slower) name-based method. */
7736 static struct type *
7737 ada_find_parallel_type_with_name (struct type *type, const char *name)
7739 struct type *result = NULL;
7741 if (HAVE_GNAT_AUX_INFO (type))
7742 result = find_parallel_type_by_descriptive_type (type, name);
7744 result = ada_find_any_type (name);
7749 /* Same as above, but specify the name of the parallel type by appending
7750 SUFFIX to the name of TYPE. */
7753 ada_find_parallel_type (struct type *type, const char *suffix)
7756 const char *type_name = ada_type_name (type);
7759 if (type_name == NULL)
7762 len = strlen (type_name);
7764 name = (char *) alloca (len + strlen (suffix) + 1);
7766 strcpy (name, type_name);
7767 strcpy (name + len, suffix);
7769 return ada_find_parallel_type_with_name (type, name);
7772 /* If TYPE is a variable-size record type, return the corresponding template
7773 type describing its fields. Otherwise, return NULL. */
7775 static struct type *
7776 dynamic_template_type (struct type *type)
7778 type = ada_check_typedef (type);
7780 if (type == NULL || type->code () != TYPE_CODE_STRUCT
7781 || ada_type_name (type) == NULL)
7785 int len = strlen (ada_type_name (type));
7787 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7790 return ada_find_parallel_type (type, "___XVE");
7794 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7795 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7798 is_dynamic_field (struct type *templ_type, int field_num)
7800 const char *name = templ_type->field (field_num).name ();
7803 && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7804 && strstr (name, "___XVL") != NULL;
7807 /* The index of the variant field of TYPE, or -1 if TYPE does not
7808 represent a variant record type. */
7811 variant_field_index (struct type *type)
7815 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7818 for (f = 0; f < type->num_fields (); f += 1)
7820 if (ada_is_variant_part (type, f))
7826 /* A record type with no fields. */
7828 static struct type *
7829 empty_record (struct type *templ)
7831 struct type *type = alloc_type_copy (templ);
7833 type->set_code (TYPE_CODE_STRUCT);
7834 INIT_NONE_SPECIFIC (type);
7835 type->set_name ("<empty>");
7836 type->set_length (0);
7840 /* An ordinary record type (with fixed-length fields) that describes
7841 the value of type TYPE at VALADDR or ADDRESS (see comments at
7842 the beginning of this section) VAL according to GNAT conventions.
7843 DVAL0 should describe the (portion of a) record that contains any
7844 necessary discriminants. It should be NULL if value_type (VAL) is
7845 an outer-level type (i.e., as opposed to a branch of a variant.) A
7846 variant field (unless unchecked) is replaced by a particular branch
7849 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7850 length are not statically known are discarded. As a consequence,
7851 VALADDR, ADDRESS and DVAL0 are ignored.
7853 NOTE: Limitations: For now, we assume that dynamic fields and
7854 variants occupy whole numbers of bytes. However, they need not be
7858 ada_template_to_fixed_record_type_1 (struct type *type,
7859 const gdb_byte *valaddr,
7860 CORE_ADDR address, struct value *dval0,
7861 int keep_dynamic_fields)
7865 int nfields, bit_len;
7871 scoped_value_mark mark;
7873 /* Compute the number of fields in this record type that are going
7874 to be processed: unless keep_dynamic_fields, this includes only
7875 fields whose position and length are static will be processed. */
7876 if (keep_dynamic_fields)
7877 nfields = type->num_fields ();
7881 while (nfields < type->num_fields ()
7882 && !ada_is_variant_part (type, nfields)
7883 && !is_dynamic_field (type, nfields))
7887 rtype = alloc_type_copy (type);
7888 rtype->set_code (TYPE_CODE_STRUCT);
7889 INIT_NONE_SPECIFIC (rtype);
7890 rtype->set_num_fields (nfields);
7892 ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7893 rtype->set_name (ada_type_name (type));
7894 rtype->set_is_fixed_instance (true);
7900 for (f = 0; f < nfields; f += 1)
7902 off = align_up (off, field_alignment (type, f))
7903 + type->field (f).loc_bitpos ();
7904 rtype->field (f).set_loc_bitpos (off);
7905 TYPE_FIELD_BITSIZE (rtype, f) = 0;
7907 if (ada_is_variant_part (type, f))
7912 else if (is_dynamic_field (type, f))
7914 const gdb_byte *field_valaddr = valaddr;
7915 CORE_ADDR field_address = address;
7916 struct type *field_type = type->field (f).type ()->target_type ();
7920 /* Using plain value_from_contents_and_address here
7921 causes problems because we will end up trying to
7922 resolve a type that is currently being
7924 dval = value_from_contents_and_address_unresolved (rtype,
7927 rtype = value_type (dval);
7932 /* If the type referenced by this field is an aligner type, we need
7933 to unwrap that aligner type, because its size might not be set.
7934 Keeping the aligner type would cause us to compute the wrong
7935 size for this field, impacting the offset of the all the fields
7936 that follow this one. */
7937 if (ada_is_aligner_type (field_type))
7939 long field_offset = type->field (f).loc_bitpos ();
7941 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7942 field_address = cond_offset_target (field_address, field_offset);
7943 field_type = ada_aligned_type (field_type);
7946 field_valaddr = cond_offset_host (field_valaddr,
7947 off / TARGET_CHAR_BIT);
7948 field_address = cond_offset_target (field_address,
7949 off / TARGET_CHAR_BIT);
7951 /* Get the fixed type of the field. Note that, in this case,
7952 we do not want to get the real type out of the tag: if
7953 the current field is the parent part of a tagged record,
7954 we will get the tag of the object. Clearly wrong: the real
7955 type of the parent is not the real type of the child. We
7956 would end up in an infinite loop. */
7957 field_type = ada_get_base_type (field_type);
7958 field_type = ada_to_fixed_type (field_type, field_valaddr,
7959 field_address, dval, 0);
7961 rtype->field (f).set_type (field_type);
7962 rtype->field (f).set_name (type->field (f).name ());
7963 /* The multiplication can potentially overflow. But because
7964 the field length has been size-checked just above, and
7965 assuming that the maximum size is a reasonable value,
7966 an overflow should not happen in practice. So rather than
7967 adding overflow recovery code to this already complex code,
7968 we just assume that it's not going to happen. */
7969 fld_bit_len = rtype->field (f).type ()->length () * TARGET_CHAR_BIT;
7973 /* Note: If this field's type is a typedef, it is important
7974 to preserve the typedef layer.
7976 Otherwise, we might be transforming a typedef to a fat
7977 pointer (encoding a pointer to an unconstrained array),
7978 into a basic fat pointer (encoding an unconstrained
7979 array). As both types are implemented using the same
7980 structure, the typedef is the only clue which allows us
7981 to distinguish between the two options. Stripping it
7982 would prevent us from printing this field appropriately. */
7983 rtype->field (f).set_type (type->field (f).type ());
7984 rtype->field (f).set_name (type->field (f).name ());
7985 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7987 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7990 struct type *field_type = type->field (f).type ();
7992 /* We need to be careful of typedefs when computing
7993 the length of our field. If this is a typedef,
7994 get the length of the target type, not the length
7996 if (field_type->code () == TYPE_CODE_TYPEDEF)
7997 field_type = ada_typedef_target_type (field_type);
8000 ada_check_typedef (field_type)->length () * TARGET_CHAR_BIT;
8003 if (off + fld_bit_len > bit_len)
8004 bit_len = off + fld_bit_len;
8006 rtype->set_length (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8009 /* We handle the variant part, if any, at the end because of certain
8010 odd cases in which it is re-ordered so as NOT to be the last field of
8011 the record. This can happen in the presence of representation
8013 if (variant_field >= 0)
8015 struct type *branch_type;
8017 off = rtype->field (variant_field).loc_bitpos ();
8021 /* Using plain value_from_contents_and_address here causes
8022 problems because we will end up trying to resolve a type
8023 that is currently being constructed. */
8024 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8026 rtype = value_type (dval);
8032 to_fixed_variant_branch_type
8033 (type->field (variant_field).type (),
8034 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8035 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8036 if (branch_type == NULL)
8038 for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8039 rtype->field (f - 1) = rtype->field (f);
8040 rtype->set_num_fields (rtype->num_fields () - 1);
8044 rtype->field (variant_field).set_type (branch_type);
8045 rtype->field (variant_field).set_name ("S");
8047 rtype->field (variant_field).type ()->length () * TARGET_CHAR_BIT;
8048 if (off + fld_bit_len > bit_len)
8049 bit_len = off + fld_bit_len;
8052 (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8056 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8057 should contain the alignment of that record, which should be a strictly
8058 positive value. If null or negative, then something is wrong, most
8059 probably in the debug info. In that case, we don't round up the size
8060 of the resulting type. If this record is not part of another structure,
8061 the current RTYPE length might be good enough for our purposes. */
8062 if (type->length () <= 0)
8065 warning (_("Invalid type size for `%s' detected: %s."),
8066 rtype->name (), pulongest (type->length ()));
8068 warning (_("Invalid type size for <unnamed> detected: %s."),
8069 pulongest (type->length ()));
8072 rtype->set_length (align_up (rtype->length (), type->length ()));
8077 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8080 static struct type *
8081 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8082 CORE_ADDR address, struct value *dval0)
8084 return ada_template_to_fixed_record_type_1 (type, valaddr,
8088 /* An ordinary record type in which ___XVL-convention fields and
8089 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8090 static approximations, containing all possible fields. Uses
8091 no runtime values. Useless for use in values, but that's OK,
8092 since the results are used only for type determinations. Works on both
8093 structs and unions. Representation note: to save space, we memorize
8094 the result of this function in the type::target_type of the
8097 static struct type *
8098 template_to_static_fixed_type (struct type *type0)
8104 /* No need no do anything if the input type is already fixed. */
8105 if (type0->is_fixed_instance ())
8108 /* Likewise if we already have computed the static approximation. */
8109 if (type0->target_type () != NULL)
8110 return type0->target_type ();
8112 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8114 nfields = type0->num_fields ();
8116 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8117 recompute all over next time. */
8118 type0->set_target_type (type);
8120 for (f = 0; f < nfields; f += 1)
8122 struct type *field_type = type0->field (f).type ();
8123 struct type *new_type;
8125 if (is_dynamic_field (type0, f))
8127 field_type = ada_check_typedef (field_type);
8128 new_type = to_static_fixed_type (field_type->target_type ());
8131 new_type = static_unwrap_type (field_type);
8133 if (new_type != field_type)
8135 /* Clone TYPE0 only the first time we get a new field type. */
8138 type = alloc_type_copy (type0);
8139 type0->set_target_type (type);
8140 type->set_code (type0->code ());
8141 INIT_NONE_SPECIFIC (type);
8142 type->set_num_fields (nfields);
8146 TYPE_ALLOC (type, nfields * sizeof (struct field)));
8147 memcpy (fields, type0->fields (),
8148 sizeof (struct field) * nfields);
8149 type->set_fields (fields);
8151 type->set_name (ada_type_name (type0));
8152 type->set_is_fixed_instance (true);
8153 type->set_length (0);
8155 type->field (f).set_type (new_type);
8156 type->field (f).set_name (type0->field (f).name ());
8163 /* Given an object of type TYPE whose contents are at VALADDR and
8164 whose address in memory is ADDRESS, returns a revision of TYPE,
8165 which should be a non-dynamic-sized record, in which the variant
8166 part, if any, is replaced with the appropriate branch. Looks
8167 for discriminant values in DVAL0, which can be NULL if the record
8168 contains the necessary discriminant values. */
8170 static struct type *
8171 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8172 CORE_ADDR address, struct value *dval0)
8176 struct type *branch_type;
8177 int nfields = type->num_fields ();
8178 int variant_field = variant_field_index (type);
8180 if (variant_field == -1)
8183 scoped_value_mark mark;
8186 dval = value_from_contents_and_address (type, valaddr, address);
8187 type = value_type (dval);
8192 rtype = alloc_type_copy (type);
8193 rtype->set_code (TYPE_CODE_STRUCT);
8194 INIT_NONE_SPECIFIC (rtype);
8195 rtype->set_num_fields (nfields);
8198 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8199 memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8200 rtype->set_fields (fields);
8202 rtype->set_name (ada_type_name (type));
8203 rtype->set_is_fixed_instance (true);
8204 rtype->set_length (type->length ());
8206 branch_type = to_fixed_variant_branch_type
8207 (type->field (variant_field).type (),
8208 cond_offset_host (valaddr,
8209 type->field (variant_field).loc_bitpos ()
8211 cond_offset_target (address,
8212 type->field (variant_field).loc_bitpos ()
8213 / TARGET_CHAR_BIT), dval);
8214 if (branch_type == NULL)
8218 for (f = variant_field + 1; f < nfields; f += 1)
8219 rtype->field (f - 1) = rtype->field (f);
8220 rtype->set_num_fields (rtype->num_fields () - 1);
8224 rtype->field (variant_field).set_type (branch_type);
8225 rtype->field (variant_field).set_name ("S");
8226 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8227 rtype->set_length (rtype->length () + branch_type->length ());
8230 rtype->set_length (rtype->length ()
8231 - type->field (variant_field).type ()->length ());
8236 /* An ordinary record type (with fixed-length fields) that describes
8237 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8238 beginning of this section]. Any necessary discriminants' values
8239 should be in DVAL, a record value; it may be NULL if the object
8240 at ADDR itself contains any necessary discriminant values.
8241 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8242 values from the record are needed. Except in the case that DVAL,
8243 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8244 unchecked) is replaced by a particular branch of the variant.
8246 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8247 is questionable and may be removed. It can arise during the
8248 processing of an unconstrained-array-of-record type where all the
8249 variant branches have exactly the same size. This is because in
8250 such cases, the compiler does not bother to use the XVS convention
8251 when encoding the record. I am currently dubious of this
8252 shortcut and suspect the compiler should be altered. FIXME. */
8254 static struct type *
8255 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8256 CORE_ADDR address, struct value *dval)
8258 struct type *templ_type;
8260 if (type0->is_fixed_instance ())
8263 templ_type = dynamic_template_type (type0);
8265 if (templ_type != NULL)
8266 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8267 else if (variant_field_index (type0) >= 0)
8269 if (dval == NULL && valaddr == NULL && address == 0)
8271 return to_record_with_fixed_variant_part (type0, valaddr, address,
8276 type0->set_is_fixed_instance (true);
8282 /* An ordinary record type (with fixed-length fields) that describes
8283 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8284 union type. Any necessary discriminants' values should be in DVAL,
8285 a record value. That is, this routine selects the appropriate
8286 branch of the union at ADDR according to the discriminant value
8287 indicated in the union's type name. Returns VAR_TYPE0 itself if
8288 it represents a variant subject to a pragma Unchecked_Union. */
8290 static struct type *
8291 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8292 CORE_ADDR address, struct value *dval)
8295 struct type *templ_type;
8296 struct type *var_type;
8298 if (var_type0->code () == TYPE_CODE_PTR)
8299 var_type = var_type0->target_type ();
8301 var_type = var_type0;
8303 templ_type = ada_find_parallel_type (var_type, "___XVU");
8305 if (templ_type != NULL)
8306 var_type = templ_type;
8308 if (is_unchecked_variant (var_type, value_type (dval)))
8310 which = ada_which_variant_applies (var_type, dval);
8313 return empty_record (var_type);
8314 else if (is_dynamic_field (var_type, which))
8315 return to_fixed_record_type
8316 (var_type->field (which).type ()->target_type(), valaddr, address, dval);
8317 else if (variant_field_index (var_type->field (which).type ()) >= 0)
8319 to_fixed_record_type
8320 (var_type->field (which).type (), valaddr, address, dval);
8322 return var_type->field (which).type ();
8325 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8326 ENCODING_TYPE, a type following the GNAT conventions for discrete
8327 type encodings, only carries redundant information. */
8330 ada_is_redundant_range_encoding (struct type *range_type,
8331 struct type *encoding_type)
8333 const char *bounds_str;
8337 gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8339 if (get_base_type (range_type)->code ()
8340 != get_base_type (encoding_type)->code ())
8342 /* The compiler probably used a simple base type to describe
8343 the range type instead of the range's actual base type,
8344 expecting us to get the real base type from the encoding
8345 anyway. In this situation, the encoding cannot be ignored
8350 if (is_dynamic_type (range_type))
8353 if (encoding_type->name () == NULL)
8356 bounds_str = strstr (encoding_type->name (), "___XDLU_");
8357 if (bounds_str == NULL)
8360 n = 8; /* Skip "___XDLU_". */
8361 if (!ada_scan_number (bounds_str, n, &lo, &n))
8363 if (range_type->bounds ()->low.const_val () != lo)
8366 n += 2; /* Skip the "__" separator between the two bounds. */
8367 if (!ada_scan_number (bounds_str, n, &hi, &n))
8369 if (range_type->bounds ()->high.const_val () != hi)
8375 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8376 a type following the GNAT encoding for describing array type
8377 indices, only carries redundant information. */
8380 ada_is_redundant_index_type_desc (struct type *array_type,
8381 struct type *desc_type)
8383 struct type *this_layer = check_typedef (array_type);
8386 for (i = 0; i < desc_type->num_fields (); i++)
8388 if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8389 desc_type->field (i).type ()))
8391 this_layer = check_typedef (this_layer->target_type ());
8397 /* Assuming that TYPE0 is an array type describing the type of a value
8398 at ADDR, and that DVAL describes a record containing any
8399 discriminants used in TYPE0, returns a type for the value that
8400 contains no dynamic components (that is, no components whose sizes
8401 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8402 true, gives an error message if the resulting type's size is over
8405 static struct type *
8406 to_fixed_array_type (struct type *type0, struct value *dval,
8409 struct type *index_type_desc;
8410 struct type *result;
8411 int constrained_packed_array_p;
8412 static const char *xa_suffix = "___XA";
8414 type0 = ada_check_typedef (type0);
8415 if (type0->is_fixed_instance ())
8418 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8419 if (constrained_packed_array_p)
8421 type0 = decode_constrained_packed_array_type (type0);
8422 if (type0 == nullptr)
8423 error (_("could not decode constrained packed array type"));
8426 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8428 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8429 encoding suffixed with 'P' may still be generated. If so,
8430 it should be used to find the XA type. */
8432 if (index_type_desc == NULL)
8434 const char *type_name = ada_type_name (type0);
8436 if (type_name != NULL)
8438 const int len = strlen (type_name);
8439 char *name = (char *) alloca (len + strlen (xa_suffix));
8441 if (type_name[len - 1] == 'P')
8443 strcpy (name, type_name);
8444 strcpy (name + len - 1, xa_suffix);
8445 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8450 ada_fixup_array_indexes_type (index_type_desc);
8451 if (index_type_desc != NULL
8452 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8454 /* Ignore this ___XA parallel type, as it does not bring any
8455 useful information. This allows us to avoid creating fixed
8456 versions of the array's index types, which would be identical
8457 to the original ones. This, in turn, can also help avoid
8458 the creation of fixed versions of the array itself. */
8459 index_type_desc = NULL;
8462 if (index_type_desc == NULL)
8464 struct type *elt_type0 = ada_check_typedef (type0->target_type ());
8466 /* NOTE: elt_type---the fixed version of elt_type0---should never
8467 depend on the contents of the array in properly constructed
8469 /* Create a fixed version of the array element type.
8470 We're not providing the address of an element here,
8471 and thus the actual object value cannot be inspected to do
8472 the conversion. This should not be a problem, since arrays of
8473 unconstrained objects are not allowed. In particular, all
8474 the elements of an array of a tagged type should all be of
8475 the same type specified in the debugging info. No need to
8476 consult the object tag. */
8477 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8479 /* Make sure we always create a new array type when dealing with
8480 packed array types, since we're going to fix-up the array
8481 type length and element bitsize a little further down. */
8482 if (elt_type0 == elt_type && !constrained_packed_array_p)
8485 result = create_array_type (alloc_type_copy (type0),
8486 elt_type, type0->index_type ());
8491 struct type *elt_type0;
8494 for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8495 elt_type0 = elt_type0->target_type ();
8497 /* NOTE: result---the fixed version of elt_type0---should never
8498 depend on the contents of the array in properly constructed
8500 /* Create a fixed version of the array element type.
8501 We're not providing the address of an element here,
8502 and thus the actual object value cannot be inspected to do
8503 the conversion. This should not be a problem, since arrays of
8504 unconstrained objects are not allowed. In particular, all
8505 the elements of an array of a tagged type should all be of
8506 the same type specified in the debugging info. No need to
8507 consult the object tag. */
8509 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8512 for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8514 struct type *range_type =
8515 to_fixed_range_type (index_type_desc->field (i).type (), dval);
8517 result = create_array_type (alloc_type_copy (elt_type0),
8518 result, range_type);
8519 elt_type0 = elt_type0->target_type ();
8523 /* We want to preserve the type name. This can be useful when
8524 trying to get the type name of a value that has already been
8525 printed (for instance, if the user did "print VAR; whatis $". */
8526 result->set_name (type0->name ());
8528 if (constrained_packed_array_p)
8530 /* So far, the resulting type has been created as if the original
8531 type was a regular (non-packed) array type. As a result, the
8532 bitsize of the array elements needs to be set again, and the array
8533 length needs to be recomputed based on that bitsize. */
8534 int len = result->length () / result->target_type ()->length ();
8535 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8537 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8538 result->set_length (len * elt_bitsize / HOST_CHAR_BIT);
8539 if (result->length () * HOST_CHAR_BIT < len * elt_bitsize)
8540 result->set_length (result->length () + 1);
8543 result->set_is_fixed_instance (true);
8548 /* A standard type (containing no dynamically sized components)
8549 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8550 DVAL describes a record containing any discriminants used in TYPE0,
8551 and may be NULL if there are none, or if the object of type TYPE at
8552 ADDRESS or in VALADDR contains these discriminants.
8554 If CHECK_TAG is not null, in the case of tagged types, this function
8555 attempts to locate the object's tag and use it to compute the actual
8556 type. However, when ADDRESS is null, we cannot use it to determine the
8557 location of the tag, and therefore compute the tagged type's actual type.
8558 So we return the tagged type without consulting the tag. */
8560 static struct type *
8561 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8562 CORE_ADDR address, struct value *dval, int check_tag)
8564 type = ada_check_typedef (type);
8566 /* Only un-fixed types need to be handled here. */
8567 if (!HAVE_GNAT_AUX_INFO (type))
8570 switch (type->code ())
8574 case TYPE_CODE_STRUCT:
8576 struct type *static_type = to_static_fixed_type (type);
8577 struct type *fixed_record_type =
8578 to_fixed_record_type (type, valaddr, address, NULL);
8580 /* If STATIC_TYPE is a tagged type and we know the object's address,
8581 then we can determine its tag, and compute the object's actual
8582 type from there. Note that we have to use the fixed record
8583 type (the parent part of the record may have dynamic fields
8584 and the way the location of _tag is expressed may depend on
8587 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8590 value_tag_from_contents_and_address
8594 struct type *real_type = type_from_tag (tag);
8596 value_from_contents_and_address (fixed_record_type,
8599 fixed_record_type = value_type (obj);
8600 if (real_type != NULL)
8601 return to_fixed_record_type
8603 value_address (ada_tag_value_at_base_address (obj)), NULL);
8606 /* Check to see if there is a parallel ___XVZ variable.
8607 If there is, then it provides the actual size of our type. */
8608 else if (ada_type_name (fixed_record_type) != NULL)
8610 const char *name = ada_type_name (fixed_record_type);
8612 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8613 bool xvz_found = false;
8616 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8619 xvz_found = get_int_var_value (xvz_name, size);
8621 catch (const gdb_exception_error &except)
8623 /* We found the variable, but somehow failed to read
8624 its value. Rethrow the same error, but with a little
8625 bit more information, to help the user understand
8626 what went wrong (Eg: the variable might have been
8628 throw_error (except.error,
8629 _("unable to read value of %s (%s)"),
8630 xvz_name, except.what ());
8633 if (xvz_found && fixed_record_type->length () != size)
8635 fixed_record_type = copy_type (fixed_record_type);
8636 fixed_record_type->set_length (size);
8638 /* The FIXED_RECORD_TYPE may have be a stub. We have
8639 observed this when the debugging info is STABS, and
8640 apparently it is something that is hard to fix.
8642 In practice, we don't need the actual type definition
8643 at all, because the presence of the XVZ variable allows us
8644 to assume that there must be a XVS type as well, which we
8645 should be able to use later, when we need the actual type
8648 In the meantime, pretend that the "fixed" type we are
8649 returning is NOT a stub, because this can cause trouble
8650 when using this type to create new types targeting it.
8651 Indeed, the associated creation routines often check
8652 whether the target type is a stub and will try to replace
8653 it, thus using a type with the wrong size. This, in turn,
8654 might cause the new type to have the wrong size too.
8655 Consider the case of an array, for instance, where the size
8656 of the array is computed from the number of elements in
8657 our array multiplied by the size of its element. */
8658 fixed_record_type->set_is_stub (false);
8661 return fixed_record_type;
8663 case TYPE_CODE_ARRAY:
8664 return to_fixed_array_type (type, dval, 1);
8665 case TYPE_CODE_UNION:
8669 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8673 /* The same as ada_to_fixed_type_1, except that it preserves the type
8674 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8676 The typedef layer needs be preserved in order to differentiate between
8677 arrays and array pointers when both types are implemented using the same
8678 fat pointer. In the array pointer case, the pointer is encoded as
8679 a typedef of the pointer type. For instance, considering:
8681 type String_Access is access String;
8682 S1 : String_Access := null;
8684 To the debugger, S1 is defined as a typedef of type String. But
8685 to the user, it is a pointer. So if the user tries to print S1,
8686 we should not dereference the array, but print the array address
8689 If we didn't preserve the typedef layer, we would lose the fact that
8690 the type is to be presented as a pointer (needs de-reference before
8691 being printed). And we would also use the source-level type name. */
8694 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8695 CORE_ADDR address, struct value *dval, int check_tag)
8698 struct type *fixed_type =
8699 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8701 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8702 then preserve the typedef layer.
8704 Implementation note: We can only check the main-type portion of
8705 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8706 from TYPE now returns a type that has the same instance flags
8707 as TYPE. For instance, if TYPE is a "typedef const", and its
8708 target type is a "struct", then the typedef elimination will return
8709 a "const" version of the target type. See check_typedef for more
8710 details about how the typedef layer elimination is done.
8712 brobecker/2010-11-19: It seems to me that the only case where it is
8713 useful to preserve the typedef layer is when dealing with fat pointers.
8714 Perhaps, we could add a check for that and preserve the typedef layer
8715 only in that situation. But this seems unnecessary so far, probably
8716 because we call check_typedef/ada_check_typedef pretty much everywhere.
8718 if (type->code () == TYPE_CODE_TYPEDEF
8719 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8720 == TYPE_MAIN_TYPE (fixed_type)))
8726 /* A standard (static-sized) type corresponding as well as possible to
8727 TYPE0, but based on no runtime data. */
8729 static struct type *
8730 to_static_fixed_type (struct type *type0)
8737 if (type0->is_fixed_instance ())
8740 type0 = ada_check_typedef (type0);
8742 switch (type0->code ())
8746 case TYPE_CODE_STRUCT:
8747 type = dynamic_template_type (type0);
8749 return template_to_static_fixed_type (type);
8751 return template_to_static_fixed_type (type0);
8752 case TYPE_CODE_UNION:
8753 type = ada_find_parallel_type (type0, "___XVU");
8755 return template_to_static_fixed_type (type);
8757 return template_to_static_fixed_type (type0);
8761 /* A static approximation of TYPE with all type wrappers removed. */
8763 static struct type *
8764 static_unwrap_type (struct type *type)
8766 if (ada_is_aligner_type (type))
8768 struct type *type1 = ada_check_typedef (type)->field (0).type ();
8769 if (ada_type_name (type1) == NULL)
8770 type1->set_name (ada_type_name (type));
8772 return static_unwrap_type (type1);
8776 struct type *raw_real_type = ada_get_base_type (type);
8778 if (raw_real_type == type)
8781 return to_static_fixed_type (raw_real_type);
8785 /* In some cases, incomplete and private types require
8786 cross-references that are not resolved as records (for example,
8788 type FooP is access Foo;
8790 type Foo is array ...;
8791 ). In these cases, since there is no mechanism for producing
8792 cross-references to such types, we instead substitute for FooP a
8793 stub enumeration type that is nowhere resolved, and whose tag is
8794 the name of the actual type. Call these types "non-record stubs". */
8796 /* A type equivalent to TYPE that is not a non-record stub, if one
8797 exists, otherwise TYPE. */
8800 ada_check_typedef (struct type *type)
8805 /* If our type is an access to an unconstrained array, which is encoded
8806 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8807 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8808 what allows us to distinguish between fat pointers that represent
8809 array types, and fat pointers that represent array access types
8810 (in both cases, the compiler implements them as fat pointers). */
8811 if (ada_is_access_to_unconstrained_array (type))
8814 type = check_typedef (type);
8815 if (type == NULL || type->code () != TYPE_CODE_ENUM
8816 || !type->is_stub ()
8817 || type->name () == NULL)
8821 const char *name = type->name ();
8822 struct type *type1 = ada_find_any_type (name);
8827 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8828 stubs pointing to arrays, as we don't create symbols for array
8829 types, only for the typedef-to-array types). If that's the case,
8830 strip the typedef layer. */
8831 if (type1->code () == TYPE_CODE_TYPEDEF)
8832 type1 = ada_check_typedef (type1);
8838 /* A value representing the data at VALADDR/ADDRESS as described by
8839 type TYPE0, but with a standard (static-sized) type that correctly
8840 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8841 type, then return VAL0 [this feature is simply to avoid redundant
8842 creation of struct values]. */
8844 static struct value *
8845 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8848 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8850 if (type == type0 && val0 != NULL)
8853 if (VALUE_LVAL (val0) != lval_memory)
8855 /* Our value does not live in memory; it could be a convenience
8856 variable, for instance. Create a not_lval value using val0's
8858 return value_from_contents (type, value_contents (val0).data ());
8861 return value_from_contents_and_address (type, 0, address);
8864 /* A value representing VAL, but with a standard (static-sized) type
8865 that correctly describes it. Does not necessarily create a new
8869 ada_to_fixed_value (struct value *val)
8871 val = unwrap_value (val);
8872 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8879 /* Table mapping attribute numbers to names.
8880 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8882 static const char * const attribute_names[] = {
8900 ada_attribute_name (enum exp_opcode n)
8902 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8903 return attribute_names[n - OP_ATR_FIRST + 1];
8905 return attribute_names[0];
8908 /* Evaluate the 'POS attribute applied to ARG. */
8911 pos_atr (struct value *arg)
8913 struct value *val = coerce_ref (arg);
8914 struct type *type = value_type (val);
8916 if (!discrete_type_p (type))
8917 error (_("'POS only defined on discrete types"));
8919 gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8920 if (!result.has_value ())
8921 error (_("enumeration value is invalid: can't find 'POS"));
8927 ada_pos_atr (struct type *expect_type,
8928 struct expression *exp,
8929 enum noside noside, enum exp_opcode op,
8932 struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8933 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8934 return value_zero (type, not_lval);
8935 return value_from_longest (type, pos_atr (arg));
8938 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8940 static struct value *
8941 val_atr (struct type *type, LONGEST val)
8943 gdb_assert (discrete_type_p (type));
8944 if (type->code () == TYPE_CODE_RANGE)
8945 type = type->target_type ();
8946 if (type->code () == TYPE_CODE_ENUM)
8948 if (val < 0 || val >= type->num_fields ())
8949 error (_("argument to 'VAL out of range"));
8950 val = type->field (val).loc_enumval ();
8952 return value_from_longest (type, val);
8956 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8958 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8959 return value_zero (type, not_lval);
8961 if (!discrete_type_p (type))
8962 error (_("'VAL only defined on discrete types"));
8963 if (!integer_type_p (value_type (arg)))
8964 error (_("'VAL requires integral argument"));
8966 return val_atr (type, value_as_long (arg));
8972 /* True if TYPE appears to be an Ada character type.
8973 [At the moment, this is true only for Character and Wide_Character;
8974 It is a heuristic test that could stand improvement]. */
8977 ada_is_character_type (struct type *type)
8981 /* If the type code says it's a character, then assume it really is,
8982 and don't check any further. */
8983 if (type->code () == TYPE_CODE_CHAR)
8986 /* Otherwise, assume it's a character type iff it is a discrete type
8987 with a known character type name. */
8988 name = ada_type_name (type);
8989 return (name != NULL
8990 && (type->code () == TYPE_CODE_INT
8991 || type->code () == TYPE_CODE_RANGE)
8992 && (strcmp (name, "character") == 0
8993 || strcmp (name, "wide_character") == 0
8994 || strcmp (name, "wide_wide_character") == 0
8995 || strcmp (name, "unsigned char") == 0));
8998 /* True if TYPE appears to be an Ada string type. */
9001 ada_is_string_type (struct type *type)
9003 type = ada_check_typedef (type);
9005 && type->code () != TYPE_CODE_PTR
9006 && (ada_is_simple_array_type (type)
9007 || ada_is_array_descriptor_type (type))
9008 && ada_array_arity (type) == 1)
9010 struct type *elttype = ada_array_element_type (type, 1);
9012 return ada_is_character_type (elttype);
9018 /* The compiler sometimes provides a parallel XVS type for a given
9019 PAD type. Normally, it is safe to follow the PAD type directly,
9020 but older versions of the compiler have a bug that causes the offset
9021 of its "F" field to be wrong. Following that field in that case
9022 would lead to incorrect results, but this can be worked around
9023 by ignoring the PAD type and using the associated XVS type instead.
9025 Set to True if the debugger should trust the contents of PAD types.
9026 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9027 static bool trust_pad_over_xvs = true;
9029 /* True if TYPE is a struct type introduced by the compiler to force the
9030 alignment of a value. Such types have a single field with a
9031 distinctive name. */
9034 ada_is_aligner_type (struct type *type)
9036 type = ada_check_typedef (type);
9038 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9041 return (type->code () == TYPE_CODE_STRUCT
9042 && type->num_fields () == 1
9043 && strcmp (type->field (0).name (), "F") == 0);
9046 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9047 the parallel type. */
9050 ada_get_base_type (struct type *raw_type)
9052 struct type *real_type_namer;
9053 struct type *raw_real_type;
9055 if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9058 if (ada_is_aligner_type (raw_type))
9059 /* The encoding specifies that we should always use the aligner type.
9060 So, even if this aligner type has an associated XVS type, we should
9063 According to the compiler gurus, an XVS type parallel to an aligner
9064 type may exist because of a stabs limitation. In stabs, aligner
9065 types are empty because the field has a variable-sized type, and
9066 thus cannot actually be used as an aligner type. As a result,
9067 we need the associated parallel XVS type to decode the type.
9068 Since the policy in the compiler is to not change the internal
9069 representation based on the debugging info format, we sometimes
9070 end up having a redundant XVS type parallel to the aligner type. */
9073 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9074 if (real_type_namer == NULL
9075 || real_type_namer->code () != TYPE_CODE_STRUCT
9076 || real_type_namer->num_fields () != 1)
9079 if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9081 /* This is an older encoding form where the base type needs to be
9082 looked up by name. We prefer the newer encoding because it is
9084 raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9085 if (raw_real_type == NULL)
9088 return raw_real_type;
9091 /* The field in our XVS type is a reference to the base type. */
9092 return real_type_namer->field (0).type ()->target_type ();
9095 /* The type of value designated by TYPE, with all aligners removed. */
9098 ada_aligned_type (struct type *type)
9100 if (ada_is_aligner_type (type))
9101 return ada_aligned_type (type->field (0).type ());
9103 return ada_get_base_type (type);
9107 /* The address of the aligned value in an object at address VALADDR
9108 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9111 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9113 if (ada_is_aligner_type (type))
9114 return ada_aligned_value_addr
9115 (type->field (0).type (),
9116 valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9123 /* The printed representation of an enumeration literal with encoded
9124 name NAME. The value is good to the next call of ada_enum_name. */
9126 ada_enum_name (const char *name)
9128 static std::string storage;
9131 /* First, unqualify the enumeration name:
9132 1. Search for the last '.' character. If we find one, then skip
9133 all the preceding characters, the unqualified name starts
9134 right after that dot.
9135 2. Otherwise, we may be debugging on a target where the compiler
9136 translates dots into "__". Search forward for double underscores,
9137 but stop searching when we hit an overloading suffix, which is
9138 of the form "__" followed by digits. */
9140 tmp = strrchr (name, '.');
9145 while ((tmp = strstr (name, "__")) != NULL)
9147 if (isdigit (tmp[2]))
9158 if (name[1] == 'U' || name[1] == 'W')
9161 if (name[1] == 'W' && name[2] == 'W')
9163 /* Also handle the QWW case. */
9166 if (sscanf (name + offset, "%x", &v) != 1)
9169 else if (((name[1] >= '0' && name[1] <= '9')
9170 || (name[1] >= 'a' && name[1] <= 'z'))
9173 storage = string_printf ("'%c'", name[1]);
9174 return storage.c_str ();
9179 if (isascii (v) && isprint (v))
9180 storage = string_printf ("'%c'", v);
9181 else if (name[1] == 'U')
9182 storage = string_printf ("'[\"%02x\"]'", v);
9183 else if (name[2] != 'W')
9184 storage = string_printf ("'[\"%04x\"]'", v);
9186 storage = string_printf ("'[\"%06x\"]'", v);
9188 return storage.c_str ();
9192 tmp = strstr (name, "__");
9194 tmp = strstr (name, "$");
9197 storage = std::string (name, tmp - name);
9198 return storage.c_str ();
9205 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9208 static struct value *
9209 unwrap_value (struct value *val)
9211 struct type *type = ada_check_typedef (value_type (val));
9213 if (ada_is_aligner_type (type))
9215 struct value *v = ada_value_struct_elt (val, "F", 0);
9216 struct type *val_type = ada_check_typedef (value_type (v));
9218 if (ada_type_name (val_type) == NULL)
9219 val_type->set_name (ada_type_name (type));
9221 return unwrap_value (v);
9225 struct type *raw_real_type =
9226 ada_check_typedef (ada_get_base_type (type));
9228 /* If there is no parallel XVS or XVE type, then the value is
9229 already unwrapped. Return it without further modification. */
9230 if ((type == raw_real_type)
9231 && ada_find_parallel_type (type, "___XVE") == NULL)
9235 coerce_unspec_val_to_type
9236 (val, ada_to_fixed_type (raw_real_type, 0,
9237 value_address (val),
9242 /* Given two array types T1 and T2, return nonzero iff both arrays
9243 contain the same number of elements. */
9246 ada_same_array_size_p (struct type *t1, struct type *t2)
9248 LONGEST lo1, hi1, lo2, hi2;
9250 /* Get the array bounds in order to verify that the size of
9251 the two arrays match. */
9252 if (!get_array_bounds (t1, &lo1, &hi1)
9253 || !get_array_bounds (t2, &lo2, &hi2))
9254 error (_("unable to determine array bounds"));
9256 /* To make things easier for size comparison, normalize a bit
9257 the case of empty arrays by making sure that the difference
9258 between upper bound and lower bound is always -1. */
9264 return (hi1 - lo1 == hi2 - lo2);
9267 /* Assuming that VAL is an array of integrals, and TYPE represents
9268 an array with the same number of elements, but with wider integral
9269 elements, return an array "casted" to TYPE. In practice, this
9270 means that the returned array is built by casting each element
9271 of the original array into TYPE's (wider) element type. */
9273 static struct value *
9274 ada_promote_array_of_integrals (struct type *type, struct value *val)
9276 struct type *elt_type = type->target_type ();
9280 /* Verify that both val and type are arrays of scalars, and
9281 that the size of val's elements is smaller than the size
9282 of type's element. */
9283 gdb_assert (type->code () == TYPE_CODE_ARRAY);
9284 gdb_assert (is_integral_type (type->target_type ()));
9285 gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9286 gdb_assert (is_integral_type (value_type (val)->target_type ()));
9287 gdb_assert (type->target_type ()->length ()
9288 > value_type (val)->target_type ()->length ());
9290 if (!get_array_bounds (type, &lo, &hi))
9291 error (_("unable to determine array bounds"));
9293 value *res = allocate_value (type);
9294 gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9296 /* Promote each array element. */
9297 for (i = 0; i < hi - lo + 1; i++)
9299 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9300 int elt_len = elt_type->length ();
9302 copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9308 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9309 return the converted value. */
9311 static struct value *
9312 coerce_for_assign (struct type *type, struct value *val)
9314 struct type *type2 = value_type (val);
9319 type2 = ada_check_typedef (type2);
9320 type = ada_check_typedef (type);
9322 if (type2->code () == TYPE_CODE_PTR
9323 && type->code () == TYPE_CODE_ARRAY)
9325 val = ada_value_ind (val);
9326 type2 = value_type (val);
9329 if (type2->code () == TYPE_CODE_ARRAY
9330 && type->code () == TYPE_CODE_ARRAY)
9332 if (!ada_same_array_size_p (type, type2))
9333 error (_("cannot assign arrays of different length"));
9335 if (is_integral_type (type->target_type ())
9336 && is_integral_type (type2->target_type ())
9337 && type2->target_type ()->length () < type->target_type ()->length ())
9339 /* Allow implicit promotion of the array elements to
9341 return ada_promote_array_of_integrals (type, val);
9344 if (type2->target_type ()->length () != type->target_type ()->length ())
9345 error (_("Incompatible types in assignment"));
9346 deprecated_set_value_type (val, type);
9351 static struct value *
9352 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9355 struct type *type1, *type2;
9358 arg1 = coerce_ref (arg1);
9359 arg2 = coerce_ref (arg2);
9360 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9361 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9363 if (type1->code () != TYPE_CODE_INT
9364 || type2->code () != TYPE_CODE_INT)
9365 return value_binop (arg1, arg2, op);
9374 return value_binop (arg1, arg2, op);
9377 v2 = value_as_long (arg2);
9381 if (op == BINOP_MOD)
9383 else if (op == BINOP_DIV)
9387 gdb_assert (op == BINOP_REM);
9391 error (_("second operand of %s must not be zero."), name);
9394 if (type1->is_unsigned () || op == BINOP_MOD)
9395 return value_binop (arg1, arg2, op);
9397 v1 = value_as_long (arg1);
9402 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9403 v += v > 0 ? -1 : 1;
9411 /* Should not reach this point. */
9415 val = allocate_value (type1);
9416 store_unsigned_integer (value_contents_raw (val).data (),
9417 value_type (val)->length (),
9418 type_byte_order (type1), v);
9423 ada_value_equal (struct value *arg1, struct value *arg2)
9425 if (ada_is_direct_array_type (value_type (arg1))
9426 || ada_is_direct_array_type (value_type (arg2)))
9428 struct type *arg1_type, *arg2_type;
9430 /* Automatically dereference any array reference before
9431 we attempt to perform the comparison. */
9432 arg1 = ada_coerce_ref (arg1);
9433 arg2 = ada_coerce_ref (arg2);
9435 arg1 = ada_coerce_to_simple_array (arg1);
9436 arg2 = ada_coerce_to_simple_array (arg2);
9438 arg1_type = ada_check_typedef (value_type (arg1));
9439 arg2_type = ada_check_typedef (value_type (arg2));
9441 if (arg1_type->code () != TYPE_CODE_ARRAY
9442 || arg2_type->code () != TYPE_CODE_ARRAY)
9443 error (_("Attempt to compare array with non-array"));
9444 /* FIXME: The following works only for types whose
9445 representations use all bits (no padding or undefined bits)
9446 and do not have user-defined equality. */
9447 return (arg1_type->length () == arg2_type->length ()
9448 && memcmp (value_contents (arg1).data (),
9449 value_contents (arg2).data (),
9450 arg1_type->length ()) == 0);
9452 return value_equal (arg1, arg2);
9459 check_objfile (const std::unique_ptr<ada_component> &comp,
9460 struct objfile *objfile)
9462 return comp->uses_objfile (objfile);
9465 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9466 component of LHS (a simple array or a record). Does not modify the
9467 inferior's memory, nor does it modify LHS (unless LHS ==
9471 assign_component (struct value *container, struct value *lhs, LONGEST index,
9472 struct expression *exp, operation_up &arg)
9474 scoped_value_mark mark;
9477 struct type *lhs_type = check_typedef (value_type (lhs));
9479 if (lhs_type->code () == TYPE_CODE_ARRAY)
9481 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9482 struct value *index_val = value_from_longest (index_type, index);
9484 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9488 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9489 elt = ada_to_fixed_value (elt);
9492 ada_aggregate_operation *ag_op
9493 = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9494 if (ag_op != nullptr)
9495 ag_op->assign_aggregate (container, elt, exp);
9497 value_assign_to_component (container, elt,
9498 arg->evaluate (nullptr, exp,
9503 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9505 for (const auto &item : m_components)
9506 if (item->uses_objfile (objfile))
9512 ada_aggregate_component::dump (ui_file *stream, int depth)
9514 gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9515 for (const auto &item : m_components)
9516 item->dump (stream, depth + 1);
9520 ada_aggregate_component::assign (struct value *container,
9521 struct value *lhs, struct expression *exp,
9522 std::vector<LONGEST> &indices,
9523 LONGEST low, LONGEST high)
9525 for (auto &item : m_components)
9526 item->assign (container, lhs, exp, indices, low, high);
9529 /* See ada-exp.h. */
9532 ada_aggregate_operation::assign_aggregate (struct value *container,
9534 struct expression *exp)
9536 struct type *lhs_type;
9537 LONGEST low_index, high_index;
9539 container = ada_coerce_ref (container);
9540 if (ada_is_direct_array_type (value_type (container)))
9541 container = ada_coerce_to_simple_array (container);
9542 lhs = ada_coerce_ref (lhs);
9543 if (!deprecated_value_modifiable (lhs))
9544 error (_("Left operand of assignment is not a modifiable lvalue."));
9546 lhs_type = check_typedef (value_type (lhs));
9547 if (ada_is_direct_array_type (lhs_type))
9549 lhs = ada_coerce_to_simple_array (lhs);
9550 lhs_type = check_typedef (value_type (lhs));
9551 low_index = lhs_type->bounds ()->low.const_val ();
9552 high_index = lhs_type->bounds ()->high.const_val ();
9554 else if (lhs_type->code () == TYPE_CODE_STRUCT)
9557 high_index = num_visible_fields (lhs_type) - 1;
9560 error (_("Left-hand side must be array or record."));
9562 std::vector<LONGEST> indices (4);
9563 indices[0] = indices[1] = low_index - 1;
9564 indices[2] = indices[3] = high_index + 1;
9566 std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9567 low_index, high_index);
9573 ada_positional_component::uses_objfile (struct objfile *objfile)
9575 return m_op->uses_objfile (objfile);
9579 ada_positional_component::dump (ui_file *stream, int depth)
9581 gdb_printf (stream, _("%*sPositional, index = %d\n"),
9582 depth, "", m_index);
9583 m_op->dump (stream, depth + 1);
9586 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9587 construct, given that the positions are relative to lower bound
9588 LOW, where HIGH is the upper bound. Record the position in
9589 INDICES. CONTAINER is as for assign_aggregate. */
9591 ada_positional_component::assign (struct value *container,
9592 struct value *lhs, struct expression *exp,
9593 std::vector<LONGEST> &indices,
9594 LONGEST low, LONGEST high)
9596 LONGEST ind = m_index + low;
9598 if (ind - 1 == high)
9599 warning (_("Extra components in aggregate ignored."));
9602 add_component_interval (ind, ind, indices);
9603 assign_component (container, lhs, ind, exp, m_op);
9608 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9610 return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9614 ada_discrete_range_association::dump (ui_file *stream, int depth)
9616 gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9617 m_low->dump (stream, depth + 1);
9618 m_high->dump (stream, depth + 1);
9622 ada_discrete_range_association::assign (struct value *container,
9624 struct expression *exp,
9625 std::vector<LONGEST> &indices,
9626 LONGEST low, LONGEST high,
9629 LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9630 LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9632 if (lower <= upper && (lower < low || upper > high))
9633 error (_("Index in component association out of bounds."));
9635 add_component_interval (lower, upper, indices);
9636 while (lower <= upper)
9638 assign_component (container, lhs, lower, exp, op);
9644 ada_name_association::uses_objfile (struct objfile *objfile)
9646 return m_val->uses_objfile (objfile);
9650 ada_name_association::dump (ui_file *stream, int depth)
9652 gdb_printf (stream, _("%*sName:\n"), depth, "");
9653 m_val->dump (stream, depth + 1);
9657 ada_name_association::assign (struct value *container,
9659 struct expression *exp,
9660 std::vector<LONGEST> &indices,
9661 LONGEST low, LONGEST high,
9666 if (ada_is_direct_array_type (value_type (lhs)))
9667 index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9671 ada_string_operation *strop
9672 = dynamic_cast<ada_string_operation *> (m_val.get ());
9675 if (strop != nullptr)
9676 name = strop->get_name ();
9679 ada_var_value_operation *vvo
9680 = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9682 error (_("Invalid record component association."));
9683 name = vvo->get_symbol ()->natural_name ();
9687 if (! find_struct_field (name, value_type (lhs), 0,
9688 NULL, NULL, NULL, NULL, &index))
9689 error (_("Unknown component name: %s."), name);
9692 add_component_interval (index, index, indices);
9693 assign_component (container, lhs, index, exp, op);
9697 ada_choices_component::uses_objfile (struct objfile *objfile)
9699 if (m_op->uses_objfile (objfile))
9701 for (const auto &item : m_assocs)
9702 if (item->uses_objfile (objfile))
9708 ada_choices_component::dump (ui_file *stream, int depth)
9710 gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9711 m_op->dump (stream, depth + 1);
9712 for (const auto &item : m_assocs)
9713 item->dump (stream, depth + 1);
9716 /* Assign into the components of LHS indexed by the OP_CHOICES
9717 construct at *POS, updating *POS past the construct, given that
9718 the allowable indices are LOW..HIGH. Record the indices assigned
9719 to in INDICES. CONTAINER is as for assign_aggregate. */
9721 ada_choices_component::assign (struct value *container,
9722 struct value *lhs, struct expression *exp,
9723 std::vector<LONGEST> &indices,
9724 LONGEST low, LONGEST high)
9726 for (auto &item : m_assocs)
9727 item->assign (container, lhs, exp, indices, low, high, m_op);
9731 ada_others_component::uses_objfile (struct objfile *objfile)
9733 return m_op->uses_objfile (objfile);
9737 ada_others_component::dump (ui_file *stream, int depth)
9739 gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9740 m_op->dump (stream, depth + 1);
9743 /* Assign the value of the expression in the OP_OTHERS construct in
9744 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9745 have not been previously assigned. The index intervals already assigned
9746 are in INDICES. CONTAINER is as for assign_aggregate. */
9748 ada_others_component::assign (struct value *container,
9749 struct value *lhs, struct expression *exp,
9750 std::vector<LONGEST> &indices,
9751 LONGEST low, LONGEST high)
9753 int num_indices = indices.size ();
9754 for (int i = 0; i < num_indices - 2; i += 2)
9756 for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9757 assign_component (container, lhs, ind, exp, m_op);
9762 ada_assign_operation::evaluate (struct type *expect_type,
9763 struct expression *exp,
9766 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9768 ada_aggregate_operation *ag_op
9769 = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9770 if (ag_op != nullptr)
9772 if (noside != EVAL_NORMAL)
9775 arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9776 return ada_value_assign (arg1, arg1);
9778 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9779 except if the lhs of our assignment is a convenience variable.
9780 In the case of assigning to a convenience variable, the lhs
9781 should be exactly the result of the evaluation of the rhs. */
9782 struct type *type = value_type (arg1);
9783 if (VALUE_LVAL (arg1) == lval_internalvar)
9785 value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9786 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9788 if (VALUE_LVAL (arg1) == lval_internalvar)
9793 arg2 = coerce_for_assign (value_type (arg1), arg2);
9794 return ada_value_assign (arg1, arg2);
9797 } /* namespace expr */
9799 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9800 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9803 add_component_interval (LONGEST low, LONGEST high,
9804 std::vector<LONGEST> &indices)
9808 int size = indices.size ();
9809 for (i = 0; i < size; i += 2) {
9810 if (high >= indices[i] && low <= indices[i + 1])
9814 for (kh = i + 2; kh < size; kh += 2)
9815 if (high < indices[kh])
9817 if (low < indices[i])
9819 indices[i + 1] = indices[kh - 1];
9820 if (high > indices[i + 1])
9821 indices[i + 1] = high;
9822 memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9823 indices.resize (kh - i - 2);
9826 else if (high < indices[i])
9830 indices.resize (indices.size () + 2);
9831 for (j = indices.size () - 1; j >= i + 2; j -= 1)
9832 indices[j] = indices[j - 2];
9834 indices[i + 1] = high;
9837 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9840 static struct value *
9841 ada_value_cast (struct type *type, struct value *arg2)
9843 if (type == ada_check_typedef (value_type (arg2)))
9846 return value_cast (type, arg2);
9849 /* Evaluating Ada expressions, and printing their result.
9850 ------------------------------------------------------
9855 We usually evaluate an Ada expression in order to print its value.
9856 We also evaluate an expression in order to print its type, which
9857 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9858 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9859 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9860 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9863 Evaluating expressions is a little more complicated for Ada entities
9864 than it is for entities in languages such as C. The main reason for
9865 this is that Ada provides types whose definition might be dynamic.
9866 One example of such types is variant records. Or another example
9867 would be an array whose bounds can only be known at run time.
9869 The following description is a general guide as to what should be
9870 done (and what should NOT be done) in order to evaluate an expression
9871 involving such types, and when. This does not cover how the semantic
9872 information is encoded by GNAT as this is covered separatly. For the
9873 document used as the reference for the GNAT encoding, see exp_dbug.ads
9874 in the GNAT sources.
9876 Ideally, we should embed each part of this description next to its
9877 associated code. Unfortunately, the amount of code is so vast right
9878 now that it's hard to see whether the code handling a particular
9879 situation might be duplicated or not. One day, when the code is
9880 cleaned up, this guide might become redundant with the comments
9881 inserted in the code, and we might want to remove it.
9883 2. ``Fixing'' an Entity, the Simple Case:
9884 -----------------------------------------
9886 When evaluating Ada expressions, the tricky issue is that they may
9887 reference entities whose type contents and size are not statically
9888 known. Consider for instance a variant record:
9890 type Rec (Empty : Boolean := True) is record
9893 when False => Value : Integer;
9896 Yes : Rec := (Empty => False, Value => 1);
9897 No : Rec := (empty => True);
9899 The size and contents of that record depends on the value of the
9900 descriminant (Rec.Empty). At this point, neither the debugging
9901 information nor the associated type structure in GDB are able to
9902 express such dynamic types. So what the debugger does is to create
9903 "fixed" versions of the type that applies to the specific object.
9904 We also informally refer to this operation as "fixing" an object,
9905 which means creating its associated fixed type.
9907 Example: when printing the value of variable "Yes" above, its fixed
9908 type would look like this:
9915 On the other hand, if we printed the value of "No", its fixed type
9922 Things become a little more complicated when trying to fix an entity
9923 with a dynamic type that directly contains another dynamic type,
9924 such as an array of variant records, for instance. There are
9925 two possible cases: Arrays, and records.
9927 3. ``Fixing'' Arrays:
9928 ---------------------
9930 The type structure in GDB describes an array in terms of its bounds,
9931 and the type of its elements. By design, all elements in the array
9932 have the same type and we cannot represent an array of variant elements
9933 using the current type structure in GDB. When fixing an array,
9934 we cannot fix the array element, as we would potentially need one
9935 fixed type per element of the array. As a result, the best we can do
9936 when fixing an array is to produce an array whose bounds and size
9937 are correct (allowing us to read it from memory), but without having
9938 touched its element type. Fixing each element will be done later,
9939 when (if) necessary.
9941 Arrays are a little simpler to handle than records, because the same
9942 amount of memory is allocated for each element of the array, even if
9943 the amount of space actually used by each element differs from element
9944 to element. Consider for instance the following array of type Rec:
9946 type Rec_Array is array (1 .. 2) of Rec;
9948 The actual amount of memory occupied by each element might be different
9949 from element to element, depending on the value of their discriminant.
9950 But the amount of space reserved for each element in the array remains
9951 fixed regardless. So we simply need to compute that size using
9952 the debugging information available, from which we can then determine
9953 the array size (we multiply the number of elements of the array by
9954 the size of each element).
9956 The simplest case is when we have an array of a constrained element
9957 type. For instance, consider the following type declarations:
9959 type Bounded_String (Max_Size : Integer) is
9961 Buffer : String (1 .. Max_Size);
9963 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9965 In this case, the compiler describes the array as an array of
9966 variable-size elements (identified by its XVS suffix) for which
9967 the size can be read in the parallel XVZ variable.
9969 In the case of an array of an unconstrained element type, the compiler
9970 wraps the array element inside a private PAD type. This type should not
9971 be shown to the user, and must be "unwrap"'ed before printing. Note
9972 that we also use the adjective "aligner" in our code to designate
9973 these wrapper types.
9975 In some cases, the size allocated for each element is statically
9976 known. In that case, the PAD type already has the correct size,
9977 and the array element should remain unfixed.
9979 But there are cases when this size is not statically known.
9980 For instance, assuming that "Five" is an integer variable:
9982 type Dynamic is array (1 .. Five) of Integer;
9983 type Wrapper (Has_Length : Boolean := False) is record
9986 when True => Length : Integer;
9990 type Wrapper_Array is array (1 .. 2) of Wrapper;
9992 Hello : Wrapper_Array := (others => (Has_Length => True,
9993 Data => (others => 17),
9997 The debugging info would describe variable Hello as being an
9998 array of a PAD type. The size of that PAD type is not statically
9999 known, but can be determined using a parallel XVZ variable.
10000 In that case, a copy of the PAD type with the correct size should
10001 be used for the fixed array.
10003 3. ``Fixing'' record type objects:
10004 ----------------------------------
10006 Things are slightly different from arrays in the case of dynamic
10007 record types. In this case, in order to compute the associated
10008 fixed type, we need to determine the size and offset of each of
10009 its components. This, in turn, requires us to compute the fixed
10010 type of each of these components.
10012 Consider for instance the example:
10014 type Bounded_String (Max_Size : Natural) is record
10015 Str : String (1 .. Max_Size);
10018 My_String : Bounded_String (Max_Size => 10);
10020 In that case, the position of field "Length" depends on the size
10021 of field Str, which itself depends on the value of the Max_Size
10022 discriminant. In order to fix the type of variable My_String,
10023 we need to fix the type of field Str. Therefore, fixing a variant
10024 record requires us to fix each of its components.
10026 However, if a component does not have a dynamic size, the component
10027 should not be fixed. In particular, fields that use a PAD type
10028 should not fixed. Here is an example where this might happen
10029 (assuming type Rec above):
10031 type Container (Big : Boolean) is record
10035 when True => Another : Integer;
10036 when False => null;
10039 My_Container : Container := (Big => False,
10040 First => (Empty => True),
10043 In that example, the compiler creates a PAD type for component First,
10044 whose size is constant, and then positions the component After just
10045 right after it. The offset of component After is therefore constant
10048 The debugger computes the position of each field based on an algorithm
10049 that uses, among other things, the actual position and size of the field
10050 preceding it. Let's now imagine that the user is trying to print
10051 the value of My_Container. If the type fixing was recursive, we would
10052 end up computing the offset of field After based on the size of the
10053 fixed version of field First. And since in our example First has
10054 only one actual field, the size of the fixed type is actually smaller
10055 than the amount of space allocated to that field, and thus we would
10056 compute the wrong offset of field After.
10058 To make things more complicated, we need to watch out for dynamic
10059 components of variant records (identified by the ___XVL suffix in
10060 the component name). Even if the target type is a PAD type, the size
10061 of that type might not be statically known. So the PAD type needs
10062 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10063 we might end up with the wrong size for our component. This can be
10064 observed with the following type declarations:
10066 type Octal is new Integer range 0 .. 7;
10067 type Octal_Array is array (Positive range <>) of Octal;
10068 pragma Pack (Octal_Array);
10070 type Octal_Buffer (Size : Positive) is record
10071 Buffer : Octal_Array (1 .. Size);
10075 In that case, Buffer is a PAD type whose size is unset and needs
10076 to be computed by fixing the unwrapped type.
10078 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10079 ----------------------------------------------------------
10081 Lastly, when should the sub-elements of an entity that remained unfixed
10082 thus far, be actually fixed?
10084 The answer is: Only when referencing that element. For instance
10085 when selecting one component of a record, this specific component
10086 should be fixed at that point in time. Or when printing the value
10087 of a record, each component should be fixed before its value gets
10088 printed. Similarly for arrays, the element of the array should be
10089 fixed when printing each element of the array, or when extracting
10090 one element out of that array. On the other hand, fixing should
10091 not be performed on the elements when taking a slice of an array!
10093 Note that one of the side effects of miscomputing the offset and
10094 size of each field is that we end up also miscomputing the size
10095 of the containing type. This can have adverse results when computing
10096 the value of an entity. GDB fetches the value of an entity based
10097 on the size of its type, and thus a wrong size causes GDB to fetch
10098 the wrong amount of memory. In the case where the computed size is
10099 too small, GDB fetches too little data to print the value of our
10100 entity. Results in this case are unpredictable, as we usually read
10101 past the buffer containing the data =:-o. */
10103 /* A helper function for TERNOP_IN_RANGE. */
10106 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10107 enum noside noside,
10108 value *arg1, value *arg2, value *arg3)
10110 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10111 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10112 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10114 value_from_longest (type,
10115 (value_less (arg1, arg3)
10116 || value_equal (arg1, arg3))
10117 && (value_less (arg2, arg1)
10118 || value_equal (arg2, arg1)));
10121 /* A helper function for UNOP_NEG. */
10124 ada_unop_neg (struct type *expect_type,
10125 struct expression *exp,
10126 enum noside noside, enum exp_opcode op,
10127 struct value *arg1)
10129 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10130 return value_neg (arg1);
10133 /* A helper function for UNOP_IN_RANGE. */
10136 ada_unop_in_range (struct type *expect_type,
10137 struct expression *exp,
10138 enum noside noside, enum exp_opcode op,
10139 struct value *arg1, struct type *type)
10141 struct value *arg2, *arg3;
10142 switch (type->code ())
10145 lim_warning (_("Membership test incompletely implemented; "
10146 "always returns true"));
10147 type = language_bool_type (exp->language_defn, exp->gdbarch);
10148 return value_from_longest (type, (LONGEST) 1);
10150 case TYPE_CODE_RANGE:
10151 arg2 = value_from_longest (type,
10152 type->bounds ()->low.const_val ());
10153 arg3 = value_from_longest (type,
10154 type->bounds ()->high.const_val ());
10155 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10156 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10157 type = language_bool_type (exp->language_defn, exp->gdbarch);
10159 value_from_longest (type,
10160 (value_less (arg1, arg3)
10161 || value_equal (arg1, arg3))
10162 && (value_less (arg2, arg1)
10163 || value_equal (arg2, arg1)));
10167 /* A helper function for OP_ATR_TAG. */
10170 ada_atr_tag (struct type *expect_type,
10171 struct expression *exp,
10172 enum noside noside, enum exp_opcode op,
10173 struct value *arg1)
10175 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10176 return value_zero (ada_tag_type (arg1), not_lval);
10178 return ada_value_tag (arg1);
10181 /* A helper function for OP_ATR_SIZE. */
10184 ada_atr_size (struct type *expect_type,
10185 struct expression *exp,
10186 enum noside noside, enum exp_opcode op,
10187 struct value *arg1)
10189 struct type *type = value_type (arg1);
10191 /* If the argument is a reference, then dereference its type, since
10192 the user is really asking for the size of the actual object,
10193 not the size of the pointer. */
10194 if (type->code () == TYPE_CODE_REF)
10195 type = type->target_type ();
10197 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10198 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10200 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10201 TARGET_CHAR_BIT * type->length ());
10204 /* A helper function for UNOP_ABS. */
10207 ada_abs (struct type *expect_type,
10208 struct expression *exp,
10209 enum noside noside, enum exp_opcode op,
10210 struct value *arg1)
10212 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10213 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10214 return value_neg (arg1);
10219 /* A helper function for BINOP_MUL. */
10222 ada_mult_binop (struct type *expect_type,
10223 struct expression *exp,
10224 enum noside noside, enum exp_opcode op,
10225 struct value *arg1, struct value *arg2)
10227 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10229 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10230 return value_zero (value_type (arg1), not_lval);
10234 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10235 return ada_value_binop (arg1, arg2, op);
10239 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10242 ada_equal_binop (struct type *expect_type,
10243 struct expression *exp,
10244 enum noside noside, enum exp_opcode op,
10245 struct value *arg1, struct value *arg2)
10248 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10252 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10253 tem = ada_value_equal (arg1, arg2);
10255 if (op == BINOP_NOTEQUAL)
10257 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10258 return value_from_longest (type, (LONGEST) tem);
10261 /* A helper function for TERNOP_SLICE. */
10264 ada_ternop_slice (struct expression *exp,
10265 enum noside noside,
10266 struct value *array, struct value *low_bound_val,
10267 struct value *high_bound_val)
10270 LONGEST high_bound;
10272 low_bound_val = coerce_ref (low_bound_val);
10273 high_bound_val = coerce_ref (high_bound_val);
10274 low_bound = value_as_long (low_bound_val);
10275 high_bound = value_as_long (high_bound_val);
10277 /* If this is a reference to an aligner type, then remove all
10279 if (value_type (array)->code () == TYPE_CODE_REF
10280 && ada_is_aligner_type (value_type (array)->target_type ()))
10281 value_type (array)->set_target_type
10282 (ada_aligned_type (value_type (array)->target_type ()));
10284 if (ada_is_any_packed_array_type (value_type (array)))
10285 error (_("cannot slice a packed array"));
10287 /* If this is a reference to an array or an array lvalue,
10288 convert to a pointer. */
10289 if (value_type (array)->code () == TYPE_CODE_REF
10290 || (value_type (array)->code () == TYPE_CODE_ARRAY
10291 && VALUE_LVAL (array) == lval_memory))
10292 array = value_addr (array);
10294 if (noside == EVAL_AVOID_SIDE_EFFECTS
10295 && ada_is_array_descriptor_type (ada_check_typedef
10296 (value_type (array))))
10297 return empty_array (ada_type_of_array (array, 0), low_bound,
10300 array = ada_coerce_to_simple_array_ptr (array);
10302 /* If we have more than one level of pointer indirection,
10303 dereference the value until we get only one level. */
10304 while (value_type (array)->code () == TYPE_CODE_PTR
10305 && (value_type (array)->target_type ()->code ()
10307 array = value_ind (array);
10309 /* Make sure we really do have an array type before going further,
10310 to avoid a SEGV when trying to get the index type or the target
10311 type later down the road if the debug info generated by
10312 the compiler is incorrect or incomplete. */
10313 if (!ada_is_simple_array_type (value_type (array)))
10314 error (_("cannot take slice of non-array"));
10316 if (ada_check_typedef (value_type (array))->code ()
10319 struct type *type0 = ada_check_typedef (value_type (array));
10321 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10322 return empty_array (type0->target_type (), low_bound, high_bound);
10325 struct type *arr_type0 =
10326 to_fixed_array_type (type0->target_type (), NULL, 1);
10328 return ada_value_slice_from_ptr (array, arr_type0,
10329 longest_to_int (low_bound),
10330 longest_to_int (high_bound));
10333 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10335 else if (high_bound < low_bound)
10336 return empty_array (value_type (array), low_bound, high_bound);
10338 return ada_value_slice (array, longest_to_int (low_bound),
10339 longest_to_int (high_bound));
10342 /* A helper function for BINOP_IN_BOUNDS. */
10345 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10346 struct value *arg1, struct value *arg2, int n)
10348 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10350 struct type *type = language_bool_type (exp->language_defn,
10352 return value_zero (type, not_lval);
10355 struct type *type = ada_index_type (value_type (arg2), n, "range");
10357 type = value_type (arg1);
10359 value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10360 arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10362 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10363 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10364 type = language_bool_type (exp->language_defn, exp->gdbarch);
10365 return value_from_longest (type,
10366 (value_less (arg1, arg3)
10367 || value_equal (arg1, arg3))
10368 && (value_less (arg2, arg1)
10369 || value_equal (arg2, arg1)));
10372 /* A helper function for some attribute operations. */
10375 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10376 struct value *arg1, struct type *type_arg, int tem)
10378 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10380 if (type_arg == NULL)
10381 type_arg = value_type (arg1);
10383 if (ada_is_constrained_packed_array_type (type_arg))
10384 type_arg = decode_constrained_packed_array_type (type_arg);
10386 if (!discrete_type_p (type_arg))
10390 default: /* Should never happen. */
10391 error (_("unexpected attribute encountered"));
10394 type_arg = ada_index_type (type_arg, tem,
10395 ada_attribute_name (op));
10397 case OP_ATR_LENGTH:
10398 type_arg = builtin_type (exp->gdbarch)->builtin_int;
10403 return value_zero (type_arg, not_lval);
10405 else if (type_arg == NULL)
10407 arg1 = ada_coerce_ref (arg1);
10409 if (ada_is_constrained_packed_array_type (value_type (arg1)))
10410 arg1 = ada_coerce_to_simple_array (arg1);
10413 if (op == OP_ATR_LENGTH)
10414 type = builtin_type (exp->gdbarch)->builtin_int;
10417 type = ada_index_type (value_type (arg1), tem,
10418 ada_attribute_name (op));
10420 type = builtin_type (exp->gdbarch)->builtin_int;
10425 default: /* Should never happen. */
10426 error (_("unexpected attribute encountered"));
10428 return value_from_longest
10429 (type, ada_array_bound (arg1, tem, 0));
10431 return value_from_longest
10432 (type, ada_array_bound (arg1, tem, 1));
10433 case OP_ATR_LENGTH:
10434 return value_from_longest
10435 (type, ada_array_length (arg1, tem));
10438 else if (discrete_type_p (type_arg))
10440 struct type *range_type;
10441 const char *name = ada_type_name (type_arg);
10444 if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10445 range_type = to_fixed_range_type (type_arg, NULL);
10446 if (range_type == NULL)
10447 range_type = type_arg;
10451 error (_("unexpected attribute encountered"));
10453 return value_from_longest
10454 (range_type, ada_discrete_type_low_bound (range_type));
10456 return value_from_longest
10457 (range_type, ada_discrete_type_high_bound (range_type));
10458 case OP_ATR_LENGTH:
10459 error (_("the 'length attribute applies only to array types"));
10462 else if (type_arg->code () == TYPE_CODE_FLT)
10463 error (_("unimplemented type attribute"));
10468 if (ada_is_constrained_packed_array_type (type_arg))
10469 type_arg = decode_constrained_packed_array_type (type_arg);
10472 if (op == OP_ATR_LENGTH)
10473 type = builtin_type (exp->gdbarch)->builtin_int;
10476 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10478 type = builtin_type (exp->gdbarch)->builtin_int;
10484 error (_("unexpected attribute encountered"));
10486 low = ada_array_bound_from_type (type_arg, tem, 0);
10487 return value_from_longest (type, low);
10489 high = ada_array_bound_from_type (type_arg, tem, 1);
10490 return value_from_longest (type, high);
10491 case OP_ATR_LENGTH:
10492 low = ada_array_bound_from_type (type_arg, tem, 0);
10493 high = ada_array_bound_from_type (type_arg, tem, 1);
10494 return value_from_longest (type, high - low + 1);
10499 /* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
10502 ada_binop_minmax (struct type *expect_type,
10503 struct expression *exp,
10504 enum noside noside, enum exp_opcode op,
10505 struct value *arg1, struct value *arg2)
10507 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10508 return value_zero (value_type (arg1), not_lval);
10511 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10512 return value_binop (arg1, arg2, op);
10516 /* A helper function for BINOP_EXP. */
10519 ada_binop_exp (struct type *expect_type,
10520 struct expression *exp,
10521 enum noside noside, enum exp_opcode op,
10522 struct value *arg1, struct value *arg2)
10524 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10525 return value_zero (value_type (arg1), not_lval);
10528 /* For integer exponentiation operations,
10529 only promote the first argument. */
10530 if (is_integral_type (value_type (arg2)))
10531 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10533 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10535 return value_binop (arg1, arg2, op);
10542 /* See ada-exp.h. */
10545 ada_resolvable::replace (operation_up &&owner,
10546 struct expression *exp,
10547 bool deprocedure_p,
10548 bool parse_completion,
10549 innermost_block_tracker *tracker,
10550 struct type *context_type)
10552 if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10553 return (make_operation<ada_funcall_operation>
10554 (std::move (owner),
10555 std::vector<operation_up> ()));
10556 return std::move (owner);
10559 /* Convert the character literal whose value would be VAL to the
10560 appropriate value of type TYPE, if there is a translation.
10561 Otherwise return VAL. Hence, in an enumeration type ('A', 'B'),
10562 the literal 'A' (VAL == 65), returns 0. */
10565 convert_char_literal (struct type *type, LONGEST val)
10572 type = check_typedef (type);
10573 if (type->code () != TYPE_CODE_ENUM)
10576 if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10577 xsnprintf (name, sizeof (name), "Q%c", (int) val);
10578 else if (val >= 0 && val < 256)
10579 xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10580 else if (val >= 0 && val < 0x10000)
10581 xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10583 xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10584 size_t len = strlen (name);
10585 for (f = 0; f < type->num_fields (); f += 1)
10587 /* Check the suffix because an enum constant in a package will
10588 have a name like "pkg__QUxx". This is safe enough because we
10589 already have the correct type, and because mangling means
10590 there can't be clashes. */
10591 const char *ename = type->field (f).name ();
10592 size_t elen = strlen (ename);
10594 if (elen >= len && strcmp (name, ename + elen - len) == 0)
10595 return type->field (f).loc_enumval ();
10601 ada_char_operation::evaluate (struct type *expect_type,
10602 struct expression *exp,
10603 enum noside noside)
10605 value *result = long_const_operation::evaluate (expect_type, exp, noside);
10606 if (expect_type != nullptr)
10607 result = ada_value_cast (expect_type, result);
10611 /* See ada-exp.h. */
10614 ada_char_operation::replace (operation_up &&owner,
10615 struct expression *exp,
10616 bool deprocedure_p,
10617 bool parse_completion,
10618 innermost_block_tracker *tracker,
10619 struct type *context_type)
10621 operation_up result = std::move (owner);
10623 if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10625 gdb_assert (result.get () == this);
10626 std::get<0> (m_storage) = context_type;
10627 std::get<1> (m_storage)
10628 = convert_char_literal (context_type, std::get<1> (m_storage));
10635 ada_wrapped_operation::evaluate (struct type *expect_type,
10636 struct expression *exp,
10637 enum noside noside)
10639 value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10640 if (noside == EVAL_NORMAL)
10641 result = unwrap_value (result);
10643 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10644 then we need to perform the conversion manually, because
10645 evaluate_subexp_standard doesn't do it. This conversion is
10646 necessary in Ada because the different kinds of float/fixed
10647 types in Ada have different representations.
10649 Similarly, we need to perform the conversion from OP_LONG
10651 if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10652 result = ada_value_cast (expect_type, result);
10658 ada_string_operation::evaluate (struct type *expect_type,
10659 struct expression *exp,
10660 enum noside noside)
10662 struct type *char_type;
10663 if (expect_type != nullptr && ada_is_string_type (expect_type))
10664 char_type = ada_array_element_type (expect_type, 1);
10666 char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10668 const std::string &str = std::get<0> (m_storage);
10669 const char *encoding;
10670 switch (char_type->length ())
10674 /* Simply copy over the data -- this isn't perhaps strictly
10675 correct according to the encodings, but it is gdb's
10676 historical behavior. */
10677 struct type *stringtype
10678 = lookup_array_range_type (char_type, 1, str.length ());
10679 struct value *val = allocate_value (stringtype);
10680 memcpy (value_contents_raw (val).data (), str.c_str (),
10686 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10687 encoding = "UTF-16BE";
10689 encoding = "UTF-16LE";
10693 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10694 encoding = "UTF-32BE";
10696 encoding = "UTF-32LE";
10700 error (_("unexpected character type size %s"),
10701 pulongest (char_type->length ()));
10704 auto_obstack converted;
10705 convert_between_encodings (host_charset (), encoding,
10706 (const gdb_byte *) str.c_str (),
10708 &converted, translit_none);
10710 struct type *stringtype
10711 = lookup_array_range_type (char_type, 1,
10712 obstack_object_size (&converted)
10713 / char_type->length ());
10714 struct value *val = allocate_value (stringtype);
10715 memcpy (value_contents_raw (val).data (),
10716 obstack_base (&converted),
10717 obstack_object_size (&converted));
10722 ada_concat_operation::evaluate (struct type *expect_type,
10723 struct expression *exp,
10724 enum noside noside)
10726 /* If one side is a literal, evaluate the other side first so that
10727 the expected type can be set properly. */
10728 const operation_up &lhs_expr = std::get<0> (m_storage);
10729 const operation_up &rhs_expr = std::get<1> (m_storage);
10732 if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10734 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10735 lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10737 else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10739 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10740 struct type *rhs_type = check_typedef (value_type (rhs));
10741 struct type *elt_type = nullptr;
10742 if (rhs_type->code () == TYPE_CODE_ARRAY)
10743 elt_type = rhs_type->target_type ();
10744 lhs = lhs_expr->evaluate (elt_type, exp, noside);
10746 else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10748 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10749 rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10751 else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10753 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10754 struct type *lhs_type = check_typedef (value_type (lhs));
10755 struct type *elt_type = nullptr;
10756 if (lhs_type->code () == TYPE_CODE_ARRAY)
10757 elt_type = lhs_type->target_type ();
10758 rhs = rhs_expr->evaluate (elt_type, exp, noside);
10761 return concat_operation::evaluate (expect_type, exp, noside);
10763 return value_concat (lhs, rhs);
10767 ada_qual_operation::evaluate (struct type *expect_type,
10768 struct expression *exp,
10769 enum noside noside)
10771 struct type *type = std::get<1> (m_storage);
10772 return std::get<0> (m_storage)->evaluate (type, exp, noside);
10776 ada_ternop_range_operation::evaluate (struct type *expect_type,
10777 struct expression *exp,
10778 enum noside noside)
10780 value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10781 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10782 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10783 return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10787 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10788 struct expression *exp,
10789 enum noside noside)
10791 value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10792 value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10794 auto do_op = [=] (LONGEST x, LONGEST y)
10796 if (std::get<0> (m_storage) == BINOP_ADD)
10801 if (value_type (arg1)->code () == TYPE_CODE_PTR)
10802 return (value_from_longest
10803 (value_type (arg1),
10804 do_op (value_as_long (arg1), value_as_long (arg2))));
10805 if (value_type (arg2)->code () == TYPE_CODE_PTR)
10806 return (value_from_longest
10807 (value_type (arg2),
10808 do_op (value_as_long (arg1), value_as_long (arg2))));
10809 /* Preserve the original type for use by the range case below.
10810 We cannot cast the result to a reference type, so if ARG1 is
10811 a reference type, find its underlying type. */
10812 struct type *type = value_type (arg1);
10813 while (type->code () == TYPE_CODE_REF)
10814 type = type->target_type ();
10815 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10816 arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10817 /* We need to special-case the result with a range.
10818 This is done for the benefit of "ptype". gdb's Ada support
10819 historically used the LHS to set the result type here, so
10820 preserve this behavior. */
10821 if (type->code () == TYPE_CODE_RANGE)
10822 arg1 = value_cast (type, arg1);
10827 ada_unop_atr_operation::evaluate (struct type *expect_type,
10828 struct expression *exp,
10829 enum noside noside)
10831 struct type *type_arg = nullptr;
10832 value *val = nullptr;
10834 if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10836 value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10837 EVAL_AVOID_SIDE_EFFECTS);
10838 type_arg = value_type (tem);
10841 val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10843 return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10844 val, type_arg, std::get<2> (m_storage));
10848 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10849 struct expression *exp,
10850 enum noside noside)
10852 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10853 return value_zero (expect_type, not_lval);
10855 const bound_minimal_symbol &b = std::get<0> (m_storage);
10856 value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10858 val = ada_value_cast (expect_type, val);
10860 /* Follow the Ada language semantics that do not allow taking
10861 an address of the result of a cast (view conversion in Ada). */
10862 if (VALUE_LVAL (val) == lval_memory)
10864 if (value_lazy (val))
10865 value_fetch_lazy (val);
10866 VALUE_LVAL (val) = not_lval;
10872 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10873 struct expression *exp,
10874 enum noside noside)
10876 value *val = evaluate_var_value (noside,
10877 std::get<0> (m_storage).block,
10878 std::get<0> (m_storage).symbol);
10880 val = ada_value_cast (expect_type, val);
10882 /* Follow the Ada language semantics that do not allow taking
10883 an address of the result of a cast (view conversion in Ada). */
10884 if (VALUE_LVAL (val) == lval_memory)
10886 if (value_lazy (val))
10887 value_fetch_lazy (val);
10888 VALUE_LVAL (val) = not_lval;
10894 ada_var_value_operation::evaluate (struct type *expect_type,
10895 struct expression *exp,
10896 enum noside noside)
10898 symbol *sym = std::get<0> (m_storage).symbol;
10900 if (sym->domain () == UNDEF_DOMAIN)
10901 /* Only encountered when an unresolved symbol occurs in a
10902 context other than a function call, in which case, it is
10904 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10905 sym->print_name ());
10907 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10909 struct type *type = static_unwrap_type (sym->type ());
10910 /* Check to see if this is a tagged type. We also need to handle
10911 the case where the type is a reference to a tagged type, but
10912 we have to be careful to exclude pointers to tagged types.
10913 The latter should be shown as usual (as a pointer), whereas
10914 a reference should mostly be transparent to the user. */
10915 if (ada_is_tagged_type (type, 0)
10916 || (type->code () == TYPE_CODE_REF
10917 && ada_is_tagged_type (type->target_type (), 0)))
10919 /* Tagged types are a little special in the fact that the real
10920 type is dynamic and can only be determined by inspecting the
10921 object's tag. This means that we need to get the object's
10922 value first (EVAL_NORMAL) and then extract the actual object
10925 Note that we cannot skip the final step where we extract
10926 the object type from its tag, because the EVAL_NORMAL phase
10927 results in dynamic components being resolved into fixed ones.
10928 This can cause problems when trying to print the type
10929 description of tagged types whose parent has a dynamic size:
10930 We use the type name of the "_parent" component in order
10931 to print the name of the ancestor type in the type description.
10932 If that component had a dynamic size, the resolution into
10933 a fixed type would result in the loss of that type name,
10934 thus preventing us from printing the name of the ancestor
10935 type in the type description. */
10936 value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10938 if (type->code () != TYPE_CODE_REF)
10940 struct type *actual_type;
10942 actual_type = type_from_tag (ada_value_tag (arg1));
10943 if (actual_type == NULL)
10944 /* If, for some reason, we were unable to determine
10945 the actual type from the tag, then use the static
10946 approximation that we just computed as a fallback.
10947 This can happen if the debugging information is
10948 incomplete, for instance. */
10949 actual_type = type;
10950 return value_zero (actual_type, not_lval);
10954 /* In the case of a ref, ada_coerce_ref takes care
10955 of determining the actual type. But the evaluation
10956 should return a ref as it should be valid to ask
10957 for its address; so rebuild a ref after coerce. */
10958 arg1 = ada_coerce_ref (arg1);
10959 return value_ref (arg1, TYPE_CODE_REF);
10963 /* Records and unions for which GNAT encodings have been
10964 generated need to be statically fixed as well.
10965 Otherwise, non-static fixing produces a type where
10966 all dynamic properties are removed, which prevents "ptype"
10967 from being able to completely describe the type.
10968 For instance, a case statement in a variant record would be
10969 replaced by the relevant components based on the actual
10970 value of the discriminants. */
10971 if ((type->code () == TYPE_CODE_STRUCT
10972 && dynamic_template_type (type) != NULL)
10973 || (type->code () == TYPE_CODE_UNION
10974 && ada_find_parallel_type (type, "___XVU") != NULL))
10975 return value_zero (to_static_fixed_type (type), not_lval);
10978 value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10979 return ada_to_fixed_value (arg1);
10983 ada_var_value_operation::resolve (struct expression *exp,
10984 bool deprocedure_p,
10985 bool parse_completion,
10986 innermost_block_tracker *tracker,
10987 struct type *context_type)
10989 symbol *sym = std::get<0> (m_storage).symbol;
10990 if (sym->domain () == UNDEF_DOMAIN)
10992 block_symbol resolved
10993 = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10994 context_type, parse_completion,
10995 deprocedure_p, tracker);
10996 std::get<0> (m_storage) = resolved;
11000 && (std::get<0> (m_storage).symbol->type ()->code ()
11001 == TYPE_CODE_FUNC))
11008 ada_atr_val_operation::evaluate (struct type *expect_type,
11009 struct expression *exp,
11010 enum noside noside)
11012 value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11013 return ada_val_atr (noside, std::get<0> (m_storage), arg);
11017 ada_unop_ind_operation::evaluate (struct type *expect_type,
11018 struct expression *exp,
11019 enum noside noside)
11021 value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11023 struct type *type = ada_check_typedef (value_type (arg1));
11024 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11026 if (ada_is_array_descriptor_type (type))
11027 /* GDB allows dereferencing GNAT array descriptors. */
11029 struct type *arrType = ada_type_of_array (arg1, 0);
11031 if (arrType == NULL)
11032 error (_("Attempt to dereference null array pointer."));
11033 return value_at_lazy (arrType, 0);
11035 else if (type->code () == TYPE_CODE_PTR
11036 || type->code () == TYPE_CODE_REF
11037 /* In C you can dereference an array to get the 1st elt. */
11038 || type->code () == TYPE_CODE_ARRAY)
11040 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11041 only be determined by inspecting the object's tag.
11042 This means that we need to evaluate completely the
11043 expression in order to get its type. */
11045 if ((type->code () == TYPE_CODE_REF
11046 || type->code () == TYPE_CODE_PTR)
11047 && ada_is_tagged_type (type->target_type (), 0))
11049 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11051 type = value_type (ada_value_ind (arg1));
11055 type = to_static_fixed_type
11057 (ada_check_typedef (type->target_type ())));
11059 return value_zero (type, lval_memory);
11061 else if (type->code () == TYPE_CODE_INT)
11063 /* GDB allows dereferencing an int. */
11064 if (expect_type == NULL)
11065 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11070 to_static_fixed_type (ada_aligned_type (expect_type));
11071 return value_zero (expect_type, lval_memory);
11075 error (_("Attempt to take contents of a non-pointer value."));
11077 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11078 type = ada_check_typedef (value_type (arg1));
11080 if (type->code () == TYPE_CODE_INT)
11081 /* GDB allows dereferencing an int. If we were given
11082 the expect_type, then use that as the target type.
11083 Otherwise, assume that the target type is an int. */
11085 if (expect_type != NULL)
11086 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11089 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11090 (CORE_ADDR) value_as_address (arg1));
11093 if (ada_is_array_descriptor_type (type))
11094 /* GDB allows dereferencing GNAT array descriptors. */
11095 return ada_coerce_to_simple_array (arg1);
11097 return ada_value_ind (arg1);
11101 ada_structop_operation::evaluate (struct type *expect_type,
11102 struct expression *exp,
11103 enum noside noside)
11105 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11106 const char *str = std::get<1> (m_storage).c_str ();
11107 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11110 struct type *type1 = value_type (arg1);
11112 if (ada_is_tagged_type (type1, 1))
11114 type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11116 /* If the field is not found, check if it exists in the
11117 extension of this object's type. This means that we
11118 need to evaluate completely the expression. */
11122 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11124 arg1 = ada_value_struct_elt (arg1, str, 0);
11125 arg1 = unwrap_value (arg1);
11126 type = value_type (ada_to_fixed_value (arg1));
11130 type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11132 return value_zero (ada_aligned_type (type), lval_memory);
11136 arg1 = ada_value_struct_elt (arg1, str, 0);
11137 arg1 = unwrap_value (arg1);
11138 return ada_to_fixed_value (arg1);
11143 ada_funcall_operation::evaluate (struct type *expect_type,
11144 struct expression *exp,
11145 enum noside noside)
11147 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11148 int nargs = args_up.size ();
11149 std::vector<value *> argvec (nargs);
11150 operation_up &callee_op = std::get<0> (m_storage);
11152 ada_var_value_operation *avv
11153 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11155 && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11156 error (_("Unexpected unresolved symbol, %s, during evaluation"),
11157 avv->get_symbol ()->print_name ());
11159 value *callee = callee_op->evaluate (nullptr, exp, noside);
11160 for (int i = 0; i < args_up.size (); ++i)
11161 argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11163 if (ada_is_constrained_packed_array_type
11164 (desc_base_type (value_type (callee))))
11165 callee = ada_coerce_to_simple_array (callee);
11166 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11167 && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11168 /* This is a packed array that has already been fixed, and
11169 therefore already coerced to a simple array. Nothing further
11172 else if (value_type (callee)->code () == TYPE_CODE_REF)
11174 /* Make sure we dereference references so that all the code below
11175 feels like it's really handling the referenced value. Wrapping
11176 types (for alignment) may be there, so make sure we strip them as
11178 callee = ada_to_fixed_value (coerce_ref (callee));
11180 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11181 && VALUE_LVAL (callee) == lval_memory)
11182 callee = value_addr (callee);
11184 struct type *type = ada_check_typedef (value_type (callee));
11186 /* Ada allows us to implicitly dereference arrays when subscripting
11187 them. So, if this is an array typedef (encoding use for array
11188 access types encoded as fat pointers), strip it now. */
11189 if (type->code () == TYPE_CODE_TYPEDEF)
11190 type = ada_typedef_target_type (type);
11192 if (type->code () == TYPE_CODE_PTR)
11194 switch (ada_check_typedef (type->target_type ())->code ())
11196 case TYPE_CODE_FUNC:
11197 type = ada_check_typedef (type->target_type ());
11199 case TYPE_CODE_ARRAY:
11201 case TYPE_CODE_STRUCT:
11202 if (noside != EVAL_AVOID_SIDE_EFFECTS)
11203 callee = ada_value_ind (callee);
11204 type = ada_check_typedef (type->target_type ());
11207 error (_("cannot subscript or call something of type `%s'"),
11208 ada_type_name (value_type (callee)));
11213 switch (type->code ())
11215 case TYPE_CODE_FUNC:
11216 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11218 if (type->target_type () == NULL)
11219 error_call_unknown_return_type (NULL);
11220 return allocate_value (type->target_type ());
11222 return call_function_by_hand (callee, NULL, argvec);
11223 case TYPE_CODE_INTERNAL_FUNCTION:
11224 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11225 /* We don't know anything about what the internal
11226 function might return, but we have to return
11228 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11231 return call_internal_function (exp->gdbarch, exp->language_defn,
11235 case TYPE_CODE_STRUCT:
11239 arity = ada_array_arity (type);
11240 type = ada_array_element_type (type, nargs);
11242 error (_("cannot subscript or call a record"));
11243 if (arity != nargs)
11244 error (_("wrong number of subscripts; expecting %d"), arity);
11245 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11246 return value_zero (ada_aligned_type (type), lval_memory);
11248 unwrap_value (ada_value_subscript
11249 (callee, nargs, argvec.data ()));
11251 case TYPE_CODE_ARRAY:
11252 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11254 type = ada_array_element_type (type, nargs);
11256 error (_("element type of array unknown"));
11258 return value_zero (ada_aligned_type (type), lval_memory);
11261 unwrap_value (ada_value_subscript
11262 (ada_coerce_to_simple_array (callee),
11263 nargs, argvec.data ()));
11264 case TYPE_CODE_PTR: /* Pointer to array */
11265 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11267 type = to_fixed_array_type (type->target_type (), NULL, 1);
11268 type = ada_array_element_type (type, nargs);
11270 error (_("element type of array unknown"));
11272 return value_zero (ada_aligned_type (type), lval_memory);
11275 unwrap_value (ada_value_ptr_subscript (callee, nargs,
11279 error (_("Attempt to index or call something other than an "
11280 "array or function"));
11285 ada_funcall_operation::resolve (struct expression *exp,
11286 bool deprocedure_p,
11287 bool parse_completion,
11288 innermost_block_tracker *tracker,
11289 struct type *context_type)
11291 operation_up &callee_op = std::get<0> (m_storage);
11293 ada_var_value_operation *avv
11294 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11295 if (avv == nullptr)
11298 symbol *sym = avv->get_symbol ();
11299 if (sym->domain () != UNDEF_DOMAIN)
11302 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11303 int nargs = args_up.size ();
11304 std::vector<value *> argvec (nargs);
11306 for (int i = 0; i < args_up.size (); ++i)
11307 argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11309 const block *block = avv->get_block ();
11310 block_symbol resolved
11311 = ada_resolve_funcall (sym, block,
11312 context_type, parse_completion,
11313 nargs, argvec.data (),
11316 std::get<0> (m_storage)
11317 = make_operation<ada_var_value_operation> (resolved);
11322 ada_ternop_slice_operation::resolve (struct expression *exp,
11323 bool deprocedure_p,
11324 bool parse_completion,
11325 innermost_block_tracker *tracker,
11326 struct type *context_type)
11328 /* Historically this check was done during resolution, so we
11329 continue that here. */
11330 value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11331 EVAL_AVOID_SIDE_EFFECTS);
11332 if (ada_is_any_packed_array_type (value_type (v)))
11333 error (_("cannot slice a packed array"));
11341 /* Return non-zero iff TYPE represents a System.Address type. */
11344 ada_is_system_address_type (struct type *type)
11346 return (type->name () && strcmp (type->name (), "system__address") == 0);
11353 /* Scan STR beginning at position K for a discriminant name, and
11354 return the value of that discriminant field of DVAL in *PX. If
11355 PNEW_K is not null, put the position of the character beyond the
11356 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11357 not alter *PX and *PNEW_K if unsuccessful. */
11360 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11363 static std::string storage;
11364 const char *pstart, *pend, *bound;
11365 struct value *bound_val;
11367 if (dval == NULL || str == NULL || str[k] == '\0')
11371 pend = strstr (pstart, "__");
11375 k += strlen (bound);
11379 int len = pend - pstart;
11381 /* Strip __ and beyond. */
11382 storage = std::string (pstart, len);
11383 bound = storage.c_str ();
11387 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11388 if (bound_val == NULL)
11391 *px = value_as_long (bound_val);
11392 if (pnew_k != NULL)
11397 /* Value of variable named NAME. Only exact matches are considered.
11398 If no such variable found, then if ERR_MSG is null, returns 0, and
11399 otherwise causes an error with message ERR_MSG. */
11401 static struct value *
11402 get_var_value (const char *name, const char *err_msg)
11404 std::string quoted_name = add_angle_brackets (name);
11406 lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11408 std::vector<struct block_symbol> syms
11409 = ada_lookup_symbol_list_worker (lookup_name,
11410 get_selected_block (0),
11413 if (syms.size () != 1)
11415 if (err_msg == NULL)
11418 error (("%s"), err_msg);
11421 return value_of_variable (syms[0].symbol, syms[0].block);
11424 /* Value of integer variable named NAME in the current environment.
11425 If no such variable is found, returns false. Otherwise, sets VALUE
11426 to the variable's value and returns true. */
11429 get_int_var_value (const char *name, LONGEST &value)
11431 struct value *var_val = get_var_value (name, 0);
11436 value = value_as_long (var_val);
11441 /* Return a range type whose base type is that of the range type named
11442 NAME in the current environment, and whose bounds are calculated
11443 from NAME according to the GNAT range encoding conventions.
11444 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11445 corresponding range type from debug information; fall back to using it
11446 if symbol lookup fails. If a new type must be created, allocate it
11447 like ORIG_TYPE was. The bounds information, in general, is encoded
11448 in NAME, the base type given in the named range type. */
11450 static struct type *
11451 to_fixed_range_type (struct type *raw_type, struct value *dval)
11454 struct type *base_type;
11455 const char *subtype_info;
11457 gdb_assert (raw_type != NULL);
11458 gdb_assert (raw_type->name () != NULL);
11460 if (raw_type->code () == TYPE_CODE_RANGE)
11461 base_type = raw_type->target_type ();
11463 base_type = raw_type;
11465 name = raw_type->name ();
11466 subtype_info = strstr (name, "___XD");
11467 if (subtype_info == NULL)
11469 LONGEST L = ada_discrete_type_low_bound (raw_type);
11470 LONGEST U = ada_discrete_type_high_bound (raw_type);
11472 if (L < INT_MIN || U > INT_MAX)
11475 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11480 int prefix_len = subtype_info - name;
11483 const char *bounds_str;
11487 bounds_str = strchr (subtype_info, '_');
11490 if (*subtype_info == 'L')
11492 if (!ada_scan_number (bounds_str, n, &L, &n)
11493 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11495 if (bounds_str[n] == '_')
11497 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11503 std::string name_buf = std::string (name, prefix_len) + "___L";
11504 if (!get_int_var_value (name_buf.c_str (), L))
11506 lim_warning (_("Unknown lower bound, using 1."));
11511 if (*subtype_info == 'U')
11513 if (!ada_scan_number (bounds_str, n, &U, &n)
11514 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11519 std::string name_buf = std::string (name, prefix_len) + "___U";
11520 if (!get_int_var_value (name_buf.c_str (), U))
11522 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11527 type = create_static_range_type (alloc_type_copy (raw_type),
11529 /* create_static_range_type alters the resulting type's length
11530 to match the size of the base_type, which is not what we want.
11531 Set it back to the original range type's length. */
11532 type->set_length (raw_type->length ());
11533 type->set_name (name);
11538 /* True iff NAME is the name of a range type. */
11541 ada_is_range_type_name (const char *name)
11543 return (name != NULL && strstr (name, "___XD"));
11547 /* Modular types */
11549 /* True iff TYPE is an Ada modular type. */
11552 ada_is_modular_type (struct type *type)
11554 struct type *subranged_type = get_base_type (type);
11556 return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11557 && subranged_type->code () == TYPE_CODE_INT
11558 && subranged_type->is_unsigned ());
11561 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11564 ada_modulus (struct type *type)
11566 const dynamic_prop &high = type->bounds ()->high;
11568 if (high.kind () == PROP_CONST)
11569 return (ULONGEST) high.const_val () + 1;
11571 /* If TYPE is unresolved, the high bound might be a location list. Return
11572 0, for lack of a better value to return. */
11577 /* Ada exception catchpoint support:
11578 ---------------------------------
11580 We support 3 kinds of exception catchpoints:
11581 . catchpoints on Ada exceptions
11582 . catchpoints on unhandled Ada exceptions
11583 . catchpoints on failed assertions
11585 Exceptions raised during failed assertions, or unhandled exceptions
11586 could perfectly be caught with the general catchpoint on Ada exceptions.
11587 However, we can easily differentiate these two special cases, and having
11588 the option to distinguish these two cases from the rest can be useful
11589 to zero-in on certain situations.
11591 Exception catchpoints are a specialized form of breakpoint,
11592 since they rely on inserting breakpoints inside known routines
11593 of the GNAT runtime. The implementation therefore uses a standard
11594 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11597 Support in the runtime for exception catchpoints have been changed
11598 a few times already, and these changes affect the implementation
11599 of these catchpoints. In order to be able to support several
11600 variants of the runtime, we use a sniffer that will determine
11601 the runtime variant used by the program being debugged. */
11603 /* Ada's standard exceptions.
11605 The Ada 83 standard also defined Numeric_Error. But there so many
11606 situations where it was unclear from the Ada 83 Reference Manual
11607 (RM) whether Constraint_Error or Numeric_Error should be raised,
11608 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11609 Interpretation saying that anytime the RM says that Numeric_Error
11610 should be raised, the implementation may raise Constraint_Error.
11611 Ada 95 went one step further and pretty much removed Numeric_Error
11612 from the list of standard exceptions (it made it a renaming of
11613 Constraint_Error, to help preserve compatibility when compiling
11614 an Ada83 compiler). As such, we do not include Numeric_Error from
11615 this list of standard exceptions. */
11617 static const char * const standard_exc[] = {
11618 "constraint_error",
11624 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11626 /* A structure that describes how to support exception catchpoints
11627 for a given executable. */
11629 struct exception_support_info
11631 /* The name of the symbol to break on in order to insert
11632 a catchpoint on exceptions. */
11633 const char *catch_exception_sym;
11635 /* The name of the symbol to break on in order to insert
11636 a catchpoint on unhandled exceptions. */
11637 const char *catch_exception_unhandled_sym;
11639 /* The name of the symbol to break on in order to insert
11640 a catchpoint on failed assertions. */
11641 const char *catch_assert_sym;
11643 /* The name of the symbol to break on in order to insert
11644 a catchpoint on exception handling. */
11645 const char *catch_handlers_sym;
11647 /* Assuming that the inferior just triggered an unhandled exception
11648 catchpoint, this function is responsible for returning the address
11649 in inferior memory where the name of that exception is stored.
11650 Return zero if the address could not be computed. */
11651 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11654 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11655 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11657 /* The following exception support info structure describes how to
11658 implement exception catchpoints with the latest version of the
11659 Ada runtime (as of 2019-08-??). */
11661 static const struct exception_support_info default_exception_support_info =
11663 "__gnat_debug_raise_exception", /* catch_exception_sym */
11664 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11665 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11666 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11667 ada_unhandled_exception_name_addr
11670 /* The following exception support info structure describes how to
11671 implement exception catchpoints with an earlier version of the
11672 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11674 static const struct exception_support_info exception_support_info_v0 =
11676 "__gnat_debug_raise_exception", /* catch_exception_sym */
11677 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11678 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11679 "__gnat_begin_handler", /* catch_handlers_sym */
11680 ada_unhandled_exception_name_addr
11683 /* The following exception support info structure describes how to
11684 implement exception catchpoints with a slightly older version
11685 of the Ada runtime. */
11687 static const struct exception_support_info exception_support_info_fallback =
11689 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11690 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11691 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11692 "__gnat_begin_handler", /* catch_handlers_sym */
11693 ada_unhandled_exception_name_addr_from_raise
11696 /* Return nonzero if we can detect the exception support routines
11697 described in EINFO.
11699 This function errors out if an abnormal situation is detected
11700 (for instance, if we find the exception support routines, but
11701 that support is found to be incomplete). */
11704 ada_has_this_exception_support (const struct exception_support_info *einfo)
11706 struct symbol *sym;
11708 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11709 that should be compiled with debugging information. As a result, we
11710 expect to find that symbol in the symtabs. */
11712 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11715 /* Perhaps we did not find our symbol because the Ada runtime was
11716 compiled without debugging info, or simply stripped of it.
11717 It happens on some GNU/Linux distributions for instance, where
11718 users have to install a separate debug package in order to get
11719 the runtime's debugging info. In that situation, let the user
11720 know why we cannot insert an Ada exception catchpoint.
11722 Note: Just for the purpose of inserting our Ada exception
11723 catchpoint, we could rely purely on the associated minimal symbol.
11724 But we would be operating in degraded mode anyway, since we are
11725 still lacking the debugging info needed later on to extract
11726 the name of the exception being raised (this name is printed in
11727 the catchpoint message, and is also used when trying to catch
11728 a specific exception). We do not handle this case for now. */
11729 struct bound_minimal_symbol msym
11730 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11732 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11733 error (_("Your Ada runtime appears to be missing some debugging "
11734 "information.\nCannot insert Ada exception catchpoint "
11735 "in this configuration."));
11740 /* Make sure that the symbol we found corresponds to a function. */
11742 if (sym->aclass () != LOC_BLOCK)
11744 error (_("Symbol \"%s\" is not a function (class = %d)"),
11745 sym->linkage_name (), sym->aclass ());
11749 sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11752 struct bound_minimal_symbol msym
11753 = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11755 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11756 error (_("Your Ada runtime appears to be missing some debugging "
11757 "information.\nCannot insert Ada exception catchpoint "
11758 "in this configuration."));
11763 /* Make sure that the symbol we found corresponds to a function. */
11765 if (sym->aclass () != LOC_BLOCK)
11767 error (_("Symbol \"%s\" is not a function (class = %d)"),
11768 sym->linkage_name (), sym->aclass ());
11775 /* Inspect the Ada runtime and determine which exception info structure
11776 should be used to provide support for exception catchpoints.
11778 This function will always set the per-inferior exception_info,
11779 or raise an error. */
11782 ada_exception_support_info_sniffer (void)
11784 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11786 /* If the exception info is already known, then no need to recompute it. */
11787 if (data->exception_info != NULL)
11790 /* Check the latest (default) exception support info. */
11791 if (ada_has_this_exception_support (&default_exception_support_info))
11793 data->exception_info = &default_exception_support_info;
11797 /* Try the v0 exception suport info. */
11798 if (ada_has_this_exception_support (&exception_support_info_v0))
11800 data->exception_info = &exception_support_info_v0;
11804 /* Try our fallback exception suport info. */
11805 if (ada_has_this_exception_support (&exception_support_info_fallback))
11807 data->exception_info = &exception_support_info_fallback;
11811 /* Sometimes, it is normal for us to not be able to find the routine
11812 we are looking for. This happens when the program is linked with
11813 the shared version of the GNAT runtime, and the program has not been
11814 started yet. Inform the user of these two possible causes if
11817 if (ada_update_initial_language (language_unknown) != language_ada)
11818 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11820 /* If the symbol does not exist, then check that the program is
11821 already started, to make sure that shared libraries have been
11822 loaded. If it is not started, this may mean that the symbol is
11823 in a shared library. */
11825 if (inferior_ptid.pid () == 0)
11826 error (_("Unable to insert catchpoint. Try to start the program first."));
11828 /* At this point, we know that we are debugging an Ada program and
11829 that the inferior has been started, but we still are not able to
11830 find the run-time symbols. That can mean that we are in
11831 configurable run time mode, or that a-except as been optimized
11832 out by the linker... In any case, at this point it is not worth
11833 supporting this feature. */
11835 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11838 /* True iff FRAME is very likely to be that of a function that is
11839 part of the runtime system. This is all very heuristic, but is
11840 intended to be used as advice as to what frames are uninteresting
11844 is_known_support_routine (frame_info_ptr frame)
11846 enum language func_lang;
11848 const char *fullname;
11850 /* If this code does not have any debugging information (no symtab),
11851 This cannot be any user code. */
11853 symtab_and_line sal = find_frame_sal (frame);
11854 if (sal.symtab == NULL)
11857 /* If there is a symtab, but the associated source file cannot be
11858 located, then assume this is not user code: Selecting a frame
11859 for which we cannot display the code would not be very helpful
11860 for the user. This should also take care of case such as VxWorks
11861 where the kernel has some debugging info provided for a few units. */
11863 fullname = symtab_to_fullname (sal.symtab);
11864 if (access (fullname, R_OK) != 0)
11867 /* Check the unit filename against the Ada runtime file naming.
11868 We also check the name of the objfile against the name of some
11869 known system libraries that sometimes come with debugging info
11872 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11874 re_comp (known_runtime_file_name_patterns[i]);
11875 if (re_exec (lbasename (sal.symtab->filename)))
11877 if (sal.symtab->compunit ()->objfile () != NULL
11878 && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11882 /* Check whether the function is a GNAT-generated entity. */
11884 gdb::unique_xmalloc_ptr<char> func_name
11885 = find_frame_funname (frame, &func_lang, NULL);
11886 if (func_name == NULL)
11889 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11891 re_comp (known_auxiliary_function_name_patterns[i]);
11892 if (re_exec (func_name.get ()))
11899 /* Find the first frame that contains debugging information and that is not
11900 part of the Ada run-time, starting from FI and moving upward. */
11903 ada_find_printable_frame (frame_info_ptr fi)
11905 for (; fi != NULL; fi = get_prev_frame (fi))
11907 if (!is_known_support_routine (fi))
11916 /* Assuming that the inferior just triggered an unhandled exception
11917 catchpoint, return the address in inferior memory where the name
11918 of the exception is stored.
11920 Return zero if the address could not be computed. */
11923 ada_unhandled_exception_name_addr (void)
11925 return parse_and_eval_address ("e.full_name");
11928 /* Same as ada_unhandled_exception_name_addr, except that this function
11929 should be used when the inferior uses an older version of the runtime,
11930 where the exception name needs to be extracted from a specific frame
11931 several frames up in the callstack. */
11934 ada_unhandled_exception_name_addr_from_raise (void)
11938 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11940 /* To determine the name of this exception, we need to select
11941 the frame corresponding to RAISE_SYM_NAME. This frame is
11942 at least 3 levels up, so we simply skip the first 3 frames
11943 without checking the name of their associated function. */
11944 fi = get_current_frame ();
11945 for (frame_level = 0; frame_level < 3; frame_level += 1)
11947 fi = get_prev_frame (fi);
11951 enum language func_lang;
11953 gdb::unique_xmalloc_ptr<char> func_name
11954 = find_frame_funname (fi, &func_lang, NULL);
11955 if (func_name != NULL)
11957 if (strcmp (func_name.get (),
11958 data->exception_info->catch_exception_sym) == 0)
11959 break; /* We found the frame we were looking for... */
11961 fi = get_prev_frame (fi);
11968 return parse_and_eval_address ("id.full_name");
11971 /* Assuming the inferior just triggered an Ada exception catchpoint
11972 (of any type), return the address in inferior memory where the name
11973 of the exception is stored, if applicable.
11975 Assumes the selected frame is the current frame.
11977 Return zero if the address could not be computed, or if not relevant. */
11980 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11982 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11986 case ada_catch_exception:
11987 return (parse_and_eval_address ("e.full_name"));
11990 case ada_catch_exception_unhandled:
11991 return data->exception_info->unhandled_exception_name_addr ();
11994 case ada_catch_handlers:
11995 return 0; /* The runtimes does not provide access to the exception
11999 case ada_catch_assert:
12000 return 0; /* Exception name is not relevant in this case. */
12004 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12008 return 0; /* Should never be reached. */
12011 /* Assuming the inferior is stopped at an exception catchpoint,
12012 return the message which was associated to the exception, if
12013 available. Return NULL if the message could not be retrieved.
12015 Note: The exception message can be associated to an exception
12016 either through the use of the Raise_Exception function, or
12017 more simply (Ada 2005 and later), via:
12019 raise Exception_Name with "exception message";
12023 static gdb::unique_xmalloc_ptr<char>
12024 ada_exception_message_1 (void)
12026 struct value *e_msg_val;
12029 /* For runtimes that support this feature, the exception message
12030 is passed as an unbounded string argument called "message". */
12031 e_msg_val = parse_and_eval ("message");
12032 if (e_msg_val == NULL)
12033 return NULL; /* Exception message not supported. */
12035 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12036 gdb_assert (e_msg_val != NULL);
12037 e_msg_len = value_type (e_msg_val)->length ();
12039 /* If the message string is empty, then treat it as if there was
12040 no exception message. */
12041 if (e_msg_len <= 0)
12044 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12045 read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12047 e_msg.get ()[e_msg_len] = '\0';
12052 /* Same as ada_exception_message_1, except that all exceptions are
12053 contained here (returning NULL instead). */
12055 static gdb::unique_xmalloc_ptr<char>
12056 ada_exception_message (void)
12058 gdb::unique_xmalloc_ptr<char> e_msg;
12062 e_msg = ada_exception_message_1 ();
12064 catch (const gdb_exception_error &e)
12066 e_msg.reset (nullptr);
12072 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12073 any error that ada_exception_name_addr_1 might cause to be thrown.
12074 When an error is intercepted, a warning with the error message is printed,
12075 and zero is returned. */
12078 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12080 CORE_ADDR result = 0;
12084 result = ada_exception_name_addr_1 (ex);
12087 catch (const gdb_exception_error &e)
12089 warning (_("failed to get exception name: %s"), e.what ());
12096 static std::string ada_exception_catchpoint_cond_string
12097 (const char *excep_string,
12098 enum ada_exception_catchpoint_kind ex);
12100 /* Ada catchpoints.
12102 In the case of catchpoints on Ada exceptions, the catchpoint will
12103 stop the target on every exception the program throws. When a user
12104 specifies the name of a specific exception, we translate this
12105 request into a condition expression (in text form), and then parse
12106 it into an expression stored in each of the catchpoint's locations.
12107 We then use this condition to check whether the exception that was
12108 raised is the one the user is interested in. If not, then the
12109 target is resumed again. We store the name of the requested
12110 exception, in order to be able to re-set the condition expression
12111 when symbols change. */
12113 /* An instance of this type is used to represent an Ada catchpoint. */
12115 struct ada_catchpoint : public code_breakpoint
12117 ada_catchpoint (struct gdbarch *gdbarch_,
12118 enum ada_exception_catchpoint_kind kind,
12119 struct symtab_and_line sal,
12120 const char *addr_string_,
12124 : code_breakpoint (gdbarch_, bp_catchpoint),
12127 add_location (sal);
12129 /* Unlike most code_breakpoint types, Ada catchpoints are
12130 pspace-specific. */
12131 gdb_assert (sal.pspace != nullptr);
12132 this->pspace = sal.pspace;
12136 struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12138 loc_gdbarch = gdbarch;
12140 describe_other_breakpoints (loc_gdbarch,
12141 sal.pspace, sal.pc, sal.section, -1);
12142 /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12143 version for exception catchpoints, because two catchpoints
12144 used for different exception names will use the same address.
12145 In this case, a "breakpoint ... also set at..." warning is
12146 unproductive. Besides, the warning phrasing is also a bit
12147 inappropriate, we should use the word catchpoint, and tell
12148 the user what type of catchpoint it is. The above is good
12149 enough for now, though. */
12152 enable_state = enabled ? bp_enabled : bp_disabled;
12153 disposition = tempflag ? disp_del : disp_donttouch;
12154 locspec = string_to_location_spec (&addr_string_,
12155 language_def (language_ada));
12156 language = language_ada;
12159 struct bp_location *allocate_location () override;
12160 void re_set () override;
12161 void check_status (struct bpstat *bs) override;
12162 enum print_stop_action print_it (const bpstat *bs) const override;
12163 bool print_one (bp_location **) const override;
12164 void print_mention () const override;
12165 void print_recreate (struct ui_file *fp) const override;
12167 /* The name of the specific exception the user specified. */
12168 std::string excep_string;
12170 /* What kind of catchpoint this is. */
12171 enum ada_exception_catchpoint_kind m_kind;
12174 /* An instance of this type is used to represent an Ada catchpoint
12175 breakpoint location. */
12177 class ada_catchpoint_location : public bp_location
12180 explicit ada_catchpoint_location (ada_catchpoint *owner)
12181 : bp_location (owner, bp_loc_software_breakpoint)
12184 /* The condition that checks whether the exception that was raised
12185 is the specific exception the user specified on catchpoint
12187 expression_up excep_cond_expr;
12190 /* Parse the exception condition string in the context of each of the
12191 catchpoint's locations, and store them for later evaluation. */
12194 create_excep_cond_exprs (struct ada_catchpoint *c,
12195 enum ada_exception_catchpoint_kind ex)
12197 /* Nothing to do if there's no specific exception to catch. */
12198 if (c->excep_string.empty ())
12201 /* Same if there are no locations... */
12202 if (c->loc == NULL)
12205 /* Compute the condition expression in text form, from the specific
12206 expection we want to catch. */
12207 std::string cond_string
12208 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12210 /* Iterate over all the catchpoint's locations, and parse an
12211 expression for each. */
12212 for (bp_location *bl : c->locations ())
12214 struct ada_catchpoint_location *ada_loc
12215 = (struct ada_catchpoint_location *) bl;
12218 if (!bl->shlib_disabled)
12222 s = cond_string.c_str ();
12225 exp = parse_exp_1 (&s, bl->address,
12226 block_for_pc (bl->address),
12229 catch (const gdb_exception_error &e)
12231 warning (_("failed to reevaluate internal exception condition "
12232 "for catchpoint %d: %s"),
12233 c->number, e.what ());
12237 ada_loc->excep_cond_expr = std::move (exp);
12241 /* Implement the ALLOCATE_LOCATION method in the structure for all
12242 exception catchpoint kinds. */
12244 struct bp_location *
12245 ada_catchpoint::allocate_location ()
12247 return new ada_catchpoint_location (this);
12250 /* Implement the RE_SET method in the structure for all exception
12251 catchpoint kinds. */
12254 ada_catchpoint::re_set ()
12256 /* Call the base class's method. This updates the catchpoint's
12258 this->code_breakpoint::re_set ();
12260 /* Reparse the exception conditional expressions. One for each
12262 create_excep_cond_exprs (this, m_kind);
12265 /* Returns true if we should stop for this breakpoint hit. If the
12266 user specified a specific exception, we only want to cause a stop
12267 if the program thrown that exception. */
12270 should_stop_exception (const struct bp_location *bl)
12272 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12273 const struct ada_catchpoint_location *ada_loc
12274 = (const struct ada_catchpoint_location *) bl;
12277 struct internalvar *var = lookup_internalvar ("_ada_exception");
12278 if (c->m_kind == ada_catch_assert)
12279 clear_internalvar (var);
12286 if (c->m_kind == ada_catch_handlers)
12287 expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12288 ".all.occurrence.id");
12292 struct value *exc = parse_and_eval (expr);
12293 set_internalvar (var, exc);
12295 catch (const gdb_exception_error &ex)
12297 clear_internalvar (var);
12301 /* With no specific exception, should always stop. */
12302 if (c->excep_string.empty ())
12305 if (ada_loc->excep_cond_expr == NULL)
12307 /* We will have a NULL expression if back when we were creating
12308 the expressions, this location's had failed to parse. */
12315 scoped_value_mark mark;
12316 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12318 catch (const gdb_exception &ex)
12320 exception_fprintf (gdb_stderr, ex,
12321 _("Error in testing exception condition:\n"));
12327 /* Implement the CHECK_STATUS method in the structure for all
12328 exception catchpoint kinds. */
12331 ada_catchpoint::check_status (bpstat *bs)
12333 bs->stop = should_stop_exception (bs->bp_location_at.get ());
12336 /* Implement the PRINT_IT method in the structure for all exception
12337 catchpoint kinds. */
12339 enum print_stop_action
12340 ada_catchpoint::print_it (const bpstat *bs) const
12342 struct ui_out *uiout = current_uiout;
12344 annotate_catchpoint (number);
12346 if (uiout->is_mi_like_p ())
12348 uiout->field_string ("reason",
12349 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12350 uiout->field_string ("disp", bpdisp_text (disposition));
12353 uiout->text (disposition == disp_del
12354 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12355 uiout->field_signed ("bkptno", number);
12356 uiout->text (", ");
12358 /* ada_exception_name_addr relies on the selected frame being the
12359 current frame. Need to do this here because this function may be
12360 called more than once when printing a stop, and below, we'll
12361 select the first frame past the Ada run-time (see
12362 ada_find_printable_frame). */
12363 select_frame (get_current_frame ());
12367 case ada_catch_exception:
12368 case ada_catch_exception_unhandled:
12369 case ada_catch_handlers:
12371 const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12372 char exception_name[256];
12376 read_memory (addr, (gdb_byte *) exception_name,
12377 sizeof (exception_name) - 1);
12378 exception_name [sizeof (exception_name) - 1] = '\0';
12382 /* For some reason, we were unable to read the exception
12383 name. This could happen if the Runtime was compiled
12384 without debugging info, for instance. In that case,
12385 just replace the exception name by the generic string
12386 "exception" - it will read as "an exception" in the
12387 notification we are about to print. */
12388 memcpy (exception_name, "exception", sizeof ("exception"));
12390 /* In the case of unhandled exception breakpoints, we print
12391 the exception name as "unhandled EXCEPTION_NAME", to make
12392 it clearer to the user which kind of catchpoint just got
12393 hit. We used ui_out_text to make sure that this extra
12394 info does not pollute the exception name in the MI case. */
12395 if (m_kind == ada_catch_exception_unhandled)
12396 uiout->text ("unhandled ");
12397 uiout->field_string ("exception-name", exception_name);
12400 case ada_catch_assert:
12401 /* In this case, the name of the exception is not really
12402 important. Just print "failed assertion" to make it clearer
12403 that his program just hit an assertion-failure catchpoint.
12404 We used ui_out_text because this info does not belong in
12406 uiout->text ("failed assertion");
12410 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12411 if (exception_message != NULL)
12413 uiout->text (" (");
12414 uiout->field_string ("exception-message", exception_message.get ());
12418 uiout->text (" at ");
12419 ada_find_printable_frame (get_current_frame ());
12421 return PRINT_SRC_AND_LOC;
12424 /* Implement the PRINT_ONE method in the structure for all exception
12425 catchpoint kinds. */
12428 ada_catchpoint::print_one (bp_location **last_loc) const
12430 struct ui_out *uiout = current_uiout;
12431 struct value_print_options opts;
12433 get_user_print_options (&opts);
12435 if (opts.addressprint)
12436 uiout->field_skip ("addr");
12438 annotate_field (5);
12441 case ada_catch_exception:
12442 if (!excep_string.empty ())
12444 std::string msg = string_printf (_("`%s' Ada exception"),
12445 excep_string.c_str ());
12447 uiout->field_string ("what", msg);
12450 uiout->field_string ("what", "all Ada exceptions");
12454 case ada_catch_exception_unhandled:
12455 uiout->field_string ("what", "unhandled Ada exceptions");
12458 case ada_catch_handlers:
12459 if (!excep_string.empty ())
12461 uiout->field_fmt ("what",
12462 _("`%s' Ada exception handlers"),
12463 excep_string.c_str ());
12466 uiout->field_string ("what", "all Ada exceptions handlers");
12469 case ada_catch_assert:
12470 uiout->field_string ("what", "failed Ada assertions");
12474 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12481 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12482 for all exception catchpoint kinds. */
12485 ada_catchpoint::print_mention () const
12487 struct ui_out *uiout = current_uiout;
12489 uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12490 : _("Catchpoint "));
12491 uiout->field_signed ("bkptno", number);
12492 uiout->text (": ");
12496 case ada_catch_exception:
12497 if (!excep_string.empty ())
12499 std::string info = string_printf (_("`%s' Ada exception"),
12500 excep_string.c_str ());
12501 uiout->text (info);
12504 uiout->text (_("all Ada exceptions"));
12507 case ada_catch_exception_unhandled:
12508 uiout->text (_("unhandled Ada exceptions"));
12511 case ada_catch_handlers:
12512 if (!excep_string.empty ())
12515 = string_printf (_("`%s' Ada exception handlers"),
12516 excep_string.c_str ());
12517 uiout->text (info);
12520 uiout->text (_("all Ada exceptions handlers"));
12523 case ada_catch_assert:
12524 uiout->text (_("failed Ada assertions"));
12528 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12533 /* Implement the PRINT_RECREATE method in the structure for all
12534 exception catchpoint kinds. */
12537 ada_catchpoint::print_recreate (struct ui_file *fp) const
12541 case ada_catch_exception:
12542 gdb_printf (fp, "catch exception");
12543 if (!excep_string.empty ())
12544 gdb_printf (fp, " %s", excep_string.c_str ());
12547 case ada_catch_exception_unhandled:
12548 gdb_printf (fp, "catch exception unhandled");
12551 case ada_catch_handlers:
12552 gdb_printf (fp, "catch handlers");
12555 case ada_catch_assert:
12556 gdb_printf (fp, "catch assert");
12560 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12562 print_recreate_thread (fp);
12565 /* See ada-lang.h. */
12568 is_ada_exception_catchpoint (breakpoint *bp)
12570 return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12573 /* Split the arguments specified in a "catch exception" command.
12574 Set EX to the appropriate catchpoint type.
12575 Set EXCEP_STRING to the name of the specific exception if
12576 specified by the user.
12577 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12578 "catch handlers" command. False otherwise.
12579 If a condition is found at the end of the arguments, the condition
12580 expression is stored in COND_STRING (memory must be deallocated
12581 after use). Otherwise COND_STRING is set to NULL. */
12584 catch_ada_exception_command_split (const char *args,
12585 bool is_catch_handlers_cmd,
12586 enum ada_exception_catchpoint_kind *ex,
12587 std::string *excep_string,
12588 std::string *cond_string)
12590 std::string exception_name;
12592 exception_name = extract_arg (&args);
12593 if (exception_name == "if")
12595 /* This is not an exception name; this is the start of a condition
12596 expression for a catchpoint on all exceptions. So, "un-get"
12597 this token, and set exception_name to NULL. */
12598 exception_name.clear ();
12602 /* Check to see if we have a condition. */
12604 args = skip_spaces (args);
12605 if (startswith (args, "if")
12606 && (isspace (args[2]) || args[2] == '\0'))
12609 args = skip_spaces (args);
12611 if (args[0] == '\0')
12612 error (_("Condition missing after `if' keyword"));
12613 *cond_string = args;
12615 args += strlen (args);
12618 /* Check that we do not have any more arguments. Anything else
12621 if (args[0] != '\0')
12622 error (_("Junk at end of expression"));
12624 if (is_catch_handlers_cmd)
12626 /* Catch handling of exceptions. */
12627 *ex = ada_catch_handlers;
12628 *excep_string = exception_name;
12630 else if (exception_name.empty ())
12632 /* Catch all exceptions. */
12633 *ex = ada_catch_exception;
12634 excep_string->clear ();
12636 else if (exception_name == "unhandled")
12638 /* Catch unhandled exceptions. */
12639 *ex = ada_catch_exception_unhandled;
12640 excep_string->clear ();
12644 /* Catch a specific exception. */
12645 *ex = ada_catch_exception;
12646 *excep_string = exception_name;
12650 /* Return the name of the symbol on which we should break in order to
12651 implement a catchpoint of the EX kind. */
12653 static const char *
12654 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12656 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12658 gdb_assert (data->exception_info != NULL);
12662 case ada_catch_exception:
12663 return (data->exception_info->catch_exception_sym);
12665 case ada_catch_exception_unhandled:
12666 return (data->exception_info->catch_exception_unhandled_sym);
12668 case ada_catch_assert:
12669 return (data->exception_info->catch_assert_sym);
12671 case ada_catch_handlers:
12672 return (data->exception_info->catch_handlers_sym);
12675 internal_error (__FILE__, __LINE__,
12676 _("unexpected catchpoint kind (%d)"), ex);
12680 /* Return the condition that will be used to match the current exception
12681 being raised with the exception that the user wants to catch. This
12682 assumes that this condition is used when the inferior just triggered
12683 an exception catchpoint.
12684 EX: the type of catchpoints used for catching Ada exceptions. */
12687 ada_exception_catchpoint_cond_string (const char *excep_string,
12688 enum ada_exception_catchpoint_kind ex)
12690 bool is_standard_exc = false;
12691 std::string result;
12693 if (ex == ada_catch_handlers)
12695 /* For exception handlers catchpoints, the condition string does
12696 not use the same parameter as for the other exceptions. */
12697 result = ("long_integer (GNAT_GCC_exception_Access"
12698 "(gcc_exception).all.occurrence.id)");
12701 result = "long_integer (e)";
12703 /* The standard exceptions are a special case. They are defined in
12704 runtime units that have been compiled without debugging info; if
12705 EXCEP_STRING is the not-fully-qualified name of a standard
12706 exception (e.g. "constraint_error") then, during the evaluation
12707 of the condition expression, the symbol lookup on this name would
12708 *not* return this standard exception. The catchpoint condition
12709 may then be set only on user-defined exceptions which have the
12710 same not-fully-qualified name (e.g. my_package.constraint_error).
12712 To avoid this unexcepted behavior, these standard exceptions are
12713 systematically prefixed by "standard". This means that "catch
12714 exception constraint_error" is rewritten into "catch exception
12715 standard.constraint_error".
12717 If an exception named constraint_error is defined in another package of
12718 the inferior program, then the only way to specify this exception as a
12719 breakpoint condition is to use its fully-qualified named:
12720 e.g. my_package.constraint_error. */
12722 for (const char *name : standard_exc)
12724 if (strcmp (name, excep_string) == 0)
12726 is_standard_exc = true;
12733 if (is_standard_exc)
12734 string_appendf (result, "long_integer (&standard.%s)", excep_string);
12736 string_appendf (result, "long_integer (&%s)", excep_string);
12741 /* Return the symtab_and_line that should be used to insert an exception
12742 catchpoint of the TYPE kind.
12744 ADDR_STRING returns the name of the function where the real
12745 breakpoint that implements the catchpoints is set, depending on the
12746 type of catchpoint we need to create. */
12748 static struct symtab_and_line
12749 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12750 std::string *addr_string)
12752 const char *sym_name;
12753 struct symbol *sym;
12755 /* First, find out which exception support info to use. */
12756 ada_exception_support_info_sniffer ();
12758 /* Then lookup the function on which we will break in order to catch
12759 the Ada exceptions requested by the user. */
12760 sym_name = ada_exception_sym_name (ex);
12761 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12764 error (_("Catchpoint symbol not found: %s"), sym_name);
12766 if (sym->aclass () != LOC_BLOCK)
12767 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12769 /* Set ADDR_STRING. */
12770 *addr_string = sym_name;
12772 return find_function_start_sal (sym, 1);
12775 /* Create an Ada exception catchpoint.
12777 EX_KIND is the kind of exception catchpoint to be created.
12779 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12780 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12781 of the exception to which this catchpoint applies.
12783 COND_STRING, if not empty, is the catchpoint condition.
12785 TEMPFLAG, if nonzero, means that the underlying breakpoint
12786 should be temporary.
12788 FROM_TTY is the usual argument passed to all commands implementations. */
12791 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12792 enum ada_exception_catchpoint_kind ex_kind,
12793 const std::string &excep_string,
12794 const std::string &cond_string,
12799 std::string addr_string;
12800 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12802 std::unique_ptr<ada_catchpoint> c
12803 (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12804 tempflag, disabled, from_tty));
12805 c->excep_string = excep_string;
12806 create_excep_cond_exprs (c.get (), ex_kind);
12807 if (!cond_string.empty ())
12808 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12809 install_breakpoint (0, std::move (c), 1);
12812 /* Implement the "catch exception" command. */
12815 catch_ada_exception_command (const char *arg_entry, int from_tty,
12816 struct cmd_list_element *command)
12818 const char *arg = arg_entry;
12819 struct gdbarch *gdbarch = get_current_arch ();
12821 enum ada_exception_catchpoint_kind ex_kind;
12822 std::string excep_string;
12823 std::string cond_string;
12825 tempflag = command->context () == CATCH_TEMPORARY;
12829 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12831 create_ada_exception_catchpoint (gdbarch, ex_kind,
12832 excep_string, cond_string,
12833 tempflag, 1 /* enabled */,
12837 /* Implement the "catch handlers" command. */
12840 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12841 struct cmd_list_element *command)
12843 const char *arg = arg_entry;
12844 struct gdbarch *gdbarch = get_current_arch ();
12846 enum ada_exception_catchpoint_kind ex_kind;
12847 std::string excep_string;
12848 std::string cond_string;
12850 tempflag = command->context () == CATCH_TEMPORARY;
12854 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12856 create_ada_exception_catchpoint (gdbarch, ex_kind,
12857 excep_string, cond_string,
12858 tempflag, 1 /* enabled */,
12862 /* Completion function for the Ada "catch" commands. */
12865 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12866 const char *text, const char *word)
12868 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12870 for (const ada_exc_info &info : exceptions)
12872 if (startswith (info.name, word))
12873 tracker.add_completion (make_unique_xstrdup (info.name));
12877 /* Split the arguments specified in a "catch assert" command.
12879 ARGS contains the command's arguments (or the empty string if
12880 no arguments were passed).
12882 If ARGS contains a condition, set COND_STRING to that condition
12883 (the memory needs to be deallocated after use). */
12886 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12888 args = skip_spaces (args);
12890 /* Check whether a condition was provided. */
12891 if (startswith (args, "if")
12892 && (isspace (args[2]) || args[2] == '\0'))
12895 args = skip_spaces (args);
12896 if (args[0] == '\0')
12897 error (_("condition missing after `if' keyword"));
12898 cond_string.assign (args);
12901 /* Otherwise, there should be no other argument at the end of
12903 else if (args[0] != '\0')
12904 error (_("Junk at end of arguments."));
12907 /* Implement the "catch assert" command. */
12910 catch_assert_command (const char *arg_entry, int from_tty,
12911 struct cmd_list_element *command)
12913 const char *arg = arg_entry;
12914 struct gdbarch *gdbarch = get_current_arch ();
12916 std::string cond_string;
12918 tempflag = command->context () == CATCH_TEMPORARY;
12922 catch_ada_assert_command_split (arg, cond_string);
12923 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12925 tempflag, 1 /* enabled */,
12929 /* Return non-zero if the symbol SYM is an Ada exception object. */
12932 ada_is_exception_sym (struct symbol *sym)
12934 const char *type_name = sym->type ()->name ();
12936 return (sym->aclass () != LOC_TYPEDEF
12937 && sym->aclass () != LOC_BLOCK
12938 && sym->aclass () != LOC_CONST
12939 && sym->aclass () != LOC_UNRESOLVED
12940 && type_name != NULL && strcmp (type_name, "exception") == 0);
12943 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12944 Ada exception object. This matches all exceptions except the ones
12945 defined by the Ada language. */
12948 ada_is_non_standard_exception_sym (struct symbol *sym)
12950 if (!ada_is_exception_sym (sym))
12953 for (const char *name : standard_exc)
12954 if (strcmp (sym->linkage_name (), name) == 0)
12955 return 0; /* A standard exception. */
12957 /* Numeric_Error is also a standard exception, so exclude it.
12958 See the STANDARD_EXC description for more details as to why
12959 this exception is not listed in that array. */
12960 if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12966 /* A helper function for std::sort, comparing two struct ada_exc_info
12969 The comparison is determined first by exception name, and then
12970 by exception address. */
12973 ada_exc_info::operator< (const ada_exc_info &other) const
12977 result = strcmp (name, other.name);
12980 if (result == 0 && addr < other.addr)
12986 ada_exc_info::operator== (const ada_exc_info &other) const
12988 return addr == other.addr && strcmp (name, other.name) == 0;
12991 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12992 routine, but keeping the first SKIP elements untouched.
12994 All duplicates are also removed. */
12997 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13000 std::sort (exceptions->begin () + skip, exceptions->end ());
13001 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13002 exceptions->end ());
13005 /* Add all exceptions defined by the Ada standard whose name match
13006 a regular expression.
13008 If PREG is not NULL, then this regexp_t object is used to
13009 perform the symbol name matching. Otherwise, no name-based
13010 filtering is performed.
13012 EXCEPTIONS is a vector of exceptions to which matching exceptions
13016 ada_add_standard_exceptions (compiled_regex *preg,
13017 std::vector<ada_exc_info> *exceptions)
13019 for (const char *name : standard_exc)
13021 if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13023 symbol_name_match_type match_type = name_match_type_from_name (name);
13024 lookup_name_info lookup_name (name, match_type);
13026 symbol_name_matcher_ftype *match_name
13027 = ada_get_symbol_name_matcher (lookup_name);
13029 /* Iterate over all objfiles irrespective of scope or linker
13030 namespaces so we get all exceptions anywhere in the
13032 for (objfile *objfile : current_program_space->objfiles ())
13034 for (minimal_symbol *msymbol : objfile->msymbols ())
13036 if (match_name (msymbol->linkage_name (), lookup_name,
13038 && msymbol->type () != mst_solib_trampoline)
13041 = {name, msymbol->value_address (objfile)};
13043 exceptions->push_back (info);
13051 /* Add all Ada exceptions defined locally and accessible from the given
13054 If PREG is not NULL, then this regexp_t object is used to
13055 perform the symbol name matching. Otherwise, no name-based
13056 filtering is performed.
13058 EXCEPTIONS is a vector of exceptions to which matching exceptions
13062 ada_add_exceptions_from_frame (compiled_regex *preg,
13063 frame_info_ptr frame,
13064 std::vector<ada_exc_info> *exceptions)
13066 const struct block *block = get_frame_block (frame, 0);
13070 struct block_iterator iter;
13071 struct symbol *sym;
13073 ALL_BLOCK_SYMBOLS (block, iter, sym)
13075 switch (sym->aclass ())
13082 if (ada_is_exception_sym (sym))
13084 struct ada_exc_info info = {sym->print_name (),
13085 sym->value_address ()};
13087 exceptions->push_back (info);
13091 if (block->function () != NULL)
13093 block = block->superblock ();
13097 /* Return true if NAME matches PREG or if PREG is NULL. */
13100 name_matches_regex (const char *name, compiled_regex *preg)
13102 return (preg == NULL
13103 || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13106 /* Add all exceptions defined globally whose name name match
13107 a regular expression, excluding standard exceptions.
13109 The reason we exclude standard exceptions is that they need
13110 to be handled separately: Standard exceptions are defined inside
13111 a runtime unit which is normally not compiled with debugging info,
13112 and thus usually do not show up in our symbol search. However,
13113 if the unit was in fact built with debugging info, we need to
13114 exclude them because they would duplicate the entry we found
13115 during the special loop that specifically searches for those
13116 standard exceptions.
13118 If PREG is not NULL, then this regexp_t object is used to
13119 perform the symbol name matching. Otherwise, no name-based
13120 filtering is performed.
13122 EXCEPTIONS is a vector of exceptions to which matching exceptions
13126 ada_add_global_exceptions (compiled_regex *preg,
13127 std::vector<ada_exc_info> *exceptions)
13129 /* In Ada, the symbol "search name" is a linkage name, whereas the
13130 regular expression used to do the matching refers to the natural
13131 name. So match against the decoded name. */
13132 expand_symtabs_matching (NULL,
13133 lookup_name_info::match_any (),
13134 [&] (const char *search_name)
13136 std::string decoded = ada_decode (search_name);
13137 return name_matches_regex (decoded.c_str (), preg);
13140 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13143 /* Iterate over all objfiles irrespective of scope or linker namespaces
13144 so we get all exceptions anywhere in the progspace. */
13145 for (objfile *objfile : current_program_space->objfiles ())
13147 for (compunit_symtab *s : objfile->compunits ())
13149 const struct blockvector *bv = s->blockvector ();
13152 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13154 const struct block *b = bv->block (i);
13155 struct block_iterator iter;
13156 struct symbol *sym;
13158 ALL_BLOCK_SYMBOLS (b, iter, sym)
13159 if (ada_is_non_standard_exception_sym (sym)
13160 && name_matches_regex (sym->natural_name (), preg))
13162 struct ada_exc_info info
13163 = {sym->print_name (), sym->value_address ()};
13165 exceptions->push_back (info);
13172 /* Implements ada_exceptions_list with the regular expression passed
13173 as a regex_t, rather than a string.
13175 If not NULL, PREG is used to filter out exceptions whose names
13176 do not match. Otherwise, all exceptions are listed. */
13178 static std::vector<ada_exc_info>
13179 ada_exceptions_list_1 (compiled_regex *preg)
13181 std::vector<ada_exc_info> result;
13184 /* First, list the known standard exceptions. These exceptions
13185 need to be handled separately, as they are usually defined in
13186 runtime units that have been compiled without debugging info. */
13188 ada_add_standard_exceptions (preg, &result);
13190 /* Next, find all exceptions whose scope is local and accessible
13191 from the currently selected frame. */
13193 if (has_stack_frames ())
13195 prev_len = result.size ();
13196 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13198 if (result.size () > prev_len)
13199 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13202 /* Add all exceptions whose scope is global. */
13204 prev_len = result.size ();
13205 ada_add_global_exceptions (preg, &result);
13206 if (result.size () > prev_len)
13207 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13212 /* Return a vector of ada_exc_info.
13214 If REGEXP is NULL, all exceptions are included in the result.
13215 Otherwise, it should contain a valid regular expression,
13216 and only the exceptions whose names match that regular expression
13217 are included in the result.
13219 The exceptions are sorted in the following order:
13220 - Standard exceptions (defined by the Ada language), in
13221 alphabetical order;
13222 - Exceptions only visible from the current frame, in
13223 alphabetical order;
13224 - Exceptions whose scope is global, in alphabetical order. */
13226 std::vector<ada_exc_info>
13227 ada_exceptions_list (const char *regexp)
13229 if (regexp == NULL)
13230 return ada_exceptions_list_1 (NULL);
13232 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13233 return ada_exceptions_list_1 (®);
13236 /* Implement the "info exceptions" command. */
13239 info_exceptions_command (const char *regexp, int from_tty)
13241 struct gdbarch *gdbarch = get_current_arch ();
13243 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13245 if (regexp != NULL)
13247 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13249 gdb_printf (_("All defined Ada exceptions:\n"));
13251 for (const ada_exc_info &info : exceptions)
13252 gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13256 /* Language vector */
13258 /* symbol_name_matcher_ftype adapter for wild_match. */
13261 do_wild_match (const char *symbol_search_name,
13262 const lookup_name_info &lookup_name,
13263 completion_match_result *comp_match_res)
13265 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13268 /* symbol_name_matcher_ftype adapter for full_match. */
13271 do_full_match (const char *symbol_search_name,
13272 const lookup_name_info &lookup_name,
13273 completion_match_result *comp_match_res)
13275 const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13277 /* If both symbols start with "_ada_", just let the loop below
13278 handle the comparison. However, if only the symbol name starts
13279 with "_ada_", skip the prefix and let the match proceed as
13281 if (startswith (symbol_search_name, "_ada_")
13282 && !startswith (lname, "_ada"))
13283 symbol_search_name += 5;
13284 /* Likewise for ghost entities. */
13285 if (startswith (symbol_search_name, "___ghost_")
13286 && !startswith (lname, "___ghost_"))
13287 symbol_search_name += 9;
13289 int uscore_count = 0;
13290 while (*lname != '\0')
13292 if (*symbol_search_name != *lname)
13294 if (*symbol_search_name == 'B' && uscore_count == 2
13295 && symbol_search_name[1] == '_')
13297 symbol_search_name += 2;
13298 while (isdigit (*symbol_search_name))
13299 ++symbol_search_name;
13300 if (symbol_search_name[0] == '_'
13301 && symbol_search_name[1] == '_')
13303 symbol_search_name += 2;
13310 if (*symbol_search_name == '_')
13315 ++symbol_search_name;
13319 return is_name_suffix (symbol_search_name);
13322 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13325 do_exact_match (const char *symbol_search_name,
13326 const lookup_name_info &lookup_name,
13327 completion_match_result *comp_match_res)
13329 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13332 /* Build the Ada lookup name for LOOKUP_NAME. */
13334 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13336 gdb::string_view user_name = lookup_name.name ();
13338 if (!user_name.empty () && user_name[0] == '<')
13340 if (user_name.back () == '>')
13342 = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13345 = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13346 m_encoded_p = true;
13347 m_verbatim_p = true;
13348 m_wild_match_p = false;
13349 m_standard_p = false;
13353 m_verbatim_p = false;
13355 m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13359 const char *folded = ada_fold_name (user_name);
13360 m_encoded_name = ada_encode_1 (folded, false);
13361 if (m_encoded_name.empty ())
13362 m_encoded_name = gdb::to_string (user_name);
13365 m_encoded_name = gdb::to_string (user_name);
13367 /* Handle the 'package Standard' special case. See description
13368 of m_standard_p. */
13369 if (startswith (m_encoded_name.c_str (), "standard__"))
13371 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13372 m_standard_p = true;
13375 m_standard_p = false;
13377 /* If the name contains a ".", then the user is entering a fully
13378 qualified entity name, and the match must not be done in wild
13379 mode. Similarly, if the user wants to complete what looks
13380 like an encoded name, the match must not be done in wild
13381 mode. Also, in the standard__ special case always do
13382 non-wild matching. */
13384 = (lookup_name.match_type () != symbol_name_match_type::FULL
13387 && user_name.find ('.') == std::string::npos);
13391 /* symbol_name_matcher_ftype method for Ada. This only handles
13392 completion mode. */
13395 ada_symbol_name_matches (const char *symbol_search_name,
13396 const lookup_name_info &lookup_name,
13397 completion_match_result *comp_match_res)
13399 return lookup_name.ada ().matches (symbol_search_name,
13400 lookup_name.match_type (),
13404 /* A name matcher that matches the symbol name exactly, with
13408 literal_symbol_name_matcher (const char *symbol_search_name,
13409 const lookup_name_info &lookup_name,
13410 completion_match_result *comp_match_res)
13412 gdb::string_view name_view = lookup_name.name ();
13414 if (lookup_name.completion_mode ()
13415 ? (strncmp (symbol_search_name, name_view.data (),
13416 name_view.size ()) == 0)
13417 : symbol_search_name == name_view)
13419 if (comp_match_res != NULL)
13420 comp_match_res->set_match (symbol_search_name);
13427 /* Implement the "get_symbol_name_matcher" language_defn method for
13430 static symbol_name_matcher_ftype *
13431 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13433 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13434 return literal_symbol_name_matcher;
13436 if (lookup_name.completion_mode ())
13437 return ada_symbol_name_matches;
13440 if (lookup_name.ada ().wild_match_p ())
13441 return do_wild_match;
13442 else if (lookup_name.ada ().verbatim_p ())
13443 return do_exact_match;
13445 return do_full_match;
13449 /* Class representing the Ada language. */
13451 class ada_language : public language_defn
13455 : language_defn (language_ada)
13458 /* See language.h. */
13460 const char *name () const override
13463 /* See language.h. */
13465 const char *natural_name () const override
13468 /* See language.h. */
13470 const std::vector<const char *> &filename_extensions () const override
13472 static const std::vector<const char *> extensions
13473 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13477 /* Print an array element index using the Ada syntax. */
13479 void print_array_index (struct type *index_type,
13481 struct ui_file *stream,
13482 const value_print_options *options) const override
13484 struct value *index_value = val_atr (index_type, index);
13486 value_print (index_value, stream, options);
13487 gdb_printf (stream, " => ");
13490 /* Implement the "read_var_value" language_defn method for Ada. */
13492 struct value *read_var_value (struct symbol *var,
13493 const struct block *var_block,
13494 frame_info_ptr frame) const override
13496 /* The only case where default_read_var_value is not sufficient
13497 is when VAR is a renaming... */
13498 if (frame != nullptr)
13500 const struct block *frame_block = get_frame_block (frame, NULL);
13501 if (frame_block != nullptr && ada_is_renaming_symbol (var))
13502 return ada_read_renaming_var_value (var, frame_block);
13505 /* This is a typical case where we expect the default_read_var_value
13506 function to work. */
13507 return language_defn::read_var_value (var, var_block, frame);
13510 /* See language.h. */
13511 bool symbol_printing_suppressed (struct symbol *symbol) const override
13513 return symbol->is_artificial ();
13516 /* See language.h. */
13517 void language_arch_info (struct gdbarch *gdbarch,
13518 struct language_arch_info *lai) const override
13520 const struct builtin_type *builtin = builtin_type (gdbarch);
13522 /* Helper function to allow shorter lines below. */
13523 auto add = [&] (struct type *t)
13525 lai->add_primitive_type (t);
13528 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13530 add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13531 0, "long_integer"));
13532 add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13533 0, "short_integer"));
13534 struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13536 lai->set_string_char_type (char_type);
13538 add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13539 add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13540 add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13541 "float", gdbarch_float_format (gdbarch)));
13542 add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13543 "long_float", gdbarch_double_format (gdbarch)));
13544 add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13545 0, "long_long_integer"));
13546 add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13548 gdbarch_long_double_format (gdbarch)));
13549 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13551 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13553 add (builtin->builtin_void);
13555 struct type *system_addr_ptr
13556 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13558 system_addr_ptr->set_name ("system__address");
13559 add (system_addr_ptr);
13561 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13562 type. This is a signed integral type whose size is the same as
13563 the size of addresses. */
13564 unsigned int addr_length = system_addr_ptr->length ();
13565 add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13566 "storage_offset"));
13568 lai->set_bool_type (builtin->builtin_bool);
13571 /* See language.h. */
13573 bool iterate_over_symbols
13574 (const struct block *block, const lookup_name_info &name,
13575 domain_enum domain,
13576 gdb::function_view<symbol_found_callback_ftype> callback) const override
13578 std::vector<struct block_symbol> results
13579 = ada_lookup_symbol_list_worker (name, block, domain, 0);
13580 for (block_symbol &sym : results)
13582 if (!callback (&sym))
13589 /* See language.h. */
13590 bool sniff_from_mangled_name
13591 (const char *mangled,
13592 gdb::unique_xmalloc_ptr<char> *out) const override
13594 std::string demangled = ada_decode (mangled);
13598 if (demangled != mangled && demangled[0] != '<')
13600 /* Set the gsymbol language to Ada, but still return 0.
13601 Two reasons for that:
13603 1. For Ada, we prefer computing the symbol's decoded name
13604 on the fly rather than pre-compute it, in order to save
13605 memory (Ada projects are typically very large).
13607 2. There are some areas in the definition of the GNAT
13608 encoding where, with a bit of bad luck, we might be able
13609 to decode a non-Ada symbol, generating an incorrect
13610 demangled name (Eg: names ending with "TB" for instance
13611 are identified as task bodies and so stripped from
13612 the decoded name returned).
13614 Returning true, here, but not setting *DEMANGLED, helps us get
13615 a little bit of the best of both worlds. Because we're last,
13616 we should not affect any of the other languages that were
13617 able to demangle the symbol before us; we get to correctly
13618 tag Ada symbols as such; and even if we incorrectly tagged a
13619 non-Ada symbol, which should be rare, any routing through the
13620 Ada language should be transparent (Ada tries to behave much
13621 like C/C++ with non-Ada symbols). */
13628 /* See language.h. */
13630 gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13631 int options) const override
13633 return make_unique_xstrdup (ada_decode (mangled).c_str ());
13636 /* See language.h. */
13638 void print_type (struct type *type, const char *varstring,
13639 struct ui_file *stream, int show, int level,
13640 const struct type_print_options *flags) const override
13642 ada_print_type (type, varstring, stream, show, level, flags);
13645 /* See language.h. */
13647 const char *word_break_characters (void) const override
13649 return ada_completer_word_break_characters;
13652 /* See language.h. */
13654 void collect_symbol_completion_matches (completion_tracker &tracker,
13655 complete_symbol_mode mode,
13656 symbol_name_match_type name_match_type,
13657 const char *text, const char *word,
13658 enum type_code code) const override
13660 struct symbol *sym;
13661 const struct block *b, *surrounding_static_block = 0;
13662 struct block_iterator iter;
13664 gdb_assert (code == TYPE_CODE_UNDEF);
13666 lookup_name_info lookup_name (text, name_match_type, true);
13668 /* First, look at the partial symtab symbols. */
13669 expand_symtabs_matching (NULL,
13673 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13676 /* At this point scan through the misc symbol vectors and add each
13677 symbol you find to the list. Eventually we want to ignore
13678 anything that isn't a text symbol (everything else will be
13679 handled by the psymtab code above). */
13681 for (objfile *objfile : current_program_space->objfiles ())
13683 for (minimal_symbol *msymbol : objfile->msymbols ())
13687 if (completion_skip_symbol (mode, msymbol))
13690 language symbol_language = msymbol->language ();
13692 /* Ada minimal symbols won't have their language set to Ada. If
13693 we let completion_list_add_name compare using the
13694 default/C-like matcher, then when completing e.g., symbols in a
13695 package named "pck", we'd match internal Ada symbols like
13696 "pckS", which are invalid in an Ada expression, unless you wrap
13697 them in '<' '>' to request a verbatim match.
13699 Unfortunately, some Ada encoded names successfully demangle as
13700 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13701 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13702 with the wrong language set. Paper over that issue here. */
13703 if (symbol_language == language_auto
13704 || symbol_language == language_cplus)
13705 symbol_language = language_ada;
13707 completion_list_add_name (tracker,
13709 msymbol->linkage_name (),
13710 lookup_name, text, word);
13714 /* Search upwards from currently selected frame (so that we can
13715 complete on local vars. */
13717 for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13719 if (!b->superblock ())
13720 surrounding_static_block = b; /* For elmin of dups */
13722 ALL_BLOCK_SYMBOLS (b, iter, sym)
13724 if (completion_skip_symbol (mode, sym))
13727 completion_list_add_name (tracker,
13729 sym->linkage_name (),
13730 lookup_name, text, word);
13734 /* Go through the symtabs and check the externs and statics for
13735 symbols which match. */
13737 for (objfile *objfile : current_program_space->objfiles ())
13739 for (compunit_symtab *s : objfile->compunits ())
13742 b = s->blockvector ()->global_block ();
13743 ALL_BLOCK_SYMBOLS (b, iter, sym)
13745 if (completion_skip_symbol (mode, sym))
13748 completion_list_add_name (tracker,
13750 sym->linkage_name (),
13751 lookup_name, text, word);
13756 for (objfile *objfile : current_program_space->objfiles ())
13758 for (compunit_symtab *s : objfile->compunits ())
13761 b = s->blockvector ()->static_block ();
13762 /* Don't do this block twice. */
13763 if (b == surrounding_static_block)
13765 ALL_BLOCK_SYMBOLS (b, iter, sym)
13767 if (completion_skip_symbol (mode, sym))
13770 completion_list_add_name (tracker,
13772 sym->linkage_name (),
13773 lookup_name, text, word);
13779 /* See language.h. */
13781 gdb::unique_xmalloc_ptr<char> watch_location_expression
13782 (struct type *type, CORE_ADDR addr) const override
13784 type = check_typedef (check_typedef (type)->target_type ());
13785 std::string name = type_to_string (type);
13786 return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13789 /* See language.h. */
13791 void value_print (struct value *val, struct ui_file *stream,
13792 const struct value_print_options *options) const override
13794 return ada_value_print (val, stream, options);
13797 /* See language.h. */
13799 void value_print_inner
13800 (struct value *val, struct ui_file *stream, int recurse,
13801 const struct value_print_options *options) const override
13803 return ada_value_print_inner (val, stream, recurse, options);
13806 /* See language.h. */
13808 struct block_symbol lookup_symbol_nonlocal
13809 (const char *name, const struct block *block,
13810 const domain_enum domain) const override
13812 struct block_symbol sym;
13814 sym = ada_lookup_symbol (name, block_static_block (block), domain);
13815 if (sym.symbol != NULL)
13818 /* If we haven't found a match at this point, try the primitive
13819 types. In other languages, this search is performed before
13820 searching for global symbols in order to short-circuit that
13821 global-symbol search if it happens that the name corresponds
13822 to a primitive type. But we cannot do the same in Ada, because
13823 it is perfectly legitimate for a program to declare a type which
13824 has the same name as a standard type. If looking up a type in
13825 that situation, we have traditionally ignored the primitive type
13826 in favor of user-defined types. This is why, unlike most other
13827 languages, we search the primitive types this late and only after
13828 having searched the global symbols without success. */
13830 if (domain == VAR_DOMAIN)
13832 struct gdbarch *gdbarch;
13835 gdbarch = target_gdbarch ();
13837 gdbarch = block_gdbarch (block);
13839 = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13840 if (sym.symbol != NULL)
13847 /* See language.h. */
13849 int parser (struct parser_state *ps) const override
13851 warnings_issued = 0;
13852 return ada_parse (ps);
13855 /* See language.h. */
13857 void emitchar (int ch, struct type *chtype,
13858 struct ui_file *stream, int quoter) const override
13860 ada_emit_char (ch, chtype, stream, quoter, 1);
13863 /* See language.h. */
13865 void printchar (int ch, struct type *chtype,
13866 struct ui_file *stream) const override
13868 ada_printchar (ch, chtype, stream);
13871 /* See language.h. */
13873 void printstr (struct ui_file *stream, struct type *elttype,
13874 const gdb_byte *string, unsigned int length,
13875 const char *encoding, int force_ellipses,
13876 const struct value_print_options *options) const override
13878 ada_printstr (stream, elttype, string, length, encoding,
13879 force_ellipses, options);
13882 /* See language.h. */
13884 void print_typedef (struct type *type, struct symbol *new_symbol,
13885 struct ui_file *stream) const override
13887 ada_print_typedef (type, new_symbol, stream);
13890 /* See language.h. */
13892 bool is_string_type_p (struct type *type) const override
13894 return ada_is_string_type (type);
13897 /* See language.h. */
13899 const char *struct_too_deep_ellipsis () const override
13900 { return "(...)"; }
13902 /* See language.h. */
13904 bool c_style_arrays_p () const override
13907 /* See language.h. */
13909 bool store_sym_names_in_linkage_form_p () const override
13912 /* See language.h. */
13914 const struct lang_varobj_ops *varobj_ops () const override
13915 { return &ada_varobj_ops; }
13918 /* See language.h. */
13920 symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13921 (const lookup_name_info &lookup_name) const override
13923 return ada_get_symbol_name_matcher (lookup_name);
13927 /* Single instance of the Ada language class. */
13929 static ada_language ada_language_defn;
13931 /* Command-list for the "set/show ada" prefix command. */
13932 static struct cmd_list_element *set_ada_list;
13933 static struct cmd_list_element *show_ada_list;
13935 /* This module's 'new_objfile' observer. */
13938 ada_new_objfile_observer (struct objfile *objfile)
13940 ada_clear_symbol_cache ();
13943 /* This module's 'free_objfile' observer. */
13946 ada_free_objfile_observer (struct objfile *objfile)
13948 ada_clear_symbol_cache ();
13951 /* Charsets known to GNAT. */
13952 static const char * const gnat_source_charsets[] =
13954 /* Note that code below assumes that the default comes first.
13955 Latin-1 is the default here, because that is also GNAT's
13965 /* Note that this value is special-cased in the encoder and
13971 void _initialize_ada_language ();
13973 _initialize_ada_language ()
13975 add_setshow_prefix_cmd
13977 _("Prefix command for changing Ada-specific settings."),
13978 _("Generic command for showing Ada-specific settings."),
13979 &set_ada_list, &show_ada_list,
13980 &setlist, &showlist);
13982 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13983 &trust_pad_over_xvs, _("\
13984 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13985 Show whether an optimization trusting PAD types over XVS types is activated."),
13987 This is related to the encoding used by the GNAT compiler. The debugger\n\
13988 should normally trust the contents of PAD types, but certain older versions\n\
13989 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13990 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13991 work around this bug. It is always safe to turn this option \"off\", but\n\
13992 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13993 this option to \"off\" unless necessary."),
13994 NULL, NULL, &set_ada_list, &show_ada_list);
13996 add_setshow_boolean_cmd ("print-signatures", class_vars,
13997 &print_signatures, _("\
13998 Enable or disable the output of formal and return types for functions in the \
13999 overloads selection menu."), _("\
14000 Show whether the output of formal and return types for functions in the \
14001 overloads selection menu is activated."),
14002 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14004 ada_source_charset = gnat_source_charsets[0];
14005 add_setshow_enum_cmd ("source-charset", class_files,
14006 gnat_source_charsets,
14007 &ada_source_charset, _("\
14008 Set the Ada source character set."), _("\
14009 Show the Ada source character set."), _("\
14010 The character set used for Ada source files.\n\
14011 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14013 &set_ada_list, &show_ada_list);
14015 add_catch_command ("exception", _("\
14016 Catch Ada exceptions, when raised.\n\
14017 Usage: catch exception [ARG] [if CONDITION]\n\
14018 Without any argument, stop when any Ada exception is raised.\n\
14019 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14020 being raised does not have a handler (and will therefore lead to the task's\n\
14022 Otherwise, the catchpoint only stops when the name of the exception being\n\
14023 raised is the same as ARG.\n\
14024 CONDITION is a boolean expression that is evaluated to see whether the\n\
14025 exception should cause a stop."),
14026 catch_ada_exception_command,
14027 catch_ada_completer,
14031 add_catch_command ("handlers", _("\
14032 Catch Ada exceptions, when handled.\n\
14033 Usage: catch handlers [ARG] [if CONDITION]\n\
14034 Without any argument, stop when any Ada exception is handled.\n\
14035 With an argument, catch only exceptions with the given name.\n\
14036 CONDITION is a boolean expression that is evaluated to see whether the\n\
14037 exception should cause a stop."),
14038 catch_ada_handlers_command,
14039 catch_ada_completer,
14042 add_catch_command ("assert", _("\
14043 Catch failed Ada assertions, when raised.\n\
14044 Usage: catch assert [if CONDITION]\n\
14045 CONDITION is a boolean expression that is evaluated to see whether the\n\
14046 exception should cause a stop."),
14047 catch_assert_command,
14052 add_info ("exceptions", info_exceptions_command,
14054 List all Ada exception names.\n\
14055 Usage: info exceptions [REGEXP]\n\
14056 If a regular expression is passed as an argument, only those matching\n\
14057 the regular expression are listed."));
14059 add_setshow_prefix_cmd ("ada", class_maintenance,
14060 _("Set Ada maintenance-related variables."),
14061 _("Show Ada maintenance-related variables."),
14062 &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14063 &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14065 add_setshow_boolean_cmd
14066 ("ignore-descriptive-types", class_maintenance,
14067 &ada_ignore_descriptive_types_p,
14068 _("Set whether descriptive types generated by GNAT should be ignored."),
14069 _("Show whether descriptive types generated by GNAT should be ignored."),
14071 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14072 DWARF attribute."),
14073 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14075 decoded_names_store = htab_create_alloc (256, htab_hash_string,
14077 NULL, xcalloc, xfree);
14079 /* The ada-lang observers. */
14080 gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14081 gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14082 gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");