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, struct objfile *objfile)
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 gdbarch_iterate_over_objfiles_in_search_order
4915 (objfile != NULL ? objfile->arch () : target_gdbarch (),
4916 [&result, lookup_name, match_name] (struct objfile *obj)
4918 for (minimal_symbol *msymbol : obj->msymbols ())
4920 if (match_name (msymbol->linkage_name (), lookup_name, nullptr)
4921 && msymbol->type () != mst_solib_trampoline)
4923 result.minsym = msymbol;
4924 result.objfile = obj;
4935 /* True if TYPE is definitely an artificial type supplied to a symbol
4936 for which no debugging information was given in the symbol file. */
4939 is_nondebugging_type (struct type *type)
4941 const char *name = ada_type_name (type);
4943 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4946 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4947 that are deemed "identical" for practical purposes.
4949 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4950 types and that their number of enumerals is identical (in other
4951 words, type1->num_fields () == type2->num_fields ()). */
4954 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4958 /* The heuristic we use here is fairly conservative. We consider
4959 that 2 enumerate types are identical if they have the same
4960 number of enumerals and that all enumerals have the same
4961 underlying value and name. */
4963 /* All enums in the type should have an identical underlying value. */
4964 for (i = 0; i < type1->num_fields (); i++)
4965 if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4968 /* All enumerals should also have the same name (modulo any numerical
4970 for (i = 0; i < type1->num_fields (); i++)
4972 const char *name_1 = type1->field (i).name ();
4973 const char *name_2 = type2->field (i).name ();
4974 int len_1 = strlen (name_1);
4975 int len_2 = strlen (name_2);
4977 ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4978 ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4980 || strncmp (type1->field (i).name (),
4981 type2->field (i).name (),
4989 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4990 that are deemed "identical" for practical purposes. Sometimes,
4991 enumerals are not strictly identical, but their types are so similar
4992 that they can be considered identical.
4994 For instance, consider the following code:
4996 type Color is (Black, Red, Green, Blue, White);
4997 type RGB_Color is new Color range Red .. Blue;
4999 Type RGB_Color is a subrange of an implicit type which is a copy
5000 of type Color. If we call that implicit type RGB_ColorB ("B" is
5001 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5002 As a result, when an expression references any of the enumeral
5003 by name (Eg. "print green"), the expression is technically
5004 ambiguous and the user should be asked to disambiguate. But
5005 doing so would only hinder the user, since it wouldn't matter
5006 what choice he makes, the outcome would always be the same.
5007 So, for practical purposes, we consider them as the same. */
5010 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5014 /* Before performing a thorough comparison check of each type,
5015 we perform a series of inexpensive checks. We expect that these
5016 checks will quickly fail in the vast majority of cases, and thus
5017 help prevent the unnecessary use of a more expensive comparison.
5018 Said comparison also expects us to make some of these checks
5019 (see ada_identical_enum_types_p). */
5021 /* Quick check: All symbols should have an enum type. */
5022 for (i = 0; i < syms.size (); i++)
5023 if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5026 /* Quick check: They should all have the same value. */
5027 for (i = 1; i < syms.size (); i++)
5028 if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5031 /* Quick check: They should all have the same number of enumerals. */
5032 for (i = 1; i < syms.size (); i++)
5033 if (syms[i].symbol->type ()->num_fields ()
5034 != syms[0].symbol->type ()->num_fields ())
5037 /* All the sanity checks passed, so we might have a set of
5038 identical enumeration types. Perform a more complete
5039 comparison of the type of each symbol. */
5040 for (i = 1; i < syms.size (); i++)
5041 if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5042 syms[0].symbol->type ()))
5048 /* Remove any non-debugging symbols in SYMS that definitely
5049 duplicate other symbols in the list (The only case I know of where
5050 this happens is when object files containing stabs-in-ecoff are
5051 linked with files containing ordinary ecoff debugging symbols (or no
5052 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
5055 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5059 /* We should never be called with less than 2 symbols, as there
5060 cannot be any extra symbol in that case. But it's easy to
5061 handle, since we have nothing to do in that case. */
5062 if (syms->size () < 2)
5066 while (i < syms->size ())
5070 /* If two symbols have the same name and one of them is a stub type,
5071 the get rid of the stub. */
5073 if ((*syms)[i].symbol->type ()->is_stub ()
5074 && (*syms)[i].symbol->linkage_name () != NULL)
5076 for (j = 0; j < syms->size (); j++)
5079 && !(*syms)[j].symbol->type ()->is_stub ()
5080 && (*syms)[j].symbol->linkage_name () != NULL
5081 && strcmp ((*syms)[i].symbol->linkage_name (),
5082 (*syms)[j].symbol->linkage_name ()) == 0)
5087 /* Two symbols with the same name, same class and same address
5088 should be identical. */
5090 else if ((*syms)[i].symbol->linkage_name () != NULL
5091 && (*syms)[i].symbol->aclass () == LOC_STATIC
5092 && is_nondebugging_type ((*syms)[i].symbol->type ()))
5094 for (j = 0; j < syms->size (); j += 1)
5097 && (*syms)[j].symbol->linkage_name () != NULL
5098 && strcmp ((*syms)[i].symbol->linkage_name (),
5099 (*syms)[j].symbol->linkage_name ()) == 0
5100 && ((*syms)[i].symbol->aclass ()
5101 == (*syms)[j].symbol->aclass ())
5102 && (*syms)[i].symbol->value_address ()
5103 == (*syms)[j].symbol->value_address ())
5109 syms->erase (syms->begin () + i);
5114 /* If all the remaining symbols are identical enumerals, then
5115 just keep the first one and discard the rest.
5117 Unlike what we did previously, we do not discard any entry
5118 unless they are ALL identical. This is because the symbol
5119 comparison is not a strict comparison, but rather a practical
5120 comparison. If all symbols are considered identical, then
5121 we can just go ahead and use the first one and discard the rest.
5122 But if we cannot reduce the list to a single element, we have
5123 to ask the user to disambiguate anyways. And if we have to
5124 present a multiple-choice menu, it's less confusing if the list
5125 isn't missing some choices that were identical and yet distinct. */
5126 if (symbols_are_identical_enums (*syms))
5130 /* Given a type that corresponds to a renaming entity, use the type name
5131 to extract the scope (package name or function name, fully qualified,
5132 and following the GNAT encoding convention) where this renaming has been
5136 xget_renaming_scope (struct type *renaming_type)
5138 /* The renaming types adhere to the following convention:
5139 <scope>__<rename>___<XR extension>.
5140 So, to extract the scope, we search for the "___XR" extension,
5141 and then backtrack until we find the first "__". */
5143 const char *name = renaming_type->name ();
5144 const char *suffix = strstr (name, "___XR");
5147 /* Now, backtrack a bit until we find the first "__". Start looking
5148 at suffix - 3, as the <rename> part is at least one character long. */
5150 for (last = suffix - 3; last > name; last--)
5151 if (last[0] == '_' && last[1] == '_')
5154 /* Make a copy of scope and return it. */
5155 return std::string (name, last);
5158 /* Return nonzero if NAME corresponds to a package name. */
5161 is_package_name (const char *name)
5163 /* Here, We take advantage of the fact that no symbols are generated
5164 for packages, while symbols are generated for each function.
5165 So the condition for NAME represent a package becomes equivalent
5166 to NAME not existing in our list of symbols. There is only one
5167 small complication with library-level functions (see below). */
5169 /* If it is a function that has not been defined at library level,
5170 then we should be able to look it up in the symbols. */
5171 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5174 /* Library-level function names start with "_ada_". See if function
5175 "_ada_" followed by NAME can be found. */
5177 /* Do a quick check that NAME does not contain "__", since library-level
5178 functions names cannot contain "__" in them. */
5179 if (strstr (name, "__") != NULL)
5182 std::string fun_name = string_printf ("_ada_%s", name);
5184 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5187 /* Return nonzero if SYM corresponds to a renaming entity that is
5188 not visible from FUNCTION_NAME. */
5191 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5193 if (sym->aclass () != LOC_TYPEDEF)
5196 std::string scope = xget_renaming_scope (sym->type ());
5198 /* If the rename has been defined in a package, then it is visible. */
5199 if (is_package_name (scope.c_str ()))
5202 /* Check that the rename is in the current function scope by checking
5203 that its name starts with SCOPE. */
5205 /* If the function name starts with "_ada_", it means that it is
5206 a library-level function. Strip this prefix before doing the
5207 comparison, as the encoding for the renaming does not contain
5209 if (startswith (function_name, "_ada_"))
5212 return !startswith (function_name, scope.c_str ());
5215 /* Remove entries from SYMS that corresponds to a renaming entity that
5216 is not visible from the function associated with CURRENT_BLOCK or
5217 that is superfluous due to the presence of more specific renaming
5218 information. Places surviving symbols in the initial entries of
5222 First, in cases where an object renaming is implemented as a
5223 reference variable, GNAT may produce both the actual reference
5224 variable and the renaming encoding. In this case, we discard the
5227 Second, GNAT emits a type following a specified encoding for each renaming
5228 entity. Unfortunately, STABS currently does not support the definition
5229 of types that are local to a given lexical block, so all renamings types
5230 are emitted at library level. As a consequence, if an application
5231 contains two renaming entities using the same name, and a user tries to
5232 print the value of one of these entities, the result of the ada symbol
5233 lookup will also contain the wrong renaming type.
5235 This function partially covers for this limitation by attempting to
5236 remove from the SYMS list renaming symbols that should be visible
5237 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5238 method with the current information available. The implementation
5239 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5241 - When the user tries to print a rename in a function while there
5242 is another rename entity defined in a package: Normally, the
5243 rename in the function has precedence over the rename in the
5244 package, so the latter should be removed from the list. This is
5245 currently not the case.
5247 - This function will incorrectly remove valid renames if
5248 the CURRENT_BLOCK corresponds to a function which symbol name
5249 has been changed by an "Export" pragma. As a consequence,
5250 the user will be unable to print such rename entities. */
5253 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5254 const struct block *current_block)
5256 struct symbol *current_function;
5257 const char *current_function_name;
5259 int is_new_style_renaming;
5261 /* If there is both a renaming foo___XR... encoded as a variable and
5262 a simple variable foo in the same block, discard the latter.
5263 First, zero out such symbols, then compress. */
5264 is_new_style_renaming = 0;
5265 for (i = 0; i < syms->size (); i += 1)
5267 struct symbol *sym = (*syms)[i].symbol;
5268 const struct block *block = (*syms)[i].block;
5272 if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5274 name = sym->linkage_name ();
5275 suffix = strstr (name, "___XR");
5279 int name_len = suffix - name;
5282 is_new_style_renaming = 1;
5283 for (j = 0; j < syms->size (); j += 1)
5284 if (i != j && (*syms)[j].symbol != NULL
5285 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5287 && block == (*syms)[j].block)
5288 (*syms)[j].symbol = NULL;
5291 if (is_new_style_renaming)
5295 for (j = k = 0; j < syms->size (); j += 1)
5296 if ((*syms)[j].symbol != NULL)
5298 (*syms)[k] = (*syms)[j];
5305 /* Extract the function name associated to CURRENT_BLOCK.
5306 Abort if unable to do so. */
5308 if (current_block == NULL)
5311 current_function = block_linkage_function (current_block);
5312 if (current_function == NULL)
5315 current_function_name = current_function->linkage_name ();
5316 if (current_function_name == NULL)
5319 /* Check each of the symbols, and remove it from the list if it is
5320 a type corresponding to a renaming that is out of the scope of
5321 the current block. */
5324 while (i < syms->size ())
5326 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5327 == ADA_OBJECT_RENAMING
5328 && old_renaming_is_invisible ((*syms)[i].symbol,
5329 current_function_name))
5330 syms->erase (syms->begin () + i);
5336 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5337 whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5339 Note: This function assumes that RESULT is empty. */
5342 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5343 const lookup_name_info &lookup_name,
5344 const struct block *block, domain_enum domain)
5346 while (block != NULL)
5348 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5350 /* If we found a non-function match, assume that's the one. We
5351 only check this when finding a function boundary, so that we
5352 can accumulate all results from intervening blocks first. */
5353 if (block->function () != nullptr && is_nonfunction (result))
5356 block = block->superblock ();
5360 /* An object of this type is used as the callback argument when
5361 calling the map_matching_symbols method. */
5365 explicit match_data (std::vector<struct block_symbol> *rp)
5369 DISABLE_COPY_AND_ASSIGN (match_data);
5371 bool operator() (struct block_symbol *bsym);
5373 struct objfile *objfile = nullptr;
5374 std::vector<struct block_symbol> *resultp;
5375 struct symbol *arg_sym = nullptr;
5376 bool found_sym = false;
5379 /* A callback for add_nonlocal_symbols that adds symbol, found in
5380 BSYM, to a list of symbols. */
5383 match_data::operator() (struct block_symbol *bsym)
5385 const struct block *block = bsym->block;
5386 struct symbol *sym = bsym->symbol;
5390 if (!found_sym && arg_sym != NULL)
5391 add_defn_to_vec (*resultp,
5392 fixup_symbol_section (arg_sym, objfile),
5399 if (sym->aclass () == LOC_UNRESOLVED)
5401 else if (sym->is_argument ())
5406 add_defn_to_vec (*resultp,
5407 fixup_symbol_section (sym, objfile),
5414 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5415 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5416 symbols to RESULT. Return whether we found such symbols. */
5419 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5420 const struct block *block,
5421 const lookup_name_info &lookup_name,
5424 struct using_direct *renaming;
5425 int defns_mark = result.size ();
5427 symbol_name_matcher_ftype *name_match
5428 = ada_get_symbol_name_matcher (lookup_name);
5430 for (renaming = block_using (block);
5432 renaming = renaming->next)
5436 /* Avoid infinite recursions: skip this renaming if we are actually
5437 already traversing it.
5439 Currently, symbol lookup in Ada don't use the namespace machinery from
5440 C++/Fortran support: skip namespace imports that use them. */
5441 if (renaming->searched
5442 || (renaming->import_src != NULL
5443 && renaming->import_src[0] != '\0')
5444 || (renaming->import_dest != NULL
5445 && renaming->import_dest[0] != '\0'))
5447 renaming->searched = 1;
5449 /* TODO: here, we perform another name-based symbol lookup, which can
5450 pull its own multiple overloads. In theory, we should be able to do
5451 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5452 not a simple name. But in order to do this, we would need to enhance
5453 the DWARF reader to associate a symbol to this renaming, instead of a
5454 name. So, for now, we do something simpler: re-use the C++/Fortran
5455 namespace machinery. */
5456 r_name = (renaming->alias != NULL
5458 : renaming->declaration);
5459 if (name_match (r_name, lookup_name, NULL))
5461 lookup_name_info decl_lookup_name (renaming->declaration,
5462 lookup_name.match_type ());
5463 ada_add_all_symbols (result, block, decl_lookup_name, domain,
5466 renaming->searched = 0;
5468 return result.size () != defns_mark;
5471 /* Implements compare_names, but only applying the comparision using
5472 the given CASING. */
5475 compare_names_with_case (const char *string1, const char *string2,
5476 enum case_sensitivity casing)
5478 while (*string1 != '\0' && *string2 != '\0')
5482 if (isspace (*string1) || isspace (*string2))
5483 return strcmp_iw_ordered (string1, string2);
5485 if (casing == case_sensitive_off)
5487 c1 = tolower (*string1);
5488 c2 = tolower (*string2);
5505 return strcmp_iw_ordered (string1, string2);
5507 if (*string2 == '\0')
5509 if (is_name_suffix (string1))
5516 if (*string2 == '(')
5517 return strcmp_iw_ordered (string1, string2);
5520 if (casing == case_sensitive_off)
5521 return tolower (*string1) - tolower (*string2);
5523 return *string1 - *string2;
5528 /* Compare STRING1 to STRING2, with results as for strcmp.
5529 Compatible with strcmp_iw_ordered in that...
5531 strcmp_iw_ordered (STRING1, STRING2) <= 0
5535 compare_names (STRING1, STRING2) <= 0
5537 (they may differ as to what symbols compare equal). */
5540 compare_names (const char *string1, const char *string2)
5544 /* Similar to what strcmp_iw_ordered does, we need to perform
5545 a case-insensitive comparison first, and only resort to
5546 a second, case-sensitive, comparison if the first one was
5547 not sufficient to differentiate the two strings. */
5549 result = compare_names_with_case (string1, string2, case_sensitive_off);
5551 result = compare_names_with_case (string1, string2, case_sensitive_on);
5556 /* Convenience function to get at the Ada encoded lookup name for
5557 LOOKUP_NAME, as a C string. */
5560 ada_lookup_name (const lookup_name_info &lookup_name)
5562 return lookup_name.ada ().lookup_name ().c_str ();
5565 /* A helper for add_nonlocal_symbols. Call expand_matching_symbols
5566 for OBJFILE, then walk the objfile's symtabs and update the
5570 map_matching_symbols (struct objfile *objfile,
5571 const lookup_name_info &lookup_name,
5577 data.objfile = objfile;
5578 objfile->expand_matching_symbols (lookup_name, domain, global,
5579 is_wild_match ? nullptr : compare_names);
5581 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5582 for (compunit_symtab *symtab : objfile->compunits ())
5584 const struct block *block
5585 = symtab->blockvector ()->block (block_kind);
5586 if (!iterate_over_symbols_terminated (block, lookup_name,
5592 /* Add to RESULT all non-local symbols whose name and domain match
5593 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5594 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5595 symbols otherwise. */
5598 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5599 const lookup_name_info &lookup_name,
5600 domain_enum domain, int global)
5602 struct match_data data (&result);
5604 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5606 for (objfile *objfile : current_program_space->objfiles ())
5608 map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5611 for (compunit_symtab *cu : objfile->compunits ())
5613 const struct block *global_block
5614 = cu->blockvector ()->global_block ();
5616 if (ada_add_block_renamings (result, global_block, lookup_name,
5618 data.found_sym = true;
5622 if (result.empty () && global && !is_wild_match)
5624 const char *name = ada_lookup_name (lookup_name);
5625 std::string bracket_name = std::string ("<_ada_") + name + '>';
5626 lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5628 for (objfile *objfile : current_program_space->objfiles ())
5629 map_matching_symbols (objfile, name1, false, domain, global, data);
5633 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5634 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5635 returning the number of matches. Add these to RESULT.
5637 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5638 symbol match within the nest of blocks whose innermost member is BLOCK,
5639 is the one match returned (no other matches in that or
5640 enclosing blocks is returned). If there are any matches in or
5641 surrounding BLOCK, then these alone are returned.
5643 Names prefixed with "standard__" are handled specially:
5644 "standard__" is first stripped off (by the lookup_name
5645 constructor), and only static and global symbols are searched.
5647 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5648 to lookup global symbols. */
5651 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5652 const struct block *block,
5653 const lookup_name_info &lookup_name,
5656 int *made_global_lookup_p)
5660 if (made_global_lookup_p)
5661 *made_global_lookup_p = 0;
5663 /* Special case: If the user specifies a symbol name inside package
5664 Standard, do a non-wild matching of the symbol name without
5665 the "standard__" prefix. This was primarily introduced in order
5666 to allow the user to specifically access the standard exceptions
5667 using, for instance, Standard.Constraint_Error when Constraint_Error
5668 is ambiguous (due to the user defining its own Constraint_Error
5669 entity inside its program). */
5670 if (lookup_name.ada ().standard_p ())
5673 /* Check the non-global symbols. If we have ANY match, then we're done. */
5678 ada_add_local_symbols (result, lookup_name, block, domain);
5681 /* In the !full_search case we're are being called by
5682 iterate_over_symbols, and we don't want to search
5684 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5686 if (!result.empty () || !full_search)
5690 /* No non-global symbols found. Check our cache to see if we have
5691 already performed this search before. If we have, then return
5694 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5695 domain, &sym, &block))
5698 add_defn_to_vec (result, sym, block);
5702 if (made_global_lookup_p)
5703 *made_global_lookup_p = 1;
5705 /* Search symbols from all global blocks. */
5707 add_nonlocal_symbols (result, lookup_name, domain, 1);
5709 /* Now add symbols from all per-file blocks if we've gotten no hits
5710 (not strictly correct, but perhaps better than an error). */
5712 if (result.empty ())
5713 add_nonlocal_symbols (result, lookup_name, domain, 0);
5716 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5717 is non-zero, enclosing scope and in global scopes.
5719 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5720 blocks and symbol tables (if any) in which they were found.
5722 When full_search is non-zero, any non-function/non-enumeral
5723 symbol match within the nest of blocks whose innermost member is BLOCK,
5724 is the one match returned (no other matches in that or
5725 enclosing blocks is returned). If there are any matches in or
5726 surrounding BLOCK, then these alone are returned.
5728 Names prefixed with "standard__" are handled specially: "standard__"
5729 is first stripped off, and only static and global symbols are searched. */
5731 static std::vector<struct block_symbol>
5732 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5733 const struct block *block,
5737 int syms_from_global_search;
5738 std::vector<struct block_symbol> results;
5740 ada_add_all_symbols (results, block, lookup_name,
5741 domain, full_search, &syms_from_global_search);
5743 remove_extra_symbols (&results);
5745 if (results.empty () && full_search && syms_from_global_search)
5746 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5748 if (results.size () == 1 && full_search && syms_from_global_search)
5749 cache_symbol (ada_lookup_name (lookup_name), domain,
5750 results[0].symbol, results[0].block);
5752 remove_irrelevant_renamings (&results, block);
5756 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5757 in global scopes, returning (SYM,BLOCK) tuples.
5759 See ada_lookup_symbol_list_worker for further details. */
5761 std::vector<struct block_symbol>
5762 ada_lookup_symbol_list (const char *name, const struct block *block,
5765 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5766 lookup_name_info lookup_name (name, name_match_type);
5768 return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5771 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5772 to 1, but choosing the first symbol found if there are multiple
5775 The result is stored in *INFO, which must be non-NULL.
5776 If no match is found, INFO->SYM is set to NULL. */
5779 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5781 struct block_symbol *info)
5783 /* Since we already have an encoded name, wrap it in '<>' to force a
5784 verbatim match. Otherwise, if the name happens to not look like
5785 an encoded name (because it doesn't include a "__"),
5786 ada_lookup_name_info would re-encode/fold it again, and that
5787 would e.g., incorrectly lowercase object renaming names like
5788 "R28b" -> "r28b". */
5789 std::string verbatim = add_angle_brackets (name);
5791 gdb_assert (info != NULL);
5792 *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5795 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5796 scope and in global scopes, or NULL if none. NAME is folded and
5797 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5798 choosing the first symbol if there are multiple choices. */
5801 ada_lookup_symbol (const char *name, const struct block *block0,
5804 std::vector<struct block_symbol> candidates
5805 = ada_lookup_symbol_list (name, block0, domain);
5807 if (candidates.empty ())
5810 block_symbol info = candidates[0];
5811 info.symbol = fixup_symbol_section (info.symbol, NULL);
5816 /* True iff STR is a possible encoded suffix of a normal Ada name
5817 that is to be ignored for matching purposes. Suffixes of parallel
5818 names (e.g., XVE) are not included here. Currently, the possible suffixes
5819 are given by any of the regular expressions:
5821 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5822 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5823 TKB [subprogram suffix for task bodies]
5824 _E[0-9]+[bs]$ [protected object entry suffixes]
5825 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5827 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5828 match is performed. This sequence is used to differentiate homonyms,
5829 is an optional part of a valid name suffix. */
5832 is_name_suffix (const char *str)
5835 const char *matching;
5836 const int len = strlen (str);
5838 /* Skip optional leading __[0-9]+. */
5840 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5843 while (isdigit (str[0]))
5849 if (str[0] == '.' || str[0] == '$')
5852 while (isdigit (matching[0]))
5854 if (matching[0] == '\0')
5860 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5863 while (isdigit (matching[0]))
5865 if (matching[0] == '\0')
5869 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5871 if (strcmp (str, "TKB") == 0)
5875 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5876 with a N at the end. Unfortunately, the compiler uses the same
5877 convention for other internal types it creates. So treating
5878 all entity names that end with an "N" as a name suffix causes
5879 some regressions. For instance, consider the case of an enumerated
5880 type. To support the 'Image attribute, it creates an array whose
5882 Having a single character like this as a suffix carrying some
5883 information is a bit risky. Perhaps we should change the encoding
5884 to be something like "_N" instead. In the meantime, do not do
5885 the following check. */
5886 /* Protected Object Subprograms */
5887 if (len == 1 && str [0] == 'N')
5892 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5895 while (isdigit (matching[0]))
5897 if ((matching[0] == 'b' || matching[0] == 's')
5898 && matching [1] == '\0')
5902 /* ??? We should not modify STR directly, as we are doing below. This
5903 is fine in this case, but may become problematic later if we find
5904 that this alternative did not work, and want to try matching
5905 another one from the begining of STR. Since we modified it, we
5906 won't be able to find the begining of the string anymore! */
5910 while (str[0] != '_' && str[0] != '\0')
5912 if (str[0] != 'n' && str[0] != 'b')
5918 if (str[0] == '\000')
5923 if (str[1] != '_' || str[2] == '\000')
5927 if (strcmp (str + 3, "JM") == 0)
5929 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5930 the LJM suffix in favor of the JM one. But we will
5931 still accept LJM as a valid suffix for a reasonable
5932 amount of time, just to allow ourselves to debug programs
5933 compiled using an older version of GNAT. */
5934 if (strcmp (str + 3, "LJM") == 0)
5938 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5939 || str[4] == 'U' || str[4] == 'P')
5941 if (str[4] == 'R' && str[5] != 'T')
5945 if (!isdigit (str[2]))
5947 for (k = 3; str[k] != '\0'; k += 1)
5948 if (!isdigit (str[k]) && str[k] != '_')
5952 if (str[0] == '$' && isdigit (str[1]))
5954 for (k = 2; str[k] != '\0'; k += 1)
5955 if (!isdigit (str[k]) && str[k] != '_')
5962 /* Return non-zero if the string starting at NAME and ending before
5963 NAME_END contains no capital letters. */
5966 is_valid_name_for_wild_match (const char *name0)
5968 std::string decoded_name = ada_decode (name0);
5971 /* If the decoded name starts with an angle bracket, it means that
5972 NAME0 does not follow the GNAT encoding format. It should then
5973 not be allowed as a possible wild match. */
5974 if (decoded_name[0] == '<')
5977 for (i=0; decoded_name[i] != '\0'; i++)
5978 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5984 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5985 character which could start a simple name. Assumes that *NAMEP points
5986 somewhere inside the string beginning at NAME0. */
5989 advance_wild_match (const char **namep, const char *name0, char target0)
5991 const char *name = *namep;
6001 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6004 if (name == name0 + 5 && startswith (name0, "_ada"))
6009 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6010 || name[2] == target0))
6015 else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6017 /* Names like "pkg__B_N__name", where N is a number, are
6018 block-local. We can handle these by simply skipping
6025 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6035 /* Return true iff NAME encodes a name of the form prefix.PATN.
6036 Ignores any informational suffixes of NAME (i.e., for which
6037 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6041 wild_match (const char *name, const char *patn)
6044 const char *name0 = name;
6046 if (startswith (name, "___ghost_"))
6051 const char *match = name;
6055 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6058 if (*p == '\0' && is_name_suffix (name))
6059 return match == name0 || is_valid_name_for_wild_match (name0);
6061 if (name[-1] == '_')
6064 if (!advance_wild_match (&name, name0, *patn))
6069 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6070 necessary). OBJFILE is the section containing BLOCK. */
6073 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6074 const struct block *block,
6075 const lookup_name_info &lookup_name,
6076 domain_enum domain, struct objfile *objfile)
6078 struct block_iterator iter;
6079 /* A matching argument symbol, if any. */
6080 struct symbol *arg_sym;
6081 /* Set true when we find a matching non-argument symbol. */
6087 for (sym = block_iter_match_first (block, lookup_name, &iter);
6089 sym = block_iter_match_next (lookup_name, &iter))
6091 if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6093 if (sym->aclass () != LOC_UNRESOLVED)
6095 if (sym->is_argument ())
6100 add_defn_to_vec (result,
6101 fixup_symbol_section (sym, objfile),
6108 /* Handle renamings. */
6110 if (ada_add_block_renamings (result, block, lookup_name, domain))
6113 if (!found_sym && arg_sym != NULL)
6115 add_defn_to_vec (result,
6116 fixup_symbol_section (arg_sym, objfile),
6120 if (!lookup_name.ada ().wild_match_p ())
6124 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6125 const char *name = ada_lookup_name.c_str ();
6126 size_t name_len = ada_lookup_name.size ();
6128 ALL_BLOCK_SYMBOLS (block, iter, sym)
6130 if (symbol_matches_domain (sym->language (),
6131 sym->domain (), domain))
6135 cmp = (int) '_' - (int) sym->linkage_name ()[0];
6138 cmp = !startswith (sym->linkage_name (), "_ada_");
6140 cmp = strncmp (name, sym->linkage_name () + 5,
6145 && is_name_suffix (sym->linkage_name () + name_len + 5))
6147 if (sym->aclass () != LOC_UNRESOLVED)
6149 if (sym->is_argument ())
6154 add_defn_to_vec (result,
6155 fixup_symbol_section (sym, objfile),
6163 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6164 They aren't parameters, right? */
6165 if (!found_sym && arg_sym != NULL)
6167 add_defn_to_vec (result,
6168 fixup_symbol_section (arg_sym, objfile),
6175 /* Symbol Completion */
6180 ada_lookup_name_info::matches
6181 (const char *sym_name,
6182 symbol_name_match_type match_type,
6183 completion_match_result *comp_match_res) const
6186 const char *text = m_encoded_name.c_str ();
6187 size_t text_len = m_encoded_name.size ();
6189 /* First, test against the fully qualified name of the symbol. */
6191 if (strncmp (sym_name, text, text_len) == 0)
6194 std::string decoded_name = ada_decode (sym_name);
6195 if (match && !m_encoded_p)
6197 /* One needed check before declaring a positive match is to verify
6198 that iff we are doing a verbatim match, the decoded version
6199 of the symbol name starts with '<'. Otherwise, this symbol name
6200 is not a suitable completion. */
6202 bool has_angle_bracket = (decoded_name[0] == '<');
6203 match = (has_angle_bracket == m_verbatim_p);
6206 if (match && !m_verbatim_p)
6208 /* When doing non-verbatim match, another check that needs to
6209 be done is to verify that the potentially matching symbol name
6210 does not include capital letters, because the ada-mode would
6211 not be able to understand these symbol names without the
6212 angle bracket notation. */
6215 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6220 /* Second: Try wild matching... */
6222 if (!match && m_wild_match_p)
6224 /* Since we are doing wild matching, this means that TEXT
6225 may represent an unqualified symbol name. We therefore must
6226 also compare TEXT against the unqualified name of the symbol. */
6227 sym_name = ada_unqualified_name (decoded_name.c_str ());
6229 if (strncmp (sym_name, text, text_len) == 0)
6233 /* Finally: If we found a match, prepare the result to return. */
6238 if (comp_match_res != NULL)
6240 std::string &match_str = comp_match_res->match.storage ();
6243 match_str = ada_decode (sym_name);
6247 match_str = add_angle_brackets (sym_name);
6249 match_str = sym_name;
6253 comp_match_res->set_match (match_str.c_str ());
6261 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6262 for tagged types. */
6265 ada_is_dispatch_table_ptr_type (struct type *type)
6269 if (type->code () != TYPE_CODE_PTR)
6272 name = type->target_type ()->name ();
6276 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6279 /* Return non-zero if TYPE is an interface tag. */
6282 ada_is_interface_tag (struct type *type)
6284 const char *name = type->name ();
6289 return (strcmp (name, "ada__tags__interface_tag") == 0);
6292 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6293 to be invisible to users. */
6296 ada_is_ignored_field (struct type *type, int field_num)
6298 if (field_num < 0 || field_num > type->num_fields ())
6301 /* Check the name of that field. */
6303 const char *name = type->field (field_num).name ();
6305 /* Anonymous field names should not be printed.
6306 brobecker/2007-02-20: I don't think this can actually happen
6307 but we don't want to print the value of anonymous fields anyway. */
6311 /* Normally, fields whose name start with an underscore ("_")
6312 are fields that have been internally generated by the compiler,
6313 and thus should not be printed. The "_parent" field is special,
6314 however: This is a field internally generated by the compiler
6315 for tagged types, and it contains the components inherited from
6316 the parent type. This field should not be printed as is, but
6317 should not be ignored either. */
6318 if (name[0] == '_' && !startswith (name, "_parent"))
6321 /* The compiler doesn't document this, but sometimes it emits
6322 a field whose name starts with a capital letter, like 'V148s'.
6323 These aren't marked as artificial in any way, but we know they
6324 should be ignored. However, wrapper fields should not be
6326 if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6328 /* Wrapper field. */
6330 else if (isupper (name[0]))
6334 /* If this is the dispatch table of a tagged type or an interface tag,
6336 if (ada_is_tagged_type (type, 1)
6337 && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6338 || ada_is_interface_tag (type->field (field_num).type ())))
6341 /* Not a special field, so it should not be ignored. */
6345 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6346 pointer or reference type whose ultimate target has a tag field. */
6349 ada_is_tagged_type (struct type *type, int refok)
6351 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6354 /* True iff TYPE represents the type of X'Tag */
6357 ada_is_tag_type (struct type *type)
6359 type = ada_check_typedef (type);
6361 if (type == NULL || type->code () != TYPE_CODE_PTR)
6365 const char *name = ada_type_name (type->target_type ());
6367 return (name != NULL
6368 && strcmp (name, "ada__tags__dispatch_table") == 0);
6372 /* The type of the tag on VAL. */
6374 static struct type *
6375 ada_tag_type (struct value *val)
6377 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6380 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6381 retired at Ada 05). */
6384 is_ada95_tag (struct value *tag)
6386 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6389 /* The value of the tag on VAL. */
6391 static struct value *
6392 ada_value_tag (struct value *val)
6394 return ada_value_struct_elt (val, "_tag", 0);
6397 /* The value of the tag on the object of type TYPE whose contents are
6398 saved at VALADDR, if it is non-null, or is at memory address
6401 static struct value *
6402 value_tag_from_contents_and_address (struct type *type,
6403 const gdb_byte *valaddr,
6406 int tag_byte_offset;
6407 struct type *tag_type;
6409 gdb::array_view<const gdb_byte> contents;
6410 if (valaddr != nullptr)
6411 contents = gdb::make_array_view (valaddr, type->length ());
6412 struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6413 if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6416 const gdb_byte *valaddr1 = ((valaddr == NULL)
6418 : valaddr + tag_byte_offset);
6419 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6421 return value_from_contents_and_address (tag_type, valaddr1, address1);
6426 static struct type *
6427 type_from_tag (struct value *tag)
6429 gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6431 if (type_name != NULL)
6432 return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6436 /* Given a value OBJ of a tagged type, return a value of this
6437 type at the base address of the object. The base address, as
6438 defined in Ada.Tags, it is the address of the primary tag of
6439 the object, and therefore where the field values of its full
6440 view can be fetched. */
6443 ada_tag_value_at_base_address (struct value *obj)
6446 LONGEST offset_to_top = 0;
6447 struct type *ptr_type, *obj_type;
6449 CORE_ADDR base_address;
6451 obj_type = value_type (obj);
6453 /* It is the responsability of the caller to deref pointers. */
6455 if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6458 tag = ada_value_tag (obj);
6462 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6464 if (is_ada95_tag (tag))
6467 struct type *offset_type
6468 = language_lookup_primitive_type (language_def (language_ada),
6469 target_gdbarch(), "storage_offset");
6470 ptr_type = lookup_pointer_type (offset_type);
6471 val = value_cast (ptr_type, tag);
6475 /* It is perfectly possible that an exception be raised while
6476 trying to determine the base address, just like for the tag;
6477 see ada_tag_name for more details. We do not print the error
6478 message for the same reason. */
6482 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6485 catch (const gdb_exception_error &e)
6490 /* If offset is null, nothing to do. */
6492 if (offset_to_top == 0)
6495 /* -1 is a special case in Ada.Tags; however, what should be done
6496 is not quite clear from the documentation. So do nothing for
6499 if (offset_to_top == -1)
6502 /* Storage_Offset'Last is used to indicate that a dynamic offset to
6503 top is used. In this situation the offset is stored just after
6504 the tag, in the object itself. */
6505 ULONGEST last = (((ULONGEST) 1) << (8 * offset_type->length () - 1)) - 1;
6506 if (offset_to_top == last)
6508 struct value *tem = value_addr (tag);
6509 tem = value_ptradd (tem, 1);
6510 tem = value_cast (ptr_type, tem);
6511 offset_to_top = value_as_long (value_ind (tem));
6514 if (offset_to_top > 0)
6516 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6517 from the base address. This was however incompatible with
6518 C++ dispatch table: C++ uses a *negative* value to *add*
6519 to the base address. Ada's convention has therefore been
6520 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6521 use the same convention. Here, we support both cases by
6522 checking the sign of OFFSET_TO_TOP. */
6523 offset_to_top = -offset_to_top;
6526 base_address = value_address (obj) + offset_to_top;
6527 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6529 /* Make sure that we have a proper tag at the new address.
6530 Otherwise, offset_to_top is bogus (which can happen when
6531 the object is not initialized yet). */
6536 obj_type = type_from_tag (tag);
6541 return value_from_contents_and_address (obj_type, NULL, base_address);
6544 /* Return the "ada__tags__type_specific_data" type. */
6546 static struct type *
6547 ada_get_tsd_type (struct inferior *inf)
6549 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6551 if (data->tsd_type == 0)
6552 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6553 return data->tsd_type;
6556 /* Return the TSD (type-specific data) associated to the given TAG.
6557 TAG is assumed to be the tag of a tagged-type entity.
6559 May return NULL if we are unable to get the TSD. */
6561 static struct value *
6562 ada_get_tsd_from_tag (struct value *tag)
6567 /* First option: The TSD is simply stored as a field of our TAG.
6568 Only older versions of GNAT would use this format, but we have
6569 to test it first, because there are no visible markers for
6570 the current approach except the absence of that field. */
6572 val = ada_value_struct_elt (tag, "tsd", 1);
6576 /* Try the second representation for the dispatch table (in which
6577 there is no explicit 'tsd' field in the referent of the tag pointer,
6578 and instead the tsd pointer is stored just before the dispatch
6581 type = ada_get_tsd_type (current_inferior());
6584 type = lookup_pointer_type (lookup_pointer_type (type));
6585 val = value_cast (type, tag);
6588 return value_ind (value_ptradd (val, -1));
6591 /* Given the TSD of a tag (type-specific data), return a string
6592 containing the name of the associated type.
6594 May return NULL if we are unable to determine the tag name. */
6596 static gdb::unique_xmalloc_ptr<char>
6597 ada_tag_name_from_tsd (struct value *tsd)
6601 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6604 gdb::unique_xmalloc_ptr<char> buffer
6605 = target_read_string (value_as_address (val), INT_MAX);
6606 if (buffer == nullptr)
6611 /* Let this throw an exception on error. If the data is
6612 uninitialized, we'd rather not have the user see a
6614 const char *folded = ada_fold_name (buffer.get (), true);
6615 return make_unique_xstrdup (folded);
6617 catch (const gdb_exception &)
6623 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6626 Return NULL if the TAG is not an Ada tag, or if we were unable to
6627 determine the name of that tag. */
6629 gdb::unique_xmalloc_ptr<char>
6630 ada_tag_name (struct value *tag)
6632 gdb::unique_xmalloc_ptr<char> name;
6634 if (!ada_is_tag_type (value_type (tag)))
6637 /* It is perfectly possible that an exception be raised while trying
6638 to determine the TAG's name, even under normal circumstances:
6639 The associated variable may be uninitialized or corrupted, for
6640 instance. We do not let any exception propagate past this point.
6641 instead we return NULL.
6643 We also do not print the error message either (which often is very
6644 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6645 the caller print a more meaningful message if necessary. */
6648 struct value *tsd = ada_get_tsd_from_tag (tag);
6651 name = ada_tag_name_from_tsd (tsd);
6653 catch (const gdb_exception_error &e)
6660 /* The parent type of TYPE, or NULL if none. */
6663 ada_parent_type (struct type *type)
6667 type = ada_check_typedef (type);
6669 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6672 for (i = 0; i < type->num_fields (); i += 1)
6673 if (ada_is_parent_field (type, i))
6675 struct type *parent_type = type->field (i).type ();
6677 /* If the _parent field is a pointer, then dereference it. */
6678 if (parent_type->code () == TYPE_CODE_PTR)
6679 parent_type = parent_type->target_type ();
6680 /* If there is a parallel XVS type, get the actual base type. */
6681 parent_type = ada_get_base_type (parent_type);
6683 return ada_check_typedef (parent_type);
6689 /* True iff field number FIELD_NUM of structure type TYPE contains the
6690 parent-type (inherited) fields of a derived type. Assumes TYPE is
6691 a structure type with at least FIELD_NUM+1 fields. */
6694 ada_is_parent_field (struct type *type, int field_num)
6696 const char *name = ada_check_typedef (type)->field (field_num).name ();
6698 return (name != NULL
6699 && (startswith (name, "PARENT")
6700 || startswith (name, "_parent")));
6703 /* True iff field number FIELD_NUM of structure type TYPE is a
6704 transparent wrapper field (which should be silently traversed when doing
6705 field selection and flattened when printing). Assumes TYPE is a
6706 structure type with at least FIELD_NUM+1 fields. Such fields are always
6710 ada_is_wrapper_field (struct type *type, int field_num)
6712 const char *name = type->field (field_num).name ();
6714 if (name != NULL && strcmp (name, "RETVAL") == 0)
6716 /* This happens in functions with "out" or "in out" parameters
6717 which are passed by copy. For such functions, GNAT describes
6718 the function's return type as being a struct where the return
6719 value is in a field called RETVAL, and where the other "out"
6720 or "in out" parameters are fields of that struct. This is not
6725 return (name != NULL
6726 && (startswith (name, "PARENT")
6727 || strcmp (name, "REP") == 0
6728 || startswith (name, "_parent")
6729 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6732 /* True iff field number FIELD_NUM of structure or union type TYPE
6733 is a variant wrapper. Assumes TYPE is a structure type with at least
6734 FIELD_NUM+1 fields. */
6737 ada_is_variant_part (struct type *type, int field_num)
6739 /* Only Ada types are eligible. */
6740 if (!ADA_TYPE_P (type))
6743 struct type *field_type = type->field (field_num).type ();
6745 return (field_type->code () == TYPE_CODE_UNION
6746 || (is_dynamic_field (type, field_num)
6747 && (field_type->target_type ()->code ()
6748 == TYPE_CODE_UNION)));
6751 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6752 whose discriminants are contained in the record type OUTER_TYPE,
6753 returns the type of the controlling discriminant for the variant.
6754 May return NULL if the type could not be found. */
6757 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6759 const char *name = ada_variant_discrim_name (var_type);
6761 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6764 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6765 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6766 represents a 'when others' clause; otherwise 0. */
6769 ada_is_others_clause (struct type *type, int field_num)
6771 const char *name = type->field (field_num).name ();
6773 return (name != NULL && name[0] == 'O');
6776 /* Assuming that TYPE0 is the type of the variant part of a record,
6777 returns the name of the discriminant controlling the variant.
6778 The value is valid until the next call to ada_variant_discrim_name. */
6781 ada_variant_discrim_name (struct type *type0)
6783 static std::string result;
6786 const char *discrim_end;
6787 const char *discrim_start;
6789 if (type0->code () == TYPE_CODE_PTR)
6790 type = type0->target_type ();
6794 name = ada_type_name (type);
6796 if (name == NULL || name[0] == '\000')
6799 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6802 if (startswith (discrim_end, "___XVN"))
6805 if (discrim_end == name)
6808 for (discrim_start = discrim_end; discrim_start != name + 3;
6811 if (discrim_start == name + 1)
6813 if ((discrim_start > name + 3
6814 && startswith (discrim_start - 3, "___"))
6815 || discrim_start[-1] == '.')
6819 result = std::string (discrim_start, discrim_end - discrim_start);
6820 return result.c_str ();
6823 /* Scan STR for a subtype-encoded number, beginning at position K.
6824 Put the position of the character just past the number scanned in
6825 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6826 Return 1 if there was a valid number at the given position, and 0
6827 otherwise. A "subtype-encoded" number consists of the absolute value
6828 in decimal, followed by the letter 'm' to indicate a negative number.
6829 Assumes 0m does not occur. */
6832 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6836 if (!isdigit (str[k]))
6839 /* Do it the hard way so as not to make any assumption about
6840 the relationship of unsigned long (%lu scan format code) and
6843 while (isdigit (str[k]))
6845 RU = RU * 10 + (str[k] - '0');
6852 *R = (-(LONGEST) (RU - 1)) - 1;
6858 /* NOTE on the above: Technically, C does not say what the results of
6859 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6860 number representable as a LONGEST (although either would probably work
6861 in most implementations). When RU>0, the locution in the then branch
6862 above is always equivalent to the negative of RU. */
6869 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6870 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6871 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6874 ada_in_variant (LONGEST val, struct type *type, int field_num)
6876 const char *name = type->field (field_num).name ();
6890 if (!ada_scan_number (name, p + 1, &W, &p))
6900 if (!ada_scan_number (name, p + 1, &L, &p)
6901 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6903 if (val >= L && val <= U)
6915 /* FIXME: Lots of redundancy below. Try to consolidate. */
6917 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6918 ARG_TYPE, extract and return the value of one of its (non-static)
6919 fields. FIELDNO says which field. Differs from value_primitive_field
6920 only in that it can handle packed values of arbitrary type. */
6923 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6924 struct type *arg_type)
6928 arg_type = ada_check_typedef (arg_type);
6929 type = arg_type->field (fieldno).type ();
6931 /* Handle packed fields. It might be that the field is not packed
6932 relative to its containing structure, but the structure itself is
6933 packed; in this case we must take the bit-field path. */
6934 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6936 int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6937 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6939 return ada_value_primitive_packed_val (arg1,
6940 value_contents (arg1).data (),
6941 offset + bit_pos / 8,
6942 bit_pos % 8, bit_size, type);
6945 return value_primitive_field (arg1, offset, fieldno, arg_type);
6948 /* Find field with name NAME in object of type TYPE. If found,
6949 set the following for each argument that is non-null:
6950 - *FIELD_TYPE_P to the field's type;
6951 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6952 an object of that type;
6953 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6954 - *BIT_SIZE_P to its size in bits if the field is packed, and
6956 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6957 fields up to but not including the desired field, or by the total
6958 number of fields if not found. A NULL value of NAME never
6959 matches; the function just counts visible fields in this case.
6961 Notice that we need to handle when a tagged record hierarchy
6962 has some components with the same name, like in this scenario:
6964 type Top_T is tagged record
6970 type Middle_T is new Top.Top_T with record
6971 N : Character := 'a';
6975 type Bottom_T is new Middle.Middle_T with record
6977 C : Character := '5';
6979 A : Character := 'J';
6982 Let's say we now have a variable declared and initialized as follow:
6984 TC : Top_A := new Bottom_T;
6986 And then we use this variable to call this function
6988 procedure Assign (Obj: in out Top_T; TV : Integer);
6992 Assign (Top_T (B), 12);
6994 Now, we're in the debugger, and we're inside that procedure
6995 then and we want to print the value of obj.c:
6997 Usually, the tagged record or one of the parent type owns the
6998 component to print and there's no issue but in this particular
6999 case, what does it mean to ask for Obj.C? Since the actual
7000 type for object is type Bottom_T, it could mean two things: type
7001 component C from the Middle_T view, but also component C from
7002 Bottom_T. So in that "undefined" case, when the component is
7003 not found in the non-resolved type (which includes all the
7004 components of the parent type), then resolve it and see if we
7005 get better luck once expanded.
7007 In the case of homonyms in the derived tagged type, we don't
7008 guaranty anything, and pick the one that's easiest for us
7011 Returns 1 if found, 0 otherwise. */
7014 find_struct_field (const char *name, struct type *type, int offset,
7015 struct type **field_type_p,
7016 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7020 int parent_offset = -1;
7022 type = ada_check_typedef (type);
7024 if (field_type_p != NULL)
7025 *field_type_p = NULL;
7026 if (byte_offset_p != NULL)
7028 if (bit_offset_p != NULL)
7030 if (bit_size_p != NULL)
7033 for (i = 0; i < type->num_fields (); i += 1)
7035 /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7036 type. However, we only need the values to be correct when
7037 the caller asks for them. */
7038 int bit_pos = 0, fld_offset = 0;
7039 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7041 bit_pos = type->field (i).loc_bitpos ();
7042 fld_offset = offset + bit_pos / 8;
7045 const char *t_field_name = type->field (i).name ();
7047 if (t_field_name == NULL)
7050 else if (ada_is_parent_field (type, i))
7052 /* This is a field pointing us to the parent type of a tagged
7053 type. As hinted in this function's documentation, we give
7054 preference to fields in the current record first, so what
7055 we do here is just record the index of this field before
7056 we skip it. If it turns out we couldn't find our field
7057 in the current record, then we'll get back to it and search
7058 inside it whether the field might exist in the parent. */
7064 else if (name != NULL && field_name_match (t_field_name, name))
7066 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7068 if (field_type_p != NULL)
7069 *field_type_p = type->field (i).type ();
7070 if (byte_offset_p != NULL)
7071 *byte_offset_p = fld_offset;
7072 if (bit_offset_p != NULL)
7073 *bit_offset_p = bit_pos % 8;
7074 if (bit_size_p != NULL)
7075 *bit_size_p = bit_size;
7078 else if (ada_is_wrapper_field (type, i))
7080 if (find_struct_field (name, type->field (i).type (), fld_offset,
7081 field_type_p, byte_offset_p, bit_offset_p,
7082 bit_size_p, index_p))
7085 else if (ada_is_variant_part (type, i))
7087 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7090 struct type *field_type
7091 = ada_check_typedef (type->field (i).type ());
7093 for (j = 0; j < field_type->num_fields (); j += 1)
7095 if (find_struct_field (name, field_type->field (j).type (),
7097 + field_type->field (j).loc_bitpos () / 8,
7098 field_type_p, byte_offset_p,
7099 bit_offset_p, bit_size_p, index_p))
7103 else if (index_p != NULL)
7107 /* Field not found so far. If this is a tagged type which
7108 has a parent, try finding that field in the parent now. */
7110 if (parent_offset != -1)
7112 /* As above, only compute the offset when truly needed. */
7113 int fld_offset = offset;
7114 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7116 int bit_pos = type->field (parent_offset).loc_bitpos ();
7117 fld_offset += bit_pos / 8;
7120 if (find_struct_field (name, type->field (parent_offset).type (),
7121 fld_offset, field_type_p, byte_offset_p,
7122 bit_offset_p, bit_size_p, index_p))
7129 /* Number of user-visible fields in record type TYPE. */
7132 num_visible_fields (struct type *type)
7137 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7141 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7142 and search in it assuming it has (class) type TYPE.
7143 If found, return value, else return NULL.
7145 Searches recursively through wrapper fields (e.g., '_parent').
7147 In the case of homonyms in the tagged types, please refer to the
7148 long explanation in find_struct_field's function documentation. */
7150 static struct value *
7151 ada_search_struct_field (const char *name, struct value *arg, int offset,
7155 int parent_offset = -1;
7157 type = ada_check_typedef (type);
7158 for (i = 0; i < type->num_fields (); i += 1)
7160 const char *t_field_name = type->field (i).name ();
7162 if (t_field_name == NULL)
7165 else if (ada_is_parent_field (type, i))
7167 /* This is a field pointing us to the parent type of a tagged
7168 type. As hinted in this function's documentation, we give
7169 preference to fields in the current record first, so what
7170 we do here is just record the index of this field before
7171 we skip it. If it turns out we couldn't find our field
7172 in the current record, then we'll get back to it and search
7173 inside it whether the field might exist in the parent. */
7179 else if (field_name_match (t_field_name, name))
7180 return ada_value_primitive_field (arg, offset, i, type);
7182 else if (ada_is_wrapper_field (type, i))
7184 struct value *v = /* Do not let indent join lines here. */
7185 ada_search_struct_field (name, arg,
7186 offset + type->field (i).loc_bitpos () / 8,
7187 type->field (i).type ());
7193 else if (ada_is_variant_part (type, i))
7195 /* PNH: Do we ever get here? See find_struct_field. */
7197 struct type *field_type = ada_check_typedef (type->field (i).type ());
7198 int var_offset = offset + type->field (i).loc_bitpos () / 8;
7200 for (j = 0; j < field_type->num_fields (); j += 1)
7202 struct value *v = ada_search_struct_field /* Force line
7205 var_offset + field_type->field (j).loc_bitpos () / 8,
7206 field_type->field (j).type ());
7214 /* Field not found so far. If this is a tagged type which
7215 has a parent, try finding that field in the parent now. */
7217 if (parent_offset != -1)
7219 struct value *v = ada_search_struct_field (
7220 name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7221 type->field (parent_offset).type ());
7230 static struct value *ada_index_struct_field_1 (int *, struct value *,
7231 int, struct type *);
7234 /* Return field #INDEX in ARG, where the index is that returned by
7235 * find_struct_field through its INDEX_P argument. Adjust the address
7236 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7237 * If found, return value, else return NULL. */
7239 static struct value *
7240 ada_index_struct_field (int index, struct value *arg, int offset,
7243 return ada_index_struct_field_1 (&index, arg, offset, type);
7247 /* Auxiliary function for ada_index_struct_field. Like
7248 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7251 static struct value *
7252 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7256 type = ada_check_typedef (type);
7258 for (i = 0; i < type->num_fields (); i += 1)
7260 if (type->field (i).name () == NULL)
7262 else if (ada_is_wrapper_field (type, i))
7264 struct value *v = /* Do not let indent join lines here. */
7265 ada_index_struct_field_1 (index_p, arg,
7266 offset + type->field (i).loc_bitpos () / 8,
7267 type->field (i).type ());
7273 else if (ada_is_variant_part (type, i))
7275 /* PNH: Do we ever get here? See ada_search_struct_field,
7276 find_struct_field. */
7277 error (_("Cannot assign this kind of variant record"));
7279 else if (*index_p == 0)
7280 return ada_value_primitive_field (arg, offset, i, type);
7287 /* Return a string representation of type TYPE. */
7290 type_as_string (struct type *type)
7292 string_file tmp_stream;
7294 type_print (type, "", &tmp_stream, -1);
7296 return tmp_stream.release ();
7299 /* Given a type TYPE, look up the type of the component of type named NAME.
7300 If DISPP is non-null, add its byte displacement from the beginning of a
7301 structure (pointed to by a value) of type TYPE to *DISPP (does not
7302 work for packed fields).
7304 Matches any field whose name has NAME as a prefix, possibly
7307 TYPE can be either a struct or union. If REFOK, TYPE may also
7308 be a (pointer or reference)+ to a struct or union, and the
7309 ultimate target type will be searched.
7311 Looks recursively into variant clauses and parent types.
7313 In the case of homonyms in the tagged types, please refer to the
7314 long explanation in find_struct_field's function documentation.
7316 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7317 TYPE is not a type of the right kind. */
7319 static struct type *
7320 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7324 int parent_offset = -1;
7329 if (refok && type != NULL)
7332 type = ada_check_typedef (type);
7333 if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7335 type = type->target_type ();
7339 || (type->code () != TYPE_CODE_STRUCT
7340 && type->code () != TYPE_CODE_UNION))
7345 error (_("Type %s is not a structure or union type"),
7346 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7349 type = to_static_fixed_type (type);
7351 for (i = 0; i < type->num_fields (); i += 1)
7353 const char *t_field_name = type->field (i).name ();
7356 if (t_field_name == NULL)
7359 else if (ada_is_parent_field (type, i))
7361 /* This is a field pointing us to the parent type of a tagged
7362 type. As hinted in this function's documentation, we give
7363 preference to fields in the current record first, so what
7364 we do here is just record the index of this field before
7365 we skip it. If it turns out we couldn't find our field
7366 in the current record, then we'll get back to it and search
7367 inside it whether the field might exist in the parent. */
7373 else if (field_name_match (t_field_name, name))
7374 return type->field (i).type ();
7376 else if (ada_is_wrapper_field (type, i))
7378 t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7384 else if (ada_is_variant_part (type, i))
7387 struct type *field_type = ada_check_typedef (type->field (i).type ());
7389 for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7391 /* FIXME pnh 2008/01/26: We check for a field that is
7392 NOT wrapped in a struct, since the compiler sometimes
7393 generates these for unchecked variant types. Revisit
7394 if the compiler changes this practice. */
7395 const char *v_field_name = field_type->field (j).name ();
7397 if (v_field_name != NULL
7398 && field_name_match (v_field_name, name))
7399 t = field_type->field (j).type ();
7401 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7411 /* Field not found so far. If this is a tagged type which
7412 has a parent, try finding that field in the parent now. */
7414 if (parent_offset != -1)
7418 t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7427 const char *name_str = name != NULL ? name : _("<null>");
7429 error (_("Type %s has no component named %s"),
7430 type_as_string (type).c_str (), name_str);
7436 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7437 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7438 represents an unchecked union (that is, the variant part of a
7439 record that is named in an Unchecked_Union pragma). */
7442 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7444 const char *discrim_name = ada_variant_discrim_name (var_type);
7446 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7450 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7451 within OUTER, determine which variant clause (field number in VAR_TYPE,
7452 numbering from 0) is applicable. Returns -1 if none are. */
7455 ada_which_variant_applies (struct type *var_type, struct value *outer)
7459 const char *discrim_name = ada_variant_discrim_name (var_type);
7460 struct value *discrim;
7461 LONGEST discrim_val;
7463 /* Using plain value_from_contents_and_address here causes problems
7464 because we will end up trying to resolve a type that is currently
7465 being constructed. */
7466 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7467 if (discrim == NULL)
7469 discrim_val = value_as_long (discrim);
7472 for (i = 0; i < var_type->num_fields (); i += 1)
7474 if (ada_is_others_clause (var_type, i))
7476 else if (ada_in_variant (discrim_val, var_type, i))
7480 return others_clause;
7485 /* Dynamic-Sized Records */
7487 /* Strategy: The type ostensibly attached to a value with dynamic size
7488 (i.e., a size that is not statically recorded in the debugging
7489 data) does not accurately reflect the size or layout of the value.
7490 Our strategy is to convert these values to values with accurate,
7491 conventional types that are constructed on the fly. */
7493 /* There is a subtle and tricky problem here. In general, we cannot
7494 determine the size of dynamic records without its data. However,
7495 the 'struct value' data structure, which GDB uses to represent
7496 quantities in the inferior process (the target), requires the size
7497 of the type at the time of its allocation in order to reserve space
7498 for GDB's internal copy of the data. That's why the
7499 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7500 rather than struct value*s.
7502 However, GDB's internal history variables ($1, $2, etc.) are
7503 struct value*s containing internal copies of the data that are not, in
7504 general, the same as the data at their corresponding addresses in
7505 the target. Fortunately, the types we give to these values are all
7506 conventional, fixed-size types (as per the strategy described
7507 above), so that we don't usually have to perform the
7508 'to_fixed_xxx_type' conversions to look at their values.
7509 Unfortunately, there is one exception: if one of the internal
7510 history variables is an array whose elements are unconstrained
7511 records, then we will need to create distinct fixed types for each
7512 element selected. */
7514 /* The upshot of all of this is that many routines take a (type, host
7515 address, target address) triple as arguments to represent a value.
7516 The host address, if non-null, is supposed to contain an internal
7517 copy of the relevant data; otherwise, the program is to consult the
7518 target at the target address. */
7520 /* Assuming that VAL0 represents a pointer value, the result of
7521 dereferencing it. Differs from value_ind in its treatment of
7522 dynamic-sized types. */
7525 ada_value_ind (struct value *val0)
7527 struct value *val = value_ind (val0);
7529 if (ada_is_tagged_type (value_type (val), 0))
7530 val = ada_tag_value_at_base_address (val);
7532 return ada_to_fixed_value (val);
7535 /* The value resulting from dereferencing any "reference to"
7536 qualifiers on VAL0. */
7538 static struct value *
7539 ada_coerce_ref (struct value *val0)
7541 if (value_type (val0)->code () == TYPE_CODE_REF)
7543 struct value *val = val0;
7545 val = coerce_ref (val);
7547 if (ada_is_tagged_type (value_type (val), 0))
7548 val = ada_tag_value_at_base_address (val);
7550 return ada_to_fixed_value (val);
7556 /* Return the bit alignment required for field #F of template type TYPE. */
7559 field_alignment (struct type *type, int f)
7561 const char *name = type->field (f).name ();
7565 /* The field name should never be null, unless the debugging information
7566 is somehow malformed. In this case, we assume the field does not
7567 require any alignment. */
7571 len = strlen (name);
7573 if (!isdigit (name[len - 1]))
7576 if (isdigit (name[len - 2]))
7577 align_offset = len - 2;
7579 align_offset = len - 1;
7581 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7582 return TARGET_CHAR_BIT;
7584 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7587 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7589 static struct symbol *
7590 ada_find_any_type_symbol (const char *name)
7594 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7595 if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7598 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7602 /* Find a type named NAME. Ignores ambiguity. This routine will look
7603 solely for types defined by debug info, it will not search the GDB
7606 static struct type *
7607 ada_find_any_type (const char *name)
7609 struct symbol *sym = ada_find_any_type_symbol (name);
7612 return sym->type ();
7617 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7618 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7619 symbol, in which case it is returned. Otherwise, this looks for
7620 symbols whose name is that of NAME_SYM suffixed with "___XR".
7621 Return symbol if found, and NULL otherwise. */
7624 ada_is_renaming_symbol (struct symbol *name_sym)
7626 const char *name = name_sym->linkage_name ();
7627 return strstr (name, "___XR") != NULL;
7630 /* Because of GNAT encoding conventions, several GDB symbols may match a
7631 given type name. If the type denoted by TYPE0 is to be preferred to
7632 that of TYPE1 for purposes of type printing, return non-zero;
7633 otherwise return 0. */
7636 ada_prefer_type (struct type *type0, struct type *type1)
7640 else if (type0 == NULL)
7642 else if (type1->code () == TYPE_CODE_VOID)
7644 else if (type0->code () == TYPE_CODE_VOID)
7646 else if (type1->name () == NULL && type0->name () != NULL)
7648 else if (ada_is_constrained_packed_array_type (type0))
7650 else if (ada_is_array_descriptor_type (type0)
7651 && !ada_is_array_descriptor_type (type1))
7655 const char *type0_name = type0->name ();
7656 const char *type1_name = type1->name ();
7658 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7659 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7665 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7669 ada_type_name (struct type *type)
7673 return type->name ();
7676 /* Search the list of "descriptive" types associated to TYPE for a type
7677 whose name is NAME. */
7679 static struct type *
7680 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7682 struct type *result, *tmp;
7684 if (ada_ignore_descriptive_types_p)
7687 /* If there no descriptive-type info, then there is no parallel type
7689 if (!HAVE_GNAT_AUX_INFO (type))
7692 result = TYPE_DESCRIPTIVE_TYPE (type);
7693 while (result != NULL)
7695 const char *result_name = ada_type_name (result);
7697 if (result_name == NULL)
7699 warning (_("unexpected null name on descriptive type"));
7703 /* If the names match, stop. */
7704 if (strcmp (result_name, name) == 0)
7707 /* Otherwise, look at the next item on the list, if any. */
7708 if (HAVE_GNAT_AUX_INFO (result))
7709 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7713 /* If not found either, try after having resolved the typedef. */
7718 result = check_typedef (result);
7719 if (HAVE_GNAT_AUX_INFO (result))
7720 result = TYPE_DESCRIPTIVE_TYPE (result);
7726 /* If we didn't find a match, see whether this is a packed array. With
7727 older compilers, the descriptive type information is either absent or
7728 irrelevant when it comes to packed arrays so the above lookup fails.
7729 Fall back to using a parallel lookup by name in this case. */
7730 if (result == NULL && ada_is_constrained_packed_array_type (type))
7731 return ada_find_any_type (name);
7736 /* Find a parallel type to TYPE with the specified NAME, using the
7737 descriptive type taken from the debugging information, if available,
7738 and otherwise using the (slower) name-based method. */
7740 static struct type *
7741 ada_find_parallel_type_with_name (struct type *type, const char *name)
7743 struct type *result = NULL;
7745 if (HAVE_GNAT_AUX_INFO (type))
7746 result = find_parallel_type_by_descriptive_type (type, name);
7748 result = ada_find_any_type (name);
7753 /* Same as above, but specify the name of the parallel type by appending
7754 SUFFIX to the name of TYPE. */
7757 ada_find_parallel_type (struct type *type, const char *suffix)
7760 const char *type_name = ada_type_name (type);
7763 if (type_name == NULL)
7766 len = strlen (type_name);
7768 name = (char *) alloca (len + strlen (suffix) + 1);
7770 strcpy (name, type_name);
7771 strcpy (name + len, suffix);
7773 return ada_find_parallel_type_with_name (type, name);
7776 /* If TYPE is a variable-size record type, return the corresponding template
7777 type describing its fields. Otherwise, return NULL. */
7779 static struct type *
7780 dynamic_template_type (struct type *type)
7782 type = ada_check_typedef (type);
7784 if (type == NULL || type->code () != TYPE_CODE_STRUCT
7785 || ada_type_name (type) == NULL)
7789 int len = strlen (ada_type_name (type));
7791 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7794 return ada_find_parallel_type (type, "___XVE");
7798 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7799 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7802 is_dynamic_field (struct type *templ_type, int field_num)
7804 const char *name = templ_type->field (field_num).name ();
7807 && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7808 && strstr (name, "___XVL") != NULL;
7811 /* The index of the variant field of TYPE, or -1 if TYPE does not
7812 represent a variant record type. */
7815 variant_field_index (struct type *type)
7819 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7822 for (f = 0; f < type->num_fields (); f += 1)
7824 if (ada_is_variant_part (type, f))
7830 /* A record type with no fields. */
7832 static struct type *
7833 empty_record (struct type *templ)
7835 struct type *type = alloc_type_copy (templ);
7837 type->set_code (TYPE_CODE_STRUCT);
7838 INIT_NONE_SPECIFIC (type);
7839 type->set_name ("<empty>");
7840 type->set_length (0);
7844 /* An ordinary record type (with fixed-length fields) that describes
7845 the value of type TYPE at VALADDR or ADDRESS (see comments at
7846 the beginning of this section) VAL according to GNAT conventions.
7847 DVAL0 should describe the (portion of a) record that contains any
7848 necessary discriminants. It should be NULL if value_type (VAL) is
7849 an outer-level type (i.e., as opposed to a branch of a variant.) A
7850 variant field (unless unchecked) is replaced by a particular branch
7853 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7854 length are not statically known are discarded. As a consequence,
7855 VALADDR, ADDRESS and DVAL0 are ignored.
7857 NOTE: Limitations: For now, we assume that dynamic fields and
7858 variants occupy whole numbers of bytes. However, they need not be
7862 ada_template_to_fixed_record_type_1 (struct type *type,
7863 const gdb_byte *valaddr,
7864 CORE_ADDR address, struct value *dval0,
7865 int keep_dynamic_fields)
7869 int nfields, bit_len;
7875 scoped_value_mark mark;
7877 /* Compute the number of fields in this record type that are going
7878 to be processed: unless keep_dynamic_fields, this includes only
7879 fields whose position and length are static will be processed. */
7880 if (keep_dynamic_fields)
7881 nfields = type->num_fields ();
7885 while (nfields < type->num_fields ()
7886 && !ada_is_variant_part (type, nfields)
7887 && !is_dynamic_field (type, nfields))
7891 rtype = alloc_type_copy (type);
7892 rtype->set_code (TYPE_CODE_STRUCT);
7893 INIT_NONE_SPECIFIC (rtype);
7894 rtype->set_num_fields (nfields);
7896 ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7897 rtype->set_name (ada_type_name (type));
7898 rtype->set_is_fixed_instance (true);
7904 for (f = 0; f < nfields; f += 1)
7906 off = align_up (off, field_alignment (type, f))
7907 + type->field (f).loc_bitpos ();
7908 rtype->field (f).set_loc_bitpos (off);
7909 TYPE_FIELD_BITSIZE (rtype, f) = 0;
7911 if (ada_is_variant_part (type, f))
7916 else if (is_dynamic_field (type, f))
7918 const gdb_byte *field_valaddr = valaddr;
7919 CORE_ADDR field_address = address;
7920 struct type *field_type = type->field (f).type ()->target_type ();
7924 /* Using plain value_from_contents_and_address here
7925 causes problems because we will end up trying to
7926 resolve a type that is currently being
7928 dval = value_from_contents_and_address_unresolved (rtype,
7931 rtype = value_type (dval);
7936 /* If the type referenced by this field is an aligner type, we need
7937 to unwrap that aligner type, because its size might not be set.
7938 Keeping the aligner type would cause us to compute the wrong
7939 size for this field, impacting the offset of the all the fields
7940 that follow this one. */
7941 if (ada_is_aligner_type (field_type))
7943 long field_offset = type->field (f).loc_bitpos ();
7945 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7946 field_address = cond_offset_target (field_address, field_offset);
7947 field_type = ada_aligned_type (field_type);
7950 field_valaddr = cond_offset_host (field_valaddr,
7951 off / TARGET_CHAR_BIT);
7952 field_address = cond_offset_target (field_address,
7953 off / TARGET_CHAR_BIT);
7955 /* Get the fixed type of the field. Note that, in this case,
7956 we do not want to get the real type out of the tag: if
7957 the current field is the parent part of a tagged record,
7958 we will get the tag of the object. Clearly wrong: the real
7959 type of the parent is not the real type of the child. We
7960 would end up in an infinite loop. */
7961 field_type = ada_get_base_type (field_type);
7962 field_type = ada_to_fixed_type (field_type, field_valaddr,
7963 field_address, dval, 0);
7965 rtype->field (f).set_type (field_type);
7966 rtype->field (f).set_name (type->field (f).name ());
7967 /* The multiplication can potentially overflow. But because
7968 the field length has been size-checked just above, and
7969 assuming that the maximum size is a reasonable value,
7970 an overflow should not happen in practice. So rather than
7971 adding overflow recovery code to this already complex code,
7972 we just assume that it's not going to happen. */
7973 fld_bit_len = rtype->field (f).type ()->length () * TARGET_CHAR_BIT;
7977 /* Note: If this field's type is a typedef, it is important
7978 to preserve the typedef layer.
7980 Otherwise, we might be transforming a typedef to a fat
7981 pointer (encoding a pointer to an unconstrained array),
7982 into a basic fat pointer (encoding an unconstrained
7983 array). As both types are implemented using the same
7984 structure, the typedef is the only clue which allows us
7985 to distinguish between the two options. Stripping it
7986 would prevent us from printing this field appropriately. */
7987 rtype->field (f).set_type (type->field (f).type ());
7988 rtype->field (f).set_name (type->field (f).name ());
7989 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7991 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7994 struct type *field_type = type->field (f).type ();
7996 /* We need to be careful of typedefs when computing
7997 the length of our field. If this is a typedef,
7998 get the length of the target type, not the length
8000 if (field_type->code () == TYPE_CODE_TYPEDEF)
8001 field_type = ada_typedef_target_type (field_type);
8004 ada_check_typedef (field_type)->length () * TARGET_CHAR_BIT;
8007 if (off + fld_bit_len > bit_len)
8008 bit_len = off + fld_bit_len;
8010 rtype->set_length (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8013 /* We handle the variant part, if any, at the end because of certain
8014 odd cases in which it is re-ordered so as NOT to be the last field of
8015 the record. This can happen in the presence of representation
8017 if (variant_field >= 0)
8019 struct type *branch_type;
8021 off = rtype->field (variant_field).loc_bitpos ();
8025 /* Using plain value_from_contents_and_address here causes
8026 problems because we will end up trying to resolve a type
8027 that is currently being constructed. */
8028 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8030 rtype = value_type (dval);
8036 to_fixed_variant_branch_type
8037 (type->field (variant_field).type (),
8038 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8039 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8040 if (branch_type == NULL)
8042 for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8043 rtype->field (f - 1) = rtype->field (f);
8044 rtype->set_num_fields (rtype->num_fields () - 1);
8048 rtype->field (variant_field).set_type (branch_type);
8049 rtype->field (variant_field).set_name ("S");
8051 rtype->field (variant_field).type ()->length () * TARGET_CHAR_BIT;
8052 if (off + fld_bit_len > bit_len)
8053 bit_len = off + fld_bit_len;
8056 (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8060 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8061 should contain the alignment of that record, which should be a strictly
8062 positive value. If null or negative, then something is wrong, most
8063 probably in the debug info. In that case, we don't round up the size
8064 of the resulting type. If this record is not part of another structure,
8065 the current RTYPE length might be good enough for our purposes. */
8066 if (type->length () <= 0)
8069 warning (_("Invalid type size for `%s' detected: %s."),
8070 rtype->name (), pulongest (type->length ()));
8072 warning (_("Invalid type size for <unnamed> detected: %s."),
8073 pulongest (type->length ()));
8076 rtype->set_length (align_up (rtype->length (), type->length ()));
8081 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8084 static struct type *
8085 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8086 CORE_ADDR address, struct value *dval0)
8088 return ada_template_to_fixed_record_type_1 (type, valaddr,
8092 /* An ordinary record type in which ___XVL-convention fields and
8093 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8094 static approximations, containing all possible fields. Uses
8095 no runtime values. Useless for use in values, but that's OK,
8096 since the results are used only for type determinations. Works on both
8097 structs and unions. Representation note: to save space, we memorize
8098 the result of this function in the type::target_type of the
8101 static struct type *
8102 template_to_static_fixed_type (struct type *type0)
8108 /* No need no do anything if the input type is already fixed. */
8109 if (type0->is_fixed_instance ())
8112 /* Likewise if we already have computed the static approximation. */
8113 if (type0->target_type () != NULL)
8114 return type0->target_type ();
8116 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8118 nfields = type0->num_fields ();
8120 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8121 recompute all over next time. */
8122 type0->set_target_type (type);
8124 for (f = 0; f < nfields; f += 1)
8126 struct type *field_type = type0->field (f).type ();
8127 struct type *new_type;
8129 if (is_dynamic_field (type0, f))
8131 field_type = ada_check_typedef (field_type);
8132 new_type = to_static_fixed_type (field_type->target_type ());
8135 new_type = static_unwrap_type (field_type);
8137 if (new_type != field_type)
8139 /* Clone TYPE0 only the first time we get a new field type. */
8142 type = alloc_type_copy (type0);
8143 type0->set_target_type (type);
8144 type->set_code (type0->code ());
8145 INIT_NONE_SPECIFIC (type);
8146 type->set_num_fields (nfields);
8150 TYPE_ALLOC (type, nfields * sizeof (struct field)));
8151 memcpy (fields, type0->fields (),
8152 sizeof (struct field) * nfields);
8153 type->set_fields (fields);
8155 type->set_name (ada_type_name (type0));
8156 type->set_is_fixed_instance (true);
8157 type->set_length (0);
8159 type->field (f).set_type (new_type);
8160 type->field (f).set_name (type0->field (f).name ());
8167 /* Given an object of type TYPE whose contents are at VALADDR and
8168 whose address in memory is ADDRESS, returns a revision of TYPE,
8169 which should be a non-dynamic-sized record, in which the variant
8170 part, if any, is replaced with the appropriate branch. Looks
8171 for discriminant values in DVAL0, which can be NULL if the record
8172 contains the necessary discriminant values. */
8174 static struct type *
8175 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8176 CORE_ADDR address, struct value *dval0)
8180 struct type *branch_type;
8181 int nfields = type->num_fields ();
8182 int variant_field = variant_field_index (type);
8184 if (variant_field == -1)
8187 scoped_value_mark mark;
8190 dval = value_from_contents_and_address (type, valaddr, address);
8191 type = value_type (dval);
8196 rtype = alloc_type_copy (type);
8197 rtype->set_code (TYPE_CODE_STRUCT);
8198 INIT_NONE_SPECIFIC (rtype);
8199 rtype->set_num_fields (nfields);
8202 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8203 memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8204 rtype->set_fields (fields);
8206 rtype->set_name (ada_type_name (type));
8207 rtype->set_is_fixed_instance (true);
8208 rtype->set_length (type->length ());
8210 branch_type = to_fixed_variant_branch_type
8211 (type->field (variant_field).type (),
8212 cond_offset_host (valaddr,
8213 type->field (variant_field).loc_bitpos ()
8215 cond_offset_target (address,
8216 type->field (variant_field).loc_bitpos ()
8217 / TARGET_CHAR_BIT), dval);
8218 if (branch_type == NULL)
8222 for (f = variant_field + 1; f < nfields; f += 1)
8223 rtype->field (f - 1) = rtype->field (f);
8224 rtype->set_num_fields (rtype->num_fields () - 1);
8228 rtype->field (variant_field).set_type (branch_type);
8229 rtype->field (variant_field).set_name ("S");
8230 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8231 rtype->set_length (rtype->length () + branch_type->length ());
8234 rtype->set_length (rtype->length ()
8235 - type->field (variant_field).type ()->length ());
8240 /* An ordinary record type (with fixed-length fields) that describes
8241 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8242 beginning of this section]. Any necessary discriminants' values
8243 should be in DVAL, a record value; it may be NULL if the object
8244 at ADDR itself contains any necessary discriminant values.
8245 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8246 values from the record are needed. Except in the case that DVAL,
8247 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8248 unchecked) is replaced by a particular branch of the variant.
8250 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8251 is questionable and may be removed. It can arise during the
8252 processing of an unconstrained-array-of-record type where all the
8253 variant branches have exactly the same size. This is because in
8254 such cases, the compiler does not bother to use the XVS convention
8255 when encoding the record. I am currently dubious of this
8256 shortcut and suspect the compiler should be altered. FIXME. */
8258 static struct type *
8259 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8260 CORE_ADDR address, struct value *dval)
8262 struct type *templ_type;
8264 if (type0->is_fixed_instance ())
8267 templ_type = dynamic_template_type (type0);
8269 if (templ_type != NULL)
8270 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8271 else if (variant_field_index (type0) >= 0)
8273 if (dval == NULL && valaddr == NULL && address == 0)
8275 return to_record_with_fixed_variant_part (type0, valaddr, address,
8280 type0->set_is_fixed_instance (true);
8286 /* An ordinary record type (with fixed-length fields) that describes
8287 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8288 union type. Any necessary discriminants' values should be in DVAL,
8289 a record value. That is, this routine selects the appropriate
8290 branch of the union at ADDR according to the discriminant value
8291 indicated in the union's type name. Returns VAR_TYPE0 itself if
8292 it represents a variant subject to a pragma Unchecked_Union. */
8294 static struct type *
8295 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8296 CORE_ADDR address, struct value *dval)
8299 struct type *templ_type;
8300 struct type *var_type;
8302 if (var_type0->code () == TYPE_CODE_PTR)
8303 var_type = var_type0->target_type ();
8305 var_type = var_type0;
8307 templ_type = ada_find_parallel_type (var_type, "___XVU");
8309 if (templ_type != NULL)
8310 var_type = templ_type;
8312 if (is_unchecked_variant (var_type, value_type (dval)))
8314 which = ada_which_variant_applies (var_type, dval);
8317 return empty_record (var_type);
8318 else if (is_dynamic_field (var_type, which))
8319 return to_fixed_record_type
8320 (var_type->field (which).type ()->target_type(), valaddr, address, dval);
8321 else if (variant_field_index (var_type->field (which).type ()) >= 0)
8323 to_fixed_record_type
8324 (var_type->field (which).type (), valaddr, address, dval);
8326 return var_type->field (which).type ();
8329 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8330 ENCODING_TYPE, a type following the GNAT conventions for discrete
8331 type encodings, only carries redundant information. */
8334 ada_is_redundant_range_encoding (struct type *range_type,
8335 struct type *encoding_type)
8337 const char *bounds_str;
8341 gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8343 if (get_base_type (range_type)->code ()
8344 != get_base_type (encoding_type)->code ())
8346 /* The compiler probably used a simple base type to describe
8347 the range type instead of the range's actual base type,
8348 expecting us to get the real base type from the encoding
8349 anyway. In this situation, the encoding cannot be ignored
8354 if (is_dynamic_type (range_type))
8357 if (encoding_type->name () == NULL)
8360 bounds_str = strstr (encoding_type->name (), "___XDLU_");
8361 if (bounds_str == NULL)
8364 n = 8; /* Skip "___XDLU_". */
8365 if (!ada_scan_number (bounds_str, n, &lo, &n))
8367 if (range_type->bounds ()->low.const_val () != lo)
8370 n += 2; /* Skip the "__" separator between the two bounds. */
8371 if (!ada_scan_number (bounds_str, n, &hi, &n))
8373 if (range_type->bounds ()->high.const_val () != hi)
8379 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8380 a type following the GNAT encoding for describing array type
8381 indices, only carries redundant information. */
8384 ada_is_redundant_index_type_desc (struct type *array_type,
8385 struct type *desc_type)
8387 struct type *this_layer = check_typedef (array_type);
8390 for (i = 0; i < desc_type->num_fields (); i++)
8392 if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8393 desc_type->field (i).type ()))
8395 this_layer = check_typedef (this_layer->target_type ());
8401 /* Assuming that TYPE0 is an array type describing the type of a value
8402 at ADDR, and that DVAL describes a record containing any
8403 discriminants used in TYPE0, returns a type for the value that
8404 contains no dynamic components (that is, no components whose sizes
8405 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8406 true, gives an error message if the resulting type's size is over
8409 static struct type *
8410 to_fixed_array_type (struct type *type0, struct value *dval,
8413 struct type *index_type_desc;
8414 struct type *result;
8415 int constrained_packed_array_p;
8416 static const char *xa_suffix = "___XA";
8418 type0 = ada_check_typedef (type0);
8419 if (type0->is_fixed_instance ())
8422 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8423 if (constrained_packed_array_p)
8425 type0 = decode_constrained_packed_array_type (type0);
8426 if (type0 == nullptr)
8427 error (_("could not decode constrained packed array type"));
8430 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8432 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8433 encoding suffixed with 'P' may still be generated. If so,
8434 it should be used to find the XA type. */
8436 if (index_type_desc == NULL)
8438 const char *type_name = ada_type_name (type0);
8440 if (type_name != NULL)
8442 const int len = strlen (type_name);
8443 char *name = (char *) alloca (len + strlen (xa_suffix));
8445 if (type_name[len - 1] == 'P')
8447 strcpy (name, type_name);
8448 strcpy (name + len - 1, xa_suffix);
8449 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8454 ada_fixup_array_indexes_type (index_type_desc);
8455 if (index_type_desc != NULL
8456 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8458 /* Ignore this ___XA parallel type, as it does not bring any
8459 useful information. This allows us to avoid creating fixed
8460 versions of the array's index types, which would be identical
8461 to the original ones. This, in turn, can also help avoid
8462 the creation of fixed versions of the array itself. */
8463 index_type_desc = NULL;
8466 if (index_type_desc == NULL)
8468 struct type *elt_type0 = ada_check_typedef (type0->target_type ());
8470 /* NOTE: elt_type---the fixed version of elt_type0---should never
8471 depend on the contents of the array in properly constructed
8473 /* Create a fixed version of the array element type.
8474 We're not providing the address of an element here,
8475 and thus the actual object value cannot be inspected to do
8476 the conversion. This should not be a problem, since arrays of
8477 unconstrained objects are not allowed. In particular, all
8478 the elements of an array of a tagged type should all be of
8479 the same type specified in the debugging info. No need to
8480 consult the object tag. */
8481 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8483 /* Make sure we always create a new array type when dealing with
8484 packed array types, since we're going to fix-up the array
8485 type length and element bitsize a little further down. */
8486 if (elt_type0 == elt_type && !constrained_packed_array_p)
8489 result = create_array_type (alloc_type_copy (type0),
8490 elt_type, type0->index_type ());
8495 struct type *elt_type0;
8498 for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8499 elt_type0 = elt_type0->target_type ();
8501 /* NOTE: result---the fixed version of elt_type0---should never
8502 depend on the contents of the array in properly constructed
8504 /* Create a fixed version of the array element type.
8505 We're not providing the address of an element here,
8506 and thus the actual object value cannot be inspected to do
8507 the conversion. This should not be a problem, since arrays of
8508 unconstrained objects are not allowed. In particular, all
8509 the elements of an array of a tagged type should all be of
8510 the same type specified in the debugging info. No need to
8511 consult the object tag. */
8513 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8516 for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8518 struct type *range_type =
8519 to_fixed_range_type (index_type_desc->field (i).type (), dval);
8521 result = create_array_type (alloc_type_copy (elt_type0),
8522 result, range_type);
8523 elt_type0 = elt_type0->target_type ();
8527 /* We want to preserve the type name. This can be useful when
8528 trying to get the type name of a value that has already been
8529 printed (for instance, if the user did "print VAR; whatis $". */
8530 result->set_name (type0->name ());
8532 if (constrained_packed_array_p)
8534 /* So far, the resulting type has been created as if the original
8535 type was a regular (non-packed) array type. As a result, the
8536 bitsize of the array elements needs to be set again, and the array
8537 length needs to be recomputed based on that bitsize. */
8538 int len = result->length () / result->target_type ()->length ();
8539 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8541 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8542 result->set_length (len * elt_bitsize / HOST_CHAR_BIT);
8543 if (result->length () * HOST_CHAR_BIT < len * elt_bitsize)
8544 result->set_length (result->length () + 1);
8547 result->set_is_fixed_instance (true);
8552 /* A standard type (containing no dynamically sized components)
8553 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8554 DVAL describes a record containing any discriminants used in TYPE0,
8555 and may be NULL if there are none, or if the object of type TYPE at
8556 ADDRESS or in VALADDR contains these discriminants.
8558 If CHECK_TAG is not null, in the case of tagged types, this function
8559 attempts to locate the object's tag and use it to compute the actual
8560 type. However, when ADDRESS is null, we cannot use it to determine the
8561 location of the tag, and therefore compute the tagged type's actual type.
8562 So we return the tagged type without consulting the tag. */
8564 static struct type *
8565 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8566 CORE_ADDR address, struct value *dval, int check_tag)
8568 type = ada_check_typedef (type);
8570 /* Only un-fixed types need to be handled here. */
8571 if (!HAVE_GNAT_AUX_INFO (type))
8574 switch (type->code ())
8578 case TYPE_CODE_STRUCT:
8580 struct type *static_type = to_static_fixed_type (type);
8581 struct type *fixed_record_type =
8582 to_fixed_record_type (type, valaddr, address, NULL);
8584 /* If STATIC_TYPE is a tagged type and we know the object's address,
8585 then we can determine its tag, and compute the object's actual
8586 type from there. Note that we have to use the fixed record
8587 type (the parent part of the record may have dynamic fields
8588 and the way the location of _tag is expressed may depend on
8591 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8594 value_tag_from_contents_and_address
8598 struct type *real_type = type_from_tag (tag);
8600 value_from_contents_and_address (fixed_record_type,
8603 fixed_record_type = value_type (obj);
8604 if (real_type != NULL)
8605 return to_fixed_record_type
8607 value_address (ada_tag_value_at_base_address (obj)), NULL);
8610 /* Check to see if there is a parallel ___XVZ variable.
8611 If there is, then it provides the actual size of our type. */
8612 else if (ada_type_name (fixed_record_type) != NULL)
8614 const char *name = ada_type_name (fixed_record_type);
8616 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8617 bool xvz_found = false;
8620 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8623 xvz_found = get_int_var_value (xvz_name, size);
8625 catch (const gdb_exception_error &except)
8627 /* We found the variable, but somehow failed to read
8628 its value. Rethrow the same error, but with a little
8629 bit more information, to help the user understand
8630 what went wrong (Eg: the variable might have been
8632 throw_error (except.error,
8633 _("unable to read value of %s (%s)"),
8634 xvz_name, except.what ());
8637 if (xvz_found && fixed_record_type->length () != size)
8639 fixed_record_type = copy_type (fixed_record_type);
8640 fixed_record_type->set_length (size);
8642 /* The FIXED_RECORD_TYPE may have be a stub. We have
8643 observed this when the debugging info is STABS, and
8644 apparently it is something that is hard to fix.
8646 In practice, we don't need the actual type definition
8647 at all, because the presence of the XVZ variable allows us
8648 to assume that there must be a XVS type as well, which we
8649 should be able to use later, when we need the actual type
8652 In the meantime, pretend that the "fixed" type we are
8653 returning is NOT a stub, because this can cause trouble
8654 when using this type to create new types targeting it.
8655 Indeed, the associated creation routines often check
8656 whether the target type is a stub and will try to replace
8657 it, thus using a type with the wrong size. This, in turn,
8658 might cause the new type to have the wrong size too.
8659 Consider the case of an array, for instance, where the size
8660 of the array is computed from the number of elements in
8661 our array multiplied by the size of its element. */
8662 fixed_record_type->set_is_stub (false);
8665 return fixed_record_type;
8667 case TYPE_CODE_ARRAY:
8668 return to_fixed_array_type (type, dval, 1);
8669 case TYPE_CODE_UNION:
8673 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8677 /* The same as ada_to_fixed_type_1, except that it preserves the type
8678 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8680 The typedef layer needs be preserved in order to differentiate between
8681 arrays and array pointers when both types are implemented using the same
8682 fat pointer. In the array pointer case, the pointer is encoded as
8683 a typedef of the pointer type. For instance, considering:
8685 type String_Access is access String;
8686 S1 : String_Access := null;
8688 To the debugger, S1 is defined as a typedef of type String. But
8689 to the user, it is a pointer. So if the user tries to print S1,
8690 we should not dereference the array, but print the array address
8693 If we didn't preserve the typedef layer, we would lose the fact that
8694 the type is to be presented as a pointer (needs de-reference before
8695 being printed). And we would also use the source-level type name. */
8698 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8699 CORE_ADDR address, struct value *dval, int check_tag)
8702 struct type *fixed_type =
8703 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8705 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8706 then preserve the typedef layer.
8708 Implementation note: We can only check the main-type portion of
8709 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8710 from TYPE now returns a type that has the same instance flags
8711 as TYPE. For instance, if TYPE is a "typedef const", and its
8712 target type is a "struct", then the typedef elimination will return
8713 a "const" version of the target type. See check_typedef for more
8714 details about how the typedef layer elimination is done.
8716 brobecker/2010-11-19: It seems to me that the only case where it is
8717 useful to preserve the typedef layer is when dealing with fat pointers.
8718 Perhaps, we could add a check for that and preserve the typedef layer
8719 only in that situation. But this seems unnecessary so far, probably
8720 because we call check_typedef/ada_check_typedef pretty much everywhere.
8722 if (type->code () == TYPE_CODE_TYPEDEF
8723 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8724 == TYPE_MAIN_TYPE (fixed_type)))
8730 /* A standard (static-sized) type corresponding as well as possible to
8731 TYPE0, but based on no runtime data. */
8733 static struct type *
8734 to_static_fixed_type (struct type *type0)
8741 if (type0->is_fixed_instance ())
8744 type0 = ada_check_typedef (type0);
8746 switch (type0->code ())
8750 case TYPE_CODE_STRUCT:
8751 type = dynamic_template_type (type0);
8753 return template_to_static_fixed_type (type);
8755 return template_to_static_fixed_type (type0);
8756 case TYPE_CODE_UNION:
8757 type = ada_find_parallel_type (type0, "___XVU");
8759 return template_to_static_fixed_type (type);
8761 return template_to_static_fixed_type (type0);
8765 /* A static approximation of TYPE with all type wrappers removed. */
8767 static struct type *
8768 static_unwrap_type (struct type *type)
8770 if (ada_is_aligner_type (type))
8772 struct type *type1 = ada_check_typedef (type)->field (0).type ();
8773 if (ada_type_name (type1) == NULL)
8774 type1->set_name (ada_type_name (type));
8776 return static_unwrap_type (type1);
8780 struct type *raw_real_type = ada_get_base_type (type);
8782 if (raw_real_type == type)
8785 return to_static_fixed_type (raw_real_type);
8789 /* In some cases, incomplete and private types require
8790 cross-references that are not resolved as records (for example,
8792 type FooP is access Foo;
8794 type Foo is array ...;
8795 ). In these cases, since there is no mechanism for producing
8796 cross-references to such types, we instead substitute for FooP a
8797 stub enumeration type that is nowhere resolved, and whose tag is
8798 the name of the actual type. Call these types "non-record stubs". */
8800 /* A type equivalent to TYPE that is not a non-record stub, if one
8801 exists, otherwise TYPE. */
8804 ada_check_typedef (struct type *type)
8809 /* If our type is an access to an unconstrained array, which is encoded
8810 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8811 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8812 what allows us to distinguish between fat pointers that represent
8813 array types, and fat pointers that represent array access types
8814 (in both cases, the compiler implements them as fat pointers). */
8815 if (ada_is_access_to_unconstrained_array (type))
8818 type = check_typedef (type);
8819 if (type == NULL || type->code () != TYPE_CODE_ENUM
8820 || !type->is_stub ()
8821 || type->name () == NULL)
8825 const char *name = type->name ();
8826 struct type *type1 = ada_find_any_type (name);
8831 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8832 stubs pointing to arrays, as we don't create symbols for array
8833 types, only for the typedef-to-array types). If that's the case,
8834 strip the typedef layer. */
8835 if (type1->code () == TYPE_CODE_TYPEDEF)
8836 type1 = ada_check_typedef (type1);
8842 /* A value representing the data at VALADDR/ADDRESS as described by
8843 type TYPE0, but with a standard (static-sized) type that correctly
8844 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8845 type, then return VAL0 [this feature is simply to avoid redundant
8846 creation of struct values]. */
8848 static struct value *
8849 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8852 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8854 if (type == type0 && val0 != NULL)
8857 if (VALUE_LVAL (val0) != lval_memory)
8859 /* Our value does not live in memory; it could be a convenience
8860 variable, for instance. Create a not_lval value using val0's
8862 return value_from_contents (type, value_contents (val0).data ());
8865 return value_from_contents_and_address (type, 0, address);
8868 /* A value representing VAL, but with a standard (static-sized) type
8869 that correctly describes it. Does not necessarily create a new
8873 ada_to_fixed_value (struct value *val)
8875 val = unwrap_value (val);
8876 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8883 /* Table mapping attribute numbers to names.
8884 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8886 static const char * const attribute_names[] = {
8904 ada_attribute_name (enum exp_opcode n)
8906 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8907 return attribute_names[n - OP_ATR_FIRST + 1];
8909 return attribute_names[0];
8912 /* Evaluate the 'POS attribute applied to ARG. */
8915 pos_atr (struct value *arg)
8917 struct value *val = coerce_ref (arg);
8918 struct type *type = value_type (val);
8920 if (!discrete_type_p (type))
8921 error (_("'POS only defined on discrete types"));
8923 gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8924 if (!result.has_value ())
8925 error (_("enumeration value is invalid: can't find 'POS"));
8931 ada_pos_atr (struct type *expect_type,
8932 struct expression *exp,
8933 enum noside noside, enum exp_opcode op,
8936 struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8937 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8938 return value_zero (type, not_lval);
8939 return value_from_longest (type, pos_atr (arg));
8942 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8944 static struct value *
8945 val_atr (struct type *type, LONGEST val)
8947 gdb_assert (discrete_type_p (type));
8948 if (type->code () == TYPE_CODE_RANGE)
8949 type = type->target_type ();
8950 if (type->code () == TYPE_CODE_ENUM)
8952 if (val < 0 || val >= type->num_fields ())
8953 error (_("argument to 'VAL out of range"));
8954 val = type->field (val).loc_enumval ();
8956 return value_from_longest (type, val);
8960 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8962 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8963 return value_zero (type, not_lval);
8965 if (!discrete_type_p (type))
8966 error (_("'VAL only defined on discrete types"));
8967 if (!integer_type_p (value_type (arg)))
8968 error (_("'VAL requires integral argument"));
8970 return val_atr (type, value_as_long (arg));
8976 /* True if TYPE appears to be an Ada character type.
8977 [At the moment, this is true only for Character and Wide_Character;
8978 It is a heuristic test that could stand improvement]. */
8981 ada_is_character_type (struct type *type)
8985 /* If the type code says it's a character, then assume it really is,
8986 and don't check any further. */
8987 if (type->code () == TYPE_CODE_CHAR)
8990 /* Otherwise, assume it's a character type iff it is a discrete type
8991 with a known character type name. */
8992 name = ada_type_name (type);
8993 return (name != NULL
8994 && (type->code () == TYPE_CODE_INT
8995 || type->code () == TYPE_CODE_RANGE)
8996 && (strcmp (name, "character") == 0
8997 || strcmp (name, "wide_character") == 0
8998 || strcmp (name, "wide_wide_character") == 0
8999 || strcmp (name, "unsigned char") == 0));
9002 /* True if TYPE appears to be an Ada string type. */
9005 ada_is_string_type (struct type *type)
9007 type = ada_check_typedef (type);
9009 && type->code () != TYPE_CODE_PTR
9010 && (ada_is_simple_array_type (type)
9011 || ada_is_array_descriptor_type (type))
9012 && ada_array_arity (type) == 1)
9014 struct type *elttype = ada_array_element_type (type, 1);
9016 return ada_is_character_type (elttype);
9022 /* The compiler sometimes provides a parallel XVS type for a given
9023 PAD type. Normally, it is safe to follow the PAD type directly,
9024 but older versions of the compiler have a bug that causes the offset
9025 of its "F" field to be wrong. Following that field in that case
9026 would lead to incorrect results, but this can be worked around
9027 by ignoring the PAD type and using the associated XVS type instead.
9029 Set to True if the debugger should trust the contents of PAD types.
9030 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9031 static bool trust_pad_over_xvs = true;
9033 /* True if TYPE is a struct type introduced by the compiler to force the
9034 alignment of a value. Such types have a single field with a
9035 distinctive name. */
9038 ada_is_aligner_type (struct type *type)
9040 type = ada_check_typedef (type);
9042 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9045 return (type->code () == TYPE_CODE_STRUCT
9046 && type->num_fields () == 1
9047 && strcmp (type->field (0).name (), "F") == 0);
9050 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9051 the parallel type. */
9054 ada_get_base_type (struct type *raw_type)
9056 struct type *real_type_namer;
9057 struct type *raw_real_type;
9059 if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9062 if (ada_is_aligner_type (raw_type))
9063 /* The encoding specifies that we should always use the aligner type.
9064 So, even if this aligner type has an associated XVS type, we should
9067 According to the compiler gurus, an XVS type parallel to an aligner
9068 type may exist because of a stabs limitation. In stabs, aligner
9069 types are empty because the field has a variable-sized type, and
9070 thus cannot actually be used as an aligner type. As a result,
9071 we need the associated parallel XVS type to decode the type.
9072 Since the policy in the compiler is to not change the internal
9073 representation based on the debugging info format, we sometimes
9074 end up having a redundant XVS type parallel to the aligner type. */
9077 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9078 if (real_type_namer == NULL
9079 || real_type_namer->code () != TYPE_CODE_STRUCT
9080 || real_type_namer->num_fields () != 1)
9083 if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9085 /* This is an older encoding form where the base type needs to be
9086 looked up by name. We prefer the newer encoding because it is
9088 raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9089 if (raw_real_type == NULL)
9092 return raw_real_type;
9095 /* The field in our XVS type is a reference to the base type. */
9096 return real_type_namer->field (0).type ()->target_type ();
9099 /* The type of value designated by TYPE, with all aligners removed. */
9102 ada_aligned_type (struct type *type)
9104 if (ada_is_aligner_type (type))
9105 return ada_aligned_type (type->field (0).type ());
9107 return ada_get_base_type (type);
9111 /* The address of the aligned value in an object at address VALADDR
9112 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9115 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9117 if (ada_is_aligner_type (type))
9118 return ada_aligned_value_addr
9119 (type->field (0).type (),
9120 valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9127 /* The printed representation of an enumeration literal with encoded
9128 name NAME. The value is good to the next call of ada_enum_name. */
9130 ada_enum_name (const char *name)
9132 static std::string storage;
9135 /* First, unqualify the enumeration name:
9136 1. Search for the last '.' character. If we find one, then skip
9137 all the preceding characters, the unqualified name starts
9138 right after that dot.
9139 2. Otherwise, we may be debugging on a target where the compiler
9140 translates dots into "__". Search forward for double underscores,
9141 but stop searching when we hit an overloading suffix, which is
9142 of the form "__" followed by digits. */
9144 tmp = strrchr (name, '.');
9149 while ((tmp = strstr (name, "__")) != NULL)
9151 if (isdigit (tmp[2]))
9162 if (name[1] == 'U' || name[1] == 'W')
9165 if (name[1] == 'W' && name[2] == 'W')
9167 /* Also handle the QWW case. */
9170 if (sscanf (name + offset, "%x", &v) != 1)
9173 else if (((name[1] >= '0' && name[1] <= '9')
9174 || (name[1] >= 'a' && name[1] <= 'z'))
9177 storage = string_printf ("'%c'", name[1]);
9178 return storage.c_str ();
9183 if (isascii (v) && isprint (v))
9184 storage = string_printf ("'%c'", v);
9185 else if (name[1] == 'U')
9186 storage = string_printf ("'[\"%02x\"]'", v);
9187 else if (name[2] != 'W')
9188 storage = string_printf ("'[\"%04x\"]'", v);
9190 storage = string_printf ("'[\"%06x\"]'", v);
9192 return storage.c_str ();
9196 tmp = strstr (name, "__");
9198 tmp = strstr (name, "$");
9201 storage = std::string (name, tmp - name);
9202 return storage.c_str ();
9209 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9212 static struct value *
9213 unwrap_value (struct value *val)
9215 struct type *type = ada_check_typedef (value_type (val));
9217 if (ada_is_aligner_type (type))
9219 struct value *v = ada_value_struct_elt (val, "F", 0);
9220 struct type *val_type = ada_check_typedef (value_type (v));
9222 if (ada_type_name (val_type) == NULL)
9223 val_type->set_name (ada_type_name (type));
9225 return unwrap_value (v);
9229 struct type *raw_real_type =
9230 ada_check_typedef (ada_get_base_type (type));
9232 /* If there is no parallel XVS or XVE type, then the value is
9233 already unwrapped. Return it without further modification. */
9234 if ((type == raw_real_type)
9235 && ada_find_parallel_type (type, "___XVE") == NULL)
9239 coerce_unspec_val_to_type
9240 (val, ada_to_fixed_type (raw_real_type, 0,
9241 value_address (val),
9246 /* Given two array types T1 and T2, return nonzero iff both arrays
9247 contain the same number of elements. */
9250 ada_same_array_size_p (struct type *t1, struct type *t2)
9252 LONGEST lo1, hi1, lo2, hi2;
9254 /* Get the array bounds in order to verify that the size of
9255 the two arrays match. */
9256 if (!get_array_bounds (t1, &lo1, &hi1)
9257 || !get_array_bounds (t2, &lo2, &hi2))
9258 error (_("unable to determine array bounds"));
9260 /* To make things easier for size comparison, normalize a bit
9261 the case of empty arrays by making sure that the difference
9262 between upper bound and lower bound is always -1. */
9268 return (hi1 - lo1 == hi2 - lo2);
9271 /* Assuming that VAL is an array of integrals, and TYPE represents
9272 an array with the same number of elements, but with wider integral
9273 elements, return an array "casted" to TYPE. In practice, this
9274 means that the returned array is built by casting each element
9275 of the original array into TYPE's (wider) element type. */
9277 static struct value *
9278 ada_promote_array_of_integrals (struct type *type, struct value *val)
9280 struct type *elt_type = type->target_type ();
9284 /* Verify that both val and type are arrays of scalars, and
9285 that the size of val's elements is smaller than the size
9286 of type's element. */
9287 gdb_assert (type->code () == TYPE_CODE_ARRAY);
9288 gdb_assert (is_integral_type (type->target_type ()));
9289 gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9290 gdb_assert (is_integral_type (value_type (val)->target_type ()));
9291 gdb_assert (type->target_type ()->length ()
9292 > value_type (val)->target_type ()->length ());
9294 if (!get_array_bounds (type, &lo, &hi))
9295 error (_("unable to determine array bounds"));
9297 value *res = allocate_value (type);
9298 gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9300 /* Promote each array element. */
9301 for (i = 0; i < hi - lo + 1; i++)
9303 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9304 int elt_len = elt_type->length ();
9306 copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9312 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9313 return the converted value. */
9315 static struct value *
9316 coerce_for_assign (struct type *type, struct value *val)
9318 struct type *type2 = value_type (val);
9323 type2 = ada_check_typedef (type2);
9324 type = ada_check_typedef (type);
9326 if (type2->code () == TYPE_CODE_PTR
9327 && type->code () == TYPE_CODE_ARRAY)
9329 val = ada_value_ind (val);
9330 type2 = value_type (val);
9333 if (type2->code () == TYPE_CODE_ARRAY
9334 && type->code () == TYPE_CODE_ARRAY)
9336 if (!ada_same_array_size_p (type, type2))
9337 error (_("cannot assign arrays of different length"));
9339 if (is_integral_type (type->target_type ())
9340 && is_integral_type (type2->target_type ())
9341 && type2->target_type ()->length () < type->target_type ()->length ())
9343 /* Allow implicit promotion of the array elements to
9345 return ada_promote_array_of_integrals (type, val);
9348 if (type2->target_type ()->length () != type->target_type ()->length ())
9349 error (_("Incompatible types in assignment"));
9350 deprecated_set_value_type (val, type);
9355 static struct value *
9356 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9359 struct type *type1, *type2;
9362 arg1 = coerce_ref (arg1);
9363 arg2 = coerce_ref (arg2);
9364 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9365 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9367 if (type1->code () != TYPE_CODE_INT
9368 || type2->code () != TYPE_CODE_INT)
9369 return value_binop (arg1, arg2, op);
9378 return value_binop (arg1, arg2, op);
9381 v2 = value_as_long (arg2);
9385 if (op == BINOP_MOD)
9387 else if (op == BINOP_DIV)
9391 gdb_assert (op == BINOP_REM);
9395 error (_("second operand of %s must not be zero."), name);
9398 if (type1->is_unsigned () || op == BINOP_MOD)
9399 return value_binop (arg1, arg2, op);
9401 v1 = value_as_long (arg1);
9406 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9407 v += v > 0 ? -1 : 1;
9415 /* Should not reach this point. */
9419 val = allocate_value (type1);
9420 store_unsigned_integer (value_contents_raw (val).data (),
9421 value_type (val)->length (),
9422 type_byte_order (type1), v);
9427 ada_value_equal (struct value *arg1, struct value *arg2)
9429 if (ada_is_direct_array_type (value_type (arg1))
9430 || ada_is_direct_array_type (value_type (arg2)))
9432 struct type *arg1_type, *arg2_type;
9434 /* Automatically dereference any array reference before
9435 we attempt to perform the comparison. */
9436 arg1 = ada_coerce_ref (arg1);
9437 arg2 = ada_coerce_ref (arg2);
9439 arg1 = ada_coerce_to_simple_array (arg1);
9440 arg2 = ada_coerce_to_simple_array (arg2);
9442 arg1_type = ada_check_typedef (value_type (arg1));
9443 arg2_type = ada_check_typedef (value_type (arg2));
9445 if (arg1_type->code () != TYPE_CODE_ARRAY
9446 || arg2_type->code () != TYPE_CODE_ARRAY)
9447 error (_("Attempt to compare array with non-array"));
9448 /* FIXME: The following works only for types whose
9449 representations use all bits (no padding or undefined bits)
9450 and do not have user-defined equality. */
9451 return (arg1_type->length () == arg2_type->length ()
9452 && memcmp (value_contents (arg1).data (),
9453 value_contents (arg2).data (),
9454 arg1_type->length ()) == 0);
9456 return value_equal (arg1, arg2);
9463 check_objfile (const std::unique_ptr<ada_component> &comp,
9464 struct objfile *objfile)
9466 return comp->uses_objfile (objfile);
9469 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9470 component of LHS (a simple array or a record). Does not modify the
9471 inferior's memory, nor does it modify LHS (unless LHS ==
9475 assign_component (struct value *container, struct value *lhs, LONGEST index,
9476 struct expression *exp, operation_up &arg)
9478 scoped_value_mark mark;
9481 struct type *lhs_type = check_typedef (value_type (lhs));
9483 if (lhs_type->code () == TYPE_CODE_ARRAY)
9485 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9486 struct value *index_val = value_from_longest (index_type, index);
9488 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9492 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9493 elt = ada_to_fixed_value (elt);
9496 ada_aggregate_operation *ag_op
9497 = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9498 if (ag_op != nullptr)
9499 ag_op->assign_aggregate (container, elt, exp);
9501 value_assign_to_component (container, elt,
9502 arg->evaluate (nullptr, exp,
9507 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9509 for (const auto &item : m_components)
9510 if (item->uses_objfile (objfile))
9516 ada_aggregate_component::dump (ui_file *stream, int depth)
9518 gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9519 for (const auto &item : m_components)
9520 item->dump (stream, depth + 1);
9524 ada_aggregate_component::assign (struct value *container,
9525 struct value *lhs, struct expression *exp,
9526 std::vector<LONGEST> &indices,
9527 LONGEST low, LONGEST high)
9529 for (auto &item : m_components)
9530 item->assign (container, lhs, exp, indices, low, high);
9533 /* See ada-exp.h. */
9536 ada_aggregate_operation::assign_aggregate (struct value *container,
9538 struct expression *exp)
9540 struct type *lhs_type;
9541 LONGEST low_index, high_index;
9543 container = ada_coerce_ref (container);
9544 if (ada_is_direct_array_type (value_type (container)))
9545 container = ada_coerce_to_simple_array (container);
9546 lhs = ada_coerce_ref (lhs);
9547 if (!deprecated_value_modifiable (lhs))
9548 error (_("Left operand of assignment is not a modifiable lvalue."));
9550 lhs_type = check_typedef (value_type (lhs));
9551 if (ada_is_direct_array_type (lhs_type))
9553 lhs = ada_coerce_to_simple_array (lhs);
9554 lhs_type = check_typedef (value_type (lhs));
9555 low_index = lhs_type->bounds ()->low.const_val ();
9556 high_index = lhs_type->bounds ()->high.const_val ();
9558 else if (lhs_type->code () == TYPE_CODE_STRUCT)
9561 high_index = num_visible_fields (lhs_type) - 1;
9564 error (_("Left-hand side must be array or record."));
9566 std::vector<LONGEST> indices (4);
9567 indices[0] = indices[1] = low_index - 1;
9568 indices[2] = indices[3] = high_index + 1;
9570 std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9571 low_index, high_index);
9577 ada_positional_component::uses_objfile (struct objfile *objfile)
9579 return m_op->uses_objfile (objfile);
9583 ada_positional_component::dump (ui_file *stream, int depth)
9585 gdb_printf (stream, _("%*sPositional, index = %d\n"),
9586 depth, "", m_index);
9587 m_op->dump (stream, depth + 1);
9590 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9591 construct, given that the positions are relative to lower bound
9592 LOW, where HIGH is the upper bound. Record the position in
9593 INDICES. CONTAINER is as for assign_aggregate. */
9595 ada_positional_component::assign (struct value *container,
9596 struct value *lhs, struct expression *exp,
9597 std::vector<LONGEST> &indices,
9598 LONGEST low, LONGEST high)
9600 LONGEST ind = m_index + low;
9602 if (ind - 1 == high)
9603 warning (_("Extra components in aggregate ignored."));
9606 add_component_interval (ind, ind, indices);
9607 assign_component (container, lhs, ind, exp, m_op);
9612 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9614 return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9618 ada_discrete_range_association::dump (ui_file *stream, int depth)
9620 gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9621 m_low->dump (stream, depth + 1);
9622 m_high->dump (stream, depth + 1);
9626 ada_discrete_range_association::assign (struct value *container,
9628 struct expression *exp,
9629 std::vector<LONGEST> &indices,
9630 LONGEST low, LONGEST high,
9633 LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9634 LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9636 if (lower <= upper && (lower < low || upper > high))
9637 error (_("Index in component association out of bounds."));
9639 add_component_interval (lower, upper, indices);
9640 while (lower <= upper)
9642 assign_component (container, lhs, lower, exp, op);
9648 ada_name_association::uses_objfile (struct objfile *objfile)
9650 return m_val->uses_objfile (objfile);
9654 ada_name_association::dump (ui_file *stream, int depth)
9656 gdb_printf (stream, _("%*sName:\n"), depth, "");
9657 m_val->dump (stream, depth + 1);
9661 ada_name_association::assign (struct value *container,
9663 struct expression *exp,
9664 std::vector<LONGEST> &indices,
9665 LONGEST low, LONGEST high,
9670 if (ada_is_direct_array_type (value_type (lhs)))
9671 index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9675 ada_string_operation *strop
9676 = dynamic_cast<ada_string_operation *> (m_val.get ());
9679 if (strop != nullptr)
9680 name = strop->get_name ();
9683 ada_var_value_operation *vvo
9684 = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9686 error (_("Invalid record component association."));
9687 name = vvo->get_symbol ()->natural_name ();
9691 if (! find_struct_field (name, value_type (lhs), 0,
9692 NULL, NULL, NULL, NULL, &index))
9693 error (_("Unknown component name: %s."), name);
9696 add_component_interval (index, index, indices);
9697 assign_component (container, lhs, index, exp, op);
9701 ada_choices_component::uses_objfile (struct objfile *objfile)
9703 if (m_op->uses_objfile (objfile))
9705 for (const auto &item : m_assocs)
9706 if (item->uses_objfile (objfile))
9712 ada_choices_component::dump (ui_file *stream, int depth)
9714 gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9715 m_op->dump (stream, depth + 1);
9716 for (const auto &item : m_assocs)
9717 item->dump (stream, depth + 1);
9720 /* Assign into the components of LHS indexed by the OP_CHOICES
9721 construct at *POS, updating *POS past the construct, given that
9722 the allowable indices are LOW..HIGH. Record the indices assigned
9723 to in INDICES. CONTAINER is as for assign_aggregate. */
9725 ada_choices_component::assign (struct value *container,
9726 struct value *lhs, struct expression *exp,
9727 std::vector<LONGEST> &indices,
9728 LONGEST low, LONGEST high)
9730 for (auto &item : m_assocs)
9731 item->assign (container, lhs, exp, indices, low, high, m_op);
9735 ada_others_component::uses_objfile (struct objfile *objfile)
9737 return m_op->uses_objfile (objfile);
9741 ada_others_component::dump (ui_file *stream, int depth)
9743 gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9744 m_op->dump (stream, depth + 1);
9747 /* Assign the value of the expression in the OP_OTHERS construct in
9748 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9749 have not been previously assigned. The index intervals already assigned
9750 are in INDICES. CONTAINER is as for assign_aggregate. */
9752 ada_others_component::assign (struct value *container,
9753 struct value *lhs, struct expression *exp,
9754 std::vector<LONGEST> &indices,
9755 LONGEST low, LONGEST high)
9757 int num_indices = indices.size ();
9758 for (int i = 0; i < num_indices - 2; i += 2)
9760 for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9761 assign_component (container, lhs, ind, exp, m_op);
9766 ada_assign_operation::evaluate (struct type *expect_type,
9767 struct expression *exp,
9770 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9772 ada_aggregate_operation *ag_op
9773 = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9774 if (ag_op != nullptr)
9776 if (noside != EVAL_NORMAL)
9779 arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9780 return ada_value_assign (arg1, arg1);
9782 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9783 except if the lhs of our assignment is a convenience variable.
9784 In the case of assigning to a convenience variable, the lhs
9785 should be exactly the result of the evaluation of the rhs. */
9786 struct type *type = value_type (arg1);
9787 if (VALUE_LVAL (arg1) == lval_internalvar)
9789 value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9790 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9792 if (VALUE_LVAL (arg1) == lval_internalvar)
9797 arg2 = coerce_for_assign (value_type (arg1), arg2);
9798 return ada_value_assign (arg1, arg2);
9801 } /* namespace expr */
9803 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9804 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9807 add_component_interval (LONGEST low, LONGEST high,
9808 std::vector<LONGEST> &indices)
9812 int size = indices.size ();
9813 for (i = 0; i < size; i += 2) {
9814 if (high >= indices[i] && low <= indices[i + 1])
9818 for (kh = i + 2; kh < size; kh += 2)
9819 if (high < indices[kh])
9821 if (low < indices[i])
9823 indices[i + 1] = indices[kh - 1];
9824 if (high > indices[i + 1])
9825 indices[i + 1] = high;
9826 memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9827 indices.resize (kh - i - 2);
9830 else if (high < indices[i])
9834 indices.resize (indices.size () + 2);
9835 for (j = indices.size () - 1; j >= i + 2; j -= 1)
9836 indices[j] = indices[j - 2];
9838 indices[i + 1] = high;
9841 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9844 static struct value *
9845 ada_value_cast (struct type *type, struct value *arg2)
9847 if (type == ada_check_typedef (value_type (arg2)))
9850 return value_cast (type, arg2);
9853 /* Evaluating Ada expressions, and printing their result.
9854 ------------------------------------------------------
9859 We usually evaluate an Ada expression in order to print its value.
9860 We also evaluate an expression in order to print its type, which
9861 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9862 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9863 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9864 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9867 Evaluating expressions is a little more complicated for Ada entities
9868 than it is for entities in languages such as C. The main reason for
9869 this is that Ada provides types whose definition might be dynamic.
9870 One example of such types is variant records. Or another example
9871 would be an array whose bounds can only be known at run time.
9873 The following description is a general guide as to what should be
9874 done (and what should NOT be done) in order to evaluate an expression
9875 involving such types, and when. This does not cover how the semantic
9876 information is encoded by GNAT as this is covered separatly. For the
9877 document used as the reference for the GNAT encoding, see exp_dbug.ads
9878 in the GNAT sources.
9880 Ideally, we should embed each part of this description next to its
9881 associated code. Unfortunately, the amount of code is so vast right
9882 now that it's hard to see whether the code handling a particular
9883 situation might be duplicated or not. One day, when the code is
9884 cleaned up, this guide might become redundant with the comments
9885 inserted in the code, and we might want to remove it.
9887 2. ``Fixing'' an Entity, the Simple Case:
9888 -----------------------------------------
9890 When evaluating Ada expressions, the tricky issue is that they may
9891 reference entities whose type contents and size are not statically
9892 known. Consider for instance a variant record:
9894 type Rec (Empty : Boolean := True) is record
9897 when False => Value : Integer;
9900 Yes : Rec := (Empty => False, Value => 1);
9901 No : Rec := (empty => True);
9903 The size and contents of that record depends on the value of the
9904 descriminant (Rec.Empty). At this point, neither the debugging
9905 information nor the associated type structure in GDB are able to
9906 express such dynamic types. So what the debugger does is to create
9907 "fixed" versions of the type that applies to the specific object.
9908 We also informally refer to this operation as "fixing" an object,
9909 which means creating its associated fixed type.
9911 Example: when printing the value of variable "Yes" above, its fixed
9912 type would look like this:
9919 On the other hand, if we printed the value of "No", its fixed type
9926 Things become a little more complicated when trying to fix an entity
9927 with a dynamic type that directly contains another dynamic type,
9928 such as an array of variant records, for instance. There are
9929 two possible cases: Arrays, and records.
9931 3. ``Fixing'' Arrays:
9932 ---------------------
9934 The type structure in GDB describes an array in terms of its bounds,
9935 and the type of its elements. By design, all elements in the array
9936 have the same type and we cannot represent an array of variant elements
9937 using the current type structure in GDB. When fixing an array,
9938 we cannot fix the array element, as we would potentially need one
9939 fixed type per element of the array. As a result, the best we can do
9940 when fixing an array is to produce an array whose bounds and size
9941 are correct (allowing us to read it from memory), but without having
9942 touched its element type. Fixing each element will be done later,
9943 when (if) necessary.
9945 Arrays are a little simpler to handle than records, because the same
9946 amount of memory is allocated for each element of the array, even if
9947 the amount of space actually used by each element differs from element
9948 to element. Consider for instance the following array of type Rec:
9950 type Rec_Array is array (1 .. 2) of Rec;
9952 The actual amount of memory occupied by each element might be different
9953 from element to element, depending on the value of their discriminant.
9954 But the amount of space reserved for each element in the array remains
9955 fixed regardless. So we simply need to compute that size using
9956 the debugging information available, from which we can then determine
9957 the array size (we multiply the number of elements of the array by
9958 the size of each element).
9960 The simplest case is when we have an array of a constrained element
9961 type. For instance, consider the following type declarations:
9963 type Bounded_String (Max_Size : Integer) is
9965 Buffer : String (1 .. Max_Size);
9967 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9969 In this case, the compiler describes the array as an array of
9970 variable-size elements (identified by its XVS suffix) for which
9971 the size can be read in the parallel XVZ variable.
9973 In the case of an array of an unconstrained element type, the compiler
9974 wraps the array element inside a private PAD type. This type should not
9975 be shown to the user, and must be "unwrap"'ed before printing. Note
9976 that we also use the adjective "aligner" in our code to designate
9977 these wrapper types.
9979 In some cases, the size allocated for each element is statically
9980 known. In that case, the PAD type already has the correct size,
9981 and the array element should remain unfixed.
9983 But there are cases when this size is not statically known.
9984 For instance, assuming that "Five" is an integer variable:
9986 type Dynamic is array (1 .. Five) of Integer;
9987 type Wrapper (Has_Length : Boolean := False) is record
9990 when True => Length : Integer;
9994 type Wrapper_Array is array (1 .. 2) of Wrapper;
9996 Hello : Wrapper_Array := (others => (Has_Length => True,
9997 Data => (others => 17),
10001 The debugging info would describe variable Hello as being an
10002 array of a PAD type. The size of that PAD type is not statically
10003 known, but can be determined using a parallel XVZ variable.
10004 In that case, a copy of the PAD type with the correct size should
10005 be used for the fixed array.
10007 3. ``Fixing'' record type objects:
10008 ----------------------------------
10010 Things are slightly different from arrays in the case of dynamic
10011 record types. In this case, in order to compute the associated
10012 fixed type, we need to determine the size and offset of each of
10013 its components. This, in turn, requires us to compute the fixed
10014 type of each of these components.
10016 Consider for instance the example:
10018 type Bounded_String (Max_Size : Natural) is record
10019 Str : String (1 .. Max_Size);
10022 My_String : Bounded_String (Max_Size => 10);
10024 In that case, the position of field "Length" depends on the size
10025 of field Str, which itself depends on the value of the Max_Size
10026 discriminant. In order to fix the type of variable My_String,
10027 we need to fix the type of field Str. Therefore, fixing a variant
10028 record requires us to fix each of its components.
10030 However, if a component does not have a dynamic size, the component
10031 should not be fixed. In particular, fields that use a PAD type
10032 should not fixed. Here is an example where this might happen
10033 (assuming type Rec above):
10035 type Container (Big : Boolean) is record
10039 when True => Another : Integer;
10040 when False => null;
10043 My_Container : Container := (Big => False,
10044 First => (Empty => True),
10047 In that example, the compiler creates a PAD type for component First,
10048 whose size is constant, and then positions the component After just
10049 right after it. The offset of component After is therefore constant
10052 The debugger computes the position of each field based on an algorithm
10053 that uses, among other things, the actual position and size of the field
10054 preceding it. Let's now imagine that the user is trying to print
10055 the value of My_Container. If the type fixing was recursive, we would
10056 end up computing the offset of field After based on the size of the
10057 fixed version of field First. And since in our example First has
10058 only one actual field, the size of the fixed type is actually smaller
10059 than the amount of space allocated to that field, and thus we would
10060 compute the wrong offset of field After.
10062 To make things more complicated, we need to watch out for dynamic
10063 components of variant records (identified by the ___XVL suffix in
10064 the component name). Even if the target type is a PAD type, the size
10065 of that type might not be statically known. So the PAD type needs
10066 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10067 we might end up with the wrong size for our component. This can be
10068 observed with the following type declarations:
10070 type Octal is new Integer range 0 .. 7;
10071 type Octal_Array is array (Positive range <>) of Octal;
10072 pragma Pack (Octal_Array);
10074 type Octal_Buffer (Size : Positive) is record
10075 Buffer : Octal_Array (1 .. Size);
10079 In that case, Buffer is a PAD type whose size is unset and needs
10080 to be computed by fixing the unwrapped type.
10082 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10083 ----------------------------------------------------------
10085 Lastly, when should the sub-elements of an entity that remained unfixed
10086 thus far, be actually fixed?
10088 The answer is: Only when referencing that element. For instance
10089 when selecting one component of a record, this specific component
10090 should be fixed at that point in time. Or when printing the value
10091 of a record, each component should be fixed before its value gets
10092 printed. Similarly for arrays, the element of the array should be
10093 fixed when printing each element of the array, or when extracting
10094 one element out of that array. On the other hand, fixing should
10095 not be performed on the elements when taking a slice of an array!
10097 Note that one of the side effects of miscomputing the offset and
10098 size of each field is that we end up also miscomputing the size
10099 of the containing type. This can have adverse results when computing
10100 the value of an entity. GDB fetches the value of an entity based
10101 on the size of its type, and thus a wrong size causes GDB to fetch
10102 the wrong amount of memory. In the case where the computed size is
10103 too small, GDB fetches too little data to print the value of our
10104 entity. Results in this case are unpredictable, as we usually read
10105 past the buffer containing the data =:-o. */
10107 /* A helper function for TERNOP_IN_RANGE. */
10110 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10111 enum noside noside,
10112 value *arg1, value *arg2, value *arg3)
10114 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10115 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10116 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10118 value_from_longest (type,
10119 (value_less (arg1, arg3)
10120 || value_equal (arg1, arg3))
10121 && (value_less (arg2, arg1)
10122 || value_equal (arg2, arg1)));
10125 /* A helper function for UNOP_NEG. */
10128 ada_unop_neg (struct type *expect_type,
10129 struct expression *exp,
10130 enum noside noside, enum exp_opcode op,
10131 struct value *arg1)
10133 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10134 return value_neg (arg1);
10137 /* A helper function for UNOP_IN_RANGE. */
10140 ada_unop_in_range (struct type *expect_type,
10141 struct expression *exp,
10142 enum noside noside, enum exp_opcode op,
10143 struct value *arg1, struct type *type)
10145 struct value *arg2, *arg3;
10146 switch (type->code ())
10149 lim_warning (_("Membership test incompletely implemented; "
10150 "always returns true"));
10151 type = language_bool_type (exp->language_defn, exp->gdbarch);
10152 return value_from_longest (type, (LONGEST) 1);
10154 case TYPE_CODE_RANGE:
10155 arg2 = value_from_longest (type,
10156 type->bounds ()->low.const_val ());
10157 arg3 = value_from_longest (type,
10158 type->bounds ()->high.const_val ());
10159 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10160 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10161 type = language_bool_type (exp->language_defn, exp->gdbarch);
10163 value_from_longest (type,
10164 (value_less (arg1, arg3)
10165 || value_equal (arg1, arg3))
10166 && (value_less (arg2, arg1)
10167 || value_equal (arg2, arg1)));
10171 /* A helper function for OP_ATR_TAG. */
10174 ada_atr_tag (struct type *expect_type,
10175 struct expression *exp,
10176 enum noside noside, enum exp_opcode op,
10177 struct value *arg1)
10179 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10180 return value_zero (ada_tag_type (arg1), not_lval);
10182 return ada_value_tag (arg1);
10185 /* A helper function for OP_ATR_SIZE. */
10188 ada_atr_size (struct type *expect_type,
10189 struct expression *exp,
10190 enum noside noside, enum exp_opcode op,
10191 struct value *arg1)
10193 struct type *type = value_type (arg1);
10195 /* If the argument is a reference, then dereference its type, since
10196 the user is really asking for the size of the actual object,
10197 not the size of the pointer. */
10198 if (type->code () == TYPE_CODE_REF)
10199 type = type->target_type ();
10201 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10202 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10204 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10205 TARGET_CHAR_BIT * type->length ());
10208 /* A helper function for UNOP_ABS. */
10211 ada_abs (struct type *expect_type,
10212 struct expression *exp,
10213 enum noside noside, enum exp_opcode op,
10214 struct value *arg1)
10216 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10217 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10218 return value_neg (arg1);
10223 /* A helper function for BINOP_MUL. */
10226 ada_mult_binop (struct type *expect_type,
10227 struct expression *exp,
10228 enum noside noside, enum exp_opcode op,
10229 struct value *arg1, struct value *arg2)
10231 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10233 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10234 return value_zero (value_type (arg1), not_lval);
10238 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10239 return ada_value_binop (arg1, arg2, op);
10243 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10246 ada_equal_binop (struct type *expect_type,
10247 struct expression *exp,
10248 enum noside noside, enum exp_opcode op,
10249 struct value *arg1, struct value *arg2)
10252 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10256 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10257 tem = ada_value_equal (arg1, arg2);
10259 if (op == BINOP_NOTEQUAL)
10261 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10262 return value_from_longest (type, (LONGEST) tem);
10265 /* A helper function for TERNOP_SLICE. */
10268 ada_ternop_slice (struct expression *exp,
10269 enum noside noside,
10270 struct value *array, struct value *low_bound_val,
10271 struct value *high_bound_val)
10274 LONGEST high_bound;
10276 low_bound_val = coerce_ref (low_bound_val);
10277 high_bound_val = coerce_ref (high_bound_val);
10278 low_bound = value_as_long (low_bound_val);
10279 high_bound = value_as_long (high_bound_val);
10281 /* If this is a reference to an aligner type, then remove all
10283 if (value_type (array)->code () == TYPE_CODE_REF
10284 && ada_is_aligner_type (value_type (array)->target_type ()))
10285 value_type (array)->set_target_type
10286 (ada_aligned_type (value_type (array)->target_type ()));
10288 if (ada_is_any_packed_array_type (value_type (array)))
10289 error (_("cannot slice a packed array"));
10291 /* If this is a reference to an array or an array lvalue,
10292 convert to a pointer. */
10293 if (value_type (array)->code () == TYPE_CODE_REF
10294 || (value_type (array)->code () == TYPE_CODE_ARRAY
10295 && VALUE_LVAL (array) == lval_memory))
10296 array = value_addr (array);
10298 if (noside == EVAL_AVOID_SIDE_EFFECTS
10299 && ada_is_array_descriptor_type (ada_check_typedef
10300 (value_type (array))))
10301 return empty_array (ada_type_of_array (array, 0), low_bound,
10304 array = ada_coerce_to_simple_array_ptr (array);
10306 /* If we have more than one level of pointer indirection,
10307 dereference the value until we get only one level. */
10308 while (value_type (array)->code () == TYPE_CODE_PTR
10309 && (value_type (array)->target_type ()->code ()
10311 array = value_ind (array);
10313 /* Make sure we really do have an array type before going further,
10314 to avoid a SEGV when trying to get the index type or the target
10315 type later down the road if the debug info generated by
10316 the compiler is incorrect or incomplete. */
10317 if (!ada_is_simple_array_type (value_type (array)))
10318 error (_("cannot take slice of non-array"));
10320 if (ada_check_typedef (value_type (array))->code ()
10323 struct type *type0 = ada_check_typedef (value_type (array));
10325 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10326 return empty_array (type0->target_type (), low_bound, high_bound);
10329 struct type *arr_type0 =
10330 to_fixed_array_type (type0->target_type (), NULL, 1);
10332 return ada_value_slice_from_ptr (array, arr_type0,
10333 longest_to_int (low_bound),
10334 longest_to_int (high_bound));
10337 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10339 else if (high_bound < low_bound)
10340 return empty_array (value_type (array), low_bound, high_bound);
10342 return ada_value_slice (array, longest_to_int (low_bound),
10343 longest_to_int (high_bound));
10346 /* A helper function for BINOP_IN_BOUNDS. */
10349 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10350 struct value *arg1, struct value *arg2, int n)
10352 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10354 struct type *type = language_bool_type (exp->language_defn,
10356 return value_zero (type, not_lval);
10359 struct type *type = ada_index_type (value_type (arg2), n, "range");
10361 type = value_type (arg1);
10363 value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10364 arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10366 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10367 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10368 type = language_bool_type (exp->language_defn, exp->gdbarch);
10369 return value_from_longest (type,
10370 (value_less (arg1, arg3)
10371 || value_equal (arg1, arg3))
10372 && (value_less (arg2, arg1)
10373 || value_equal (arg2, arg1)));
10376 /* A helper function for some attribute operations. */
10379 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10380 struct value *arg1, struct type *type_arg, int tem)
10382 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10384 if (type_arg == NULL)
10385 type_arg = value_type (arg1);
10387 if (ada_is_constrained_packed_array_type (type_arg))
10388 type_arg = decode_constrained_packed_array_type (type_arg);
10390 if (!discrete_type_p (type_arg))
10394 default: /* Should never happen. */
10395 error (_("unexpected attribute encountered"));
10398 type_arg = ada_index_type (type_arg, tem,
10399 ada_attribute_name (op));
10401 case OP_ATR_LENGTH:
10402 type_arg = builtin_type (exp->gdbarch)->builtin_int;
10407 return value_zero (type_arg, not_lval);
10409 else if (type_arg == NULL)
10411 arg1 = ada_coerce_ref (arg1);
10413 if (ada_is_constrained_packed_array_type (value_type (arg1)))
10414 arg1 = ada_coerce_to_simple_array (arg1);
10417 if (op == OP_ATR_LENGTH)
10418 type = builtin_type (exp->gdbarch)->builtin_int;
10421 type = ada_index_type (value_type (arg1), tem,
10422 ada_attribute_name (op));
10424 type = builtin_type (exp->gdbarch)->builtin_int;
10429 default: /* Should never happen. */
10430 error (_("unexpected attribute encountered"));
10432 return value_from_longest
10433 (type, ada_array_bound (arg1, tem, 0));
10435 return value_from_longest
10436 (type, ada_array_bound (arg1, tem, 1));
10437 case OP_ATR_LENGTH:
10438 return value_from_longest
10439 (type, ada_array_length (arg1, tem));
10442 else if (discrete_type_p (type_arg))
10444 struct type *range_type;
10445 const char *name = ada_type_name (type_arg);
10448 if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10449 range_type = to_fixed_range_type (type_arg, NULL);
10450 if (range_type == NULL)
10451 range_type = type_arg;
10455 error (_("unexpected attribute encountered"));
10457 return value_from_longest
10458 (range_type, ada_discrete_type_low_bound (range_type));
10460 return value_from_longest
10461 (range_type, ada_discrete_type_high_bound (range_type));
10462 case OP_ATR_LENGTH:
10463 error (_("the 'length attribute applies only to array types"));
10466 else if (type_arg->code () == TYPE_CODE_FLT)
10467 error (_("unimplemented type attribute"));
10472 if (ada_is_constrained_packed_array_type (type_arg))
10473 type_arg = decode_constrained_packed_array_type (type_arg);
10476 if (op == OP_ATR_LENGTH)
10477 type = builtin_type (exp->gdbarch)->builtin_int;
10480 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10482 type = builtin_type (exp->gdbarch)->builtin_int;
10488 error (_("unexpected attribute encountered"));
10490 low = ada_array_bound_from_type (type_arg, tem, 0);
10491 return value_from_longest (type, low);
10493 high = ada_array_bound_from_type (type_arg, tem, 1);
10494 return value_from_longest (type, high);
10495 case OP_ATR_LENGTH:
10496 low = ada_array_bound_from_type (type_arg, tem, 0);
10497 high = ada_array_bound_from_type (type_arg, tem, 1);
10498 return value_from_longest (type, high - low + 1);
10503 /* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
10506 ada_binop_minmax (struct type *expect_type,
10507 struct expression *exp,
10508 enum noside noside, enum exp_opcode op,
10509 struct value *arg1, struct value *arg2)
10511 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10512 return value_zero (value_type (arg1), not_lval);
10515 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10516 return value_binop (arg1, arg2, op);
10520 /* A helper function for BINOP_EXP. */
10523 ada_binop_exp (struct type *expect_type,
10524 struct expression *exp,
10525 enum noside noside, enum exp_opcode op,
10526 struct value *arg1, struct value *arg2)
10528 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10529 return value_zero (value_type (arg1), not_lval);
10532 /* For integer exponentiation operations,
10533 only promote the first argument. */
10534 if (is_integral_type (value_type (arg2)))
10535 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10537 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10539 return value_binop (arg1, arg2, op);
10546 /* See ada-exp.h. */
10549 ada_resolvable::replace (operation_up &&owner,
10550 struct expression *exp,
10551 bool deprocedure_p,
10552 bool parse_completion,
10553 innermost_block_tracker *tracker,
10554 struct type *context_type)
10556 if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10557 return (make_operation<ada_funcall_operation>
10558 (std::move (owner),
10559 std::vector<operation_up> ()));
10560 return std::move (owner);
10563 /* Convert the character literal whose value would be VAL to the
10564 appropriate value of type TYPE, if there is a translation.
10565 Otherwise return VAL. Hence, in an enumeration type ('A', 'B'),
10566 the literal 'A' (VAL == 65), returns 0. */
10569 convert_char_literal (struct type *type, LONGEST val)
10576 type = check_typedef (type);
10577 if (type->code () != TYPE_CODE_ENUM)
10580 if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10581 xsnprintf (name, sizeof (name), "Q%c", (int) val);
10582 else if (val >= 0 && val < 256)
10583 xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10584 else if (val >= 0 && val < 0x10000)
10585 xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10587 xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10588 size_t len = strlen (name);
10589 for (f = 0; f < type->num_fields (); f += 1)
10591 /* Check the suffix because an enum constant in a package will
10592 have a name like "pkg__QUxx". This is safe enough because we
10593 already have the correct type, and because mangling means
10594 there can't be clashes. */
10595 const char *ename = type->field (f).name ();
10596 size_t elen = strlen (ename);
10598 if (elen >= len && strcmp (name, ename + elen - len) == 0)
10599 return type->field (f).loc_enumval ();
10605 ada_char_operation::evaluate (struct type *expect_type,
10606 struct expression *exp,
10607 enum noside noside)
10609 value *result = long_const_operation::evaluate (expect_type, exp, noside);
10610 if (expect_type != nullptr)
10611 result = ada_value_cast (expect_type, result);
10615 /* See ada-exp.h. */
10618 ada_char_operation::replace (operation_up &&owner,
10619 struct expression *exp,
10620 bool deprocedure_p,
10621 bool parse_completion,
10622 innermost_block_tracker *tracker,
10623 struct type *context_type)
10625 operation_up result = std::move (owner);
10627 if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10629 gdb_assert (result.get () == this);
10630 std::get<0> (m_storage) = context_type;
10631 std::get<1> (m_storage)
10632 = convert_char_literal (context_type, std::get<1> (m_storage));
10639 ada_wrapped_operation::evaluate (struct type *expect_type,
10640 struct expression *exp,
10641 enum noside noside)
10643 value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10644 if (noside == EVAL_NORMAL)
10645 result = unwrap_value (result);
10647 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10648 then we need to perform the conversion manually, because
10649 evaluate_subexp_standard doesn't do it. This conversion is
10650 necessary in Ada because the different kinds of float/fixed
10651 types in Ada have different representations.
10653 Similarly, we need to perform the conversion from OP_LONG
10655 if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10656 result = ada_value_cast (expect_type, result);
10662 ada_string_operation::evaluate (struct type *expect_type,
10663 struct expression *exp,
10664 enum noside noside)
10666 struct type *char_type;
10667 if (expect_type != nullptr && ada_is_string_type (expect_type))
10668 char_type = ada_array_element_type (expect_type, 1);
10670 char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10672 const std::string &str = std::get<0> (m_storage);
10673 const char *encoding;
10674 switch (char_type->length ())
10678 /* Simply copy over the data -- this isn't perhaps strictly
10679 correct according to the encodings, but it is gdb's
10680 historical behavior. */
10681 struct type *stringtype
10682 = lookup_array_range_type (char_type, 1, str.length ());
10683 struct value *val = allocate_value (stringtype);
10684 memcpy (value_contents_raw (val).data (), str.c_str (),
10690 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10691 encoding = "UTF-16BE";
10693 encoding = "UTF-16LE";
10697 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10698 encoding = "UTF-32BE";
10700 encoding = "UTF-32LE";
10704 error (_("unexpected character type size %s"),
10705 pulongest (char_type->length ()));
10708 auto_obstack converted;
10709 convert_between_encodings (host_charset (), encoding,
10710 (const gdb_byte *) str.c_str (),
10712 &converted, translit_none);
10714 struct type *stringtype
10715 = lookup_array_range_type (char_type, 1,
10716 obstack_object_size (&converted)
10717 / char_type->length ());
10718 struct value *val = allocate_value (stringtype);
10719 memcpy (value_contents_raw (val).data (),
10720 obstack_base (&converted),
10721 obstack_object_size (&converted));
10726 ada_concat_operation::evaluate (struct type *expect_type,
10727 struct expression *exp,
10728 enum noside noside)
10730 /* If one side is a literal, evaluate the other side first so that
10731 the expected type can be set properly. */
10732 const operation_up &lhs_expr = std::get<0> (m_storage);
10733 const operation_up &rhs_expr = std::get<1> (m_storage);
10736 if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10738 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10739 lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10741 else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10743 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10744 struct type *rhs_type = check_typedef (value_type (rhs));
10745 struct type *elt_type = nullptr;
10746 if (rhs_type->code () == TYPE_CODE_ARRAY)
10747 elt_type = rhs_type->target_type ();
10748 lhs = lhs_expr->evaluate (elt_type, exp, noside);
10750 else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10752 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10753 rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10755 else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10757 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10758 struct type *lhs_type = check_typedef (value_type (lhs));
10759 struct type *elt_type = nullptr;
10760 if (lhs_type->code () == TYPE_CODE_ARRAY)
10761 elt_type = lhs_type->target_type ();
10762 rhs = rhs_expr->evaluate (elt_type, exp, noside);
10765 return concat_operation::evaluate (expect_type, exp, noside);
10767 return value_concat (lhs, rhs);
10771 ada_qual_operation::evaluate (struct type *expect_type,
10772 struct expression *exp,
10773 enum noside noside)
10775 struct type *type = std::get<1> (m_storage);
10776 return std::get<0> (m_storage)->evaluate (type, exp, noside);
10780 ada_ternop_range_operation::evaluate (struct type *expect_type,
10781 struct expression *exp,
10782 enum noside noside)
10784 value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10785 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10786 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10787 return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10791 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10792 struct expression *exp,
10793 enum noside noside)
10795 value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10796 value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10798 auto do_op = [=] (LONGEST x, LONGEST y)
10800 if (std::get<0> (m_storage) == BINOP_ADD)
10805 if (value_type (arg1)->code () == TYPE_CODE_PTR)
10806 return (value_from_longest
10807 (value_type (arg1),
10808 do_op (value_as_long (arg1), value_as_long (arg2))));
10809 if (value_type (arg2)->code () == TYPE_CODE_PTR)
10810 return (value_from_longest
10811 (value_type (arg2),
10812 do_op (value_as_long (arg1), value_as_long (arg2))));
10813 /* Preserve the original type for use by the range case below.
10814 We cannot cast the result to a reference type, so if ARG1 is
10815 a reference type, find its underlying type. */
10816 struct type *type = value_type (arg1);
10817 while (type->code () == TYPE_CODE_REF)
10818 type = type->target_type ();
10819 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10820 arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10821 /* We need to special-case the result with a range.
10822 This is done for the benefit of "ptype". gdb's Ada support
10823 historically used the LHS to set the result type here, so
10824 preserve this behavior. */
10825 if (type->code () == TYPE_CODE_RANGE)
10826 arg1 = value_cast (type, arg1);
10831 ada_unop_atr_operation::evaluate (struct type *expect_type,
10832 struct expression *exp,
10833 enum noside noside)
10835 struct type *type_arg = nullptr;
10836 value *val = nullptr;
10838 if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10840 value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10841 EVAL_AVOID_SIDE_EFFECTS);
10842 type_arg = value_type (tem);
10845 val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10847 return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10848 val, type_arg, std::get<2> (m_storage));
10852 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10853 struct expression *exp,
10854 enum noside noside)
10856 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10857 return value_zero (expect_type, not_lval);
10859 const bound_minimal_symbol &b = std::get<0> (m_storage);
10860 value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10862 val = ada_value_cast (expect_type, val);
10864 /* Follow the Ada language semantics that do not allow taking
10865 an address of the result of a cast (view conversion in Ada). */
10866 if (VALUE_LVAL (val) == lval_memory)
10868 if (value_lazy (val))
10869 value_fetch_lazy (val);
10870 VALUE_LVAL (val) = not_lval;
10876 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10877 struct expression *exp,
10878 enum noside noside)
10880 value *val = evaluate_var_value (noside,
10881 std::get<0> (m_storage).block,
10882 std::get<0> (m_storage).symbol);
10884 val = ada_value_cast (expect_type, val);
10886 /* Follow the Ada language semantics that do not allow taking
10887 an address of the result of a cast (view conversion in Ada). */
10888 if (VALUE_LVAL (val) == lval_memory)
10890 if (value_lazy (val))
10891 value_fetch_lazy (val);
10892 VALUE_LVAL (val) = not_lval;
10898 ada_var_value_operation::evaluate (struct type *expect_type,
10899 struct expression *exp,
10900 enum noside noside)
10902 symbol *sym = std::get<0> (m_storage).symbol;
10904 if (sym->domain () == UNDEF_DOMAIN)
10905 /* Only encountered when an unresolved symbol occurs in a
10906 context other than a function call, in which case, it is
10908 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10909 sym->print_name ());
10911 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10913 struct type *type = static_unwrap_type (sym->type ());
10914 /* Check to see if this is a tagged type. We also need to handle
10915 the case where the type is a reference to a tagged type, but
10916 we have to be careful to exclude pointers to tagged types.
10917 The latter should be shown as usual (as a pointer), whereas
10918 a reference should mostly be transparent to the user. */
10919 if (ada_is_tagged_type (type, 0)
10920 || (type->code () == TYPE_CODE_REF
10921 && ada_is_tagged_type (type->target_type (), 0)))
10923 /* Tagged types are a little special in the fact that the real
10924 type is dynamic and can only be determined by inspecting the
10925 object's tag. This means that we need to get the object's
10926 value first (EVAL_NORMAL) and then extract the actual object
10929 Note that we cannot skip the final step where we extract
10930 the object type from its tag, because the EVAL_NORMAL phase
10931 results in dynamic components being resolved into fixed ones.
10932 This can cause problems when trying to print the type
10933 description of tagged types whose parent has a dynamic size:
10934 We use the type name of the "_parent" component in order
10935 to print the name of the ancestor type in the type description.
10936 If that component had a dynamic size, the resolution into
10937 a fixed type would result in the loss of that type name,
10938 thus preventing us from printing the name of the ancestor
10939 type in the type description. */
10940 value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10942 if (type->code () != TYPE_CODE_REF)
10944 struct type *actual_type;
10946 actual_type = type_from_tag (ada_value_tag (arg1));
10947 if (actual_type == NULL)
10948 /* If, for some reason, we were unable to determine
10949 the actual type from the tag, then use the static
10950 approximation that we just computed as a fallback.
10951 This can happen if the debugging information is
10952 incomplete, for instance. */
10953 actual_type = type;
10954 return value_zero (actual_type, not_lval);
10958 /* In the case of a ref, ada_coerce_ref takes care
10959 of determining the actual type. But the evaluation
10960 should return a ref as it should be valid to ask
10961 for its address; so rebuild a ref after coerce. */
10962 arg1 = ada_coerce_ref (arg1);
10963 return value_ref (arg1, TYPE_CODE_REF);
10967 /* Records and unions for which GNAT encodings have been
10968 generated need to be statically fixed as well.
10969 Otherwise, non-static fixing produces a type where
10970 all dynamic properties are removed, which prevents "ptype"
10971 from being able to completely describe the type.
10972 For instance, a case statement in a variant record would be
10973 replaced by the relevant components based on the actual
10974 value of the discriminants. */
10975 if ((type->code () == TYPE_CODE_STRUCT
10976 && dynamic_template_type (type) != NULL)
10977 || (type->code () == TYPE_CODE_UNION
10978 && ada_find_parallel_type (type, "___XVU") != NULL))
10979 return value_zero (to_static_fixed_type (type), not_lval);
10982 value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10983 return ada_to_fixed_value (arg1);
10987 ada_var_value_operation::resolve (struct expression *exp,
10988 bool deprocedure_p,
10989 bool parse_completion,
10990 innermost_block_tracker *tracker,
10991 struct type *context_type)
10993 symbol *sym = std::get<0> (m_storage).symbol;
10994 if (sym->domain () == UNDEF_DOMAIN)
10996 block_symbol resolved
10997 = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10998 context_type, parse_completion,
10999 deprocedure_p, tracker);
11000 std::get<0> (m_storage) = resolved;
11004 && (std::get<0> (m_storage).symbol->type ()->code ()
11005 == TYPE_CODE_FUNC))
11012 ada_atr_val_operation::evaluate (struct type *expect_type,
11013 struct expression *exp,
11014 enum noside noside)
11016 value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11017 return ada_val_atr (noside, std::get<0> (m_storage), arg);
11021 ada_unop_ind_operation::evaluate (struct type *expect_type,
11022 struct expression *exp,
11023 enum noside noside)
11025 value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11027 struct type *type = ada_check_typedef (value_type (arg1));
11028 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11030 if (ada_is_array_descriptor_type (type))
11031 /* GDB allows dereferencing GNAT array descriptors. */
11033 struct type *arrType = ada_type_of_array (arg1, 0);
11035 if (arrType == NULL)
11036 error (_("Attempt to dereference null array pointer."));
11037 return value_at_lazy (arrType, 0);
11039 else if (type->code () == TYPE_CODE_PTR
11040 || type->code () == TYPE_CODE_REF
11041 /* In C you can dereference an array to get the 1st elt. */
11042 || type->code () == TYPE_CODE_ARRAY)
11044 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11045 only be determined by inspecting the object's tag.
11046 This means that we need to evaluate completely the
11047 expression in order to get its type. */
11049 if ((type->code () == TYPE_CODE_REF
11050 || type->code () == TYPE_CODE_PTR)
11051 && ada_is_tagged_type (type->target_type (), 0))
11053 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11055 type = value_type (ada_value_ind (arg1));
11059 type = to_static_fixed_type
11061 (ada_check_typedef (type->target_type ())));
11063 return value_zero (type, lval_memory);
11065 else if (type->code () == TYPE_CODE_INT)
11067 /* GDB allows dereferencing an int. */
11068 if (expect_type == NULL)
11069 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11074 to_static_fixed_type (ada_aligned_type (expect_type));
11075 return value_zero (expect_type, lval_memory);
11079 error (_("Attempt to take contents of a non-pointer value."));
11081 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11082 type = ada_check_typedef (value_type (arg1));
11084 if (type->code () == TYPE_CODE_INT)
11085 /* GDB allows dereferencing an int. If we were given
11086 the expect_type, then use that as the target type.
11087 Otherwise, assume that the target type is an int. */
11089 if (expect_type != NULL)
11090 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11093 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11094 (CORE_ADDR) value_as_address (arg1));
11097 if (ada_is_array_descriptor_type (type))
11098 /* GDB allows dereferencing GNAT array descriptors. */
11099 return ada_coerce_to_simple_array (arg1);
11101 return ada_value_ind (arg1);
11105 ada_structop_operation::evaluate (struct type *expect_type,
11106 struct expression *exp,
11107 enum noside noside)
11109 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11110 const char *str = std::get<1> (m_storage).c_str ();
11111 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11114 struct type *type1 = value_type (arg1);
11116 if (ada_is_tagged_type (type1, 1))
11118 type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11120 /* If the field is not found, check if it exists in the
11121 extension of this object's type. This means that we
11122 need to evaluate completely the expression. */
11126 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11128 arg1 = ada_value_struct_elt (arg1, str, 0);
11129 arg1 = unwrap_value (arg1);
11130 type = value_type (ada_to_fixed_value (arg1));
11134 type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11136 return value_zero (ada_aligned_type (type), lval_memory);
11140 arg1 = ada_value_struct_elt (arg1, str, 0);
11141 arg1 = unwrap_value (arg1);
11142 return ada_to_fixed_value (arg1);
11147 ada_funcall_operation::evaluate (struct type *expect_type,
11148 struct expression *exp,
11149 enum noside noside)
11151 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11152 int nargs = args_up.size ();
11153 std::vector<value *> argvec (nargs);
11154 operation_up &callee_op = std::get<0> (m_storage);
11156 ada_var_value_operation *avv
11157 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11159 && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11160 error (_("Unexpected unresolved symbol, %s, during evaluation"),
11161 avv->get_symbol ()->print_name ());
11163 value *callee = callee_op->evaluate (nullptr, exp, noside);
11164 for (int i = 0; i < args_up.size (); ++i)
11165 argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11167 if (ada_is_constrained_packed_array_type
11168 (desc_base_type (value_type (callee))))
11169 callee = ada_coerce_to_simple_array (callee);
11170 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11171 && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11172 /* This is a packed array that has already been fixed, and
11173 therefore already coerced to a simple array. Nothing further
11176 else if (value_type (callee)->code () == TYPE_CODE_REF)
11178 /* Make sure we dereference references so that all the code below
11179 feels like it's really handling the referenced value. Wrapping
11180 types (for alignment) may be there, so make sure we strip them as
11182 callee = ada_to_fixed_value (coerce_ref (callee));
11184 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11185 && VALUE_LVAL (callee) == lval_memory)
11186 callee = value_addr (callee);
11188 struct type *type = ada_check_typedef (value_type (callee));
11190 /* Ada allows us to implicitly dereference arrays when subscripting
11191 them. So, if this is an array typedef (encoding use for array
11192 access types encoded as fat pointers), strip it now. */
11193 if (type->code () == TYPE_CODE_TYPEDEF)
11194 type = ada_typedef_target_type (type);
11196 if (type->code () == TYPE_CODE_PTR)
11198 switch (ada_check_typedef (type->target_type ())->code ())
11200 case TYPE_CODE_FUNC:
11201 type = ada_check_typedef (type->target_type ());
11203 case TYPE_CODE_ARRAY:
11205 case TYPE_CODE_STRUCT:
11206 if (noside != EVAL_AVOID_SIDE_EFFECTS)
11207 callee = ada_value_ind (callee);
11208 type = ada_check_typedef (type->target_type ());
11211 error (_("cannot subscript or call something of type `%s'"),
11212 ada_type_name (value_type (callee)));
11217 switch (type->code ())
11219 case TYPE_CODE_FUNC:
11220 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11222 if (type->target_type () == NULL)
11223 error_call_unknown_return_type (NULL);
11224 return allocate_value (type->target_type ());
11226 return call_function_by_hand (callee, NULL, argvec);
11227 case TYPE_CODE_INTERNAL_FUNCTION:
11228 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11229 /* We don't know anything about what the internal
11230 function might return, but we have to return
11232 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11235 return call_internal_function (exp->gdbarch, exp->language_defn,
11239 case TYPE_CODE_STRUCT:
11243 arity = ada_array_arity (type);
11244 type = ada_array_element_type (type, nargs);
11246 error (_("cannot subscript or call a record"));
11247 if (arity != nargs)
11248 error (_("wrong number of subscripts; expecting %d"), arity);
11249 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11250 return value_zero (ada_aligned_type (type), lval_memory);
11252 unwrap_value (ada_value_subscript
11253 (callee, nargs, argvec.data ()));
11255 case TYPE_CODE_ARRAY:
11256 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11258 type = ada_array_element_type (type, nargs);
11260 error (_("element type of array unknown"));
11262 return value_zero (ada_aligned_type (type), lval_memory);
11265 unwrap_value (ada_value_subscript
11266 (ada_coerce_to_simple_array (callee),
11267 nargs, argvec.data ()));
11268 case TYPE_CODE_PTR: /* Pointer to array */
11269 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11271 type = to_fixed_array_type (type->target_type (), NULL, 1);
11272 type = ada_array_element_type (type, nargs);
11274 error (_("element type of array unknown"));
11276 return value_zero (ada_aligned_type (type), lval_memory);
11279 unwrap_value (ada_value_ptr_subscript (callee, nargs,
11283 error (_("Attempt to index or call something other than an "
11284 "array or function"));
11289 ada_funcall_operation::resolve (struct expression *exp,
11290 bool deprocedure_p,
11291 bool parse_completion,
11292 innermost_block_tracker *tracker,
11293 struct type *context_type)
11295 operation_up &callee_op = std::get<0> (m_storage);
11297 ada_var_value_operation *avv
11298 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11299 if (avv == nullptr)
11302 symbol *sym = avv->get_symbol ();
11303 if (sym->domain () != UNDEF_DOMAIN)
11306 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11307 int nargs = args_up.size ();
11308 std::vector<value *> argvec (nargs);
11310 for (int i = 0; i < args_up.size (); ++i)
11311 argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11313 const block *block = avv->get_block ();
11314 block_symbol resolved
11315 = ada_resolve_funcall (sym, block,
11316 context_type, parse_completion,
11317 nargs, argvec.data (),
11320 std::get<0> (m_storage)
11321 = make_operation<ada_var_value_operation> (resolved);
11326 ada_ternop_slice_operation::resolve (struct expression *exp,
11327 bool deprocedure_p,
11328 bool parse_completion,
11329 innermost_block_tracker *tracker,
11330 struct type *context_type)
11332 /* Historically this check was done during resolution, so we
11333 continue that here. */
11334 value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11335 EVAL_AVOID_SIDE_EFFECTS);
11336 if (ada_is_any_packed_array_type (value_type (v)))
11337 error (_("cannot slice a packed array"));
11345 /* Return non-zero iff TYPE represents a System.Address type. */
11348 ada_is_system_address_type (struct type *type)
11350 return (type->name () && strcmp (type->name (), "system__address") == 0);
11357 /* Scan STR beginning at position K for a discriminant name, and
11358 return the value of that discriminant field of DVAL in *PX. If
11359 PNEW_K is not null, put the position of the character beyond the
11360 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11361 not alter *PX and *PNEW_K if unsuccessful. */
11364 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11367 static std::string storage;
11368 const char *pstart, *pend, *bound;
11369 struct value *bound_val;
11371 if (dval == NULL || str == NULL || str[k] == '\0')
11375 pend = strstr (pstart, "__");
11379 k += strlen (bound);
11383 int len = pend - pstart;
11385 /* Strip __ and beyond. */
11386 storage = std::string (pstart, len);
11387 bound = storage.c_str ();
11391 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11392 if (bound_val == NULL)
11395 *px = value_as_long (bound_val);
11396 if (pnew_k != NULL)
11401 /* Value of variable named NAME. Only exact matches are considered.
11402 If no such variable found, then if ERR_MSG is null, returns 0, and
11403 otherwise causes an error with message ERR_MSG. */
11405 static struct value *
11406 get_var_value (const char *name, const char *err_msg)
11408 std::string quoted_name = add_angle_brackets (name);
11410 lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11412 std::vector<struct block_symbol> syms
11413 = ada_lookup_symbol_list_worker (lookup_name,
11414 get_selected_block (0),
11417 if (syms.size () != 1)
11419 if (err_msg == NULL)
11422 error (("%s"), err_msg);
11425 return value_of_variable (syms[0].symbol, syms[0].block);
11428 /* Value of integer variable named NAME in the current environment.
11429 If no such variable is found, returns false. Otherwise, sets VALUE
11430 to the variable's value and returns true. */
11433 get_int_var_value (const char *name, LONGEST &value)
11435 struct value *var_val = get_var_value (name, 0);
11440 value = value_as_long (var_val);
11445 /* Return a range type whose base type is that of the range type named
11446 NAME in the current environment, and whose bounds are calculated
11447 from NAME according to the GNAT range encoding conventions.
11448 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11449 corresponding range type from debug information; fall back to using it
11450 if symbol lookup fails. If a new type must be created, allocate it
11451 like ORIG_TYPE was. The bounds information, in general, is encoded
11452 in NAME, the base type given in the named range type. */
11454 static struct type *
11455 to_fixed_range_type (struct type *raw_type, struct value *dval)
11458 struct type *base_type;
11459 const char *subtype_info;
11461 gdb_assert (raw_type != NULL);
11462 gdb_assert (raw_type->name () != NULL);
11464 if (raw_type->code () == TYPE_CODE_RANGE)
11465 base_type = raw_type->target_type ();
11467 base_type = raw_type;
11469 name = raw_type->name ();
11470 subtype_info = strstr (name, "___XD");
11471 if (subtype_info == NULL)
11473 LONGEST L = ada_discrete_type_low_bound (raw_type);
11474 LONGEST U = ada_discrete_type_high_bound (raw_type);
11476 if (L < INT_MIN || U > INT_MAX)
11479 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11484 int prefix_len = subtype_info - name;
11487 const char *bounds_str;
11491 bounds_str = strchr (subtype_info, '_');
11494 if (*subtype_info == 'L')
11496 if (!ada_scan_number (bounds_str, n, &L, &n)
11497 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11499 if (bounds_str[n] == '_')
11501 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11507 std::string name_buf = std::string (name, prefix_len) + "___L";
11508 if (!get_int_var_value (name_buf.c_str (), L))
11510 lim_warning (_("Unknown lower bound, using 1."));
11515 if (*subtype_info == 'U')
11517 if (!ada_scan_number (bounds_str, n, &U, &n)
11518 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11523 std::string name_buf = std::string (name, prefix_len) + "___U";
11524 if (!get_int_var_value (name_buf.c_str (), U))
11526 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11531 type = create_static_range_type (alloc_type_copy (raw_type),
11533 /* create_static_range_type alters the resulting type's length
11534 to match the size of the base_type, which is not what we want.
11535 Set it back to the original range type's length. */
11536 type->set_length (raw_type->length ());
11537 type->set_name (name);
11542 /* True iff NAME is the name of a range type. */
11545 ada_is_range_type_name (const char *name)
11547 return (name != NULL && strstr (name, "___XD"));
11551 /* Modular types */
11553 /* True iff TYPE is an Ada modular type. */
11556 ada_is_modular_type (struct type *type)
11558 struct type *subranged_type = get_base_type (type);
11560 return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11561 && subranged_type->code () == TYPE_CODE_INT
11562 && subranged_type->is_unsigned ());
11565 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11568 ada_modulus (struct type *type)
11570 const dynamic_prop &high = type->bounds ()->high;
11572 if (high.kind () == PROP_CONST)
11573 return (ULONGEST) high.const_val () + 1;
11575 /* If TYPE is unresolved, the high bound might be a location list. Return
11576 0, for lack of a better value to return. */
11581 /* Ada exception catchpoint support:
11582 ---------------------------------
11584 We support 3 kinds of exception catchpoints:
11585 . catchpoints on Ada exceptions
11586 . catchpoints on unhandled Ada exceptions
11587 . catchpoints on failed assertions
11589 Exceptions raised during failed assertions, or unhandled exceptions
11590 could perfectly be caught with the general catchpoint on Ada exceptions.
11591 However, we can easily differentiate these two special cases, and having
11592 the option to distinguish these two cases from the rest can be useful
11593 to zero-in on certain situations.
11595 Exception catchpoints are a specialized form of breakpoint,
11596 since they rely on inserting breakpoints inside known routines
11597 of the GNAT runtime. The implementation therefore uses a standard
11598 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11601 Support in the runtime for exception catchpoints have been changed
11602 a few times already, and these changes affect the implementation
11603 of these catchpoints. In order to be able to support several
11604 variants of the runtime, we use a sniffer that will determine
11605 the runtime variant used by the program being debugged. */
11607 /* Ada's standard exceptions.
11609 The Ada 83 standard also defined Numeric_Error. But there so many
11610 situations where it was unclear from the Ada 83 Reference Manual
11611 (RM) whether Constraint_Error or Numeric_Error should be raised,
11612 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11613 Interpretation saying that anytime the RM says that Numeric_Error
11614 should be raised, the implementation may raise Constraint_Error.
11615 Ada 95 went one step further and pretty much removed Numeric_Error
11616 from the list of standard exceptions (it made it a renaming of
11617 Constraint_Error, to help preserve compatibility when compiling
11618 an Ada83 compiler). As such, we do not include Numeric_Error from
11619 this list of standard exceptions. */
11621 static const char * const standard_exc[] = {
11622 "constraint_error",
11628 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11630 /* A structure that describes how to support exception catchpoints
11631 for a given executable. */
11633 struct exception_support_info
11635 /* The name of the symbol to break on in order to insert
11636 a catchpoint on exceptions. */
11637 const char *catch_exception_sym;
11639 /* The name of the symbol to break on in order to insert
11640 a catchpoint on unhandled exceptions. */
11641 const char *catch_exception_unhandled_sym;
11643 /* The name of the symbol to break on in order to insert
11644 a catchpoint on failed assertions. */
11645 const char *catch_assert_sym;
11647 /* The name of the symbol to break on in order to insert
11648 a catchpoint on exception handling. */
11649 const char *catch_handlers_sym;
11651 /* Assuming that the inferior just triggered an unhandled exception
11652 catchpoint, this function is responsible for returning the address
11653 in inferior memory where the name of that exception is stored.
11654 Return zero if the address could not be computed. */
11655 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11658 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11659 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11661 /* The following exception support info structure describes how to
11662 implement exception catchpoints with the latest version of the
11663 Ada runtime (as of 2019-08-??). */
11665 static const struct exception_support_info default_exception_support_info =
11667 "__gnat_debug_raise_exception", /* catch_exception_sym */
11668 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11669 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11670 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11671 ada_unhandled_exception_name_addr
11674 /* The following exception support info structure describes how to
11675 implement exception catchpoints with an earlier version of the
11676 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11678 static const struct exception_support_info exception_support_info_v0 =
11680 "__gnat_debug_raise_exception", /* catch_exception_sym */
11681 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11682 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11683 "__gnat_begin_handler", /* catch_handlers_sym */
11684 ada_unhandled_exception_name_addr
11687 /* The following exception support info structure describes how to
11688 implement exception catchpoints with a slightly older version
11689 of the Ada runtime. */
11691 static const struct exception_support_info exception_support_info_fallback =
11693 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11694 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11695 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11696 "__gnat_begin_handler", /* catch_handlers_sym */
11697 ada_unhandled_exception_name_addr_from_raise
11700 /* Return nonzero if we can detect the exception support routines
11701 described in EINFO.
11703 This function errors out if an abnormal situation is detected
11704 (for instance, if we find the exception support routines, but
11705 that support is found to be incomplete). */
11708 ada_has_this_exception_support (const struct exception_support_info *einfo)
11710 struct symbol *sym;
11712 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11713 that should be compiled with debugging information. As a result, we
11714 expect to find that symbol in the symtabs. */
11716 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11719 /* Perhaps we did not find our symbol because the Ada runtime was
11720 compiled without debugging info, or simply stripped of it.
11721 It happens on some GNU/Linux distributions for instance, where
11722 users have to install a separate debug package in order to get
11723 the runtime's debugging info. In that situation, let the user
11724 know why we cannot insert an Ada exception catchpoint.
11726 Note: Just for the purpose of inserting our Ada exception
11727 catchpoint, we could rely purely on the associated minimal symbol.
11728 But we would be operating in degraded mode anyway, since we are
11729 still lacking the debugging info needed later on to extract
11730 the name of the exception being raised (this name is printed in
11731 the catchpoint message, and is also used when trying to catch
11732 a specific exception). We do not handle this case for now. */
11733 struct bound_minimal_symbol msym
11734 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11736 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11737 error (_("Your Ada runtime appears to be missing some debugging "
11738 "information.\nCannot insert Ada exception catchpoint "
11739 "in this configuration."));
11744 /* Make sure that the symbol we found corresponds to a function. */
11746 if (sym->aclass () != LOC_BLOCK)
11748 error (_("Symbol \"%s\" is not a function (class = %d)"),
11749 sym->linkage_name (), sym->aclass ());
11753 sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11756 struct bound_minimal_symbol msym
11757 = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11759 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11760 error (_("Your Ada runtime appears to be missing some debugging "
11761 "information.\nCannot insert Ada exception catchpoint "
11762 "in this configuration."));
11767 /* Make sure that the symbol we found corresponds to a function. */
11769 if (sym->aclass () != LOC_BLOCK)
11771 error (_("Symbol \"%s\" is not a function (class = %d)"),
11772 sym->linkage_name (), sym->aclass ());
11779 /* Inspect the Ada runtime and determine which exception info structure
11780 should be used to provide support for exception catchpoints.
11782 This function will always set the per-inferior exception_info,
11783 or raise an error. */
11786 ada_exception_support_info_sniffer (void)
11788 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11790 /* If the exception info is already known, then no need to recompute it. */
11791 if (data->exception_info != NULL)
11794 /* Check the latest (default) exception support info. */
11795 if (ada_has_this_exception_support (&default_exception_support_info))
11797 data->exception_info = &default_exception_support_info;
11801 /* Try the v0 exception suport info. */
11802 if (ada_has_this_exception_support (&exception_support_info_v0))
11804 data->exception_info = &exception_support_info_v0;
11808 /* Try our fallback exception suport info. */
11809 if (ada_has_this_exception_support (&exception_support_info_fallback))
11811 data->exception_info = &exception_support_info_fallback;
11815 /* Sometimes, it is normal for us to not be able to find the routine
11816 we are looking for. This happens when the program is linked with
11817 the shared version of the GNAT runtime, and the program has not been
11818 started yet. Inform the user of these two possible causes if
11821 if (ada_update_initial_language (language_unknown) != language_ada)
11822 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11824 /* If the symbol does not exist, then check that the program is
11825 already started, to make sure that shared libraries have been
11826 loaded. If it is not started, this may mean that the symbol is
11827 in a shared library. */
11829 if (inferior_ptid.pid () == 0)
11830 error (_("Unable to insert catchpoint. Try to start the program first."));
11832 /* At this point, we know that we are debugging an Ada program and
11833 that the inferior has been started, but we still are not able to
11834 find the run-time symbols. That can mean that we are in
11835 configurable run time mode, or that a-except as been optimized
11836 out by the linker... In any case, at this point it is not worth
11837 supporting this feature. */
11839 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11842 /* True iff FRAME is very likely to be that of a function that is
11843 part of the runtime system. This is all very heuristic, but is
11844 intended to be used as advice as to what frames are uninteresting
11848 is_known_support_routine (frame_info_ptr frame)
11850 enum language func_lang;
11852 const char *fullname;
11854 /* If this code does not have any debugging information (no symtab),
11855 This cannot be any user code. */
11857 symtab_and_line sal = find_frame_sal (frame);
11858 if (sal.symtab == NULL)
11861 /* If there is a symtab, but the associated source file cannot be
11862 located, then assume this is not user code: Selecting a frame
11863 for which we cannot display the code would not be very helpful
11864 for the user. This should also take care of case such as VxWorks
11865 where the kernel has some debugging info provided for a few units. */
11867 fullname = symtab_to_fullname (sal.symtab);
11868 if (access (fullname, R_OK) != 0)
11871 /* Check the unit filename against the Ada runtime file naming.
11872 We also check the name of the objfile against the name of some
11873 known system libraries that sometimes come with debugging info
11876 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11878 re_comp (known_runtime_file_name_patterns[i]);
11879 if (re_exec (lbasename (sal.symtab->filename)))
11881 if (sal.symtab->compunit ()->objfile () != NULL
11882 && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11886 /* Check whether the function is a GNAT-generated entity. */
11888 gdb::unique_xmalloc_ptr<char> func_name
11889 = find_frame_funname (frame, &func_lang, NULL);
11890 if (func_name == NULL)
11893 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11895 re_comp (known_auxiliary_function_name_patterns[i]);
11896 if (re_exec (func_name.get ()))
11903 /* Find the first frame that contains debugging information and that is not
11904 part of the Ada run-time, starting from FI and moving upward. */
11907 ada_find_printable_frame (frame_info_ptr fi)
11909 for (; fi != NULL; fi = get_prev_frame (fi))
11911 if (!is_known_support_routine (fi))
11920 /* Assuming that the inferior just triggered an unhandled exception
11921 catchpoint, return the address in inferior memory where the name
11922 of the exception is stored.
11924 Return zero if the address could not be computed. */
11927 ada_unhandled_exception_name_addr (void)
11929 return parse_and_eval_address ("e.full_name");
11932 /* Same as ada_unhandled_exception_name_addr, except that this function
11933 should be used when the inferior uses an older version of the runtime,
11934 where the exception name needs to be extracted from a specific frame
11935 several frames up in the callstack. */
11938 ada_unhandled_exception_name_addr_from_raise (void)
11942 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11944 /* To determine the name of this exception, we need to select
11945 the frame corresponding to RAISE_SYM_NAME. This frame is
11946 at least 3 levels up, so we simply skip the first 3 frames
11947 without checking the name of their associated function. */
11948 fi = get_current_frame ();
11949 for (frame_level = 0; frame_level < 3; frame_level += 1)
11951 fi = get_prev_frame (fi);
11955 enum language func_lang;
11957 gdb::unique_xmalloc_ptr<char> func_name
11958 = find_frame_funname (fi, &func_lang, NULL);
11959 if (func_name != NULL)
11961 if (strcmp (func_name.get (),
11962 data->exception_info->catch_exception_sym) == 0)
11963 break; /* We found the frame we were looking for... */
11965 fi = get_prev_frame (fi);
11972 return parse_and_eval_address ("id.full_name");
11975 /* Assuming the inferior just triggered an Ada exception catchpoint
11976 (of any type), return the address in inferior memory where the name
11977 of the exception is stored, if applicable.
11979 Assumes the selected frame is the current frame.
11981 Return zero if the address could not be computed, or if not relevant. */
11984 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11986 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11990 case ada_catch_exception:
11991 return (parse_and_eval_address ("e.full_name"));
11994 case ada_catch_exception_unhandled:
11995 return data->exception_info->unhandled_exception_name_addr ();
11998 case ada_catch_handlers:
11999 return 0; /* The runtimes does not provide access to the exception
12003 case ada_catch_assert:
12004 return 0; /* Exception name is not relevant in this case. */
12008 internal_error (_("unexpected catchpoint type"));
12012 return 0; /* Should never be reached. */
12015 /* Assuming the inferior is stopped at an exception catchpoint,
12016 return the message which was associated to the exception, if
12017 available. Return NULL if the message could not be retrieved.
12019 Note: The exception message can be associated to an exception
12020 either through the use of the Raise_Exception function, or
12021 more simply (Ada 2005 and later), via:
12023 raise Exception_Name with "exception message";
12027 static gdb::unique_xmalloc_ptr<char>
12028 ada_exception_message_1 (void)
12030 struct value *e_msg_val;
12033 /* For runtimes that support this feature, the exception message
12034 is passed as an unbounded string argument called "message". */
12035 e_msg_val = parse_and_eval ("message");
12036 if (e_msg_val == NULL)
12037 return NULL; /* Exception message not supported. */
12039 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12040 gdb_assert (e_msg_val != NULL);
12041 e_msg_len = value_type (e_msg_val)->length ();
12043 /* If the message string is empty, then treat it as if there was
12044 no exception message. */
12045 if (e_msg_len <= 0)
12048 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12049 read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12051 e_msg.get ()[e_msg_len] = '\0';
12056 /* Same as ada_exception_message_1, except that all exceptions are
12057 contained here (returning NULL instead). */
12059 static gdb::unique_xmalloc_ptr<char>
12060 ada_exception_message (void)
12062 gdb::unique_xmalloc_ptr<char> e_msg;
12066 e_msg = ada_exception_message_1 ();
12068 catch (const gdb_exception_error &e)
12070 e_msg.reset (nullptr);
12076 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12077 any error that ada_exception_name_addr_1 might cause to be thrown.
12078 When an error is intercepted, a warning with the error message is printed,
12079 and zero is returned. */
12082 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12084 CORE_ADDR result = 0;
12088 result = ada_exception_name_addr_1 (ex);
12091 catch (const gdb_exception_error &e)
12093 warning (_("failed to get exception name: %s"), e.what ());
12100 static std::string ada_exception_catchpoint_cond_string
12101 (const char *excep_string,
12102 enum ada_exception_catchpoint_kind ex);
12104 /* Ada catchpoints.
12106 In the case of catchpoints on Ada exceptions, the catchpoint will
12107 stop the target on every exception the program throws. When a user
12108 specifies the name of a specific exception, we translate this
12109 request into a condition expression (in text form), and then parse
12110 it into an expression stored in each of the catchpoint's locations.
12111 We then use this condition to check whether the exception that was
12112 raised is the one the user is interested in. If not, then the
12113 target is resumed again. We store the name of the requested
12114 exception, in order to be able to re-set the condition expression
12115 when symbols change. */
12117 /* An instance of this type is used to represent an Ada catchpoint. */
12119 struct ada_catchpoint : public code_breakpoint
12121 ada_catchpoint (struct gdbarch *gdbarch_,
12122 enum ada_exception_catchpoint_kind kind,
12123 struct symtab_and_line sal,
12124 const char *addr_string_,
12128 : code_breakpoint (gdbarch_, bp_catchpoint),
12131 add_location (sal);
12133 /* Unlike most code_breakpoint types, Ada catchpoints are
12134 pspace-specific. */
12135 gdb_assert (sal.pspace != nullptr);
12136 this->pspace = sal.pspace;
12140 struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12142 loc_gdbarch = gdbarch;
12144 describe_other_breakpoints (loc_gdbarch,
12145 sal.pspace, sal.pc, sal.section, -1);
12146 /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12147 version for exception catchpoints, because two catchpoints
12148 used for different exception names will use the same address.
12149 In this case, a "breakpoint ... also set at..." warning is
12150 unproductive. Besides, the warning phrasing is also a bit
12151 inappropriate, we should use the word catchpoint, and tell
12152 the user what type of catchpoint it is. The above is good
12153 enough for now, though. */
12156 enable_state = enabled ? bp_enabled : bp_disabled;
12157 disposition = tempflag ? disp_del : disp_donttouch;
12158 locspec = string_to_location_spec (&addr_string_,
12159 language_def (language_ada));
12160 language = language_ada;
12163 struct bp_location *allocate_location () override;
12164 void re_set () override;
12165 void check_status (struct bpstat *bs) override;
12166 enum print_stop_action print_it (const bpstat *bs) const override;
12167 bool print_one (bp_location **) const override;
12168 void print_mention () const override;
12169 void print_recreate (struct ui_file *fp) const override;
12171 /* The name of the specific exception the user specified. */
12172 std::string excep_string;
12174 /* What kind of catchpoint this is. */
12175 enum ada_exception_catchpoint_kind m_kind;
12178 /* An instance of this type is used to represent an Ada catchpoint
12179 breakpoint location. */
12181 class ada_catchpoint_location : public bp_location
12184 explicit ada_catchpoint_location (ada_catchpoint *owner)
12185 : bp_location (owner, bp_loc_software_breakpoint)
12188 /* The condition that checks whether the exception that was raised
12189 is the specific exception the user specified on catchpoint
12191 expression_up excep_cond_expr;
12194 /* Parse the exception condition string in the context of each of the
12195 catchpoint's locations, and store them for later evaluation. */
12198 create_excep_cond_exprs (struct ada_catchpoint *c,
12199 enum ada_exception_catchpoint_kind ex)
12201 /* Nothing to do if there's no specific exception to catch. */
12202 if (c->excep_string.empty ())
12205 /* Same if there are no locations... */
12206 if (c->loc == NULL)
12209 /* Compute the condition expression in text form, from the specific
12210 expection we want to catch. */
12211 std::string cond_string
12212 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12214 /* Iterate over all the catchpoint's locations, and parse an
12215 expression for each. */
12216 for (bp_location *bl : c->locations ())
12218 struct ada_catchpoint_location *ada_loc
12219 = (struct ada_catchpoint_location *) bl;
12222 if (!bl->shlib_disabled)
12226 s = cond_string.c_str ();
12229 exp = parse_exp_1 (&s, bl->address,
12230 block_for_pc (bl->address),
12233 catch (const gdb_exception_error &e)
12235 warning (_("failed to reevaluate internal exception condition "
12236 "for catchpoint %d: %s"),
12237 c->number, e.what ());
12241 ada_loc->excep_cond_expr = std::move (exp);
12245 /* Implement the ALLOCATE_LOCATION method in the structure for all
12246 exception catchpoint kinds. */
12248 struct bp_location *
12249 ada_catchpoint::allocate_location ()
12251 return new ada_catchpoint_location (this);
12254 /* Implement the RE_SET method in the structure for all exception
12255 catchpoint kinds. */
12258 ada_catchpoint::re_set ()
12260 /* Call the base class's method. This updates the catchpoint's
12262 this->code_breakpoint::re_set ();
12264 /* Reparse the exception conditional expressions. One for each
12266 create_excep_cond_exprs (this, m_kind);
12269 /* Returns true if we should stop for this breakpoint hit. If the
12270 user specified a specific exception, we only want to cause a stop
12271 if the program thrown that exception. */
12274 should_stop_exception (const struct bp_location *bl)
12276 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12277 const struct ada_catchpoint_location *ada_loc
12278 = (const struct ada_catchpoint_location *) bl;
12281 struct internalvar *var = lookup_internalvar ("_ada_exception");
12282 if (c->m_kind == ada_catch_assert)
12283 clear_internalvar (var);
12290 if (c->m_kind == ada_catch_handlers)
12291 expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12292 ".all.occurrence.id");
12296 struct value *exc = parse_and_eval (expr);
12297 set_internalvar (var, exc);
12299 catch (const gdb_exception_error &ex)
12301 clear_internalvar (var);
12305 /* With no specific exception, should always stop. */
12306 if (c->excep_string.empty ())
12309 if (ada_loc->excep_cond_expr == NULL)
12311 /* We will have a NULL expression if back when we were creating
12312 the expressions, this location's had failed to parse. */
12319 scoped_value_mark mark;
12320 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12322 catch (const gdb_exception &ex)
12324 exception_fprintf (gdb_stderr, ex,
12325 _("Error in testing exception condition:\n"));
12331 /* Implement the CHECK_STATUS method in the structure for all
12332 exception catchpoint kinds. */
12335 ada_catchpoint::check_status (bpstat *bs)
12337 bs->stop = should_stop_exception (bs->bp_location_at.get ());
12340 /* Implement the PRINT_IT method in the structure for all exception
12341 catchpoint kinds. */
12343 enum print_stop_action
12344 ada_catchpoint::print_it (const bpstat *bs) const
12346 struct ui_out *uiout = current_uiout;
12348 annotate_catchpoint (number);
12350 if (uiout->is_mi_like_p ())
12352 uiout->field_string ("reason",
12353 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12354 uiout->field_string ("disp", bpdisp_text (disposition));
12357 uiout->text (disposition == disp_del
12358 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12359 uiout->field_signed ("bkptno", number);
12360 uiout->text (", ");
12362 /* ada_exception_name_addr relies on the selected frame being the
12363 current frame. Need to do this here because this function may be
12364 called more than once when printing a stop, and below, we'll
12365 select the first frame past the Ada run-time (see
12366 ada_find_printable_frame). */
12367 select_frame (get_current_frame ());
12371 case ada_catch_exception:
12372 case ada_catch_exception_unhandled:
12373 case ada_catch_handlers:
12375 const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12376 char exception_name[256];
12380 read_memory (addr, (gdb_byte *) exception_name,
12381 sizeof (exception_name) - 1);
12382 exception_name [sizeof (exception_name) - 1] = '\0';
12386 /* For some reason, we were unable to read the exception
12387 name. This could happen if the Runtime was compiled
12388 without debugging info, for instance. In that case,
12389 just replace the exception name by the generic string
12390 "exception" - it will read as "an exception" in the
12391 notification we are about to print. */
12392 memcpy (exception_name, "exception", sizeof ("exception"));
12394 /* In the case of unhandled exception breakpoints, we print
12395 the exception name as "unhandled EXCEPTION_NAME", to make
12396 it clearer to the user which kind of catchpoint just got
12397 hit. We used ui_out_text to make sure that this extra
12398 info does not pollute the exception name in the MI case. */
12399 if (m_kind == ada_catch_exception_unhandled)
12400 uiout->text ("unhandled ");
12401 uiout->field_string ("exception-name", exception_name);
12404 case ada_catch_assert:
12405 /* In this case, the name of the exception is not really
12406 important. Just print "failed assertion" to make it clearer
12407 that his program just hit an assertion-failure catchpoint.
12408 We used ui_out_text because this info does not belong in
12410 uiout->text ("failed assertion");
12414 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12415 if (exception_message != NULL)
12417 uiout->text (" (");
12418 uiout->field_string ("exception-message", exception_message.get ());
12422 uiout->text (" at ");
12423 ada_find_printable_frame (get_current_frame ());
12425 return PRINT_SRC_AND_LOC;
12428 /* Implement the PRINT_ONE method in the structure for all exception
12429 catchpoint kinds. */
12432 ada_catchpoint::print_one (bp_location **last_loc) const
12434 struct ui_out *uiout = current_uiout;
12435 struct value_print_options opts;
12437 get_user_print_options (&opts);
12439 if (opts.addressprint)
12440 uiout->field_skip ("addr");
12442 annotate_field (5);
12445 case ada_catch_exception:
12446 if (!excep_string.empty ())
12448 std::string msg = string_printf (_("`%s' Ada exception"),
12449 excep_string.c_str ());
12451 uiout->field_string ("what", msg);
12454 uiout->field_string ("what", "all Ada exceptions");
12458 case ada_catch_exception_unhandled:
12459 uiout->field_string ("what", "unhandled Ada exceptions");
12462 case ada_catch_handlers:
12463 if (!excep_string.empty ())
12465 uiout->field_fmt ("what",
12466 _("`%s' Ada exception handlers"),
12467 excep_string.c_str ());
12470 uiout->field_string ("what", "all Ada exceptions handlers");
12473 case ada_catch_assert:
12474 uiout->field_string ("what", "failed Ada assertions");
12478 internal_error (_("unexpected catchpoint type"));
12485 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12486 for all exception catchpoint kinds. */
12489 ada_catchpoint::print_mention () const
12491 struct ui_out *uiout = current_uiout;
12493 uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12494 : _("Catchpoint "));
12495 uiout->field_signed ("bkptno", number);
12496 uiout->text (": ");
12500 case ada_catch_exception:
12501 if (!excep_string.empty ())
12503 std::string info = string_printf (_("`%s' Ada exception"),
12504 excep_string.c_str ());
12505 uiout->text (info);
12508 uiout->text (_("all Ada exceptions"));
12511 case ada_catch_exception_unhandled:
12512 uiout->text (_("unhandled Ada exceptions"));
12515 case ada_catch_handlers:
12516 if (!excep_string.empty ())
12519 = string_printf (_("`%s' Ada exception handlers"),
12520 excep_string.c_str ());
12521 uiout->text (info);
12524 uiout->text (_("all Ada exceptions handlers"));
12527 case ada_catch_assert:
12528 uiout->text (_("failed Ada assertions"));
12532 internal_error (_("unexpected catchpoint type"));
12537 /* Implement the PRINT_RECREATE method in the structure for all
12538 exception catchpoint kinds. */
12541 ada_catchpoint::print_recreate (struct ui_file *fp) const
12545 case ada_catch_exception:
12546 gdb_printf (fp, "catch exception");
12547 if (!excep_string.empty ())
12548 gdb_printf (fp, " %s", excep_string.c_str ());
12551 case ada_catch_exception_unhandled:
12552 gdb_printf (fp, "catch exception unhandled");
12555 case ada_catch_handlers:
12556 gdb_printf (fp, "catch handlers");
12559 case ada_catch_assert:
12560 gdb_printf (fp, "catch assert");
12564 internal_error (_("unexpected catchpoint type"));
12566 print_recreate_thread (fp);
12569 /* See ada-lang.h. */
12572 is_ada_exception_catchpoint (breakpoint *bp)
12574 return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12577 /* Split the arguments specified in a "catch exception" command.
12578 Set EX to the appropriate catchpoint type.
12579 Set EXCEP_STRING to the name of the specific exception if
12580 specified by the user.
12581 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12582 "catch handlers" command. False otherwise.
12583 If a condition is found at the end of the arguments, the condition
12584 expression is stored in COND_STRING (memory must be deallocated
12585 after use). Otherwise COND_STRING is set to NULL. */
12588 catch_ada_exception_command_split (const char *args,
12589 bool is_catch_handlers_cmd,
12590 enum ada_exception_catchpoint_kind *ex,
12591 std::string *excep_string,
12592 std::string *cond_string)
12594 std::string exception_name;
12596 exception_name = extract_arg (&args);
12597 if (exception_name == "if")
12599 /* This is not an exception name; this is the start of a condition
12600 expression for a catchpoint on all exceptions. So, "un-get"
12601 this token, and set exception_name to NULL. */
12602 exception_name.clear ();
12606 /* Check to see if we have a condition. */
12608 args = skip_spaces (args);
12609 if (startswith (args, "if")
12610 && (isspace (args[2]) || args[2] == '\0'))
12613 args = skip_spaces (args);
12615 if (args[0] == '\0')
12616 error (_("Condition missing after `if' keyword"));
12617 *cond_string = args;
12619 args += strlen (args);
12622 /* Check that we do not have any more arguments. Anything else
12625 if (args[0] != '\0')
12626 error (_("Junk at end of expression"));
12628 if (is_catch_handlers_cmd)
12630 /* Catch handling of exceptions. */
12631 *ex = ada_catch_handlers;
12632 *excep_string = exception_name;
12634 else if (exception_name.empty ())
12636 /* Catch all exceptions. */
12637 *ex = ada_catch_exception;
12638 excep_string->clear ();
12640 else if (exception_name == "unhandled")
12642 /* Catch unhandled exceptions. */
12643 *ex = ada_catch_exception_unhandled;
12644 excep_string->clear ();
12648 /* Catch a specific exception. */
12649 *ex = ada_catch_exception;
12650 *excep_string = exception_name;
12654 /* Return the name of the symbol on which we should break in order to
12655 implement a catchpoint of the EX kind. */
12657 static const char *
12658 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12660 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12662 gdb_assert (data->exception_info != NULL);
12666 case ada_catch_exception:
12667 return (data->exception_info->catch_exception_sym);
12669 case ada_catch_exception_unhandled:
12670 return (data->exception_info->catch_exception_unhandled_sym);
12672 case ada_catch_assert:
12673 return (data->exception_info->catch_assert_sym);
12675 case ada_catch_handlers:
12676 return (data->exception_info->catch_handlers_sym);
12679 internal_error (_("unexpected catchpoint kind (%d)"), ex);
12683 /* Return the condition that will be used to match the current exception
12684 being raised with the exception that the user wants to catch. This
12685 assumes that this condition is used when the inferior just triggered
12686 an exception catchpoint.
12687 EX: the type of catchpoints used for catching Ada exceptions. */
12690 ada_exception_catchpoint_cond_string (const char *excep_string,
12691 enum ada_exception_catchpoint_kind ex)
12693 bool is_standard_exc = false;
12694 std::string result;
12696 if (ex == ada_catch_handlers)
12698 /* For exception handlers catchpoints, the condition string does
12699 not use the same parameter as for the other exceptions. */
12700 result = ("long_integer (GNAT_GCC_exception_Access"
12701 "(gcc_exception).all.occurrence.id)");
12704 result = "long_integer (e)";
12706 /* The standard exceptions are a special case. They are defined in
12707 runtime units that have been compiled without debugging info; if
12708 EXCEP_STRING is the not-fully-qualified name of a standard
12709 exception (e.g. "constraint_error") then, during the evaluation
12710 of the condition expression, the symbol lookup on this name would
12711 *not* return this standard exception. The catchpoint condition
12712 may then be set only on user-defined exceptions which have the
12713 same not-fully-qualified name (e.g. my_package.constraint_error).
12715 To avoid this unexcepted behavior, these standard exceptions are
12716 systematically prefixed by "standard". This means that "catch
12717 exception constraint_error" is rewritten into "catch exception
12718 standard.constraint_error".
12720 If an exception named constraint_error is defined in another package of
12721 the inferior program, then the only way to specify this exception as a
12722 breakpoint condition is to use its fully-qualified named:
12723 e.g. my_package.constraint_error. */
12725 for (const char *name : standard_exc)
12727 if (strcmp (name, excep_string) == 0)
12729 is_standard_exc = true;
12736 if (is_standard_exc)
12737 string_appendf (result, "long_integer (&standard.%s)", excep_string);
12739 string_appendf (result, "long_integer (&%s)", excep_string);
12744 /* Return the symtab_and_line that should be used to insert an exception
12745 catchpoint of the TYPE kind.
12747 ADDR_STRING returns the name of the function where the real
12748 breakpoint that implements the catchpoints is set, depending on the
12749 type of catchpoint we need to create. */
12751 static struct symtab_and_line
12752 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12753 std::string *addr_string)
12755 const char *sym_name;
12756 struct symbol *sym;
12758 /* First, find out which exception support info to use. */
12759 ada_exception_support_info_sniffer ();
12761 /* Then lookup the function on which we will break in order to catch
12762 the Ada exceptions requested by the user. */
12763 sym_name = ada_exception_sym_name (ex);
12764 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12767 error (_("Catchpoint symbol not found: %s"), sym_name);
12769 if (sym->aclass () != LOC_BLOCK)
12770 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12772 /* Set ADDR_STRING. */
12773 *addr_string = sym_name;
12775 return find_function_start_sal (sym, 1);
12778 /* Create an Ada exception catchpoint.
12780 EX_KIND is the kind of exception catchpoint to be created.
12782 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12783 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12784 of the exception to which this catchpoint applies.
12786 COND_STRING, if not empty, is the catchpoint condition.
12788 TEMPFLAG, if nonzero, means that the underlying breakpoint
12789 should be temporary.
12791 FROM_TTY is the usual argument passed to all commands implementations. */
12794 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12795 enum ada_exception_catchpoint_kind ex_kind,
12796 const std::string &excep_string,
12797 const std::string &cond_string,
12802 std::string addr_string;
12803 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12805 std::unique_ptr<ada_catchpoint> c
12806 (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12807 tempflag, disabled, from_tty));
12808 c->excep_string = excep_string;
12809 create_excep_cond_exprs (c.get (), ex_kind);
12810 if (!cond_string.empty ())
12811 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12812 install_breakpoint (0, std::move (c), 1);
12815 /* Implement the "catch exception" command. */
12818 catch_ada_exception_command (const char *arg_entry, int from_tty,
12819 struct cmd_list_element *command)
12821 const char *arg = arg_entry;
12822 struct gdbarch *gdbarch = get_current_arch ();
12824 enum ada_exception_catchpoint_kind ex_kind;
12825 std::string excep_string;
12826 std::string cond_string;
12828 tempflag = command->context () == CATCH_TEMPORARY;
12832 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12834 create_ada_exception_catchpoint (gdbarch, ex_kind,
12835 excep_string, cond_string,
12836 tempflag, 1 /* enabled */,
12840 /* Implement the "catch handlers" command. */
12843 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12844 struct cmd_list_element *command)
12846 const char *arg = arg_entry;
12847 struct gdbarch *gdbarch = get_current_arch ();
12849 enum ada_exception_catchpoint_kind ex_kind;
12850 std::string excep_string;
12851 std::string cond_string;
12853 tempflag = command->context () == CATCH_TEMPORARY;
12857 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12859 create_ada_exception_catchpoint (gdbarch, ex_kind,
12860 excep_string, cond_string,
12861 tempflag, 1 /* enabled */,
12865 /* Completion function for the Ada "catch" commands. */
12868 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12869 const char *text, const char *word)
12871 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12873 for (const ada_exc_info &info : exceptions)
12875 if (startswith (info.name, word))
12876 tracker.add_completion (make_unique_xstrdup (info.name));
12880 /* Split the arguments specified in a "catch assert" command.
12882 ARGS contains the command's arguments (or the empty string if
12883 no arguments were passed).
12885 If ARGS contains a condition, set COND_STRING to that condition
12886 (the memory needs to be deallocated after use). */
12889 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12891 args = skip_spaces (args);
12893 /* Check whether a condition was provided. */
12894 if (startswith (args, "if")
12895 && (isspace (args[2]) || args[2] == '\0'))
12898 args = skip_spaces (args);
12899 if (args[0] == '\0')
12900 error (_("condition missing after `if' keyword"));
12901 cond_string.assign (args);
12904 /* Otherwise, there should be no other argument at the end of
12906 else if (args[0] != '\0')
12907 error (_("Junk at end of arguments."));
12910 /* Implement the "catch assert" command. */
12913 catch_assert_command (const char *arg_entry, int from_tty,
12914 struct cmd_list_element *command)
12916 const char *arg = arg_entry;
12917 struct gdbarch *gdbarch = get_current_arch ();
12919 std::string cond_string;
12921 tempflag = command->context () == CATCH_TEMPORARY;
12925 catch_ada_assert_command_split (arg, cond_string);
12926 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12928 tempflag, 1 /* enabled */,
12932 /* Return non-zero if the symbol SYM is an Ada exception object. */
12935 ada_is_exception_sym (struct symbol *sym)
12937 const char *type_name = sym->type ()->name ();
12939 return (sym->aclass () != LOC_TYPEDEF
12940 && sym->aclass () != LOC_BLOCK
12941 && sym->aclass () != LOC_CONST
12942 && sym->aclass () != LOC_UNRESOLVED
12943 && type_name != NULL && strcmp (type_name, "exception") == 0);
12946 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12947 Ada exception object. This matches all exceptions except the ones
12948 defined by the Ada language. */
12951 ada_is_non_standard_exception_sym (struct symbol *sym)
12953 if (!ada_is_exception_sym (sym))
12956 for (const char *name : standard_exc)
12957 if (strcmp (sym->linkage_name (), name) == 0)
12958 return 0; /* A standard exception. */
12960 /* Numeric_Error is also a standard exception, so exclude it.
12961 See the STANDARD_EXC description for more details as to why
12962 this exception is not listed in that array. */
12963 if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12969 /* A helper function for std::sort, comparing two struct ada_exc_info
12972 The comparison is determined first by exception name, and then
12973 by exception address. */
12976 ada_exc_info::operator< (const ada_exc_info &other) const
12980 result = strcmp (name, other.name);
12983 if (result == 0 && addr < other.addr)
12989 ada_exc_info::operator== (const ada_exc_info &other) const
12991 return addr == other.addr && strcmp (name, other.name) == 0;
12994 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12995 routine, but keeping the first SKIP elements untouched.
12997 All duplicates are also removed. */
13000 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13003 std::sort (exceptions->begin () + skip, exceptions->end ());
13004 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13005 exceptions->end ());
13008 /* Add all exceptions defined by the Ada standard whose name match
13009 a regular expression.
13011 If PREG is not NULL, then this regexp_t object is used to
13012 perform the symbol name matching. Otherwise, no name-based
13013 filtering is performed.
13015 EXCEPTIONS is a vector of exceptions to which matching exceptions
13019 ada_add_standard_exceptions (compiled_regex *preg,
13020 std::vector<ada_exc_info> *exceptions)
13022 for (const char *name : standard_exc)
13024 if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13026 symbol_name_match_type match_type = name_match_type_from_name (name);
13027 lookup_name_info lookup_name (name, match_type);
13029 symbol_name_matcher_ftype *match_name
13030 = ada_get_symbol_name_matcher (lookup_name);
13032 /* Iterate over all objfiles irrespective of scope or linker
13033 namespaces so we get all exceptions anywhere in the
13035 for (objfile *objfile : current_program_space->objfiles ())
13037 for (minimal_symbol *msymbol : objfile->msymbols ())
13039 if (match_name (msymbol->linkage_name (), lookup_name,
13041 && msymbol->type () != mst_solib_trampoline)
13044 = {name, msymbol->value_address (objfile)};
13046 exceptions->push_back (info);
13054 /* Add all Ada exceptions defined locally and accessible from the given
13057 If PREG is not NULL, then this regexp_t object is used to
13058 perform the symbol name matching. Otherwise, no name-based
13059 filtering is performed.
13061 EXCEPTIONS is a vector of exceptions to which matching exceptions
13065 ada_add_exceptions_from_frame (compiled_regex *preg,
13066 frame_info_ptr frame,
13067 std::vector<ada_exc_info> *exceptions)
13069 const struct block *block = get_frame_block (frame, 0);
13073 struct block_iterator iter;
13074 struct symbol *sym;
13076 ALL_BLOCK_SYMBOLS (block, iter, sym)
13078 switch (sym->aclass ())
13085 if (ada_is_exception_sym (sym))
13087 struct ada_exc_info info = {sym->print_name (),
13088 sym->value_address ()};
13090 exceptions->push_back (info);
13094 if (block->function () != NULL)
13096 block = block->superblock ();
13100 /* Return true if NAME matches PREG or if PREG is NULL. */
13103 name_matches_regex (const char *name, compiled_regex *preg)
13105 return (preg == NULL
13106 || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13109 /* Add all exceptions defined globally whose name name match
13110 a regular expression, excluding standard exceptions.
13112 The reason we exclude standard exceptions is that they need
13113 to be handled separately: Standard exceptions are defined inside
13114 a runtime unit which is normally not compiled with debugging info,
13115 and thus usually do not show up in our symbol search. However,
13116 if the unit was in fact built with debugging info, we need to
13117 exclude them because they would duplicate the entry we found
13118 during the special loop that specifically searches for those
13119 standard exceptions.
13121 If PREG is not NULL, then this regexp_t object is used to
13122 perform the symbol name matching. Otherwise, no name-based
13123 filtering is performed.
13125 EXCEPTIONS is a vector of exceptions to which matching exceptions
13129 ada_add_global_exceptions (compiled_regex *preg,
13130 std::vector<ada_exc_info> *exceptions)
13132 /* In Ada, the symbol "search name" is a linkage name, whereas the
13133 regular expression used to do the matching refers to the natural
13134 name. So match against the decoded name. */
13135 expand_symtabs_matching (NULL,
13136 lookup_name_info::match_any (),
13137 [&] (const char *search_name)
13139 std::string decoded = ada_decode (search_name);
13140 return name_matches_regex (decoded.c_str (), preg);
13143 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13146 /* Iterate over all objfiles irrespective of scope or linker namespaces
13147 so we get all exceptions anywhere in the progspace. */
13148 for (objfile *objfile : current_program_space->objfiles ())
13150 for (compunit_symtab *s : objfile->compunits ())
13152 const struct blockvector *bv = s->blockvector ();
13155 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13157 const struct block *b = bv->block (i);
13158 struct block_iterator iter;
13159 struct symbol *sym;
13161 ALL_BLOCK_SYMBOLS (b, iter, sym)
13162 if (ada_is_non_standard_exception_sym (sym)
13163 && name_matches_regex (sym->natural_name (), preg))
13165 struct ada_exc_info info
13166 = {sym->print_name (), sym->value_address ()};
13168 exceptions->push_back (info);
13175 /* Implements ada_exceptions_list with the regular expression passed
13176 as a regex_t, rather than a string.
13178 If not NULL, PREG is used to filter out exceptions whose names
13179 do not match. Otherwise, all exceptions are listed. */
13181 static std::vector<ada_exc_info>
13182 ada_exceptions_list_1 (compiled_regex *preg)
13184 std::vector<ada_exc_info> result;
13187 /* First, list the known standard exceptions. These exceptions
13188 need to be handled separately, as they are usually defined in
13189 runtime units that have been compiled without debugging info. */
13191 ada_add_standard_exceptions (preg, &result);
13193 /* Next, find all exceptions whose scope is local and accessible
13194 from the currently selected frame. */
13196 if (has_stack_frames ())
13198 prev_len = result.size ();
13199 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13201 if (result.size () > prev_len)
13202 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13205 /* Add all exceptions whose scope is global. */
13207 prev_len = result.size ();
13208 ada_add_global_exceptions (preg, &result);
13209 if (result.size () > prev_len)
13210 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13215 /* Return a vector of ada_exc_info.
13217 If REGEXP is NULL, all exceptions are included in the result.
13218 Otherwise, it should contain a valid regular expression,
13219 and only the exceptions whose names match that regular expression
13220 are included in the result.
13222 The exceptions are sorted in the following order:
13223 - Standard exceptions (defined by the Ada language), in
13224 alphabetical order;
13225 - Exceptions only visible from the current frame, in
13226 alphabetical order;
13227 - Exceptions whose scope is global, in alphabetical order. */
13229 std::vector<ada_exc_info>
13230 ada_exceptions_list (const char *regexp)
13232 if (regexp == NULL)
13233 return ada_exceptions_list_1 (NULL);
13235 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13236 return ada_exceptions_list_1 (®);
13239 /* Implement the "info exceptions" command. */
13242 info_exceptions_command (const char *regexp, int from_tty)
13244 struct gdbarch *gdbarch = get_current_arch ();
13246 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13248 if (regexp != NULL)
13250 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13252 gdb_printf (_("All defined Ada exceptions:\n"));
13254 for (const ada_exc_info &info : exceptions)
13255 gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13259 /* Language vector */
13261 /* symbol_name_matcher_ftype adapter for wild_match. */
13264 do_wild_match (const char *symbol_search_name,
13265 const lookup_name_info &lookup_name,
13266 completion_match_result *comp_match_res)
13268 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13271 /* symbol_name_matcher_ftype adapter for full_match. */
13274 do_full_match (const char *symbol_search_name,
13275 const lookup_name_info &lookup_name,
13276 completion_match_result *comp_match_res)
13278 const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13280 /* If both symbols start with "_ada_", just let the loop below
13281 handle the comparison. However, if only the symbol name starts
13282 with "_ada_", skip the prefix and let the match proceed as
13284 if (startswith (symbol_search_name, "_ada_")
13285 && !startswith (lname, "_ada"))
13286 symbol_search_name += 5;
13287 /* Likewise for ghost entities. */
13288 if (startswith (symbol_search_name, "___ghost_")
13289 && !startswith (lname, "___ghost_"))
13290 symbol_search_name += 9;
13292 int uscore_count = 0;
13293 while (*lname != '\0')
13295 if (*symbol_search_name != *lname)
13297 if (*symbol_search_name == 'B' && uscore_count == 2
13298 && symbol_search_name[1] == '_')
13300 symbol_search_name += 2;
13301 while (isdigit (*symbol_search_name))
13302 ++symbol_search_name;
13303 if (symbol_search_name[0] == '_'
13304 && symbol_search_name[1] == '_')
13306 symbol_search_name += 2;
13313 if (*symbol_search_name == '_')
13318 ++symbol_search_name;
13322 return is_name_suffix (symbol_search_name);
13325 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13328 do_exact_match (const char *symbol_search_name,
13329 const lookup_name_info &lookup_name,
13330 completion_match_result *comp_match_res)
13332 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13335 /* Build the Ada lookup name for LOOKUP_NAME. */
13337 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13339 gdb::string_view user_name = lookup_name.name ();
13341 if (!user_name.empty () && user_name[0] == '<')
13343 if (user_name.back () == '>')
13345 = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13348 = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13349 m_encoded_p = true;
13350 m_verbatim_p = true;
13351 m_wild_match_p = false;
13352 m_standard_p = false;
13356 m_verbatim_p = false;
13358 m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13362 const char *folded = ada_fold_name (user_name);
13363 m_encoded_name = ada_encode_1 (folded, false);
13364 if (m_encoded_name.empty ())
13365 m_encoded_name = gdb::to_string (user_name);
13368 m_encoded_name = gdb::to_string (user_name);
13370 /* Handle the 'package Standard' special case. See description
13371 of m_standard_p. */
13372 if (startswith (m_encoded_name.c_str (), "standard__"))
13374 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13375 m_standard_p = true;
13378 m_standard_p = false;
13380 /* If the name contains a ".", then the user is entering a fully
13381 qualified entity name, and the match must not be done in wild
13382 mode. Similarly, if the user wants to complete what looks
13383 like an encoded name, the match must not be done in wild
13384 mode. Also, in the standard__ special case always do
13385 non-wild matching. */
13387 = (lookup_name.match_type () != symbol_name_match_type::FULL
13390 && user_name.find ('.') == std::string::npos);
13394 /* symbol_name_matcher_ftype method for Ada. This only handles
13395 completion mode. */
13398 ada_symbol_name_matches (const char *symbol_search_name,
13399 const lookup_name_info &lookup_name,
13400 completion_match_result *comp_match_res)
13402 return lookup_name.ada ().matches (symbol_search_name,
13403 lookup_name.match_type (),
13407 /* A name matcher that matches the symbol name exactly, with
13411 literal_symbol_name_matcher (const char *symbol_search_name,
13412 const lookup_name_info &lookup_name,
13413 completion_match_result *comp_match_res)
13415 gdb::string_view name_view = lookup_name.name ();
13417 if (lookup_name.completion_mode ()
13418 ? (strncmp (symbol_search_name, name_view.data (),
13419 name_view.size ()) == 0)
13420 : symbol_search_name == name_view)
13422 if (comp_match_res != NULL)
13423 comp_match_res->set_match (symbol_search_name);
13430 /* Implement the "get_symbol_name_matcher" language_defn method for
13433 static symbol_name_matcher_ftype *
13434 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13436 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13437 return literal_symbol_name_matcher;
13439 if (lookup_name.completion_mode ())
13440 return ada_symbol_name_matches;
13443 if (lookup_name.ada ().wild_match_p ())
13444 return do_wild_match;
13445 else if (lookup_name.ada ().verbatim_p ())
13446 return do_exact_match;
13448 return do_full_match;
13452 /* Class representing the Ada language. */
13454 class ada_language : public language_defn
13458 : language_defn (language_ada)
13461 /* See language.h. */
13463 const char *name () const override
13466 /* See language.h. */
13468 const char *natural_name () const override
13471 /* See language.h. */
13473 const std::vector<const char *> &filename_extensions () const override
13475 static const std::vector<const char *> extensions
13476 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13480 /* Print an array element index using the Ada syntax. */
13482 void print_array_index (struct type *index_type,
13484 struct ui_file *stream,
13485 const value_print_options *options) const override
13487 struct value *index_value = val_atr (index_type, index);
13489 value_print (index_value, stream, options);
13490 gdb_printf (stream, " => ");
13493 /* Implement the "read_var_value" language_defn method for Ada. */
13495 struct value *read_var_value (struct symbol *var,
13496 const struct block *var_block,
13497 frame_info_ptr frame) const override
13499 /* The only case where default_read_var_value is not sufficient
13500 is when VAR is a renaming... */
13501 if (frame != nullptr)
13503 const struct block *frame_block = get_frame_block (frame, NULL);
13504 if (frame_block != nullptr && ada_is_renaming_symbol (var))
13505 return ada_read_renaming_var_value (var, frame_block);
13508 /* This is a typical case where we expect the default_read_var_value
13509 function to work. */
13510 return language_defn::read_var_value (var, var_block, frame);
13513 /* See language.h. */
13514 bool symbol_printing_suppressed (struct symbol *symbol) const override
13516 return symbol->is_artificial ();
13519 /* See language.h. */
13520 void language_arch_info (struct gdbarch *gdbarch,
13521 struct language_arch_info *lai) const override
13523 const struct builtin_type *builtin = builtin_type (gdbarch);
13525 /* Helper function to allow shorter lines below. */
13526 auto add = [&] (struct type *t)
13528 lai->add_primitive_type (t);
13531 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13533 add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13534 0, "long_integer"));
13535 add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13536 0, "short_integer"));
13537 struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13539 lai->set_string_char_type (char_type);
13541 add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13542 add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13543 add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13544 "float", gdbarch_float_format (gdbarch)));
13545 add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13546 "long_float", gdbarch_double_format (gdbarch)));
13547 add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13548 0, "long_long_integer"));
13549 add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13551 gdbarch_long_double_format (gdbarch)));
13552 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13554 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13556 add (builtin->builtin_void);
13558 struct type *system_addr_ptr
13559 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13561 system_addr_ptr->set_name ("system__address");
13562 add (system_addr_ptr);
13564 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13565 type. This is a signed integral type whose size is the same as
13566 the size of addresses. */
13567 unsigned int addr_length = system_addr_ptr->length ();
13568 add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13569 "storage_offset"));
13571 lai->set_bool_type (builtin->builtin_bool);
13574 /* See language.h. */
13576 bool iterate_over_symbols
13577 (const struct block *block, const lookup_name_info &name,
13578 domain_enum domain,
13579 gdb::function_view<symbol_found_callback_ftype> callback) const override
13581 std::vector<struct block_symbol> results
13582 = ada_lookup_symbol_list_worker (name, block, domain, 0);
13583 for (block_symbol &sym : results)
13585 if (!callback (&sym))
13592 /* See language.h. */
13593 bool sniff_from_mangled_name
13594 (const char *mangled,
13595 gdb::unique_xmalloc_ptr<char> *out) const override
13597 std::string demangled = ada_decode (mangled);
13601 if (demangled != mangled && demangled[0] != '<')
13603 /* Set the gsymbol language to Ada, but still return 0.
13604 Two reasons for that:
13606 1. For Ada, we prefer computing the symbol's decoded name
13607 on the fly rather than pre-compute it, in order to save
13608 memory (Ada projects are typically very large).
13610 2. There are some areas in the definition of the GNAT
13611 encoding where, with a bit of bad luck, we might be able
13612 to decode a non-Ada symbol, generating an incorrect
13613 demangled name (Eg: names ending with "TB" for instance
13614 are identified as task bodies and so stripped from
13615 the decoded name returned).
13617 Returning true, here, but not setting *DEMANGLED, helps us get
13618 a little bit of the best of both worlds. Because we're last,
13619 we should not affect any of the other languages that were
13620 able to demangle the symbol before us; we get to correctly
13621 tag Ada symbols as such; and even if we incorrectly tagged a
13622 non-Ada symbol, which should be rare, any routing through the
13623 Ada language should be transparent (Ada tries to behave much
13624 like C/C++ with non-Ada symbols). */
13631 /* See language.h. */
13633 gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13634 int options) const override
13636 return make_unique_xstrdup (ada_decode (mangled).c_str ());
13639 /* See language.h. */
13641 void print_type (struct type *type, const char *varstring,
13642 struct ui_file *stream, int show, int level,
13643 const struct type_print_options *flags) const override
13645 ada_print_type (type, varstring, stream, show, level, flags);
13648 /* See language.h. */
13650 const char *word_break_characters (void) const override
13652 return ada_completer_word_break_characters;
13655 /* See language.h. */
13657 void collect_symbol_completion_matches (completion_tracker &tracker,
13658 complete_symbol_mode mode,
13659 symbol_name_match_type name_match_type,
13660 const char *text, const char *word,
13661 enum type_code code) const override
13663 struct symbol *sym;
13664 const struct block *b, *surrounding_static_block = 0;
13665 struct block_iterator iter;
13667 gdb_assert (code == TYPE_CODE_UNDEF);
13669 lookup_name_info lookup_name (text, name_match_type, true);
13671 /* First, look at the partial symtab symbols. */
13672 expand_symtabs_matching (NULL,
13676 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13679 /* At this point scan through the misc symbol vectors and add each
13680 symbol you find to the list. Eventually we want to ignore
13681 anything that isn't a text symbol (everything else will be
13682 handled by the psymtab code above). */
13684 for (objfile *objfile : current_program_space->objfiles ())
13686 for (minimal_symbol *msymbol : objfile->msymbols ())
13690 if (completion_skip_symbol (mode, msymbol))
13693 language symbol_language = msymbol->language ();
13695 /* Ada minimal symbols won't have their language set to Ada. If
13696 we let completion_list_add_name compare using the
13697 default/C-like matcher, then when completing e.g., symbols in a
13698 package named "pck", we'd match internal Ada symbols like
13699 "pckS", which are invalid in an Ada expression, unless you wrap
13700 them in '<' '>' to request a verbatim match.
13702 Unfortunately, some Ada encoded names successfully demangle as
13703 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13704 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13705 with the wrong language set. Paper over that issue here. */
13706 if (symbol_language == language_auto
13707 || symbol_language == language_cplus)
13708 symbol_language = language_ada;
13710 completion_list_add_name (tracker,
13712 msymbol->linkage_name (),
13713 lookup_name, text, word);
13717 /* Search upwards from currently selected frame (so that we can
13718 complete on local vars. */
13720 for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13722 if (!b->superblock ())
13723 surrounding_static_block = b; /* For elmin of dups */
13725 ALL_BLOCK_SYMBOLS (b, iter, sym)
13727 if (completion_skip_symbol (mode, sym))
13730 completion_list_add_name (tracker,
13732 sym->linkage_name (),
13733 lookup_name, text, word);
13737 /* Go through the symtabs and check the externs and statics for
13738 symbols which match. */
13740 for (objfile *objfile : current_program_space->objfiles ())
13742 for (compunit_symtab *s : objfile->compunits ())
13745 b = s->blockvector ()->global_block ();
13746 ALL_BLOCK_SYMBOLS (b, iter, sym)
13748 if (completion_skip_symbol (mode, sym))
13751 completion_list_add_name (tracker,
13753 sym->linkage_name (),
13754 lookup_name, text, word);
13759 for (objfile *objfile : current_program_space->objfiles ())
13761 for (compunit_symtab *s : objfile->compunits ())
13764 b = s->blockvector ()->static_block ();
13765 /* Don't do this block twice. */
13766 if (b == surrounding_static_block)
13768 ALL_BLOCK_SYMBOLS (b, iter, sym)
13770 if (completion_skip_symbol (mode, sym))
13773 completion_list_add_name (tracker,
13775 sym->linkage_name (),
13776 lookup_name, text, word);
13782 /* See language.h. */
13784 gdb::unique_xmalloc_ptr<char> watch_location_expression
13785 (struct type *type, CORE_ADDR addr) const override
13787 type = check_typedef (check_typedef (type)->target_type ());
13788 std::string name = type_to_string (type);
13789 return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13792 /* See language.h. */
13794 void value_print (struct value *val, struct ui_file *stream,
13795 const struct value_print_options *options) const override
13797 return ada_value_print (val, stream, options);
13800 /* See language.h. */
13802 void value_print_inner
13803 (struct value *val, struct ui_file *stream, int recurse,
13804 const struct value_print_options *options) const override
13806 return ada_value_print_inner (val, stream, recurse, options);
13809 /* See language.h. */
13811 struct block_symbol lookup_symbol_nonlocal
13812 (const char *name, const struct block *block,
13813 const domain_enum domain) const override
13815 struct block_symbol sym;
13817 sym = ada_lookup_symbol (name, block_static_block (block), domain);
13818 if (sym.symbol != NULL)
13821 /* If we haven't found a match at this point, try the primitive
13822 types. In other languages, this search is performed before
13823 searching for global symbols in order to short-circuit that
13824 global-symbol search if it happens that the name corresponds
13825 to a primitive type. But we cannot do the same in Ada, because
13826 it is perfectly legitimate for a program to declare a type which
13827 has the same name as a standard type. If looking up a type in
13828 that situation, we have traditionally ignored the primitive type
13829 in favor of user-defined types. This is why, unlike most other
13830 languages, we search the primitive types this late and only after
13831 having searched the global symbols without success. */
13833 if (domain == VAR_DOMAIN)
13835 struct gdbarch *gdbarch;
13838 gdbarch = target_gdbarch ();
13840 gdbarch = block_gdbarch (block);
13842 = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13843 if (sym.symbol != NULL)
13850 /* See language.h. */
13852 int parser (struct parser_state *ps) const override
13854 warnings_issued = 0;
13855 return ada_parse (ps);
13858 /* See language.h. */
13860 void emitchar (int ch, struct type *chtype,
13861 struct ui_file *stream, int quoter) const override
13863 ada_emit_char (ch, chtype, stream, quoter, 1);
13866 /* See language.h. */
13868 void printchar (int ch, struct type *chtype,
13869 struct ui_file *stream) const override
13871 ada_printchar (ch, chtype, stream);
13874 /* See language.h. */
13876 void printstr (struct ui_file *stream, struct type *elttype,
13877 const gdb_byte *string, unsigned int length,
13878 const char *encoding, int force_ellipses,
13879 const struct value_print_options *options) const override
13881 ada_printstr (stream, elttype, string, length, encoding,
13882 force_ellipses, options);
13885 /* See language.h. */
13887 void print_typedef (struct type *type, struct symbol *new_symbol,
13888 struct ui_file *stream) const override
13890 ada_print_typedef (type, new_symbol, stream);
13893 /* See language.h. */
13895 bool is_string_type_p (struct type *type) const override
13897 return ada_is_string_type (type);
13900 /* See language.h. */
13902 const char *struct_too_deep_ellipsis () const override
13903 { return "(...)"; }
13905 /* See language.h. */
13907 bool c_style_arrays_p () const override
13910 /* See language.h. */
13912 bool store_sym_names_in_linkage_form_p () const override
13915 /* See language.h. */
13917 const struct lang_varobj_ops *varobj_ops () const override
13918 { return &ada_varobj_ops; }
13921 /* See language.h. */
13923 symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13924 (const lookup_name_info &lookup_name) const override
13926 return ada_get_symbol_name_matcher (lookup_name);
13930 /* Single instance of the Ada language class. */
13932 static ada_language ada_language_defn;
13934 /* Command-list for the "set/show ada" prefix command. */
13935 static struct cmd_list_element *set_ada_list;
13936 static struct cmd_list_element *show_ada_list;
13938 /* This module's 'new_objfile' observer. */
13941 ada_new_objfile_observer (struct objfile *objfile)
13943 ada_clear_symbol_cache ();
13946 /* This module's 'free_objfile' observer. */
13949 ada_free_objfile_observer (struct objfile *objfile)
13951 ada_clear_symbol_cache ();
13954 /* Charsets known to GNAT. */
13955 static const char * const gnat_source_charsets[] =
13957 /* Note that code below assumes that the default comes first.
13958 Latin-1 is the default here, because that is also GNAT's
13968 /* Note that this value is special-cased in the encoder and
13974 void _initialize_ada_language ();
13976 _initialize_ada_language ()
13978 add_setshow_prefix_cmd
13980 _("Prefix command for changing Ada-specific settings."),
13981 _("Generic command for showing Ada-specific settings."),
13982 &set_ada_list, &show_ada_list,
13983 &setlist, &showlist);
13985 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13986 &trust_pad_over_xvs, _("\
13987 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13988 Show whether an optimization trusting PAD types over XVS types is activated."),
13990 This is related to the encoding used by the GNAT compiler. The debugger\n\
13991 should normally trust the contents of PAD types, but certain older versions\n\
13992 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13993 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13994 work around this bug. It is always safe to turn this option \"off\", but\n\
13995 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13996 this option to \"off\" unless necessary."),
13997 NULL, NULL, &set_ada_list, &show_ada_list);
13999 add_setshow_boolean_cmd ("print-signatures", class_vars,
14000 &print_signatures, _("\
14001 Enable or disable the output of formal and return types for functions in the \
14002 overloads selection menu."), _("\
14003 Show whether the output of formal and return types for functions in the \
14004 overloads selection menu is activated."),
14005 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14007 ada_source_charset = gnat_source_charsets[0];
14008 add_setshow_enum_cmd ("source-charset", class_files,
14009 gnat_source_charsets,
14010 &ada_source_charset, _("\
14011 Set the Ada source character set."), _("\
14012 Show the Ada source character set."), _("\
14013 The character set used for Ada source files.\n\
14014 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14016 &set_ada_list, &show_ada_list);
14018 add_catch_command ("exception", _("\
14019 Catch Ada exceptions, when raised.\n\
14020 Usage: catch exception [ARG] [if CONDITION]\n\
14021 Without any argument, stop when any Ada exception is raised.\n\
14022 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14023 being raised does not have a handler (and will therefore lead to the task's\n\
14025 Otherwise, the catchpoint only stops when the name of the exception being\n\
14026 raised is the same as ARG.\n\
14027 CONDITION is a boolean expression that is evaluated to see whether the\n\
14028 exception should cause a stop."),
14029 catch_ada_exception_command,
14030 catch_ada_completer,
14034 add_catch_command ("handlers", _("\
14035 Catch Ada exceptions, when handled.\n\
14036 Usage: catch handlers [ARG] [if CONDITION]\n\
14037 Without any argument, stop when any Ada exception is handled.\n\
14038 With an argument, catch only exceptions with the given name.\n\
14039 CONDITION is a boolean expression that is evaluated to see whether the\n\
14040 exception should cause a stop."),
14041 catch_ada_handlers_command,
14042 catch_ada_completer,
14045 add_catch_command ("assert", _("\
14046 Catch failed Ada assertions, when raised.\n\
14047 Usage: catch assert [if CONDITION]\n\
14048 CONDITION is a boolean expression that is evaluated to see whether the\n\
14049 exception should cause a stop."),
14050 catch_assert_command,
14055 add_info ("exceptions", info_exceptions_command,
14057 List all Ada exception names.\n\
14058 Usage: info exceptions [REGEXP]\n\
14059 If a regular expression is passed as an argument, only those matching\n\
14060 the regular expression are listed."));
14062 add_setshow_prefix_cmd ("ada", class_maintenance,
14063 _("Set Ada maintenance-related variables."),
14064 _("Show Ada maintenance-related variables."),
14065 &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14066 &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14068 add_setshow_boolean_cmd
14069 ("ignore-descriptive-types", class_maintenance,
14070 &ada_ignore_descriptive_types_p,
14071 _("Set whether descriptive types generated by GNAT should be ignored."),
14072 _("Show whether descriptive types generated by GNAT should be ignored."),
14074 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14075 DWARF attribute."),
14076 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14078 decoded_names_store = htab_create_alloc (256, htab_hash_string,
14080 NULL, xcalloc, xfree);
14082 /* The ada-lang observers. */
14083 gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14084 gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14085 gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");