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 (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 (type) > TYPE_LENGTH (value_type (val))))
564 result = allocate_value_lazy (type);
567 result = allocate_value (type);
568 value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
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 (TYPE_LENGTH (t));
651 return max_of_size (TYPE_LENGTH (t));
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 (TYPE_LENGTH (t));
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) || TYPE_TARGET_TYPE (type) == NULL)
744 type = TYPE_TARGET_TYPE (type);
749 /* Return a decoded version of the given VALUE. This means returning
750 a value whose type is obtained by applying all the GNAT-specific
751 encodings, making the resulting type a static but standard description
752 of the initial type. */
755 ada_get_decoded_value (struct value *value)
757 struct type *type = ada_check_typedef (value_type (value));
759 if (ada_is_array_descriptor_type (type)
760 || (ada_is_constrained_packed_array_type (type)
761 && type->code () != TYPE_CODE_PTR))
763 if (type->code () == TYPE_CODE_TYPEDEF) /* array access type. */
764 value = ada_coerce_to_simple_array_ptr (value);
766 value = ada_coerce_to_simple_array (value);
769 value = ada_to_fixed_value (value);
774 /* Same as ada_get_decoded_value, but with the given TYPE.
775 Because there is no associated actual value for this type,
776 the resulting type might be a best-effort approximation in
777 the case of dynamic types. */
780 ada_get_decoded_type (struct type *type)
782 type = to_static_fixed_type (type);
783 if (ada_is_constrained_packed_array_type (type))
784 type = ada_coerce_to_simple_array_type (type);
790 /* Language Selection */
792 /* If the main program is in Ada, return language_ada, otherwise return LANG
793 (the main program is in Ada iif the adainit symbol is found). */
796 ada_update_initial_language (enum language lang)
798 if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
804 /* If the main procedure is written in Ada, then return its name.
805 The result is good until the next call. Return NULL if the main
806 procedure doesn't appear to be in Ada. */
811 struct bound_minimal_symbol msym;
812 static gdb::unique_xmalloc_ptr<char> main_program_name;
814 /* For Ada, the name of the main procedure is stored in a specific
815 string constant, generated by the binder. Look for that symbol,
816 extract its address, and then read that string. If we didn't find
817 that string, then most probably the main procedure is not written
819 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
821 if (msym.minsym != NULL)
823 CORE_ADDR main_program_name_addr = msym.value_address ();
824 if (main_program_name_addr == 0)
825 error (_("Invalid address for Ada main program name."));
827 main_program_name = target_read_string (main_program_name_addr, 1024);
828 return main_program_name.get ();
831 /* The main procedure doesn't seem to be in Ada. */
837 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
840 const struct ada_opname_map ada_opname_table[] = {
841 {"Oadd", "\"+\"", BINOP_ADD},
842 {"Osubtract", "\"-\"", BINOP_SUB},
843 {"Omultiply", "\"*\"", BINOP_MUL},
844 {"Odivide", "\"/\"", BINOP_DIV},
845 {"Omod", "\"mod\"", BINOP_MOD},
846 {"Orem", "\"rem\"", BINOP_REM},
847 {"Oexpon", "\"**\"", BINOP_EXP},
848 {"Olt", "\"<\"", BINOP_LESS},
849 {"Ole", "\"<=\"", BINOP_LEQ},
850 {"Ogt", "\">\"", BINOP_GTR},
851 {"Oge", "\">=\"", BINOP_GEQ},
852 {"Oeq", "\"=\"", BINOP_EQUAL},
853 {"One", "\"/=\"", BINOP_NOTEQUAL},
854 {"Oand", "\"and\"", BINOP_BITWISE_AND},
855 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857 {"Oconcat", "\"&\"", BINOP_CONCAT},
858 {"Oabs", "\"abs\"", UNOP_ABS},
859 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860 {"Oadd", "\"+\"", UNOP_PLUS},
861 {"Osubtract", "\"-\"", UNOP_NEG},
865 /* If STR is a decoded version of a compiler-provided suffix (like the
866 "[cold]" in "symbol[cold]"), return true. Otherwise, return
870 is_compiler_suffix (const char *str)
872 gdb_assert (*str == '[');
874 while (*str != '\0' && isalpha (*str))
876 /* We accept a missing "]" in order to support completion. */
877 return *str == '\0' || (str[0] == ']' && str[1] == '\0');
880 /* Append a non-ASCII character to RESULT. */
882 append_hex_encoded (std::string &result, uint32_t one_char)
884 if (one_char <= 0xff)
887 result.append (phex (one_char, 1));
889 else if (one_char <= 0xffff)
892 result.append (phex (one_char, 2));
896 result.append ("WW");
897 result.append (phex (one_char, 4));
901 /* Return a string that is a copy of the data in STORAGE, with
902 non-ASCII characters replaced by the appropriate hex encoding. A
903 template is used because, for UTF-8, we actually want to work with
904 UTF-32 codepoints. */
907 copy_and_hex_encode (struct obstack *storage)
909 const T *chars = (T *) obstack_base (storage);
910 int num_chars = obstack_object_size (storage) / sizeof (T);
912 for (int i = 0; i < num_chars; ++i)
914 if (chars[i] <= 0x7f)
916 /* The host character set has to be a superset of ASCII, as
917 are all the other character sets we can use. */
918 result.push_back (chars[i]);
921 append_hex_encoded (result, chars[i]);
926 /* The "encoded" form of DECODED, according to GNAT conventions. If
927 THROW_ERRORS, throw an error if invalid operator name is found.
928 Otherwise, return the empty string in that case. */
931 ada_encode_1 (const char *decoded, bool throw_errors)
936 std::string encoding_buffer;
937 bool saw_non_ascii = false;
938 for (const char *p = decoded; *p != '\0'; p += 1)
940 if ((*p & 0x80) != 0)
941 saw_non_ascii = true;
944 encoding_buffer.append ("__");
945 else if (*p == '[' && is_compiler_suffix (p))
947 encoding_buffer = encoding_buffer + "." + (p + 1);
948 if (encoding_buffer.back () == ']')
949 encoding_buffer.pop_back ();
954 const struct ada_opname_map *mapping;
956 for (mapping = ada_opname_table;
957 mapping->encoded != NULL
958 && !startswith (p, mapping->decoded); mapping += 1)
960 if (mapping->encoded == NULL)
963 error (_("invalid Ada operator name: %s"), p);
967 encoding_buffer.append (mapping->encoded);
971 encoding_buffer.push_back (*p);
974 /* If a non-ASCII character is seen, we must convert it to the
975 appropriate hex form. As this is more expensive, we keep track
976 of whether it is even necessary. */
979 auto_obstack storage;
980 bool is_utf8 = ada_source_charset == ada_utf8;
983 convert_between_encodings
985 is_utf8 ? HOST_UTF32 : ada_source_charset,
986 (const gdb_byte *) encoding_buffer.c_str (),
987 encoding_buffer.length (), 1,
988 &storage, translit_none);
990 catch (const gdb_exception &)
992 static bool warned = false;
994 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
995 might like to know why. */
999 warning (_("charset conversion failure for '%s'.\n"
1000 "You may have the wrong value for 'set ada source-charset'."),
1001 encoding_buffer.c_str ());
1004 /* We don't try to recover from errors. */
1005 return encoding_buffer;
1009 return copy_and_hex_encode<uint32_t> (&storage);
1010 return copy_and_hex_encode<gdb_byte> (&storage);
1013 return encoding_buffer;
1016 /* Find the entry for C in the case-folding table. Return nullptr if
1017 the entry does not cover C. */
1018 static const utf8_entry *
1019 find_case_fold_entry (uint32_t c)
1021 auto iter = std::lower_bound (std::begin (ada_case_fold),
1022 std::end (ada_case_fold),
1024 if (iter == std::end (ada_case_fold)
1031 /* Return NAME folded to lower case, or, if surrounded by single
1032 quotes, unfolded, but with the quotes stripped away. If
1033 THROW_ON_ERROR is true, encoding failures will throw an exception
1034 rather than emitting a warning. Result good to next call. */
1037 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1039 static std::string fold_storage;
1041 if (!name.empty () && name[0] == '\'')
1042 fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1045 /* Why convert to UTF-32 and implement our own case-folding,
1046 rather than convert to wchar_t and use the platform's
1047 functions? I'm glad you asked.
1049 The main problem is that GNAT implements an unusual rule for
1050 case folding. For ASCII letters, letters in single-byte
1051 encodings (such as ISO-8859-*), and Unicode letters that fit
1052 in a single byte (i.e., code point is <= 0xff), the letter is
1053 folded to lower case. Other Unicode letters are folded to
1056 This rule means that the code must be able to examine the
1057 value of the character. And, some hosts do not use Unicode
1058 for wchar_t, so examining the value of such characters is
1060 auto_obstack storage;
1063 convert_between_encodings
1064 (host_charset (), HOST_UTF32,
1065 (const gdb_byte *) name.data (),
1067 &storage, translit_none);
1069 catch (const gdb_exception &)
1074 static bool warned = false;
1076 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1077 might like to know why. */
1081 warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1082 "This normally should not happen, please file a bug report."),
1083 gdb::to_string (name).c_str (), host_charset ());
1086 /* We don't try to recover from errors; just return the
1088 fold_storage = gdb::to_string (name);
1089 return fold_storage.c_str ();
1092 bool is_utf8 = ada_source_charset == ada_utf8;
1093 uint32_t *chars = (uint32_t *) obstack_base (&storage);
1094 int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1095 for (int i = 0; i < num_chars; ++i)
1097 const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1098 if (entry != nullptr)
1100 uint32_t low = chars[i] + entry->lower_delta;
1101 if (!is_utf8 || low <= 0xff)
1104 chars[i] = chars[i] + entry->upper_delta;
1108 /* Now convert back to ordinary characters. */
1109 auto_obstack reconverted;
1112 convert_between_encodings (HOST_UTF32,
1114 (const gdb_byte *) chars,
1115 num_chars * sizeof (uint32_t),
1119 obstack_1grow (&reconverted, '\0');
1120 fold_storage = std::string ((const char *) obstack_base (&reconverted));
1122 catch (const gdb_exception &)
1127 static bool warned = false;
1129 /* Converting back from UTF-32 shouldn't normally fail, but
1130 there are some host encodings without upper/lower
1135 warning (_("could not convert the lower-cased variant of '%s'\n"
1136 "from UTF-32 to the host encoding (%s)."),
1137 gdb::to_string (name).c_str (), host_charset ());
1140 /* We don't try to recover from errors; just return the
1142 fold_storage = gdb::to_string (name);
1146 return fold_storage.c_str ();
1149 /* The "encoded" form of DECODED, according to GNAT conventions. */
1152 ada_encode (const char *decoded)
1154 if (decoded[0] != '<')
1155 decoded = ada_fold_name (decoded);
1156 return ada_encode_1 (decoded, true);
1159 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1162 is_lower_alphanum (const char c)
1164 return (isdigit (c) || (isalpha (c) && islower (c)));
1167 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1168 This function saves in LEN the length of that same symbol name but
1169 without either of these suffixes:
1175 These are suffixes introduced by the compiler for entities such as
1176 nested subprogram for instance, in order to avoid name clashes.
1177 They do not serve any purpose for the debugger. */
1180 ada_remove_trailing_digits (const char *encoded, int *len)
1182 if (*len > 1 && isdigit (encoded[*len - 1]))
1186 while (i > 0 && isdigit (encoded[i]))
1188 if (i >= 0 && encoded[i] == '.')
1190 else if (i >= 0 && encoded[i] == '$')
1192 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1194 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1199 /* Remove the suffix introduced by the compiler for protected object
1203 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1205 /* Remove trailing N. */
1207 /* Protected entry subprograms are broken into two
1208 separate subprograms: The first one is unprotected, and has
1209 a 'N' suffix; the second is the protected version, and has
1210 the 'P' suffix. The second calls the first one after handling
1211 the protection. Since the P subprograms are internally generated,
1212 we leave these names undecoded, giving the user a clue that this
1213 entity is internal. */
1216 && encoded[*len - 1] == 'N'
1217 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1221 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1222 then update *LEN to remove the suffix and return the offset of the
1223 character just past the ".". Otherwise, return -1. */
1226 remove_compiler_suffix (const char *encoded, int *len)
1228 int offset = *len - 1;
1229 while (offset > 0 && isalpha (encoded[offset]))
1231 if (offset > 0 && encoded[offset] == '.')
1239 /* Convert an ASCII hex string to a number. Reads exactly N
1240 characters from STR. Returns true on success, false if one of the
1241 digits was not a hex digit. */
1243 convert_hex (const char *str, int n, uint32_t *out)
1245 uint32_t result = 0;
1247 for (int i = 0; i < n; ++i)
1249 if (!isxdigit (str[i]))
1252 result |= fromhex (str[i]);
1259 /* Convert a wide character from its ASCII hex representation in STR
1260 (consisting of exactly N characters) to the host encoding,
1261 appending the resulting bytes to OUT. If N==2 and the Ada source
1262 charset is not UTF-8, then hex refers to an encoding in the
1263 ADA_SOURCE_CHARSET; otherwise, use UTF-32. Return true on success.
1264 Return false and do not modify OUT on conversion failure. */
1266 convert_from_hex_encoded (std::string &out, const char *str, int n)
1270 if (!convert_hex (str, n, &value))
1275 /* In the 'U' case, the hex digits encode the character in the
1276 Ada source charset. However, if the source charset is UTF-8,
1277 this really means it is a single-byte UTF-32 character. */
1278 if (n == 2 && ada_source_charset != ada_utf8)
1280 gdb_byte one_char = (gdb_byte) value;
1282 convert_between_encodings (ada_source_charset, host_charset (),
1284 sizeof (one_char), sizeof (one_char),
1285 &bytes, translit_none);
1288 convert_between_encodings (HOST_UTF32, host_charset (),
1289 (const gdb_byte *) &value,
1290 sizeof (value), sizeof (value),
1291 &bytes, translit_none);
1292 obstack_1grow (&bytes, '\0');
1293 out.append ((const char *) obstack_base (&bytes));
1295 catch (const gdb_exception &)
1297 /* On failure, the caller will just let the encoded form
1298 through, which seems basically reasonable. */
1305 /* See ada-lang.h. */
1308 ada_decode (const char *encoded, bool wrap, bool operators)
1314 std::string decoded;
1317 /* With function descriptors on PPC64, the value of a symbol named
1318 ".FN", if it exists, is the entry point of the function "FN". */
1319 if (encoded[0] == '.')
1322 /* The name of the Ada main procedure starts with "_ada_".
1323 This prefix is not part of the decoded name, so skip this part
1324 if we see this prefix. */
1325 if (startswith (encoded, "_ada_"))
1327 /* The "___ghost_" prefix is used for ghost entities. Normally
1328 these aren't preserved but when they are, it's useful to see
1330 if (startswith (encoded, "___ghost_"))
1333 /* If the name starts with '_', then it is not a properly encoded
1334 name, so do not attempt to decode it. Similarly, if the name
1335 starts with '<', the name should not be decoded. */
1336 if (encoded[0] == '_' || encoded[0] == '<')
1339 len0 = strlen (encoded);
1341 suffix = remove_compiler_suffix (encoded, &len0);
1343 ada_remove_trailing_digits (encoded, &len0);
1344 ada_remove_po_subprogram_suffix (encoded, &len0);
1346 /* Remove the ___X.* suffix if present. Do not forget to verify that
1347 the suffix is located before the current "end" of ENCODED. We want
1348 to avoid re-matching parts of ENCODED that have previously been
1349 marked as discarded (by decrementing LEN0). */
1350 p = strstr (encoded, "___");
1351 if (p != NULL && p - encoded < len0 - 3)
1359 /* Remove any trailing TKB suffix. It tells us that this symbol
1360 is for the body of a task, but that information does not actually
1361 appear in the decoded name. */
1363 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1366 /* Remove any trailing TB suffix. The TB suffix is slightly different
1367 from the TKB suffix because it is used for non-anonymous task
1370 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1373 /* Remove trailing "B" suffixes. */
1374 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1376 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1379 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1381 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1384 while ((i >= 0 && isdigit (encoded[i]))
1385 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1387 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1389 else if (encoded[i] == '$')
1393 /* The first few characters that are not alphabetic are not part
1394 of any encoding we use, so we can copy them over verbatim. */
1396 for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1397 decoded.push_back (encoded[i]);
1402 /* Is this a symbol function? */
1403 if (operators && at_start_name && encoded[i] == 'O')
1407 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1409 int op_len = strlen (ada_opname_table[k].encoded);
1410 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1412 && !isalnum (encoded[i + op_len]))
1414 decoded.append (ada_opname_table[k].decoded);
1420 if (ada_opname_table[k].encoded != NULL)
1425 /* Replace "TK__" with "__", which will eventually be translated
1426 into "." (just below). */
1428 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1431 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1432 be translated into "." (just below). These are internal names
1433 generated for anonymous blocks inside which our symbol is nested. */
1435 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1436 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1437 && isdigit (encoded [i+4]))
1441 while (k < len0 && isdigit (encoded[k]))
1442 k++; /* Skip any extra digit. */
1444 /* Double-check that the "__B_{DIGITS}+" sequence we found
1445 is indeed followed by "__". */
1446 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1450 /* Remove _E{DIGITS}+[sb] */
1452 /* Just as for protected object subprograms, there are 2 categories
1453 of subprograms created by the compiler for each entry. The first
1454 one implements the actual entry code, and has a suffix following
1455 the convention above; the second one implements the barrier and
1456 uses the same convention as above, except that the 'E' is replaced
1459 Just as above, we do not decode the name of barrier functions
1460 to give the user a clue that the code he is debugging has been
1461 internally generated. */
1463 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1464 && isdigit (encoded[i+2]))
1468 while (k < len0 && isdigit (encoded[k]))
1472 && (encoded[k] == 'b' || encoded[k] == 's'))
1475 /* Just as an extra precaution, make sure that if this
1476 suffix is followed by anything else, it is a '_'.
1477 Otherwise, we matched this sequence by accident. */
1479 || (k < len0 && encoded[k] == '_'))
1484 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1485 the GNAT front-end in protected object subprograms. */
1488 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1490 /* Backtrack a bit up until we reach either the begining of
1491 the encoded name, or "__". Make sure that we only find
1492 digits or lowercase characters. */
1493 const char *ptr = encoded + i - 1;
1495 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1498 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1502 if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1504 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1510 else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1512 if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1518 else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1519 && isxdigit (encoded[i + 2]))
1521 if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1528 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1530 /* This is a X[bn]* sequence not separated from the previous
1531 part of the name with a non-alpha-numeric character (in other
1532 words, immediately following an alpha-numeric character), then
1533 verify that it is placed at the end of the encoded name. If
1534 not, then the encoding is not valid and we should abort the
1535 decoding. Otherwise, just skip it, it is used in body-nested
1539 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1543 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1545 /* Replace '__' by '.'. */
1546 decoded.push_back ('.');
1552 /* It's a character part of the decoded name, so just copy it
1554 decoded.push_back (encoded[i]);
1559 /* Decoded names should never contain any uppercase character.
1560 Double-check this, and abort the decoding if we find one. */
1564 for (i = 0; i < decoded.length(); ++i)
1565 if (isupper (decoded[i]) || decoded[i] == ' ')
1569 /* If the compiler added a suffix, append it now. */
1571 decoded = decoded + "[" + &encoded[suffix] + "]";
1579 if (encoded[0] == '<')
1582 decoded = '<' + std::string(encoded) + '>';
1586 /* Table for keeping permanent unique copies of decoded names. Once
1587 allocated, names in this table are never released. While this is a
1588 storage leak, it should not be significant unless there are massive
1589 changes in the set of decoded names in successive versions of a
1590 symbol table loaded during a single session. */
1591 static struct htab *decoded_names_store;
1593 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1594 in the language-specific part of GSYMBOL, if it has not been
1595 previously computed. Tries to save the decoded name in the same
1596 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1597 in any case, the decoded symbol has a lifetime at least that of
1599 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1600 const, but nevertheless modified to a semantically equivalent form
1601 when a decoded name is cached in it. */
1604 ada_decode_symbol (const struct general_symbol_info *arg)
1606 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1607 const char **resultp =
1608 &gsymbol->language_specific.demangled_name;
1610 if (!gsymbol->ada_mangled)
1612 std::string decoded = ada_decode (gsymbol->linkage_name ());
1613 struct obstack *obstack = gsymbol->language_specific.obstack;
1615 gsymbol->ada_mangled = 1;
1617 if (obstack != NULL)
1618 *resultp = obstack_strdup (obstack, decoded.c_str ());
1621 /* Sometimes, we can't find a corresponding objfile, in
1622 which case, we put the result on the heap. Since we only
1623 decode when needed, we hope this usually does not cause a
1624 significant memory leak (FIXME). */
1626 char **slot = (char **) htab_find_slot (decoded_names_store,
1627 decoded.c_str (), INSERT);
1630 *slot = xstrdup (decoded.c_str ());
1642 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1643 generated by the GNAT compiler to describe the index type used
1644 for each dimension of an array, check whether it follows the latest
1645 known encoding. If not, fix it up to conform to the latest encoding.
1646 Otherwise, do nothing. This function also does nothing if
1647 INDEX_DESC_TYPE is NULL.
1649 The GNAT encoding used to describe the array index type evolved a bit.
1650 Initially, the information would be provided through the name of each
1651 field of the structure type only, while the type of these fields was
1652 described as unspecified and irrelevant. The debugger was then expected
1653 to perform a global type lookup using the name of that field in order
1654 to get access to the full index type description. Because these global
1655 lookups can be very expensive, the encoding was later enhanced to make
1656 the global lookup unnecessary by defining the field type as being
1657 the full index type description.
1659 The purpose of this routine is to allow us to support older versions
1660 of the compiler by detecting the use of the older encoding, and by
1661 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1662 we essentially replace each field's meaningless type by the associated
1666 ada_fixup_array_indexes_type (struct type *index_desc_type)
1670 if (index_desc_type == NULL)
1672 gdb_assert (index_desc_type->num_fields () > 0);
1674 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1675 to check one field only, no need to check them all). If not, return
1678 If our INDEX_DESC_TYPE was generated using the older encoding,
1679 the field type should be a meaningless integer type whose name
1680 is not equal to the field name. */
1681 if (index_desc_type->field (0).type ()->name () != NULL
1682 && strcmp (index_desc_type->field (0).type ()->name (),
1683 index_desc_type->field (0).name ()) == 0)
1686 /* Fixup each field of INDEX_DESC_TYPE. */
1687 for (i = 0; i < index_desc_type->num_fields (); i++)
1689 const char *name = index_desc_type->field (i).name ();
1690 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1693 index_desc_type->field (i).set_type (raw_type);
1697 /* The desc_* routines return primitive portions of array descriptors
1700 /* The descriptor or array type, if any, indicated by TYPE; removes
1701 level of indirection, if needed. */
1703 static struct type *
1704 desc_base_type (struct type *type)
1708 type = ada_check_typedef (type);
1709 if (type->code () == TYPE_CODE_TYPEDEF)
1710 type = ada_typedef_target_type (type);
1713 && (type->code () == TYPE_CODE_PTR
1714 || type->code () == TYPE_CODE_REF))
1715 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1720 /* True iff TYPE indicates a "thin" array pointer type. */
1723 is_thin_pntr (struct type *type)
1726 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1727 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1730 /* The descriptor type for thin pointer type TYPE. */
1732 static struct type *
1733 thin_descriptor_type (struct type *type)
1735 struct type *base_type = desc_base_type (type);
1737 if (base_type == NULL)
1739 if (is_suffix (ada_type_name (base_type), "___XVE"))
1743 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1745 if (alt_type == NULL)
1752 /* A pointer to the array data for thin-pointer value VAL. */
1754 static struct value *
1755 thin_data_pntr (struct value *val)
1757 struct type *type = ada_check_typedef (value_type (val));
1758 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1760 data_type = lookup_pointer_type (data_type);
1762 if (type->code () == TYPE_CODE_PTR)
1763 return value_cast (data_type, value_copy (val));
1765 return value_from_longest (data_type, value_address (val));
1768 /* True iff TYPE indicates a "thick" array pointer type. */
1771 is_thick_pntr (struct type *type)
1773 type = desc_base_type (type);
1774 return (type != NULL && type->code () == TYPE_CODE_STRUCT
1775 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1778 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1779 pointer to one, the type of its bounds data; otherwise, NULL. */
1781 static struct type *
1782 desc_bounds_type (struct type *type)
1786 type = desc_base_type (type);
1790 else if (is_thin_pntr (type))
1792 type = thin_descriptor_type (type);
1795 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1797 return ada_check_typedef (r);
1799 else if (type->code () == TYPE_CODE_STRUCT)
1801 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1803 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1808 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1809 one, a pointer to its bounds data. Otherwise NULL. */
1811 static struct value *
1812 desc_bounds (struct value *arr)
1814 struct type *type = ada_check_typedef (value_type (arr));
1816 if (is_thin_pntr (type))
1818 struct type *bounds_type =
1819 desc_bounds_type (thin_descriptor_type (type));
1822 if (bounds_type == NULL)
1823 error (_("Bad GNAT array descriptor"));
1825 /* NOTE: The following calculation is not really kosher, but
1826 since desc_type is an XVE-encoded type (and shouldn't be),
1827 the correct calculation is a real pain. FIXME (and fix GCC). */
1828 if (type->code () == TYPE_CODE_PTR)
1829 addr = value_as_long (arr);
1831 addr = value_address (arr);
1834 value_from_longest (lookup_pointer_type (bounds_type),
1835 addr - TYPE_LENGTH (bounds_type));
1838 else if (is_thick_pntr (type))
1840 struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1841 _("Bad GNAT array descriptor"));
1842 struct type *p_bounds_type = value_type (p_bounds);
1845 && p_bounds_type->code () == TYPE_CODE_PTR)
1847 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1849 if (target_type->is_stub ())
1850 p_bounds = value_cast (lookup_pointer_type
1851 (ada_check_typedef (target_type)),
1855 error (_("Bad GNAT array descriptor"));
1863 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1864 position of the field containing the address of the bounds data. */
1867 fat_pntr_bounds_bitpos (struct type *type)
1869 return desc_base_type (type)->field (1).loc_bitpos ();
1872 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1873 size of the field containing the address of the bounds data. */
1876 fat_pntr_bounds_bitsize (struct type *type)
1878 type = desc_base_type (type);
1880 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1881 return TYPE_FIELD_BITSIZE (type, 1);
1883 return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1886 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1887 pointer to one, the type of its array data (a array-with-no-bounds type);
1888 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1891 static struct type *
1892 desc_data_target_type (struct type *type)
1894 type = desc_base_type (type);
1896 /* NOTE: The following is bogus; see comment in desc_bounds. */
1897 if (is_thin_pntr (type))
1898 return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1899 else if (is_thick_pntr (type))
1901 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1904 && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1905 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1911 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1914 static struct value *
1915 desc_data (struct value *arr)
1917 struct type *type = value_type (arr);
1919 if (is_thin_pntr (type))
1920 return thin_data_pntr (arr);
1921 else if (is_thick_pntr (type))
1922 return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1923 _("Bad GNAT array descriptor"));
1929 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1930 position of the field containing the address of the data. */
1933 fat_pntr_data_bitpos (struct type *type)
1935 return desc_base_type (type)->field (0).loc_bitpos ();
1938 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1939 size of the field containing the address of the data. */
1942 fat_pntr_data_bitsize (struct type *type)
1944 type = desc_base_type (type);
1946 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1947 return TYPE_FIELD_BITSIZE (type, 0);
1949 return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1952 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1953 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1954 bound, if WHICH is 1. The first bound is I=1. */
1956 static struct value *
1957 desc_one_bound (struct value *bounds, int i, int which)
1959 char bound_name[20];
1960 xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1961 which ? 'U' : 'L', i - 1);
1962 return value_struct_elt (&bounds, {}, bound_name, NULL,
1963 _("Bad GNAT array descriptor bounds"));
1966 /* If BOUNDS is an array-bounds structure type, return the bit position
1967 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1968 bound, if WHICH is 1. The first bound is I=1. */
1971 desc_bound_bitpos (struct type *type, int i, int which)
1973 return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1976 /* If BOUNDS is an array-bounds structure type, return the bit field size
1977 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1978 bound, if WHICH is 1. The first bound is I=1. */
1981 desc_bound_bitsize (struct type *type, int i, int which)
1983 type = desc_base_type (type);
1985 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1986 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1988 return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1991 /* If TYPE is the type of an array-bounds structure, the type of its
1992 Ith bound (numbering from 1). Otherwise, NULL. */
1994 static struct type *
1995 desc_index_type (struct type *type, int i)
1997 type = desc_base_type (type);
1999 if (type->code () == TYPE_CODE_STRUCT)
2001 char bound_name[20];
2002 xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2003 return lookup_struct_elt_type (type, bound_name, 1);
2009 /* The number of index positions in the array-bounds type TYPE.
2010 Return 0 if TYPE is NULL. */
2013 desc_arity (struct type *type)
2015 type = desc_base_type (type);
2018 return type->num_fields () / 2;
2022 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
2023 an array descriptor type (representing an unconstrained array
2027 ada_is_direct_array_type (struct type *type)
2031 type = ada_check_typedef (type);
2032 return (type->code () == TYPE_CODE_ARRAY
2033 || ada_is_array_descriptor_type (type));
2036 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2040 ada_is_array_type (struct type *type)
2043 && (type->code () == TYPE_CODE_PTR
2044 || type->code () == TYPE_CODE_REF))
2045 type = TYPE_TARGET_TYPE (type);
2046 return ada_is_direct_array_type (type);
2049 /* Non-zero iff TYPE is a simple array type or pointer to one. */
2052 ada_is_simple_array_type (struct type *type)
2056 type = ada_check_typedef (type);
2057 return (type->code () == TYPE_CODE_ARRAY
2058 || (type->code () == TYPE_CODE_PTR
2059 && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
2060 == TYPE_CODE_ARRAY)));
2063 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
2066 ada_is_array_descriptor_type (struct type *type)
2068 struct type *data_type = desc_data_target_type (type);
2072 type = ada_check_typedef (type);
2073 return (data_type != NULL
2074 && data_type->code () == TYPE_CODE_ARRAY
2075 && desc_arity (desc_bounds_type (type)) > 0);
2078 /* Non-zero iff type is a partially mal-formed GNAT array
2079 descriptor. FIXME: This is to compensate for some problems with
2080 debugging output from GNAT. Re-examine periodically to see if it
2084 ada_is_bogus_array_descriptor (struct type *type)
2088 && type->code () == TYPE_CODE_STRUCT
2089 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2090 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2091 && !ada_is_array_descriptor_type (type);
2095 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2096 (fat pointer) returns the type of the array data described---specifically,
2097 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
2098 in from the descriptor; otherwise, they are left unspecified. If
2099 the ARR denotes a null array descriptor and BOUNDS is non-zero,
2100 returns NULL. The result is simply the type of ARR if ARR is not
2103 static struct type *
2104 ada_type_of_array (struct value *arr, int bounds)
2106 if (ada_is_constrained_packed_array_type (value_type (arr)))
2107 return decode_constrained_packed_array_type (value_type (arr));
2109 if (!ada_is_array_descriptor_type (value_type (arr)))
2110 return value_type (arr);
2114 struct type *array_type =
2115 ada_check_typedef (desc_data_target_type (value_type (arr)));
2117 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2118 TYPE_FIELD_BITSIZE (array_type, 0) =
2119 decode_packed_array_bitsize (value_type (arr));
2125 struct type *elt_type;
2127 struct value *descriptor;
2129 elt_type = ada_array_element_type (value_type (arr), -1);
2130 arity = ada_array_arity (value_type (arr));
2132 if (elt_type == NULL || arity == 0)
2133 return ada_check_typedef (value_type (arr));
2135 descriptor = desc_bounds (arr);
2136 if (value_as_long (descriptor) == 0)
2140 struct type *range_type = alloc_type_copy (value_type (arr));
2141 struct type *array_type = alloc_type_copy (value_type (arr));
2142 struct value *low = desc_one_bound (descriptor, arity, 0);
2143 struct value *high = desc_one_bound (descriptor, arity, 1);
2146 create_static_range_type (range_type, value_type (low),
2147 longest_to_int (value_as_long (low)),
2148 longest_to_int (value_as_long (high)));
2149 elt_type = create_array_type (array_type, elt_type, range_type);
2151 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2153 /* We need to store the element packed bitsize, as well as
2154 recompute the array size, because it was previously
2155 computed based on the unpacked element size. */
2156 LONGEST lo = value_as_long (low);
2157 LONGEST hi = value_as_long (high);
2159 TYPE_FIELD_BITSIZE (elt_type, 0) =
2160 decode_packed_array_bitsize (value_type (arr));
2161 /* If the array has no element, then the size is already
2162 zero, and does not need to be recomputed. */
2166 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2168 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2173 return lookup_pointer_type (elt_type);
2177 /* If ARR does not represent an array, returns ARR unchanged.
2178 Otherwise, returns either a standard GDB array with bounds set
2179 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2180 GDB array. Returns NULL if ARR is a null fat pointer. */
2183 ada_coerce_to_simple_array_ptr (struct value *arr)
2185 if (ada_is_array_descriptor_type (value_type (arr)))
2187 struct type *arrType = ada_type_of_array (arr, 1);
2189 if (arrType == NULL)
2191 return value_cast (arrType, value_copy (desc_data (arr)));
2193 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2194 return decode_constrained_packed_array (arr);
2199 /* If ARR does not represent an array, returns ARR unchanged.
2200 Otherwise, returns a standard GDB array describing ARR (which may
2201 be ARR itself if it already is in the proper form). */
2204 ada_coerce_to_simple_array (struct value *arr)
2206 if (ada_is_array_descriptor_type (value_type (arr)))
2208 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2211 error (_("Bounds unavailable for null array pointer."));
2212 return value_ind (arrVal);
2214 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2215 return decode_constrained_packed_array (arr);
2220 /* If TYPE represents a GNAT array type, return it translated to an
2221 ordinary GDB array type (possibly with BITSIZE fields indicating
2222 packing). For other types, is the identity. */
2225 ada_coerce_to_simple_array_type (struct type *type)
2227 if (ada_is_constrained_packed_array_type (type))
2228 return decode_constrained_packed_array_type (type);
2230 if (ada_is_array_descriptor_type (type))
2231 return ada_check_typedef (desc_data_target_type (type));
2236 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2239 ada_is_gnat_encoded_packed_array_type (struct type *type)
2243 type = desc_base_type (type);
2244 type = ada_check_typedef (type);
2246 ada_type_name (type) != NULL
2247 && strstr (ada_type_name (type), "___XP") != NULL;
2250 /* Non-zero iff TYPE represents a standard GNAT constrained
2251 packed-array type. */
2254 ada_is_constrained_packed_array_type (struct type *type)
2256 return ada_is_gnat_encoded_packed_array_type (type)
2257 && !ada_is_array_descriptor_type (type);
2260 /* Non-zero iff TYPE represents an array descriptor for a
2261 unconstrained packed-array type. */
2264 ada_is_unconstrained_packed_array_type (struct type *type)
2266 if (!ada_is_array_descriptor_type (type))
2269 if (ada_is_gnat_encoded_packed_array_type (type))
2272 /* If we saw GNAT encodings, then the above code is sufficient.
2273 However, with minimal encodings, we will just have a thick
2275 if (is_thick_pntr (type))
2277 type = desc_base_type (type);
2278 /* The structure's first field is a pointer to an array, so this
2279 fetches the array type. */
2280 type = TYPE_TARGET_TYPE (type->field (0).type ());
2281 if (type->code () == TYPE_CODE_TYPEDEF)
2282 type = ada_typedef_target_type (type);
2283 /* Now we can see if the array elements are packed. */
2284 return TYPE_FIELD_BITSIZE (type, 0) > 0;
2290 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2291 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2294 ada_is_any_packed_array_type (struct type *type)
2296 return (ada_is_constrained_packed_array_type (type)
2297 || (type->code () == TYPE_CODE_ARRAY
2298 && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2301 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2302 return the size of its elements in bits. */
2305 decode_packed_array_bitsize (struct type *type)
2307 const char *raw_name;
2311 /* Access to arrays implemented as fat pointers are encoded as a typedef
2312 of the fat pointer type. We need the name of the fat pointer type
2313 to do the decoding, so strip the typedef layer. */
2314 if (type->code () == TYPE_CODE_TYPEDEF)
2315 type = ada_typedef_target_type (type);
2317 raw_name = ada_type_name (ada_check_typedef (type));
2319 raw_name = ada_type_name (desc_base_type (type));
2324 tail = strstr (raw_name, "___XP");
2325 if (tail == nullptr)
2327 gdb_assert (is_thick_pntr (type));
2328 /* The structure's first field is a pointer to an array, so this
2329 fetches the array type. */
2330 type = TYPE_TARGET_TYPE (type->field (0).type ());
2331 /* Now we can see if the array elements are packed. */
2332 return TYPE_FIELD_BITSIZE (type, 0);
2335 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2338 (_("could not understand bit size information on packed array"));
2345 /* Given that TYPE is a standard GDB array type with all bounds filled
2346 in, and that the element size of its ultimate scalar constituents
2347 (that is, either its elements, or, if it is an array of arrays, its
2348 elements' elements, etc.) is *ELT_BITS, return an identical type,
2349 but with the bit sizes of its elements (and those of any
2350 constituent arrays) recorded in the BITSIZE components of its
2351 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2354 Note that, for arrays whose index type has an XA encoding where
2355 a bound references a record discriminant, getting that discriminant,
2356 and therefore the actual value of that bound, is not possible
2357 because none of the given parameters gives us access to the record.
2358 This function assumes that it is OK in the context where it is being
2359 used to return an array whose bounds are still dynamic and where
2360 the length is arbitrary. */
2362 static struct type *
2363 constrained_packed_array_type (struct type *type, long *elt_bits)
2365 struct type *new_elt_type;
2366 struct type *new_type;
2367 struct type *index_type_desc;
2368 struct type *index_type;
2369 LONGEST low_bound, high_bound;
2371 type = ada_check_typedef (type);
2372 if (type->code () != TYPE_CODE_ARRAY)
2375 index_type_desc = ada_find_parallel_type (type, "___XA");
2376 if (index_type_desc)
2377 index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2380 index_type = type->index_type ();
2382 new_type = alloc_type_copy (type);
2384 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2386 create_array_type (new_type, new_elt_type, index_type);
2387 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2388 new_type->set_name (ada_type_name (type));
2390 if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2391 && is_dynamic_type (check_typedef (index_type)))
2392 || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2393 low_bound = high_bound = 0;
2394 if (high_bound < low_bound)
2395 *elt_bits = TYPE_LENGTH (new_type) = 0;
2398 *elt_bits *= (high_bound - low_bound + 1);
2399 TYPE_LENGTH (new_type) =
2400 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2403 new_type->set_is_fixed_instance (true);
2407 /* The array type encoded by TYPE, where
2408 ada_is_constrained_packed_array_type (TYPE). */
2410 static struct type *
2411 decode_constrained_packed_array_type (struct type *type)
2413 const char *raw_name = ada_type_name (ada_check_typedef (type));
2416 struct type *shadow_type;
2420 raw_name = ada_type_name (desc_base_type (type));
2425 name = (char *) alloca (strlen (raw_name) + 1);
2426 tail = strstr (raw_name, "___XP");
2427 type = desc_base_type (type);
2429 memcpy (name, raw_name, tail - raw_name);
2430 name[tail - raw_name] = '\000';
2432 shadow_type = ada_find_parallel_type_with_name (type, name);
2434 if (shadow_type == NULL)
2436 lim_warning (_("could not find bounds information on packed array"));
2439 shadow_type = check_typedef (shadow_type);
2441 if (shadow_type->code () != TYPE_CODE_ARRAY)
2443 lim_warning (_("could not understand bounds "
2444 "information on packed array"));
2448 bits = decode_packed_array_bitsize (type);
2449 return constrained_packed_array_type (shadow_type, &bits);
2452 /* Helper function for decode_constrained_packed_array. Set the field
2453 bitsize on a series of packed arrays. Returns the number of
2454 elements in TYPE. */
2457 recursively_update_array_bitsize (struct type *type)
2459 gdb_assert (type->code () == TYPE_CODE_ARRAY);
2462 if (!get_discrete_bounds (type->index_type (), &low, &high)
2465 LONGEST our_len = high - low + 1;
2467 struct type *elt_type = TYPE_TARGET_TYPE (type);
2468 if (elt_type->code () == TYPE_CODE_ARRAY)
2470 LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2471 LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2472 TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2474 TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2481 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2482 array, returns a simple array that denotes that array. Its type is a
2483 standard GDB array type except that the BITSIZEs of the array
2484 target types are set to the number of bits in each element, and the
2485 type length is set appropriately. */
2487 static struct value *
2488 decode_constrained_packed_array (struct value *arr)
2492 /* If our value is a pointer, then dereference it. Likewise if
2493 the value is a reference. Make sure that this operation does not
2494 cause the target type to be fixed, as this would indirectly cause
2495 this array to be decoded. The rest of the routine assumes that
2496 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2497 and "value_ind" routines to perform the dereferencing, as opposed
2498 to using "ada_coerce_ref" or "ada_value_ind". */
2499 arr = coerce_ref (arr);
2500 if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2501 arr = value_ind (arr);
2503 type = decode_constrained_packed_array_type (value_type (arr));
2506 error (_("can't unpack array"));
2510 /* Decoding the packed array type could not correctly set the field
2511 bitsizes for any dimension except the innermost, because the
2512 bounds may be variable and were not passed to that function. So,
2513 we further resolve the array bounds here and then update the
2515 const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2516 CORE_ADDR address = value_address (arr);
2517 gdb::array_view<const gdb_byte> view
2518 = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2519 type = resolve_dynamic_type (type, view, address);
2520 recursively_update_array_bitsize (type);
2522 if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2523 && ada_is_modular_type (value_type (arr)))
2525 /* This is a (right-justified) modular type representing a packed
2526 array with no wrapper. In order to interpret the value through
2527 the (left-justified) packed array type we just built, we must
2528 first left-justify it. */
2529 int bit_size, bit_pos;
2532 mod = ada_modulus (value_type (arr)) - 1;
2539 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2540 arr = ada_value_primitive_packed_val (arr, NULL,
2541 bit_pos / HOST_CHAR_BIT,
2542 bit_pos % HOST_CHAR_BIT,
2547 return coerce_unspec_val_to_type (arr, type);
2551 /* The value of the element of packed array ARR at the ARITY indices
2552 given in IND. ARR must be a simple array. */
2554 static struct value *
2555 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2558 int bits, elt_off, bit_off;
2559 long elt_total_bit_offset;
2560 struct type *elt_type;
2564 elt_total_bit_offset = 0;
2565 elt_type = ada_check_typedef (value_type (arr));
2566 for (i = 0; i < arity; i += 1)
2568 if (elt_type->code () != TYPE_CODE_ARRAY
2569 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2571 (_("attempt to do packed indexing of "
2572 "something other than a packed array"));
2575 struct type *range_type = elt_type->index_type ();
2576 LONGEST lowerbound, upperbound;
2579 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2581 lim_warning (_("don't know bounds of array"));
2582 lowerbound = upperbound = 0;
2585 idx = pos_atr (ind[i]);
2586 if (idx < lowerbound || idx > upperbound)
2587 lim_warning (_("packed array index %ld out of bounds"),
2589 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2590 elt_total_bit_offset += (idx - lowerbound) * bits;
2591 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2594 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2595 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2597 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2602 /* Non-zero iff TYPE includes negative integer values. */
2605 has_negatives (struct type *type)
2607 switch (type->code ())
2612 return !type->is_unsigned ();
2613 case TYPE_CODE_RANGE:
2614 return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2618 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2619 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2620 the unpacked buffer.
2622 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2623 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2625 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2628 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2630 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2633 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2634 gdb_byte *unpacked, int unpacked_len,
2635 int is_big_endian, int is_signed_type,
2638 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2639 int src_idx; /* Index into the source area */
2640 int src_bytes_left; /* Number of source bytes left to process. */
2641 int srcBitsLeft; /* Number of source bits left to move */
2642 int unusedLS; /* Number of bits in next significant
2643 byte of source that are unused */
2645 int unpacked_idx; /* Index into the unpacked buffer */
2646 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2648 unsigned long accum; /* Staging area for bits being transferred */
2649 int accumSize; /* Number of meaningful bits in accum */
2652 /* Transmit bytes from least to most significant; delta is the direction
2653 the indices move. */
2654 int delta = is_big_endian ? -1 : 1;
2656 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2658 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2659 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2660 bit_size, unpacked_len);
2662 srcBitsLeft = bit_size;
2663 src_bytes_left = src_len;
2664 unpacked_bytes_left = unpacked_len;
2669 src_idx = src_len - 1;
2671 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2675 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2681 unpacked_idx = unpacked_len - 1;
2685 /* Non-scalar values must be aligned at a byte boundary... */
2687 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2688 /* ... And are placed at the beginning (most-significant) bytes
2690 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2691 unpacked_bytes_left = unpacked_idx + 1;
2696 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2698 src_idx = unpacked_idx = 0;
2699 unusedLS = bit_offset;
2702 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2707 while (src_bytes_left > 0)
2709 /* Mask for removing bits of the next source byte that are not
2710 part of the value. */
2711 unsigned int unusedMSMask =
2712 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2714 /* Sign-extend bits for this byte. */
2715 unsigned int signMask = sign & ~unusedMSMask;
2718 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2719 accumSize += HOST_CHAR_BIT - unusedLS;
2720 if (accumSize >= HOST_CHAR_BIT)
2722 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2723 accumSize -= HOST_CHAR_BIT;
2724 accum >>= HOST_CHAR_BIT;
2725 unpacked_bytes_left -= 1;
2726 unpacked_idx += delta;
2728 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2730 src_bytes_left -= 1;
2733 while (unpacked_bytes_left > 0)
2735 accum |= sign << accumSize;
2736 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2737 accumSize -= HOST_CHAR_BIT;
2740 accum >>= HOST_CHAR_BIT;
2741 unpacked_bytes_left -= 1;
2742 unpacked_idx += delta;
2746 /* Create a new value of type TYPE from the contents of OBJ starting
2747 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2748 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2749 assigning through the result will set the field fetched from.
2750 VALADDR is ignored unless OBJ is NULL, in which case,
2751 VALADDR+OFFSET must address the start of storage containing the
2752 packed value. The value returned in this case is never an lval.
2753 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2756 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2757 long offset, int bit_offset, int bit_size,
2761 const gdb_byte *src; /* First byte containing data to unpack */
2763 const int is_scalar = is_scalar_type (type);
2764 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2765 gdb::byte_vector staging;
2767 type = ada_check_typedef (type);
2770 src = valaddr + offset;
2772 src = value_contents (obj).data () + offset;
2774 if (is_dynamic_type (type))
2776 /* The length of TYPE might by dynamic, so we need to resolve
2777 TYPE in order to know its actual size, which we then use
2778 to create the contents buffer of the value we return.
2779 The difficulty is that the data containing our object is
2780 packed, and therefore maybe not at a byte boundary. So, what
2781 we do, is unpack the data into a byte-aligned buffer, and then
2782 use that buffer as our object's value for resolving the type. */
2783 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2784 staging.resize (staging_len);
2786 ada_unpack_from_contents (src, bit_offset, bit_size,
2787 staging.data (), staging.size (),
2788 is_big_endian, has_negatives (type),
2790 type = resolve_dynamic_type (type, staging, 0);
2791 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2793 /* This happens when the length of the object is dynamic,
2794 and is actually smaller than the space reserved for it.
2795 For instance, in an array of variant records, the bit_size
2796 we're given is the array stride, which is constant and
2797 normally equal to the maximum size of its element.
2798 But, in reality, each element only actually spans a portion
2800 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2806 v = allocate_value (type);
2807 src = valaddr + offset;
2809 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2811 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2814 v = value_at (type, value_address (obj) + offset);
2815 buf = (gdb_byte *) alloca (src_len);
2816 read_memory (value_address (v), buf, src_len);
2821 v = allocate_value (type);
2822 src = value_contents (obj).data () + offset;
2827 long new_offset = offset;
2829 set_value_component_location (v, obj);
2830 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2831 set_value_bitsize (v, bit_size);
2832 if (value_bitpos (v) >= HOST_CHAR_BIT)
2835 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2837 set_value_offset (v, new_offset);
2839 /* Also set the parent value. This is needed when trying to
2840 assign a new value (in inferior memory). */
2841 set_value_parent (v, obj);
2844 set_value_bitsize (v, bit_size);
2845 unpacked = value_contents_writeable (v).data ();
2849 memset (unpacked, 0, TYPE_LENGTH (type));
2853 if (staging.size () == TYPE_LENGTH (type))
2855 /* Small short-cut: If we've unpacked the data into a buffer
2856 of the same size as TYPE's length, then we can reuse that,
2857 instead of doing the unpacking again. */
2858 memcpy (unpacked, staging.data (), staging.size ());
2861 ada_unpack_from_contents (src, bit_offset, bit_size,
2862 unpacked, TYPE_LENGTH (type),
2863 is_big_endian, has_negatives (type), is_scalar);
2868 /* Store the contents of FROMVAL into the location of TOVAL.
2869 Return a new value with the location of TOVAL and contents of
2870 FROMVAL. Handles assignment into packed fields that have
2871 floating-point or non-scalar types. */
2873 static struct value *
2874 ada_value_assign (struct value *toval, struct value *fromval)
2876 struct type *type = value_type (toval);
2877 int bits = value_bitsize (toval);
2879 toval = ada_coerce_ref (toval);
2880 fromval = ada_coerce_ref (fromval);
2882 if (ada_is_direct_array_type (value_type (toval)))
2883 toval = ada_coerce_to_simple_array (toval);
2884 if (ada_is_direct_array_type (value_type (fromval)))
2885 fromval = ada_coerce_to_simple_array (fromval);
2887 if (!deprecated_value_modifiable (toval))
2888 error (_("Left operand of assignment is not a modifiable lvalue."));
2890 if (VALUE_LVAL (toval) == lval_memory
2892 && (type->code () == TYPE_CODE_FLT
2893 || type->code () == TYPE_CODE_STRUCT))
2895 int len = (value_bitpos (toval)
2896 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2898 gdb_byte *buffer = (gdb_byte *) alloca (len);
2900 CORE_ADDR to_addr = value_address (toval);
2902 if (type->code () == TYPE_CODE_FLT)
2903 fromval = value_cast (type, fromval);
2905 read_memory (to_addr, buffer, len);
2906 from_size = value_bitsize (fromval);
2908 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2910 const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2911 ULONGEST from_offset = 0;
2912 if (is_big_endian && is_scalar_type (value_type (fromval)))
2913 from_offset = from_size - bits;
2914 copy_bitwise (buffer, value_bitpos (toval),
2915 value_contents (fromval).data (), from_offset,
2916 bits, is_big_endian);
2917 write_memory_with_notification (to_addr, buffer, len);
2919 val = value_copy (toval);
2920 memcpy (value_contents_raw (val).data (),
2921 value_contents (fromval).data (),
2922 TYPE_LENGTH (type));
2923 deprecated_set_value_type (val, type);
2928 return value_assign (toval, fromval);
2932 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2933 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2934 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2935 COMPONENT, and not the inferior's memory. The current contents
2936 of COMPONENT are ignored.
2938 Although not part of the initial design, this function also works
2939 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2940 had a null address, and COMPONENT had an address which is equal to
2941 its offset inside CONTAINER. */
2944 value_assign_to_component (struct value *container, struct value *component,
2947 LONGEST offset_in_container =
2948 (LONGEST) (value_address (component) - value_address (container));
2949 int bit_offset_in_container =
2950 value_bitpos (component) - value_bitpos (container);
2953 val = value_cast (value_type (component), val);
2955 if (value_bitsize (component) == 0)
2956 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2958 bits = value_bitsize (component);
2960 if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2964 if (is_scalar_type (check_typedef (value_type (component))))
2966 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2969 copy_bitwise ((value_contents_writeable (container).data ()
2970 + offset_in_container),
2971 value_bitpos (container) + bit_offset_in_container,
2972 value_contents (val).data (), src_offset, bits, 1);
2975 copy_bitwise ((value_contents_writeable (container).data ()
2976 + offset_in_container),
2977 value_bitpos (container) + bit_offset_in_container,
2978 value_contents (val).data (), 0, bits, 0);
2981 /* Determine if TYPE is an access to an unconstrained array. */
2984 ada_is_access_to_unconstrained_array (struct type *type)
2986 return (type->code () == TYPE_CODE_TYPEDEF
2987 && is_thick_pntr (ada_typedef_target_type (type)));
2990 /* The value of the element of array ARR at the ARITY indices given in IND.
2991 ARR may be either a simple array, GNAT array descriptor, or pointer
2995 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2999 struct type *elt_type;
3001 elt = ada_coerce_to_simple_array (arr);
3003 elt_type = ada_check_typedef (value_type (elt));
3004 if (elt_type->code () == TYPE_CODE_ARRAY
3005 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3006 return value_subscript_packed (elt, arity, ind);
3008 for (k = 0; k < arity; k += 1)
3010 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
3012 if (elt_type->code () != TYPE_CODE_ARRAY)
3013 error (_("too many subscripts (%d expected)"), k);
3015 elt = value_subscript (elt, pos_atr (ind[k]));
3017 if (ada_is_access_to_unconstrained_array (saved_elt_type)
3018 && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3020 /* The element is a typedef to an unconstrained array,
3021 except that the value_subscript call stripped the
3022 typedef layer. The typedef layer is GNAT's way to
3023 specify that the element is, at the source level, an
3024 access to the unconstrained array, rather than the
3025 unconstrained array. So, we need to restore that
3026 typedef layer, which we can do by forcing the element's
3027 type back to its original type. Otherwise, the returned
3028 value is going to be printed as the array, rather
3029 than as an access. Another symptom of the same issue
3030 would be that an expression trying to dereference the
3031 element would also be improperly rejected. */
3032 deprecated_set_value_type (elt, saved_elt_type);
3035 elt_type = ada_check_typedef (value_type (elt));
3041 /* Assuming ARR is a pointer to a GDB array, the value of the element
3042 of *ARR at the ARITY indices given in IND.
3043 Does not read the entire array into memory.
3045 Note: Unlike what one would expect, this function is used instead of
3046 ada_value_subscript for basically all non-packed array types. The reason
3047 for this is that a side effect of doing our own pointer arithmetics instead
3048 of relying on value_subscript is that there is no implicit typedef peeling.
3049 This is important for arrays of array accesses, where it allows us to
3050 preserve the fact that the array's element is an array access, where the
3051 access part os encoded in a typedef layer. */
3053 static struct value *
3054 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3057 struct value *array_ind = ada_value_ind (arr);
3059 = check_typedef (value_enclosing_type (array_ind));
3061 if (type->code () == TYPE_CODE_ARRAY
3062 && TYPE_FIELD_BITSIZE (type, 0) > 0)
3063 return value_subscript_packed (array_ind, arity, ind);
3065 for (k = 0; k < arity; k += 1)
3069 if (type->code () != TYPE_CODE_ARRAY)
3070 error (_("too many subscripts (%d expected)"), k);
3071 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
3073 get_discrete_bounds (type->index_type (), &lwb, &upb);
3074 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3075 type = TYPE_TARGET_TYPE (type);
3078 return value_ind (arr);
3081 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3082 actual type of ARRAY_PTR is ignored), returns the Ada slice of
3083 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
3084 this array is LOW, as per Ada rules. */
3085 static struct value *
3086 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3089 struct type *type0 = ada_check_typedef (type);
3090 struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
3091 struct type *index_type
3092 = create_static_range_type (NULL, base_index_type, low, high);
3093 struct type *slice_type = create_array_type_with_stride
3094 (NULL, TYPE_TARGET_TYPE (type0), index_type,
3095 type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3096 TYPE_FIELD_BITSIZE (type0, 0));
3097 int base_low = ada_discrete_type_low_bound (type0->index_type ());
3098 gdb::optional<LONGEST> base_low_pos, low_pos;
3101 low_pos = discrete_position (base_index_type, low);
3102 base_low_pos = discrete_position (base_index_type, base_low);
3104 if (!low_pos.has_value () || !base_low_pos.has_value ())
3106 warning (_("unable to get positions in slice, use bounds instead"));
3108 base_low_pos = base_low;
3111 ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3113 stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
3115 base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3116 return value_at_lazy (slice_type, base);
3120 static struct value *
3121 ada_value_slice (struct value *array, int low, int high)
3123 struct type *type = ada_check_typedef (value_type (array));
3124 struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
3125 struct type *index_type
3126 = create_static_range_type (NULL, type->index_type (), low, high);
3127 struct type *slice_type = create_array_type_with_stride
3128 (NULL, TYPE_TARGET_TYPE (type), index_type,
3129 type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3130 TYPE_FIELD_BITSIZE (type, 0));
3131 gdb::optional<LONGEST> low_pos, high_pos;
3134 low_pos = discrete_position (base_index_type, low);
3135 high_pos = discrete_position (base_index_type, high);
3137 if (!low_pos.has_value () || !high_pos.has_value ())
3139 warning (_("unable to get positions in slice, use bounds instead"));
3144 return value_cast (slice_type,
3145 value_slice (array, low, *high_pos - *low_pos + 1));
3148 /* If type is a record type in the form of a standard GNAT array
3149 descriptor, returns the number of dimensions for type. If arr is a
3150 simple array, returns the number of "array of"s that prefix its
3151 type designation. Otherwise, returns 0. */
3154 ada_array_arity (struct type *type)
3161 type = desc_base_type (type);
3164 if (type->code () == TYPE_CODE_STRUCT)
3165 return desc_arity (desc_bounds_type (type));
3167 while (type->code () == TYPE_CODE_ARRAY)
3170 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
3176 /* If TYPE is a record type in the form of a standard GNAT array
3177 descriptor or a simple array type, returns the element type for
3178 TYPE after indexing by NINDICES indices, or by all indices if
3179 NINDICES is -1. Otherwise, returns NULL. */
3182 ada_array_element_type (struct type *type, int nindices)
3184 type = desc_base_type (type);
3186 if (type->code () == TYPE_CODE_STRUCT)
3189 struct type *p_array_type;
3191 p_array_type = desc_data_target_type (type);
3193 k = ada_array_arity (type);
3197 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3198 if (nindices >= 0 && k > nindices)
3200 while (k > 0 && p_array_type != NULL)
3202 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3205 return p_array_type;
3207 else if (type->code () == TYPE_CODE_ARRAY)
3209 while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3211 type = TYPE_TARGET_TYPE (type);
3212 /* A multi-dimensional array is represented using a sequence
3213 of array types. If one of these types has a name, then
3214 it is not another dimension of the outer array, but
3215 rather the element type of the outermost array. */
3216 if (type->name () != nullptr)
3226 /* See ada-lang.h. */
3229 ada_index_type (struct type *type, int n, const char *name)
3231 struct type *result_type;
3233 type = desc_base_type (type);
3235 if (n < 0 || n > ada_array_arity (type))
3236 error (_("invalid dimension number to '%s"), name);
3238 if (ada_is_simple_array_type (type))
3242 for (i = 1; i < n; i += 1)
3244 type = ada_check_typedef (type);
3245 type = TYPE_TARGET_TYPE (type);
3247 result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
3248 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3249 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3250 perhaps stabsread.c would make more sense. */
3251 if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3256 result_type = desc_index_type (desc_bounds_type (type), n);
3257 if (result_type == NULL)
3258 error (_("attempt to take bound of something that is not an array"));
3264 /* Given that arr is an array type, returns the lower bound of the
3265 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3266 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3267 array-descriptor type. It works for other arrays with bounds supplied
3268 by run-time quantities other than discriminants. */
3271 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3273 struct type *type, *index_type_desc, *index_type;
3276 gdb_assert (which == 0 || which == 1);
3278 if (ada_is_constrained_packed_array_type (arr_type))
3279 arr_type = decode_constrained_packed_array_type (arr_type);
3281 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3282 return (LONGEST) - which;
3284 if (arr_type->code () == TYPE_CODE_PTR)
3285 type = TYPE_TARGET_TYPE (arr_type);
3289 if (type->is_fixed_instance ())
3291 /* The array has already been fixed, so we do not need to
3292 check the parallel ___XA type again. That encoding has
3293 already been applied, so ignore it now. */
3294 index_type_desc = NULL;
3298 index_type_desc = ada_find_parallel_type (type, "___XA");
3299 ada_fixup_array_indexes_type (index_type_desc);
3302 if (index_type_desc != NULL)
3303 index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3307 struct type *elt_type = check_typedef (type);
3309 for (i = 1; i < n; i++)
3310 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3312 index_type = elt_type->index_type ();
3316 (LONGEST) (which == 0
3317 ? ada_discrete_type_low_bound (index_type)
3318 : ada_discrete_type_high_bound (index_type));
3321 /* Given that arr is an array value, returns the lower bound of the
3322 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3323 WHICH is 1. This routine will also work for arrays with bounds
3324 supplied by run-time quantities other than discriminants. */
3327 ada_array_bound (struct value *arr, int n, int which)
3329 struct type *arr_type;
3331 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3332 arr = value_ind (arr);
3333 arr_type = value_enclosing_type (arr);
3335 if (ada_is_constrained_packed_array_type (arr_type))
3336 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3337 else if (ada_is_simple_array_type (arr_type))
3338 return ada_array_bound_from_type (arr_type, n, which);
3340 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3343 /* Given that arr is an array value, returns the length of the
3344 nth index. This routine will also work for arrays with bounds
3345 supplied by run-time quantities other than discriminants.
3346 Does not work for arrays indexed by enumeration types with representation
3347 clauses at the moment. */
3350 ada_array_length (struct value *arr, int n)
3352 struct type *arr_type, *index_type;
3355 if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3356 arr = value_ind (arr);
3357 arr_type = value_enclosing_type (arr);
3359 if (ada_is_constrained_packed_array_type (arr_type))
3360 return ada_array_length (decode_constrained_packed_array (arr), n);
3362 if (ada_is_simple_array_type (arr_type))
3364 low = ada_array_bound_from_type (arr_type, n, 0);
3365 high = ada_array_bound_from_type (arr_type, n, 1);
3369 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3370 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3373 arr_type = check_typedef (arr_type);
3374 index_type = ada_index_type (arr_type, n, "length");
3375 if (index_type != NULL)
3377 struct type *base_type;
3378 if (index_type->code () == TYPE_CODE_RANGE)
3379 base_type = TYPE_TARGET_TYPE (index_type);
3381 base_type = index_type;
3383 low = pos_atr (value_from_longest (base_type, low));
3384 high = pos_atr (value_from_longest (base_type, high));
3386 return high - low + 1;
3389 /* An array whose type is that of ARR_TYPE (an array type), with
3390 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3391 less than LOW, then LOW-1 is used. */
3393 static struct value *
3394 empty_array (struct type *arr_type, int low, int high)
3396 struct type *arr_type0 = ada_check_typedef (arr_type);
3397 struct type *index_type
3398 = create_static_range_type
3399 (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3400 high < low ? low - 1 : high);
3401 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3403 return allocate_value (create_array_type (NULL, elt_type, index_type));
3407 /* Name resolution */
3409 /* The "decoded" name for the user-definable Ada operator corresponding
3413 ada_decoded_op_name (enum exp_opcode op)
3417 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3419 if (ada_opname_table[i].op == op)
3420 return ada_opname_table[i].decoded;
3422 error (_("Could not find operator name for opcode"));
3425 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3426 in a listing of choices during disambiguation (see sort_choices, below).
3427 The idea is that overloadings of a subprogram name from the
3428 same package should sort in their source order. We settle for ordering
3429 such symbols by their trailing number (__N or $N). */
3432 encoded_ordered_before (const char *N0, const char *N1)
3436 else if (N0 == NULL)
3442 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3444 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3446 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3447 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3452 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3455 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3457 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3458 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3460 return (strcmp (N0, N1) < 0);
3464 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3468 sort_choices (struct block_symbol syms[], int nsyms)
3472 for (i = 1; i < nsyms; i += 1)
3474 struct block_symbol sym = syms[i];
3477 for (j = i - 1; j >= 0; j -= 1)
3479 if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3480 sym.symbol->linkage_name ()))
3482 syms[j + 1] = syms[j];
3488 /* Whether GDB should display formals and return types for functions in the
3489 overloads selection menu. */
3490 static bool print_signatures = true;
3492 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3493 all but functions, the signature is just the name of the symbol. For
3494 functions, this is the name of the function, the list of types for formals
3495 and the return type (if any). */
3498 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3499 const struct type_print_options *flags)
3501 struct type *type = sym->type ();
3503 gdb_printf (stream, "%s", sym->print_name ());
3504 if (!print_signatures
3506 || type->code () != TYPE_CODE_FUNC)
3509 if (type->num_fields () > 0)
3513 gdb_printf (stream, " (");
3514 for (i = 0; i < type->num_fields (); ++i)
3517 gdb_printf (stream, "; ");
3518 ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3521 gdb_printf (stream, ")");
3523 if (TYPE_TARGET_TYPE (type) != NULL
3524 && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3526 gdb_printf (stream, " return ");
3527 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3531 /* Read and validate a set of numeric choices from the user in the
3532 range 0 .. N_CHOICES-1. Place the results in increasing
3533 order in CHOICES[0 .. N-1], and return N.
3535 The user types choices as a sequence of numbers on one line
3536 separated by blanks, encoding them as follows:
3538 + A choice of 0 means to cancel the selection, throwing an error.
3539 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3540 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3542 The user is not allowed to choose more than MAX_RESULTS values.
3544 ANNOTATION_SUFFIX, if present, is used to annotate the input
3545 prompts (for use with the -f switch). */
3548 get_selections (int *choices, int n_choices, int max_results,
3549 int is_all_choice, const char *annotation_suffix)
3554 int first_choice = is_all_choice ? 2 : 1;
3556 prompt = getenv ("PS2");
3560 args = command_line_input (prompt, annotation_suffix);
3563 error_no_arg (_("one or more choice numbers"));
3567 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3568 order, as given in args. Choices are validated. */
3574 args = skip_spaces (args);
3575 if (*args == '\0' && n_chosen == 0)
3576 error_no_arg (_("one or more choice numbers"));
3577 else if (*args == '\0')
3580 choice = strtol (args, &args2, 10);
3581 if (args == args2 || choice < 0
3582 || choice > n_choices + first_choice - 1)
3583 error (_("Argument must be choice number"));
3587 error (_("cancelled"));
3589 if (choice < first_choice)
3591 n_chosen = n_choices;
3592 for (j = 0; j < n_choices; j += 1)
3596 choice -= first_choice;
3598 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3602 if (j < 0 || choice != choices[j])
3606 for (k = n_chosen - 1; k > j; k -= 1)
3607 choices[k + 1] = choices[k];
3608 choices[j + 1] = choice;
3613 if (n_chosen > max_results)
3614 error (_("Select no more than %d of the above"), max_results);
3619 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3620 by asking the user (if necessary), returning the number selected,
3621 and setting the first elements of SYMS items. Error if no symbols
3624 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3625 to be re-integrated one of these days. */
3628 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3631 int *chosen = XALLOCAVEC (int , nsyms);
3633 int first_choice = (max_results == 1) ? 1 : 2;
3634 const char *select_mode = multiple_symbols_select_mode ();
3636 if (max_results < 1)
3637 error (_("Request to select 0 symbols!"));
3641 if (select_mode == multiple_symbols_cancel)
3643 canceled because the command is ambiguous\n\
3644 See set/show multiple-symbol."));
3646 /* If select_mode is "all", then return all possible symbols.
3647 Only do that if more than one symbol can be selected, of course.
3648 Otherwise, display the menu as usual. */
3649 if (select_mode == multiple_symbols_all && max_results > 1)
3652 gdb_printf (_("[0] cancel\n"));
3653 if (max_results > 1)
3654 gdb_printf (_("[1] all\n"));
3656 sort_choices (syms, nsyms);
3658 for (i = 0; i < nsyms; i += 1)
3660 if (syms[i].symbol == NULL)
3663 if (syms[i].symbol->aclass () == LOC_BLOCK)
3665 struct symtab_and_line sal =
3666 find_function_start_sal (syms[i].symbol, 1);
3668 gdb_printf ("[%d] ", i + first_choice);
3669 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3670 &type_print_raw_options);
3671 if (sal.symtab == NULL)
3672 gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3673 metadata_style.style ().ptr (), nullptr, sal.line);
3677 styled_string (file_name_style.style (),
3678 symtab_to_filename_for_display (sal.symtab)),
3685 (syms[i].symbol->aclass () == LOC_CONST
3686 && syms[i].symbol->type () != NULL
3687 && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3688 struct symtab *symtab = NULL;
3690 if (syms[i].symbol->is_objfile_owned ())
3691 symtab = syms[i].symbol->symtab ();
3693 if (syms[i].symbol->line () != 0 && symtab != NULL)
3695 gdb_printf ("[%d] ", i + first_choice);
3696 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3697 &type_print_raw_options);
3698 gdb_printf (_(" at %s:%d\n"),
3699 symtab_to_filename_for_display (symtab),
3700 syms[i].symbol->line ());
3702 else if (is_enumeral
3703 && syms[i].symbol->type ()->name () != NULL)
3705 gdb_printf (("[%d] "), i + first_choice);
3706 ada_print_type (syms[i].symbol->type (), NULL,
3707 gdb_stdout, -1, 0, &type_print_raw_options);
3708 gdb_printf (_("'(%s) (enumeral)\n"),
3709 syms[i].symbol->print_name ());
3713 gdb_printf ("[%d] ", i + first_choice);
3714 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3715 &type_print_raw_options);
3718 gdb_printf (is_enumeral
3719 ? _(" in %s (enumeral)\n")
3721 symtab_to_filename_for_display (symtab));
3723 gdb_printf (is_enumeral
3724 ? _(" (enumeral)\n")
3730 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3733 for (i = 0; i < n_chosen; i += 1)
3734 syms[i] = syms[chosen[i]];
3739 /* See ada-lang.h. */
3742 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3743 int nargs, value *argvec[])
3745 if (possible_user_operator_p (op, argvec))
3747 std::vector<struct block_symbol> candidates
3748 = ada_lookup_symbol_list (ada_decoded_op_name (op),
3751 int i = ada_resolve_function (candidates, argvec,
3752 nargs, ada_decoded_op_name (op), NULL,
3755 return candidates[i];
3760 /* See ada-lang.h. */
3763 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3764 struct type *context_type,
3765 bool parse_completion,
3766 int nargs, value *argvec[],
3767 innermost_block_tracker *tracker)
3769 std::vector<struct block_symbol> candidates
3770 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3773 if (candidates.size () == 1)
3777 i = ada_resolve_function
3780 sym->linkage_name (),
3781 context_type, parse_completion);
3783 error (_("Could not find a match for %s"), sym->print_name ());
3786 tracker->update (candidates[i]);
3787 return candidates[i];
3790 /* Resolve a mention of a name where the context type is an
3791 enumeration type. */
3794 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3795 const char *name, struct type *context_type,
3796 bool parse_completion)
3798 gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3799 context_type = ada_check_typedef (context_type);
3801 for (int i = 0; i < syms.size (); ++i)
3803 /* We already know the name matches, so we're just looking for
3804 an element of the correct enum type. */
3805 if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3809 error (_("No name '%s' in enumeration type '%s'"), name,
3810 ada_type_name (context_type));
3813 /* See ada-lang.h. */
3816 ada_resolve_variable (struct symbol *sym, const struct block *block,
3817 struct type *context_type,
3818 bool parse_completion,
3820 innermost_block_tracker *tracker)
3822 std::vector<struct block_symbol> candidates
3823 = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3825 if (std::any_of (candidates.begin (),
3827 [] (block_symbol &bsym)
3829 switch (bsym.symbol->aclass ())
3834 case LOC_REGPARM_ADDR:
3843 /* Types tend to get re-introduced locally, so if there
3844 are any local symbols that are not types, first filter
3848 (candidates.begin (),
3850 [] (block_symbol &bsym)
3852 return bsym.symbol->aclass () == LOC_TYPEDEF;
3857 /* Filter out artificial symbols. */
3860 (candidates.begin (),
3862 [] (block_symbol &bsym)
3864 return bsym.symbol->is_artificial ();
3869 if (candidates.empty ())
3870 error (_("No definition found for %s"), sym->print_name ());
3871 else if (candidates.size () == 1)
3873 else if (context_type != nullptr
3874 && context_type->code () == TYPE_CODE_ENUM)
3875 i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3877 else if (deprocedure_p && !is_nonfunction (candidates))
3879 i = ada_resolve_function
3880 (candidates, NULL, 0,
3881 sym->linkage_name (),
3882 context_type, parse_completion);
3884 error (_("Could not find a match for %s"), sym->print_name ());
3888 gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3889 user_select_syms (candidates.data (), candidates.size (), 1);
3893 tracker->update (candidates[i]);
3894 return candidates[i];
3897 /* Return non-zero if formal type FTYPE matches actual type ATYPE. */
3898 /* The term "match" here is rather loose. The match is heuristic and
3902 ada_type_match (struct type *ftype, struct type *atype)
3904 ftype = ada_check_typedef (ftype);
3905 atype = ada_check_typedef (atype);
3907 if (ftype->code () == TYPE_CODE_REF)
3908 ftype = TYPE_TARGET_TYPE (ftype);
3909 if (atype->code () == TYPE_CODE_REF)
3910 atype = TYPE_TARGET_TYPE (atype);
3912 switch (ftype->code ())
3915 return ftype->code () == atype->code ();
3917 if (atype->code () != TYPE_CODE_PTR)
3919 atype = TYPE_TARGET_TYPE (atype);
3920 /* This can only happen if the actual argument is 'null'. */
3921 if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3923 return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3925 case TYPE_CODE_ENUM:
3926 case TYPE_CODE_RANGE:
3927 switch (atype->code ())
3930 case TYPE_CODE_ENUM:
3931 case TYPE_CODE_RANGE:
3937 case TYPE_CODE_ARRAY:
3938 return (atype->code () == TYPE_CODE_ARRAY
3939 || ada_is_array_descriptor_type (atype));
3941 case TYPE_CODE_STRUCT:
3942 if (ada_is_array_descriptor_type (ftype))
3943 return (atype->code () == TYPE_CODE_ARRAY
3944 || ada_is_array_descriptor_type (atype));
3946 return (atype->code () == TYPE_CODE_STRUCT
3947 && !ada_is_array_descriptor_type (atype));
3949 case TYPE_CODE_UNION:
3951 return (atype->code () == ftype->code ());
3955 /* Return non-zero if the formals of FUNC "sufficiently match" the
3956 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3957 may also be an enumeral, in which case it is treated as a 0-
3958 argument function. */
3961 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3964 struct type *func_type = func->type ();
3966 if (func->aclass () == LOC_CONST
3967 && func_type->code () == TYPE_CODE_ENUM)
3968 return (n_actuals == 0);
3969 else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3972 if (func_type->num_fields () != n_actuals)
3975 for (i = 0; i < n_actuals; i += 1)
3977 if (actuals[i] == NULL)
3981 struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3982 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3984 if (!ada_type_match (ftype, atype))
3991 /* False iff function type FUNC_TYPE definitely does not produce a value
3992 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3993 FUNC_TYPE is not a valid function type with a non-null return type
3994 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3997 return_match (struct type *func_type, struct type *context_type)
3999 struct type *return_type;
4001 if (func_type == NULL)
4004 if (func_type->code () == TYPE_CODE_FUNC)
4005 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4007 return_type = get_base_type (func_type);
4008 if (return_type == NULL)
4011 context_type = get_base_type (context_type);
4013 if (return_type->code () == TYPE_CODE_ENUM)
4014 return context_type == NULL || return_type == context_type;
4015 else if (context_type == NULL)
4016 return return_type->code () != TYPE_CODE_VOID;
4018 return return_type->code () == context_type->code ();
4022 /* Returns the index in SYMS that contains the symbol for the
4023 function (if any) that matches the types of the NARGS arguments in
4024 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
4025 that returns that type, then eliminate matches that don't. If
4026 CONTEXT_TYPE is void and there is at least one match that does not
4027 return void, eliminate all matches that do.
4029 Asks the user if there is more than one match remaining. Returns -1
4030 if there is no such symbol or none is selected. NAME is used
4031 solely for messages. May re-arrange and modify SYMS in
4032 the process; the index returned is for the modified vector. */
4035 ada_resolve_function (std::vector<struct block_symbol> &syms,
4036 struct value **args, int nargs,
4037 const char *name, struct type *context_type,
4038 bool parse_completion)
4042 int m; /* Number of hits */
4045 /* In the first pass of the loop, we only accept functions matching
4046 context_type. If none are found, we add a second pass of the loop
4047 where every function is accepted. */
4048 for (fallback = 0; m == 0 && fallback < 2; fallback++)
4050 for (k = 0; k < syms.size (); k += 1)
4052 struct type *type = ada_check_typedef (syms[k].symbol->type ());
4054 if (ada_args_match (syms[k].symbol, args, nargs)
4055 && (fallback || return_match (type, context_type)))
4063 /* If we got multiple matches, ask the user which one to use. Don't do this
4064 interactive thing during completion, though, as the purpose of the
4065 completion is providing a list of all possible matches. Prompting the
4066 user to filter it down would be completely unexpected in this case. */
4069 else if (m > 1 && !parse_completion)
4071 gdb_printf (_("Multiple matches for %s\n"), name);
4072 user_select_syms (syms.data (), m, 1);
4078 /* Type-class predicates */
4080 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4084 numeric_type_p (struct type *type)
4090 switch (type->code ())
4094 case TYPE_CODE_FIXED_POINT:
4096 case TYPE_CODE_RANGE:
4097 return (type == TYPE_TARGET_TYPE (type)
4098 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4105 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4108 integer_type_p (struct type *type)
4114 switch (type->code ())
4118 case TYPE_CODE_RANGE:
4119 return (type == TYPE_TARGET_TYPE (type)
4120 || integer_type_p (TYPE_TARGET_TYPE (type)));
4127 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4130 scalar_type_p (struct type *type)
4136 switch (type->code ())
4139 case TYPE_CODE_RANGE:
4140 case TYPE_CODE_ENUM:
4142 case TYPE_CODE_FIXED_POINT:
4150 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4153 discrete_type_p (struct type *type)
4159 switch (type->code ())
4162 case TYPE_CODE_RANGE:
4163 case TYPE_CODE_ENUM:
4164 case TYPE_CODE_BOOL:
4172 /* Returns non-zero if OP with operands in the vector ARGS could be
4173 a user-defined function. Errs on the side of pre-defined operators
4174 (i.e., result 0). */
4177 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4179 struct type *type0 =
4180 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4181 struct type *type1 =
4182 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4196 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4200 case BINOP_BITWISE_AND:
4201 case BINOP_BITWISE_IOR:
4202 case BINOP_BITWISE_XOR:
4203 return (!(integer_type_p (type0) && integer_type_p (type1)));
4206 case BINOP_NOTEQUAL:
4211 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4214 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4217 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4221 case UNOP_LOGICAL_NOT:
4223 return (!numeric_type_p (type0));
4232 1. In the following, we assume that a renaming type's name may
4233 have an ___XD suffix. It would be nice if this went away at some
4235 2. We handle both the (old) purely type-based representation of
4236 renamings and the (new) variable-based encoding. At some point,
4237 it is devoutly to be hoped that the former goes away
4238 (FIXME: hilfinger-2007-07-09).
4239 3. Subprogram renamings are not implemented, although the XRS
4240 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4242 /* If SYM encodes a renaming,
4244 <renaming> renames <renamed entity>,
4246 sets *LEN to the length of the renamed entity's name,
4247 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4248 the string describing the subcomponent selected from the renamed
4249 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4250 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4251 are undefined). Otherwise, returns a value indicating the category
4252 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4253 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4254 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4255 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4256 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4257 may be NULL, in which case they are not assigned.
4259 [Currently, however, GCC does not generate subprogram renamings.] */
4261 enum ada_renaming_category
4262 ada_parse_renaming (struct symbol *sym,
4263 const char **renamed_entity, int *len,
4264 const char **renaming_expr)
4266 enum ada_renaming_category kind;
4271 return ADA_NOT_RENAMING;
4272 switch (sym->aclass ())
4275 return ADA_NOT_RENAMING;
4279 case LOC_OPTIMIZED_OUT:
4280 info = strstr (sym->linkage_name (), "___XR");
4282 return ADA_NOT_RENAMING;
4286 kind = ADA_OBJECT_RENAMING;
4290 kind = ADA_EXCEPTION_RENAMING;
4294 kind = ADA_PACKAGE_RENAMING;
4298 kind = ADA_SUBPROGRAM_RENAMING;
4302 return ADA_NOT_RENAMING;
4306 if (renamed_entity != NULL)
4307 *renamed_entity = info;
4308 suffix = strstr (info, "___XE");
4309 if (suffix == NULL || suffix == info)
4310 return ADA_NOT_RENAMING;
4312 *len = strlen (info) - strlen (suffix);
4314 if (renaming_expr != NULL)
4315 *renaming_expr = suffix;
4319 /* Compute the value of the given RENAMING_SYM, which is expected to
4320 be a symbol encoding a renaming expression. BLOCK is the block
4321 used to evaluate the renaming. */
4323 static struct value *
4324 ada_read_renaming_var_value (struct symbol *renaming_sym,
4325 const struct block *block)
4327 const char *sym_name;
4329 sym_name = renaming_sym->linkage_name ();
4330 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4331 return evaluate_expression (expr.get ());
4335 /* Evaluation: Function Calls */
4337 /* Return an lvalue containing the value VAL. This is the identity on
4338 lvalues, and otherwise has the side-effect of allocating memory
4339 in the inferior where a copy of the value contents is copied. */
4341 static struct value *
4342 ensure_lval (struct value *val)
4344 if (VALUE_LVAL (val) == not_lval
4345 || VALUE_LVAL (val) == lval_internalvar)
4347 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4348 const CORE_ADDR addr =
4349 value_as_long (value_allocate_space_in_inferior (len));
4351 VALUE_LVAL (val) = lval_memory;
4352 set_value_address (val, addr);
4353 write_memory (addr, value_contents (val).data (), len);
4359 /* Given ARG, a value of type (pointer or reference to a)*
4360 structure/union, extract the component named NAME from the ultimate
4361 target structure/union and return it as a value with its
4364 The routine searches for NAME among all members of the structure itself
4365 and (recursively) among all members of any wrapper members
4368 If NO_ERR, then simply return NULL in case of error, rather than
4371 static struct value *
4372 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4374 struct type *t, *t1;
4379 t1 = t = ada_check_typedef (value_type (arg));
4380 if (t->code () == TYPE_CODE_REF)
4382 t1 = TYPE_TARGET_TYPE (t);
4385 t1 = ada_check_typedef (t1);
4386 if (t1->code () == TYPE_CODE_PTR)
4388 arg = coerce_ref (arg);
4393 while (t->code () == TYPE_CODE_PTR)
4395 t1 = TYPE_TARGET_TYPE (t);
4398 t1 = ada_check_typedef (t1);
4399 if (t1->code () == TYPE_CODE_PTR)
4401 arg = value_ind (arg);
4408 if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4412 v = ada_search_struct_field (name, arg, 0, t);
4415 int bit_offset, bit_size, byte_offset;
4416 struct type *field_type;
4419 if (t->code () == TYPE_CODE_PTR)
4420 address = value_address (ada_value_ind (arg));
4422 address = value_address (ada_coerce_ref (arg));
4424 /* Check to see if this is a tagged type. We also need to handle
4425 the case where the type is a reference to a tagged type, but
4426 we have to be careful to exclude pointers to tagged types.
4427 The latter should be shown as usual (as a pointer), whereas
4428 a reference should mostly be transparent to the user. */
4430 if (ada_is_tagged_type (t1, 0)
4431 || (t1->code () == TYPE_CODE_REF
4432 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4434 /* We first try to find the searched field in the current type.
4435 If not found then let's look in the fixed type. */
4437 if (!find_struct_field (name, t1, 0,
4438 nullptr, nullptr, nullptr,
4447 /* Convert to fixed type in all cases, so that we have proper
4448 offsets to each field in unconstrained record types. */
4449 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4450 address, NULL, check_tag);
4452 /* Resolve the dynamic type as well. */
4453 arg = value_from_contents_and_address (t1, nullptr, address);
4454 t1 = value_type (arg);
4456 if (find_struct_field (name, t1, 0,
4457 &field_type, &byte_offset, &bit_offset,
4462 if (t->code () == TYPE_CODE_REF)
4463 arg = ada_coerce_ref (arg);
4465 arg = ada_value_ind (arg);
4466 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4467 bit_offset, bit_size,
4471 v = value_at_lazy (field_type, address + byte_offset);
4475 if (v != NULL || no_err)
4478 error (_("There is no member named %s."), name);
4484 error (_("Attempt to extract a component of "
4485 "a value that is not a record."));
4488 /* Return the value ACTUAL, converted to be an appropriate value for a
4489 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4490 allocating any necessary descriptors (fat pointers), or copies of
4491 values not residing in memory, updating it as needed. */
4494 ada_convert_actual (struct value *actual, struct type *formal_type0)
4496 struct type *actual_type = ada_check_typedef (value_type (actual));
4497 struct type *formal_type = ada_check_typedef (formal_type0);
4498 struct type *formal_target =
4499 formal_type->code () == TYPE_CODE_PTR
4500 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4501 struct type *actual_target =
4502 actual_type->code () == TYPE_CODE_PTR
4503 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4505 if (ada_is_array_descriptor_type (formal_target)
4506 && actual_target->code () == TYPE_CODE_ARRAY)
4507 return make_array_descriptor (formal_type, actual);
4508 else if (formal_type->code () == TYPE_CODE_PTR
4509 || formal_type->code () == TYPE_CODE_REF)
4511 struct value *result;
4513 if (formal_target->code () == TYPE_CODE_ARRAY
4514 && ada_is_array_descriptor_type (actual_target))
4515 result = desc_data (actual);
4516 else if (formal_type->code () != TYPE_CODE_PTR)
4518 if (VALUE_LVAL (actual) != lval_memory)
4522 actual_type = ada_check_typedef (value_type (actual));
4523 val = allocate_value (actual_type);
4524 copy (value_contents (actual), value_contents_raw (val));
4525 actual = ensure_lval (val);
4527 result = value_addr (actual);
4531 return value_cast_pointers (formal_type, result, 0);
4533 else if (actual_type->code () == TYPE_CODE_PTR)
4534 return ada_value_ind (actual);
4535 else if (ada_is_aligner_type (formal_type))
4537 /* We need to turn this parameter into an aligner type
4539 struct value *aligner = allocate_value (formal_type);
4540 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4542 value_assign_to_component (aligner, component, actual);
4549 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4550 type TYPE. This is usually an inefficient no-op except on some targets
4551 (such as AVR) where the representation of a pointer and an address
4555 value_pointer (struct value *value, struct type *type)
4557 unsigned len = TYPE_LENGTH (type);
4558 gdb_byte *buf = (gdb_byte *) alloca (len);
4561 addr = value_address (value);
4562 gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4563 addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4568 /* Push a descriptor of type TYPE for array value ARR on the stack at
4569 *SP, updating *SP to reflect the new descriptor. Return either
4570 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4571 to-descriptor type rather than a descriptor type), a struct value *
4572 representing a pointer to this descriptor. */
4574 static struct value *
4575 make_array_descriptor (struct type *type, struct value *arr)
4577 struct type *bounds_type = desc_bounds_type (type);
4578 struct type *desc_type = desc_base_type (type);
4579 struct value *descriptor = allocate_value (desc_type);
4580 struct value *bounds = allocate_value (bounds_type);
4583 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4586 modify_field (value_type (bounds),
4587 value_contents_writeable (bounds).data (),
4588 ada_array_bound (arr, i, 0),
4589 desc_bound_bitpos (bounds_type, i, 0),
4590 desc_bound_bitsize (bounds_type, i, 0));
4591 modify_field (value_type (bounds),
4592 value_contents_writeable (bounds).data (),
4593 ada_array_bound (arr, i, 1),
4594 desc_bound_bitpos (bounds_type, i, 1),
4595 desc_bound_bitsize (bounds_type, i, 1));
4598 bounds = ensure_lval (bounds);
4600 modify_field (value_type (descriptor),
4601 value_contents_writeable (descriptor).data (),
4602 value_pointer (ensure_lval (arr),
4603 desc_type->field (0).type ()),
4604 fat_pntr_data_bitpos (desc_type),
4605 fat_pntr_data_bitsize (desc_type));
4607 modify_field (value_type (descriptor),
4608 value_contents_writeable (descriptor).data (),
4609 value_pointer (bounds,
4610 desc_type->field (1).type ()),
4611 fat_pntr_bounds_bitpos (desc_type),
4612 fat_pntr_bounds_bitsize (desc_type));
4614 descriptor = ensure_lval (descriptor);
4616 if (type->code () == TYPE_CODE_PTR)
4617 return value_addr (descriptor);
4622 /* Symbol Cache Module */
4624 /* Performance measurements made as of 2010-01-15 indicate that
4625 this cache does bring some noticeable improvements. Depending
4626 on the type of entity being printed, the cache can make it as much
4627 as an order of magnitude faster than without it.
4629 The descriptive type DWARF extension has significantly reduced
4630 the need for this cache, at least when DWARF is being used. However,
4631 even in this case, some expensive name-based symbol searches are still
4632 sometimes necessary - to find an XVZ variable, mostly. */
4634 /* Return the symbol cache associated to the given program space PSPACE.
4635 If not allocated for this PSPACE yet, allocate and initialize one. */
4637 static struct ada_symbol_cache *
4638 ada_get_symbol_cache (struct program_space *pspace)
4640 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4642 if (pspace_data->sym_cache == nullptr)
4643 pspace_data->sym_cache.reset (new ada_symbol_cache);
4645 return pspace_data->sym_cache.get ();
4648 /* Clear all entries from the symbol cache. */
4651 ada_clear_symbol_cache ()
4653 struct ada_pspace_data *pspace_data
4654 = get_ada_pspace_data (current_program_space);
4656 if (pspace_data->sym_cache != nullptr)
4657 pspace_data->sym_cache.reset ();
4660 /* Search our cache for an entry matching NAME and DOMAIN.
4661 Return it if found, or NULL otherwise. */
4663 static struct cache_entry **
4664 find_entry (const char *name, domain_enum domain)
4666 struct ada_symbol_cache *sym_cache
4667 = ada_get_symbol_cache (current_program_space);
4668 int h = msymbol_hash (name) % HASH_SIZE;
4669 struct cache_entry **e;
4671 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4673 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4679 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4680 Return 1 if found, 0 otherwise.
4682 If an entry was found and SYM is not NULL, set *SYM to the entry's
4683 SYM. Same principle for BLOCK if not NULL. */
4686 lookup_cached_symbol (const char *name, domain_enum domain,
4687 struct symbol **sym, const struct block **block)
4689 struct cache_entry **e = find_entry (name, domain);
4696 *block = (*e)->block;
4700 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4701 in domain DOMAIN, save this result in our symbol cache. */
4704 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4705 const struct block *block)
4707 struct ada_symbol_cache *sym_cache
4708 = ada_get_symbol_cache (current_program_space);
4710 struct cache_entry *e;
4712 /* Symbols for builtin types don't have a block.
4713 For now don't cache such symbols. */
4714 if (sym != NULL && !sym->is_objfile_owned ())
4717 /* If the symbol is a local symbol, then do not cache it, as a search
4718 for that symbol depends on the context. To determine whether
4719 the symbol is local or not, we check the block where we found it
4720 against the global and static blocks of its associated symtab. */
4723 const blockvector &bv = *sym->symtab ()->compunit ()->blockvector ();
4725 if (bv.global_block () != block && bv.static_block () != block)
4729 h = msymbol_hash (name) % HASH_SIZE;
4730 e = XOBNEW (&sym_cache->cache_space, cache_entry);
4731 e->next = sym_cache->root[h];
4732 sym_cache->root[h] = e;
4733 e->name = obstack_strdup (&sym_cache->cache_space, name);
4741 /* Return the symbol name match type that should be used used when
4742 searching for all symbols matching LOOKUP_NAME.
4744 LOOKUP_NAME is expected to be a symbol name after transformation
4747 static symbol_name_match_type
4748 name_match_type_from_name (const char *lookup_name)
4750 return (strstr (lookup_name, "__") == NULL
4751 ? symbol_name_match_type::WILD
4752 : symbol_name_match_type::FULL);
4755 /* Return the result of a standard (literal, C-like) lookup of NAME in
4756 given DOMAIN, visible from lexical block BLOCK. */
4758 static struct symbol *
4759 standard_lookup (const char *name, const struct block *block,
4762 /* Initialize it just to avoid a GCC false warning. */
4763 struct block_symbol sym = {};
4765 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4767 ada_lookup_encoded_symbol (name, block, domain, &sym);
4768 cache_symbol (name, domain, sym.symbol, sym.block);
4773 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4774 in the symbol fields of SYMS. We treat enumerals as functions,
4775 since they contend in overloading in the same way. */
4777 is_nonfunction (const std::vector<struct block_symbol> &syms)
4779 for (const block_symbol &sym : syms)
4780 if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4781 && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4782 || sym.symbol->aclass () != LOC_CONST))
4788 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4789 struct types. Otherwise, they may not. */
4792 equiv_types (struct type *type0, struct type *type1)
4796 if (type0 == NULL || type1 == NULL
4797 || type0->code () != type1->code ())
4799 if ((type0->code () == TYPE_CODE_STRUCT
4800 || type0->code () == TYPE_CODE_ENUM)
4801 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4802 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4808 /* True iff SYM0 represents the same entity as SYM1, or one that is
4809 no more defined than that of SYM1. */
4812 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4816 if (sym0->domain () != sym1->domain ()
4817 || sym0->aclass () != sym1->aclass ())
4820 switch (sym0->aclass ())
4826 struct type *type0 = sym0->type ();
4827 struct type *type1 = sym1->type ();
4828 const char *name0 = sym0->linkage_name ();
4829 const char *name1 = sym1->linkage_name ();
4830 int len0 = strlen (name0);
4833 type0->code () == type1->code ()
4834 && (equiv_types (type0, type1)
4835 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4836 && startswith (name1 + len0, "___XV")));
4839 return sym0->value_longest () == sym1->value_longest ()
4840 && equiv_types (sym0->type (), sym1->type ());
4844 const char *name0 = sym0->linkage_name ();
4845 const char *name1 = sym1->linkage_name ();
4846 return (strcmp (name0, name1) == 0
4847 && sym0->value_address () == sym1->value_address ());
4855 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4856 records in RESULT. Do nothing if SYM is a duplicate. */
4859 add_defn_to_vec (std::vector<struct block_symbol> &result,
4861 const struct block *block)
4863 /* Do not try to complete stub types, as the debugger is probably
4864 already scanning all symbols matching a certain name at the
4865 time when this function is called. Trying to replace the stub
4866 type by its associated full type will cause us to restart a scan
4867 which may lead to an infinite recursion. Instead, the client
4868 collecting the matching symbols will end up collecting several
4869 matches, with at least one of them complete. It can then filter
4870 out the stub ones if needed. */
4872 for (int i = result.size () - 1; i >= 0; i -= 1)
4874 if (lesseq_defined_than (sym, result[i].symbol))
4876 else if (lesseq_defined_than (result[i].symbol, sym))
4878 result[i].symbol = sym;
4879 result[i].block = block;
4884 struct block_symbol info;
4887 result.push_back (info);
4890 /* Return a bound minimal symbol matching NAME according to Ada
4891 decoding rules. Returns an invalid symbol if there is no such
4892 minimal symbol. Names prefixed with "standard__" are handled
4893 specially: "standard__" is first stripped off, and only static and
4894 global symbols are searched. */
4896 struct bound_minimal_symbol
4897 ada_lookup_simple_minsym (const char *name)
4899 struct bound_minimal_symbol result;
4901 symbol_name_match_type match_type = name_match_type_from_name (name);
4902 lookup_name_info lookup_name (name, match_type);
4904 symbol_name_matcher_ftype *match_name
4905 = ada_get_symbol_name_matcher (lookup_name);
4907 for (objfile *objfile : current_program_space->objfiles ())
4909 for (minimal_symbol *msymbol : objfile->msymbols ())
4911 if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4912 && msymbol->type () != mst_solib_trampoline)
4914 result.minsym = msymbol;
4915 result.objfile = objfile;
4924 /* True if TYPE is definitely an artificial type supplied to a symbol
4925 for which no debugging information was given in the symbol file. */
4928 is_nondebugging_type (struct type *type)
4930 const char *name = ada_type_name (type);
4932 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4935 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4936 that are deemed "identical" for practical purposes.
4938 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4939 types and that their number of enumerals is identical (in other
4940 words, type1->num_fields () == type2->num_fields ()). */
4943 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4947 /* The heuristic we use here is fairly conservative. We consider
4948 that 2 enumerate types are identical if they have the same
4949 number of enumerals and that all enumerals have the same
4950 underlying value and name. */
4952 /* All enums in the type should have an identical underlying value. */
4953 for (i = 0; i < type1->num_fields (); i++)
4954 if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4957 /* All enumerals should also have the same name (modulo any numerical
4959 for (i = 0; i < type1->num_fields (); i++)
4961 const char *name_1 = type1->field (i).name ();
4962 const char *name_2 = type2->field (i).name ();
4963 int len_1 = strlen (name_1);
4964 int len_2 = strlen (name_2);
4966 ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4967 ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4969 || strncmp (type1->field (i).name (),
4970 type2->field (i).name (),
4978 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4979 that are deemed "identical" for practical purposes. Sometimes,
4980 enumerals are not strictly identical, but their types are so similar
4981 that they can be considered identical.
4983 For instance, consider the following code:
4985 type Color is (Black, Red, Green, Blue, White);
4986 type RGB_Color is new Color range Red .. Blue;
4988 Type RGB_Color is a subrange of an implicit type which is a copy
4989 of type Color. If we call that implicit type RGB_ColorB ("B" is
4990 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4991 As a result, when an expression references any of the enumeral
4992 by name (Eg. "print green"), the expression is technically
4993 ambiguous and the user should be asked to disambiguate. But
4994 doing so would only hinder the user, since it wouldn't matter
4995 what choice he makes, the outcome would always be the same.
4996 So, for practical purposes, we consider them as the same. */
4999 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5003 /* Before performing a thorough comparison check of each type,
5004 we perform a series of inexpensive checks. We expect that these
5005 checks will quickly fail in the vast majority of cases, and thus
5006 help prevent the unnecessary use of a more expensive comparison.
5007 Said comparison also expects us to make some of these checks
5008 (see ada_identical_enum_types_p). */
5010 /* Quick check: All symbols should have an enum type. */
5011 for (i = 0; i < syms.size (); i++)
5012 if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5015 /* Quick check: They should all have the same value. */
5016 for (i = 1; i < syms.size (); i++)
5017 if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5020 /* Quick check: They should all have the same number of enumerals. */
5021 for (i = 1; i < syms.size (); i++)
5022 if (syms[i].symbol->type ()->num_fields ()
5023 != syms[0].symbol->type ()->num_fields ())
5026 /* All the sanity checks passed, so we might have a set of
5027 identical enumeration types. Perform a more complete
5028 comparison of the type of each symbol. */
5029 for (i = 1; i < syms.size (); i++)
5030 if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5031 syms[0].symbol->type ()))
5037 /* Remove any non-debugging symbols in SYMS that definitely
5038 duplicate other symbols in the list (The only case I know of where
5039 this happens is when object files containing stabs-in-ecoff are
5040 linked with files containing ordinary ecoff debugging symbols (or no
5041 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
5044 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5048 /* We should never be called with less than 2 symbols, as there
5049 cannot be any extra symbol in that case. But it's easy to
5050 handle, since we have nothing to do in that case. */
5051 if (syms->size () < 2)
5055 while (i < syms->size ())
5059 /* If two symbols have the same name and one of them is a stub type,
5060 the get rid of the stub. */
5062 if ((*syms)[i].symbol->type ()->is_stub ()
5063 && (*syms)[i].symbol->linkage_name () != NULL)
5065 for (j = 0; j < syms->size (); j++)
5068 && !(*syms)[j].symbol->type ()->is_stub ()
5069 && (*syms)[j].symbol->linkage_name () != NULL
5070 && strcmp ((*syms)[i].symbol->linkage_name (),
5071 (*syms)[j].symbol->linkage_name ()) == 0)
5076 /* Two symbols with the same name, same class and same address
5077 should be identical. */
5079 else if ((*syms)[i].symbol->linkage_name () != NULL
5080 && (*syms)[i].symbol->aclass () == LOC_STATIC
5081 && is_nondebugging_type ((*syms)[i].symbol->type ()))
5083 for (j = 0; j < syms->size (); j += 1)
5086 && (*syms)[j].symbol->linkage_name () != NULL
5087 && strcmp ((*syms)[i].symbol->linkage_name (),
5088 (*syms)[j].symbol->linkage_name ()) == 0
5089 && ((*syms)[i].symbol->aclass ()
5090 == (*syms)[j].symbol->aclass ())
5091 && (*syms)[i].symbol->value_address ()
5092 == (*syms)[j].symbol->value_address ())
5098 syms->erase (syms->begin () + i);
5103 /* If all the remaining symbols are identical enumerals, then
5104 just keep the first one and discard the rest.
5106 Unlike what we did previously, we do not discard any entry
5107 unless they are ALL identical. This is because the symbol
5108 comparison is not a strict comparison, but rather a practical
5109 comparison. If all symbols are considered identical, then
5110 we can just go ahead and use the first one and discard the rest.
5111 But if we cannot reduce the list to a single element, we have
5112 to ask the user to disambiguate anyways. And if we have to
5113 present a multiple-choice menu, it's less confusing if the list
5114 isn't missing some choices that were identical and yet distinct. */
5115 if (symbols_are_identical_enums (*syms))
5119 /* Given a type that corresponds to a renaming entity, use the type name
5120 to extract the scope (package name or function name, fully qualified,
5121 and following the GNAT encoding convention) where this renaming has been
5125 xget_renaming_scope (struct type *renaming_type)
5127 /* The renaming types adhere to the following convention:
5128 <scope>__<rename>___<XR extension>.
5129 So, to extract the scope, we search for the "___XR" extension,
5130 and then backtrack until we find the first "__". */
5132 const char *name = renaming_type->name ();
5133 const char *suffix = strstr (name, "___XR");
5136 /* Now, backtrack a bit until we find the first "__". Start looking
5137 at suffix - 3, as the <rename> part is at least one character long. */
5139 for (last = suffix - 3; last > name; last--)
5140 if (last[0] == '_' && last[1] == '_')
5143 /* Make a copy of scope and return it. */
5144 return std::string (name, last);
5147 /* Return nonzero if NAME corresponds to a package name. */
5150 is_package_name (const char *name)
5152 /* Here, We take advantage of the fact that no symbols are generated
5153 for packages, while symbols are generated for each function.
5154 So the condition for NAME represent a package becomes equivalent
5155 to NAME not existing in our list of symbols. There is only one
5156 small complication with library-level functions (see below). */
5158 /* If it is a function that has not been defined at library level,
5159 then we should be able to look it up in the symbols. */
5160 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5163 /* Library-level function names start with "_ada_". See if function
5164 "_ada_" followed by NAME can be found. */
5166 /* Do a quick check that NAME does not contain "__", since library-level
5167 functions names cannot contain "__" in them. */
5168 if (strstr (name, "__") != NULL)
5171 std::string fun_name = string_printf ("_ada_%s", name);
5173 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5176 /* Return nonzero if SYM corresponds to a renaming entity that is
5177 not visible from FUNCTION_NAME. */
5180 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5182 if (sym->aclass () != LOC_TYPEDEF)
5185 std::string scope = xget_renaming_scope (sym->type ());
5187 /* If the rename has been defined in a package, then it is visible. */
5188 if (is_package_name (scope.c_str ()))
5191 /* Check that the rename is in the current function scope by checking
5192 that its name starts with SCOPE. */
5194 /* If the function name starts with "_ada_", it means that it is
5195 a library-level function. Strip this prefix before doing the
5196 comparison, as the encoding for the renaming does not contain
5198 if (startswith (function_name, "_ada_"))
5201 return !startswith (function_name, scope.c_str ());
5204 /* Remove entries from SYMS that corresponds to a renaming entity that
5205 is not visible from the function associated with CURRENT_BLOCK or
5206 that is superfluous due to the presence of more specific renaming
5207 information. Places surviving symbols in the initial entries of
5211 First, in cases where an object renaming is implemented as a
5212 reference variable, GNAT may produce both the actual reference
5213 variable and the renaming encoding. In this case, we discard the
5216 Second, GNAT emits a type following a specified encoding for each renaming
5217 entity. Unfortunately, STABS currently does not support the definition
5218 of types that are local to a given lexical block, so all renamings types
5219 are emitted at library level. As a consequence, if an application
5220 contains two renaming entities using the same name, and a user tries to
5221 print the value of one of these entities, the result of the ada symbol
5222 lookup will also contain the wrong renaming type.
5224 This function partially covers for this limitation by attempting to
5225 remove from the SYMS list renaming symbols that should be visible
5226 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5227 method with the current information available. The implementation
5228 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5230 - When the user tries to print a rename in a function while there
5231 is another rename entity defined in a package: Normally, the
5232 rename in the function has precedence over the rename in the
5233 package, so the latter should be removed from the list. This is
5234 currently not the case.
5236 - This function will incorrectly remove valid renames if
5237 the CURRENT_BLOCK corresponds to a function which symbol name
5238 has been changed by an "Export" pragma. As a consequence,
5239 the user will be unable to print such rename entities. */
5242 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5243 const struct block *current_block)
5245 struct symbol *current_function;
5246 const char *current_function_name;
5248 int is_new_style_renaming;
5250 /* If there is both a renaming foo___XR... encoded as a variable and
5251 a simple variable foo in the same block, discard the latter.
5252 First, zero out such symbols, then compress. */
5253 is_new_style_renaming = 0;
5254 for (i = 0; i < syms->size (); i += 1)
5256 struct symbol *sym = (*syms)[i].symbol;
5257 const struct block *block = (*syms)[i].block;
5261 if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5263 name = sym->linkage_name ();
5264 suffix = strstr (name, "___XR");
5268 int name_len = suffix - name;
5271 is_new_style_renaming = 1;
5272 for (j = 0; j < syms->size (); j += 1)
5273 if (i != j && (*syms)[j].symbol != NULL
5274 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5276 && block == (*syms)[j].block)
5277 (*syms)[j].symbol = NULL;
5280 if (is_new_style_renaming)
5284 for (j = k = 0; j < syms->size (); j += 1)
5285 if ((*syms)[j].symbol != NULL)
5287 (*syms)[k] = (*syms)[j];
5294 /* Extract the function name associated to CURRENT_BLOCK.
5295 Abort if unable to do so. */
5297 if (current_block == NULL)
5300 current_function = block_linkage_function (current_block);
5301 if (current_function == NULL)
5304 current_function_name = current_function->linkage_name ();
5305 if (current_function_name == NULL)
5308 /* Check each of the symbols, and remove it from the list if it is
5309 a type corresponding to a renaming that is out of the scope of
5310 the current block. */
5313 while (i < syms->size ())
5315 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5316 == ADA_OBJECT_RENAMING
5317 && old_renaming_is_invisible ((*syms)[i].symbol,
5318 current_function_name))
5319 syms->erase (syms->begin () + i);
5325 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5326 whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5328 Note: This function assumes that RESULT is empty. */
5331 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5332 const lookup_name_info &lookup_name,
5333 const struct block *block, domain_enum domain)
5335 while (block != NULL)
5337 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5339 /* If we found a non-function match, assume that's the one. We
5340 only check this when finding a function boundary, so that we
5341 can accumulate all results from intervening blocks first. */
5342 if (block->function () != nullptr && is_nonfunction (result))
5345 block = block->superblock ();
5349 /* An object of this type is used as the callback argument when
5350 calling the map_matching_symbols method. */
5354 explicit match_data (std::vector<struct block_symbol> *rp)
5358 DISABLE_COPY_AND_ASSIGN (match_data);
5360 bool operator() (struct block_symbol *bsym);
5362 struct objfile *objfile = nullptr;
5363 std::vector<struct block_symbol> *resultp;
5364 struct symbol *arg_sym = nullptr;
5365 bool found_sym = false;
5368 /* A callback for add_nonlocal_symbols that adds symbol, found in
5369 BSYM, to a list of symbols. */
5372 match_data::operator() (struct block_symbol *bsym)
5374 const struct block *block = bsym->block;
5375 struct symbol *sym = bsym->symbol;
5379 if (!found_sym && arg_sym != NULL)
5380 add_defn_to_vec (*resultp,
5381 fixup_symbol_section (arg_sym, objfile),
5388 if (sym->aclass () == LOC_UNRESOLVED)
5390 else if (sym->is_argument ())
5395 add_defn_to_vec (*resultp,
5396 fixup_symbol_section (sym, objfile),
5403 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5404 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5405 symbols to RESULT. Return whether we found such symbols. */
5408 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5409 const struct block *block,
5410 const lookup_name_info &lookup_name,
5413 struct using_direct *renaming;
5414 int defns_mark = result.size ();
5416 symbol_name_matcher_ftype *name_match
5417 = ada_get_symbol_name_matcher (lookup_name);
5419 for (renaming = block_using (block);
5421 renaming = renaming->next)
5425 /* Avoid infinite recursions: skip this renaming if we are actually
5426 already traversing it.
5428 Currently, symbol lookup in Ada don't use the namespace machinery from
5429 C++/Fortran support: skip namespace imports that use them. */
5430 if (renaming->searched
5431 || (renaming->import_src != NULL
5432 && renaming->import_src[0] != '\0')
5433 || (renaming->import_dest != NULL
5434 && renaming->import_dest[0] != '\0'))
5436 renaming->searched = 1;
5438 /* TODO: here, we perform another name-based symbol lookup, which can
5439 pull its own multiple overloads. In theory, we should be able to do
5440 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5441 not a simple name. But in order to do this, we would need to enhance
5442 the DWARF reader to associate a symbol to this renaming, instead of a
5443 name. So, for now, we do something simpler: re-use the C++/Fortran
5444 namespace machinery. */
5445 r_name = (renaming->alias != NULL
5447 : renaming->declaration);
5448 if (name_match (r_name, lookup_name, NULL))
5450 lookup_name_info decl_lookup_name (renaming->declaration,
5451 lookup_name.match_type ());
5452 ada_add_all_symbols (result, block, decl_lookup_name, domain,
5455 renaming->searched = 0;
5457 return result.size () != defns_mark;
5460 /* Implements compare_names, but only applying the comparision using
5461 the given CASING. */
5464 compare_names_with_case (const char *string1, const char *string2,
5465 enum case_sensitivity casing)
5467 while (*string1 != '\0' && *string2 != '\0')
5471 if (isspace (*string1) || isspace (*string2))
5472 return strcmp_iw_ordered (string1, string2);
5474 if (casing == case_sensitive_off)
5476 c1 = tolower (*string1);
5477 c2 = tolower (*string2);
5494 return strcmp_iw_ordered (string1, string2);
5496 if (*string2 == '\0')
5498 if (is_name_suffix (string1))
5505 if (*string2 == '(')
5506 return strcmp_iw_ordered (string1, string2);
5509 if (casing == case_sensitive_off)
5510 return tolower (*string1) - tolower (*string2);
5512 return *string1 - *string2;
5517 /* Compare STRING1 to STRING2, with results as for strcmp.
5518 Compatible with strcmp_iw_ordered in that...
5520 strcmp_iw_ordered (STRING1, STRING2) <= 0
5524 compare_names (STRING1, STRING2) <= 0
5526 (they may differ as to what symbols compare equal). */
5529 compare_names (const char *string1, const char *string2)
5533 /* Similar to what strcmp_iw_ordered does, we need to perform
5534 a case-insensitive comparison first, and only resort to
5535 a second, case-sensitive, comparison if the first one was
5536 not sufficient to differentiate the two strings. */
5538 result = compare_names_with_case (string1, string2, case_sensitive_off);
5540 result = compare_names_with_case (string1, string2, case_sensitive_on);
5545 /* Convenience function to get at the Ada encoded lookup name for
5546 LOOKUP_NAME, as a C string. */
5549 ada_lookup_name (const lookup_name_info &lookup_name)
5551 return lookup_name.ada ().lookup_name ().c_str ();
5554 /* A helper for add_nonlocal_symbols. Call expand_matching_symbols
5555 for OBJFILE, then walk the objfile's symtabs and update the
5559 map_matching_symbols (struct objfile *objfile,
5560 const lookup_name_info &lookup_name,
5566 data.objfile = objfile;
5567 objfile->expand_matching_symbols (lookup_name, domain, global,
5568 is_wild_match ? nullptr : compare_names);
5570 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5571 for (compunit_symtab *symtab : objfile->compunits ())
5573 const struct block *block
5574 = symtab->blockvector ()->block (block_kind);
5575 if (!iterate_over_symbols_terminated (block, lookup_name,
5581 /* Add to RESULT all non-local symbols whose name and domain match
5582 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5583 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5584 symbols otherwise. */
5587 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5588 const lookup_name_info &lookup_name,
5589 domain_enum domain, int global)
5591 struct match_data data (&result);
5593 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5595 for (objfile *objfile : current_program_space->objfiles ())
5597 map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5600 for (compunit_symtab *cu : objfile->compunits ())
5602 const struct block *global_block
5603 = cu->blockvector ()->global_block ();
5605 if (ada_add_block_renamings (result, global_block, lookup_name,
5607 data.found_sym = true;
5611 if (result.empty () && global && !is_wild_match)
5613 const char *name = ada_lookup_name (lookup_name);
5614 std::string bracket_name = std::string ("<_ada_") + name + '>';
5615 lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5617 for (objfile *objfile : current_program_space->objfiles ())
5618 map_matching_symbols (objfile, name1, false, domain, global, data);
5622 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5623 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5624 returning the number of matches. Add these to RESULT.
5626 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5627 symbol match within the nest of blocks whose innermost member is BLOCK,
5628 is the one match returned (no other matches in that or
5629 enclosing blocks is returned). If there are any matches in or
5630 surrounding BLOCK, then these alone are returned.
5632 Names prefixed with "standard__" are handled specially:
5633 "standard__" is first stripped off (by the lookup_name
5634 constructor), and only static and global symbols are searched.
5636 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5637 to lookup global symbols. */
5640 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5641 const struct block *block,
5642 const lookup_name_info &lookup_name,
5645 int *made_global_lookup_p)
5649 if (made_global_lookup_p)
5650 *made_global_lookup_p = 0;
5652 /* Special case: If the user specifies a symbol name inside package
5653 Standard, do a non-wild matching of the symbol name without
5654 the "standard__" prefix. This was primarily introduced in order
5655 to allow the user to specifically access the standard exceptions
5656 using, for instance, Standard.Constraint_Error when Constraint_Error
5657 is ambiguous (due to the user defining its own Constraint_Error
5658 entity inside its program). */
5659 if (lookup_name.ada ().standard_p ())
5662 /* Check the non-global symbols. If we have ANY match, then we're done. */
5667 ada_add_local_symbols (result, lookup_name, block, domain);
5670 /* In the !full_search case we're are being called by
5671 iterate_over_symbols, and we don't want to search
5673 ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5675 if (!result.empty () || !full_search)
5679 /* No non-global symbols found. Check our cache to see if we have
5680 already performed this search before. If we have, then return
5683 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5684 domain, &sym, &block))
5687 add_defn_to_vec (result, sym, block);
5691 if (made_global_lookup_p)
5692 *made_global_lookup_p = 1;
5694 /* Search symbols from all global blocks. */
5696 add_nonlocal_symbols (result, lookup_name, domain, 1);
5698 /* Now add symbols from all per-file blocks if we've gotten no hits
5699 (not strictly correct, but perhaps better than an error). */
5701 if (result.empty ())
5702 add_nonlocal_symbols (result, lookup_name, domain, 0);
5705 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5706 is non-zero, enclosing scope and in global scopes.
5708 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5709 blocks and symbol tables (if any) in which they were found.
5711 When full_search is non-zero, any non-function/non-enumeral
5712 symbol match within the nest of blocks whose innermost member is BLOCK,
5713 is the one match returned (no other matches in that or
5714 enclosing blocks is returned). If there are any matches in or
5715 surrounding BLOCK, then these alone are returned.
5717 Names prefixed with "standard__" are handled specially: "standard__"
5718 is first stripped off, and only static and global symbols are searched. */
5720 static std::vector<struct block_symbol>
5721 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5722 const struct block *block,
5726 int syms_from_global_search;
5727 std::vector<struct block_symbol> results;
5729 ada_add_all_symbols (results, block, lookup_name,
5730 domain, full_search, &syms_from_global_search);
5732 remove_extra_symbols (&results);
5734 if (results.empty () && full_search && syms_from_global_search)
5735 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5737 if (results.size () == 1 && full_search && syms_from_global_search)
5738 cache_symbol (ada_lookup_name (lookup_name), domain,
5739 results[0].symbol, results[0].block);
5741 remove_irrelevant_renamings (&results, block);
5745 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5746 in global scopes, returning (SYM,BLOCK) tuples.
5748 See ada_lookup_symbol_list_worker for further details. */
5750 std::vector<struct block_symbol>
5751 ada_lookup_symbol_list (const char *name, const struct block *block,
5754 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5755 lookup_name_info lookup_name (name, name_match_type);
5757 return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5760 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5761 to 1, but choosing the first symbol found if there are multiple
5764 The result is stored in *INFO, which must be non-NULL.
5765 If no match is found, INFO->SYM is set to NULL. */
5768 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5770 struct block_symbol *info)
5772 /* Since we already have an encoded name, wrap it in '<>' to force a
5773 verbatim match. Otherwise, if the name happens to not look like
5774 an encoded name (because it doesn't include a "__"),
5775 ada_lookup_name_info would re-encode/fold it again, and that
5776 would e.g., incorrectly lowercase object renaming names like
5777 "R28b" -> "r28b". */
5778 std::string verbatim = add_angle_brackets (name);
5780 gdb_assert (info != NULL);
5781 *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5784 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5785 scope and in global scopes, or NULL if none. NAME is folded and
5786 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5787 choosing the first symbol if there are multiple choices. */
5790 ada_lookup_symbol (const char *name, const struct block *block0,
5793 std::vector<struct block_symbol> candidates
5794 = ada_lookup_symbol_list (name, block0, domain);
5796 if (candidates.empty ())
5799 block_symbol info = candidates[0];
5800 info.symbol = fixup_symbol_section (info.symbol, NULL);
5805 /* True iff STR is a possible encoded suffix of a normal Ada name
5806 that is to be ignored for matching purposes. Suffixes of parallel
5807 names (e.g., XVE) are not included here. Currently, the possible suffixes
5808 are given by any of the regular expressions:
5810 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5811 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5812 TKB [subprogram suffix for task bodies]
5813 _E[0-9]+[bs]$ [protected object entry suffixes]
5814 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5816 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5817 match is performed. This sequence is used to differentiate homonyms,
5818 is an optional part of a valid name suffix. */
5821 is_name_suffix (const char *str)
5824 const char *matching;
5825 const int len = strlen (str);
5827 /* Skip optional leading __[0-9]+. */
5829 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5832 while (isdigit (str[0]))
5838 if (str[0] == '.' || str[0] == '$')
5841 while (isdigit (matching[0]))
5843 if (matching[0] == '\0')
5849 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5852 while (isdigit (matching[0]))
5854 if (matching[0] == '\0')
5858 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5860 if (strcmp (str, "TKB") == 0)
5864 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5865 with a N at the end. Unfortunately, the compiler uses the same
5866 convention for other internal types it creates. So treating
5867 all entity names that end with an "N" as a name suffix causes
5868 some regressions. For instance, consider the case of an enumerated
5869 type. To support the 'Image attribute, it creates an array whose
5871 Having a single character like this as a suffix carrying some
5872 information is a bit risky. Perhaps we should change the encoding
5873 to be something like "_N" instead. In the meantime, do not do
5874 the following check. */
5875 /* Protected Object Subprograms */
5876 if (len == 1 && str [0] == 'N')
5881 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5884 while (isdigit (matching[0]))
5886 if ((matching[0] == 'b' || matching[0] == 's')
5887 && matching [1] == '\0')
5891 /* ??? We should not modify STR directly, as we are doing below. This
5892 is fine in this case, but may become problematic later if we find
5893 that this alternative did not work, and want to try matching
5894 another one from the begining of STR. Since we modified it, we
5895 won't be able to find the begining of the string anymore! */
5899 while (str[0] != '_' && str[0] != '\0')
5901 if (str[0] != 'n' && str[0] != 'b')
5907 if (str[0] == '\000')
5912 if (str[1] != '_' || str[2] == '\000')
5916 if (strcmp (str + 3, "JM") == 0)
5918 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5919 the LJM suffix in favor of the JM one. But we will
5920 still accept LJM as a valid suffix for a reasonable
5921 amount of time, just to allow ourselves to debug programs
5922 compiled using an older version of GNAT. */
5923 if (strcmp (str + 3, "LJM") == 0)
5927 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5928 || str[4] == 'U' || str[4] == 'P')
5930 if (str[4] == 'R' && str[5] != 'T')
5934 if (!isdigit (str[2]))
5936 for (k = 3; str[k] != '\0'; k += 1)
5937 if (!isdigit (str[k]) && str[k] != '_')
5941 if (str[0] == '$' && isdigit (str[1]))
5943 for (k = 2; str[k] != '\0'; k += 1)
5944 if (!isdigit (str[k]) && str[k] != '_')
5951 /* Return non-zero if the string starting at NAME and ending before
5952 NAME_END contains no capital letters. */
5955 is_valid_name_for_wild_match (const char *name0)
5957 std::string decoded_name = ada_decode (name0);
5960 /* If the decoded name starts with an angle bracket, it means that
5961 NAME0 does not follow the GNAT encoding format. It should then
5962 not be allowed as a possible wild match. */
5963 if (decoded_name[0] == '<')
5966 for (i=0; decoded_name[i] != '\0'; i++)
5967 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5973 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5974 character which could start a simple name. Assumes that *NAMEP points
5975 somewhere inside the string beginning at NAME0. */
5978 advance_wild_match (const char **namep, const char *name0, char target0)
5980 const char *name = *namep;
5990 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5993 if (name == name0 + 5 && startswith (name0, "_ada"))
5998 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5999 || name[2] == target0))
6004 else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6006 /* Names like "pkg__B_N__name", where N is a number, are
6007 block-local. We can handle these by simply skipping
6014 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6024 /* Return true iff NAME encodes a name of the form prefix.PATN.
6025 Ignores any informational suffixes of NAME (i.e., for which
6026 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6030 wild_match (const char *name, const char *patn)
6033 const char *name0 = name;
6035 if (startswith (name, "___ghost_"))
6040 const char *match = name;
6044 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6047 if (*p == '\0' && is_name_suffix (name))
6048 return match == name0 || is_valid_name_for_wild_match (name0);
6050 if (name[-1] == '_')
6053 if (!advance_wild_match (&name, name0, *patn))
6058 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6059 necessary). OBJFILE is the section containing BLOCK. */
6062 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6063 const struct block *block,
6064 const lookup_name_info &lookup_name,
6065 domain_enum domain, struct objfile *objfile)
6067 struct block_iterator iter;
6068 /* A matching argument symbol, if any. */
6069 struct symbol *arg_sym;
6070 /* Set true when we find a matching non-argument symbol. */
6076 for (sym = block_iter_match_first (block, lookup_name, &iter);
6078 sym = block_iter_match_next (lookup_name, &iter))
6080 if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6082 if (sym->aclass () != LOC_UNRESOLVED)
6084 if (sym->is_argument ())
6089 add_defn_to_vec (result,
6090 fixup_symbol_section (sym, objfile),
6097 /* Handle renamings. */
6099 if (ada_add_block_renamings (result, block, lookup_name, domain))
6102 if (!found_sym && arg_sym != NULL)
6104 add_defn_to_vec (result,
6105 fixup_symbol_section (arg_sym, objfile),
6109 if (!lookup_name.ada ().wild_match_p ())
6113 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6114 const char *name = ada_lookup_name.c_str ();
6115 size_t name_len = ada_lookup_name.size ();
6117 ALL_BLOCK_SYMBOLS (block, iter, sym)
6119 if (symbol_matches_domain (sym->language (),
6120 sym->domain (), domain))
6124 cmp = (int) '_' - (int) sym->linkage_name ()[0];
6127 cmp = !startswith (sym->linkage_name (), "_ada_");
6129 cmp = strncmp (name, sym->linkage_name () + 5,
6134 && is_name_suffix (sym->linkage_name () + name_len + 5))
6136 if (sym->aclass () != LOC_UNRESOLVED)
6138 if (sym->is_argument ())
6143 add_defn_to_vec (result,
6144 fixup_symbol_section (sym, objfile),
6152 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6153 They aren't parameters, right? */
6154 if (!found_sym && arg_sym != NULL)
6156 add_defn_to_vec (result,
6157 fixup_symbol_section (arg_sym, objfile),
6164 /* Symbol Completion */
6169 ada_lookup_name_info::matches
6170 (const char *sym_name,
6171 symbol_name_match_type match_type,
6172 completion_match_result *comp_match_res) const
6175 const char *text = m_encoded_name.c_str ();
6176 size_t text_len = m_encoded_name.size ();
6178 /* First, test against the fully qualified name of the symbol. */
6180 if (strncmp (sym_name, text, text_len) == 0)
6183 std::string decoded_name = ada_decode (sym_name);
6184 if (match && !m_encoded_p)
6186 /* One needed check before declaring a positive match is to verify
6187 that iff we are doing a verbatim match, the decoded version
6188 of the symbol name starts with '<'. Otherwise, this symbol name
6189 is not a suitable completion. */
6191 bool has_angle_bracket = (decoded_name[0] == '<');
6192 match = (has_angle_bracket == m_verbatim_p);
6195 if (match && !m_verbatim_p)
6197 /* When doing non-verbatim match, another check that needs to
6198 be done is to verify that the potentially matching symbol name
6199 does not include capital letters, because the ada-mode would
6200 not be able to understand these symbol names without the
6201 angle bracket notation. */
6204 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6209 /* Second: Try wild matching... */
6211 if (!match && m_wild_match_p)
6213 /* Since we are doing wild matching, this means that TEXT
6214 may represent an unqualified symbol name. We therefore must
6215 also compare TEXT against the unqualified name of the symbol. */
6216 sym_name = ada_unqualified_name (decoded_name.c_str ());
6218 if (strncmp (sym_name, text, text_len) == 0)
6222 /* Finally: If we found a match, prepare the result to return. */
6227 if (comp_match_res != NULL)
6229 std::string &match_str = comp_match_res->match.storage ();
6232 match_str = ada_decode (sym_name);
6236 match_str = add_angle_brackets (sym_name);
6238 match_str = sym_name;
6242 comp_match_res->set_match (match_str.c_str ());
6250 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6251 for tagged types. */
6254 ada_is_dispatch_table_ptr_type (struct type *type)
6258 if (type->code () != TYPE_CODE_PTR)
6261 name = TYPE_TARGET_TYPE (type)->name ();
6265 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6268 /* Return non-zero if TYPE is an interface tag. */
6271 ada_is_interface_tag (struct type *type)
6273 const char *name = type->name ();
6278 return (strcmp (name, "ada__tags__interface_tag") == 0);
6281 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6282 to be invisible to users. */
6285 ada_is_ignored_field (struct type *type, int field_num)
6287 if (field_num < 0 || field_num > type->num_fields ())
6290 /* Check the name of that field. */
6292 const char *name = type->field (field_num).name ();
6294 /* Anonymous field names should not be printed.
6295 brobecker/2007-02-20: I don't think this can actually happen
6296 but we don't want to print the value of anonymous fields anyway. */
6300 /* Normally, fields whose name start with an underscore ("_")
6301 are fields that have been internally generated by the compiler,
6302 and thus should not be printed. The "_parent" field is special,
6303 however: This is a field internally generated by the compiler
6304 for tagged types, and it contains the components inherited from
6305 the parent type. This field should not be printed as is, but
6306 should not be ignored either. */
6307 if (name[0] == '_' && !startswith (name, "_parent"))
6310 /* The compiler doesn't document this, but sometimes it emits
6311 a field whose name starts with a capital letter, like 'V148s'.
6312 These aren't marked as artificial in any way, but we know they
6313 should be ignored. However, wrapper fields should not be
6315 if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6317 /* Wrapper field. */
6319 else if (isupper (name[0]))
6323 /* If this is the dispatch table of a tagged type or an interface tag,
6325 if (ada_is_tagged_type (type, 1)
6326 && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6327 || ada_is_interface_tag (type->field (field_num).type ())))
6330 /* Not a special field, so it should not be ignored. */
6334 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6335 pointer or reference type whose ultimate target has a tag field. */
6338 ada_is_tagged_type (struct type *type, int refok)
6340 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6343 /* True iff TYPE represents the type of X'Tag */
6346 ada_is_tag_type (struct type *type)
6348 type = ada_check_typedef (type);
6350 if (type == NULL || type->code () != TYPE_CODE_PTR)
6354 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6356 return (name != NULL
6357 && strcmp (name, "ada__tags__dispatch_table") == 0);
6361 /* The type of the tag on VAL. */
6363 static struct type *
6364 ada_tag_type (struct value *val)
6366 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6369 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6370 retired at Ada 05). */
6373 is_ada95_tag (struct value *tag)
6375 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6378 /* The value of the tag on VAL. */
6380 static struct value *
6381 ada_value_tag (struct value *val)
6383 return ada_value_struct_elt (val, "_tag", 0);
6386 /* The value of the tag on the object of type TYPE whose contents are
6387 saved at VALADDR, if it is non-null, or is at memory address
6390 static struct value *
6391 value_tag_from_contents_and_address (struct type *type,
6392 const gdb_byte *valaddr,
6395 int tag_byte_offset;
6396 struct type *tag_type;
6398 gdb::array_view<const gdb_byte> contents;
6399 if (valaddr != nullptr)
6400 contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6401 struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6402 if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6405 const gdb_byte *valaddr1 = ((valaddr == NULL)
6407 : valaddr + tag_byte_offset);
6408 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6410 return value_from_contents_and_address (tag_type, valaddr1, address1);
6415 static struct type *
6416 type_from_tag (struct value *tag)
6418 gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6420 if (type_name != NULL)
6421 return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6425 /* Given a value OBJ of a tagged type, return a value of this
6426 type at the base address of the object. The base address, as
6427 defined in Ada.Tags, it is the address of the primary tag of
6428 the object, and therefore where the field values of its full
6429 view can be fetched. */
6432 ada_tag_value_at_base_address (struct value *obj)
6435 LONGEST offset_to_top = 0;
6436 struct type *ptr_type, *obj_type;
6438 CORE_ADDR base_address;
6440 obj_type = value_type (obj);
6442 /* It is the responsability of the caller to deref pointers. */
6444 if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6447 tag = ada_value_tag (obj);
6451 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6453 if (is_ada95_tag (tag))
6456 struct type *offset_type
6457 = language_lookup_primitive_type (language_def (language_ada),
6458 target_gdbarch(), "storage_offset");
6459 ptr_type = lookup_pointer_type (offset_type);
6460 val = value_cast (ptr_type, tag);
6464 /* It is perfectly possible that an exception be raised while
6465 trying to determine the base address, just like for the tag;
6466 see ada_tag_name for more details. We do not print the error
6467 message for the same reason. */
6471 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6474 catch (const gdb_exception_error &e)
6479 /* If offset is null, nothing to do. */
6481 if (offset_to_top == 0)
6484 /* -1 is a special case in Ada.Tags; however, what should be done
6485 is not quite clear from the documentation. So do nothing for
6488 if (offset_to_top == -1)
6491 /* Storage_Offset'Last is used to indicate that a dynamic offset to
6492 top is used. In this situation the offset is stored just after
6493 the tag, in the object itself. */
6494 ULONGEST last = (((ULONGEST) 1) << (8 * TYPE_LENGTH (offset_type) - 1)) - 1;
6495 if (offset_to_top == last)
6497 struct value *tem = value_addr (tag);
6498 tem = value_ptradd (tem, 1);
6499 tem = value_cast (ptr_type, tem);
6500 offset_to_top = value_as_long (value_ind (tem));
6503 if (offset_to_top > 0)
6505 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6506 from the base address. This was however incompatible with
6507 C++ dispatch table: C++ uses a *negative* value to *add*
6508 to the base address. Ada's convention has therefore been
6509 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6510 use the same convention. Here, we support both cases by
6511 checking the sign of OFFSET_TO_TOP. */
6512 offset_to_top = -offset_to_top;
6515 base_address = value_address (obj) + offset_to_top;
6516 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6518 /* Make sure that we have a proper tag at the new address.
6519 Otherwise, offset_to_top is bogus (which can happen when
6520 the object is not initialized yet). */
6525 obj_type = type_from_tag (tag);
6530 return value_from_contents_and_address (obj_type, NULL, base_address);
6533 /* Return the "ada__tags__type_specific_data" type. */
6535 static struct type *
6536 ada_get_tsd_type (struct inferior *inf)
6538 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6540 if (data->tsd_type == 0)
6541 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6542 return data->tsd_type;
6545 /* Return the TSD (type-specific data) associated to the given TAG.
6546 TAG is assumed to be the tag of a tagged-type entity.
6548 May return NULL if we are unable to get the TSD. */
6550 static struct value *
6551 ada_get_tsd_from_tag (struct value *tag)
6556 /* First option: The TSD is simply stored as a field of our TAG.
6557 Only older versions of GNAT would use this format, but we have
6558 to test it first, because there are no visible markers for
6559 the current approach except the absence of that field. */
6561 val = ada_value_struct_elt (tag, "tsd", 1);
6565 /* Try the second representation for the dispatch table (in which
6566 there is no explicit 'tsd' field in the referent of the tag pointer,
6567 and instead the tsd pointer is stored just before the dispatch
6570 type = ada_get_tsd_type (current_inferior());
6573 type = lookup_pointer_type (lookup_pointer_type (type));
6574 val = value_cast (type, tag);
6577 return value_ind (value_ptradd (val, -1));
6580 /* Given the TSD of a tag (type-specific data), return a string
6581 containing the name of the associated type.
6583 May return NULL if we are unable to determine the tag name. */
6585 static gdb::unique_xmalloc_ptr<char>
6586 ada_tag_name_from_tsd (struct value *tsd)
6590 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6593 gdb::unique_xmalloc_ptr<char> buffer
6594 = target_read_string (value_as_address (val), INT_MAX);
6595 if (buffer == nullptr)
6600 /* Let this throw an exception on error. If the data is
6601 uninitialized, we'd rather not have the user see a
6603 const char *folded = ada_fold_name (buffer.get (), true);
6604 return make_unique_xstrdup (folded);
6606 catch (const gdb_exception &)
6612 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6615 Return NULL if the TAG is not an Ada tag, or if we were unable to
6616 determine the name of that tag. */
6618 gdb::unique_xmalloc_ptr<char>
6619 ada_tag_name (struct value *tag)
6621 gdb::unique_xmalloc_ptr<char> name;
6623 if (!ada_is_tag_type (value_type (tag)))
6626 /* It is perfectly possible that an exception be raised while trying
6627 to determine the TAG's name, even under normal circumstances:
6628 The associated variable may be uninitialized or corrupted, for
6629 instance. We do not let any exception propagate past this point.
6630 instead we return NULL.
6632 We also do not print the error message either (which often is very
6633 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6634 the caller print a more meaningful message if necessary. */
6637 struct value *tsd = ada_get_tsd_from_tag (tag);
6640 name = ada_tag_name_from_tsd (tsd);
6642 catch (const gdb_exception_error &e)
6649 /* The parent type of TYPE, or NULL if none. */
6652 ada_parent_type (struct type *type)
6656 type = ada_check_typedef (type);
6658 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6661 for (i = 0; i < type->num_fields (); i += 1)
6662 if (ada_is_parent_field (type, i))
6664 struct type *parent_type = type->field (i).type ();
6666 /* If the _parent field is a pointer, then dereference it. */
6667 if (parent_type->code () == TYPE_CODE_PTR)
6668 parent_type = TYPE_TARGET_TYPE (parent_type);
6669 /* If there is a parallel XVS type, get the actual base type. */
6670 parent_type = ada_get_base_type (parent_type);
6672 return ada_check_typedef (parent_type);
6678 /* True iff field number FIELD_NUM of structure type TYPE contains the
6679 parent-type (inherited) fields of a derived type. Assumes TYPE is
6680 a structure type with at least FIELD_NUM+1 fields. */
6683 ada_is_parent_field (struct type *type, int field_num)
6685 const char *name = ada_check_typedef (type)->field (field_num).name ();
6687 return (name != NULL
6688 && (startswith (name, "PARENT")
6689 || startswith (name, "_parent")));
6692 /* True iff field number FIELD_NUM of structure type TYPE is a
6693 transparent wrapper field (which should be silently traversed when doing
6694 field selection and flattened when printing). Assumes TYPE is a
6695 structure type with at least FIELD_NUM+1 fields. Such fields are always
6699 ada_is_wrapper_field (struct type *type, int field_num)
6701 const char *name = type->field (field_num).name ();
6703 if (name != NULL && strcmp (name, "RETVAL") == 0)
6705 /* This happens in functions with "out" or "in out" parameters
6706 which are passed by copy. For such functions, GNAT describes
6707 the function's return type as being a struct where the return
6708 value is in a field called RETVAL, and where the other "out"
6709 or "in out" parameters are fields of that struct. This is not
6714 return (name != NULL
6715 && (startswith (name, "PARENT")
6716 || strcmp (name, "REP") == 0
6717 || startswith (name, "_parent")
6718 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6721 /* True iff field number FIELD_NUM of structure or union type TYPE
6722 is a variant wrapper. Assumes TYPE is a structure type with at least
6723 FIELD_NUM+1 fields. */
6726 ada_is_variant_part (struct type *type, int field_num)
6728 /* Only Ada types are eligible. */
6729 if (!ADA_TYPE_P (type))
6732 struct type *field_type = type->field (field_num).type ();
6734 return (field_type->code () == TYPE_CODE_UNION
6735 || (is_dynamic_field (type, field_num)
6736 && (TYPE_TARGET_TYPE (field_type)->code ()
6737 == TYPE_CODE_UNION)));
6740 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6741 whose discriminants are contained in the record type OUTER_TYPE,
6742 returns the type of the controlling discriminant for the variant.
6743 May return NULL if the type could not be found. */
6746 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6748 const char *name = ada_variant_discrim_name (var_type);
6750 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6753 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6754 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6755 represents a 'when others' clause; otherwise 0. */
6758 ada_is_others_clause (struct type *type, int field_num)
6760 const char *name = type->field (field_num).name ();
6762 return (name != NULL && name[0] == 'O');
6765 /* Assuming that TYPE0 is the type of the variant part of a record,
6766 returns the name of the discriminant controlling the variant.
6767 The value is valid until the next call to ada_variant_discrim_name. */
6770 ada_variant_discrim_name (struct type *type0)
6772 static std::string result;
6775 const char *discrim_end;
6776 const char *discrim_start;
6778 if (type0->code () == TYPE_CODE_PTR)
6779 type = TYPE_TARGET_TYPE (type0);
6783 name = ada_type_name (type);
6785 if (name == NULL || name[0] == '\000')
6788 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6791 if (startswith (discrim_end, "___XVN"))
6794 if (discrim_end == name)
6797 for (discrim_start = discrim_end; discrim_start != name + 3;
6800 if (discrim_start == name + 1)
6802 if ((discrim_start > name + 3
6803 && startswith (discrim_start - 3, "___"))
6804 || discrim_start[-1] == '.')
6808 result = std::string (discrim_start, discrim_end - discrim_start);
6809 return result.c_str ();
6812 /* Scan STR for a subtype-encoded number, beginning at position K.
6813 Put the position of the character just past the number scanned in
6814 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6815 Return 1 if there was a valid number at the given position, and 0
6816 otherwise. A "subtype-encoded" number consists of the absolute value
6817 in decimal, followed by the letter 'm' to indicate a negative number.
6818 Assumes 0m does not occur. */
6821 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6825 if (!isdigit (str[k]))
6828 /* Do it the hard way so as not to make any assumption about
6829 the relationship of unsigned long (%lu scan format code) and
6832 while (isdigit (str[k]))
6834 RU = RU * 10 + (str[k] - '0');
6841 *R = (-(LONGEST) (RU - 1)) - 1;
6847 /* NOTE on the above: Technically, C does not say what the results of
6848 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6849 number representable as a LONGEST (although either would probably work
6850 in most implementations). When RU>0, the locution in the then branch
6851 above is always equivalent to the negative of RU. */
6858 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6859 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6860 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6863 ada_in_variant (LONGEST val, struct type *type, int field_num)
6865 const char *name = type->field (field_num).name ();
6879 if (!ada_scan_number (name, p + 1, &W, &p))
6889 if (!ada_scan_number (name, p + 1, &L, &p)
6890 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6892 if (val >= L && val <= U)
6904 /* FIXME: Lots of redundancy below. Try to consolidate. */
6906 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6907 ARG_TYPE, extract and return the value of one of its (non-static)
6908 fields. FIELDNO says which field. Differs from value_primitive_field
6909 only in that it can handle packed values of arbitrary type. */
6912 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6913 struct type *arg_type)
6917 arg_type = ada_check_typedef (arg_type);
6918 type = arg_type->field (fieldno).type ();
6920 /* Handle packed fields. It might be that the field is not packed
6921 relative to its containing structure, but the structure itself is
6922 packed; in this case we must take the bit-field path. */
6923 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6925 int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6926 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6928 return ada_value_primitive_packed_val (arg1,
6929 value_contents (arg1).data (),
6930 offset + bit_pos / 8,
6931 bit_pos % 8, bit_size, type);
6934 return value_primitive_field (arg1, offset, fieldno, arg_type);
6937 /* Find field with name NAME in object of type TYPE. If found,
6938 set the following for each argument that is non-null:
6939 - *FIELD_TYPE_P to the field's type;
6940 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6941 an object of that type;
6942 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6943 - *BIT_SIZE_P to its size in bits if the field is packed, and
6945 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6946 fields up to but not including the desired field, or by the total
6947 number of fields if not found. A NULL value of NAME never
6948 matches; the function just counts visible fields in this case.
6950 Notice that we need to handle when a tagged record hierarchy
6951 has some components with the same name, like in this scenario:
6953 type Top_T is tagged record
6959 type Middle_T is new Top.Top_T with record
6960 N : Character := 'a';
6964 type Bottom_T is new Middle.Middle_T with record
6966 C : Character := '5';
6968 A : Character := 'J';
6971 Let's say we now have a variable declared and initialized as follow:
6973 TC : Top_A := new Bottom_T;
6975 And then we use this variable to call this function
6977 procedure Assign (Obj: in out Top_T; TV : Integer);
6981 Assign (Top_T (B), 12);
6983 Now, we're in the debugger, and we're inside that procedure
6984 then and we want to print the value of obj.c:
6986 Usually, the tagged record or one of the parent type owns the
6987 component to print and there's no issue but in this particular
6988 case, what does it mean to ask for Obj.C? Since the actual
6989 type for object is type Bottom_T, it could mean two things: type
6990 component C from the Middle_T view, but also component C from
6991 Bottom_T. So in that "undefined" case, when the component is
6992 not found in the non-resolved type (which includes all the
6993 components of the parent type), then resolve it and see if we
6994 get better luck once expanded.
6996 In the case of homonyms in the derived tagged type, we don't
6997 guaranty anything, and pick the one that's easiest for us
7000 Returns 1 if found, 0 otherwise. */
7003 find_struct_field (const char *name, struct type *type, int offset,
7004 struct type **field_type_p,
7005 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7009 int parent_offset = -1;
7011 type = ada_check_typedef (type);
7013 if (field_type_p != NULL)
7014 *field_type_p = NULL;
7015 if (byte_offset_p != NULL)
7017 if (bit_offset_p != NULL)
7019 if (bit_size_p != NULL)
7022 for (i = 0; i < type->num_fields (); i += 1)
7024 /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7025 type. However, we only need the values to be correct when
7026 the caller asks for them. */
7027 int bit_pos = 0, fld_offset = 0;
7028 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7030 bit_pos = type->field (i).loc_bitpos ();
7031 fld_offset = offset + bit_pos / 8;
7034 const char *t_field_name = type->field (i).name ();
7036 if (t_field_name == NULL)
7039 else if (ada_is_parent_field (type, i))
7041 /* This is a field pointing us to the parent type of a tagged
7042 type. As hinted in this function's documentation, we give
7043 preference to fields in the current record first, so what
7044 we do here is just record the index of this field before
7045 we skip it. If it turns out we couldn't find our field
7046 in the current record, then we'll get back to it and search
7047 inside it whether the field might exist in the parent. */
7053 else if (name != NULL && field_name_match (t_field_name, name))
7055 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7057 if (field_type_p != NULL)
7058 *field_type_p = type->field (i).type ();
7059 if (byte_offset_p != NULL)
7060 *byte_offset_p = fld_offset;
7061 if (bit_offset_p != NULL)
7062 *bit_offset_p = bit_pos % 8;
7063 if (bit_size_p != NULL)
7064 *bit_size_p = bit_size;
7067 else if (ada_is_wrapper_field (type, i))
7069 if (find_struct_field (name, type->field (i).type (), fld_offset,
7070 field_type_p, byte_offset_p, bit_offset_p,
7071 bit_size_p, index_p))
7074 else if (ada_is_variant_part (type, i))
7076 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7079 struct type *field_type
7080 = ada_check_typedef (type->field (i).type ());
7082 for (j = 0; j < field_type->num_fields (); j += 1)
7084 if (find_struct_field (name, field_type->field (j).type (),
7086 + field_type->field (j).loc_bitpos () / 8,
7087 field_type_p, byte_offset_p,
7088 bit_offset_p, bit_size_p, index_p))
7092 else if (index_p != NULL)
7096 /* Field not found so far. If this is a tagged type which
7097 has a parent, try finding that field in the parent now. */
7099 if (parent_offset != -1)
7101 /* As above, only compute the offset when truly needed. */
7102 int fld_offset = offset;
7103 if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7105 int bit_pos = type->field (parent_offset).loc_bitpos ();
7106 fld_offset += bit_pos / 8;
7109 if (find_struct_field (name, type->field (parent_offset).type (),
7110 fld_offset, field_type_p, byte_offset_p,
7111 bit_offset_p, bit_size_p, index_p))
7118 /* Number of user-visible fields in record type TYPE. */
7121 num_visible_fields (struct type *type)
7126 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7130 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7131 and search in it assuming it has (class) type TYPE.
7132 If found, return value, else return NULL.
7134 Searches recursively through wrapper fields (e.g., '_parent').
7136 In the case of homonyms in the tagged types, please refer to the
7137 long explanation in find_struct_field's function documentation. */
7139 static struct value *
7140 ada_search_struct_field (const char *name, struct value *arg, int offset,
7144 int parent_offset = -1;
7146 type = ada_check_typedef (type);
7147 for (i = 0; i < type->num_fields (); i += 1)
7149 const char *t_field_name = type->field (i).name ();
7151 if (t_field_name == NULL)
7154 else if (ada_is_parent_field (type, i))
7156 /* This is a field pointing us to the parent type of a tagged
7157 type. As hinted in this function's documentation, we give
7158 preference to fields in the current record first, so what
7159 we do here is just record the index of this field before
7160 we skip it. If it turns out we couldn't find our field
7161 in the current record, then we'll get back to it and search
7162 inside it whether the field might exist in the parent. */
7168 else if (field_name_match (t_field_name, name))
7169 return ada_value_primitive_field (arg, offset, i, type);
7171 else if (ada_is_wrapper_field (type, i))
7173 struct value *v = /* Do not let indent join lines here. */
7174 ada_search_struct_field (name, arg,
7175 offset + type->field (i).loc_bitpos () / 8,
7176 type->field (i).type ());
7182 else if (ada_is_variant_part (type, i))
7184 /* PNH: Do we ever get here? See find_struct_field. */
7186 struct type *field_type = ada_check_typedef (type->field (i).type ());
7187 int var_offset = offset + type->field (i).loc_bitpos () / 8;
7189 for (j = 0; j < field_type->num_fields (); j += 1)
7191 struct value *v = ada_search_struct_field /* Force line
7194 var_offset + field_type->field (j).loc_bitpos () / 8,
7195 field_type->field (j).type ());
7203 /* Field not found so far. If this is a tagged type which
7204 has a parent, try finding that field in the parent now. */
7206 if (parent_offset != -1)
7208 struct value *v = ada_search_struct_field (
7209 name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7210 type->field (parent_offset).type ());
7219 static struct value *ada_index_struct_field_1 (int *, struct value *,
7220 int, struct type *);
7223 /* Return field #INDEX in ARG, where the index is that returned by
7224 * find_struct_field through its INDEX_P argument. Adjust the address
7225 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7226 * If found, return value, else return NULL. */
7228 static struct value *
7229 ada_index_struct_field (int index, struct value *arg, int offset,
7232 return ada_index_struct_field_1 (&index, arg, offset, type);
7236 /* Auxiliary function for ada_index_struct_field. Like
7237 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7240 static struct value *
7241 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7245 type = ada_check_typedef (type);
7247 for (i = 0; i < type->num_fields (); i += 1)
7249 if (type->field (i).name () == NULL)
7251 else if (ada_is_wrapper_field (type, i))
7253 struct value *v = /* Do not let indent join lines here. */
7254 ada_index_struct_field_1 (index_p, arg,
7255 offset + type->field (i).loc_bitpos () / 8,
7256 type->field (i).type ());
7262 else if (ada_is_variant_part (type, i))
7264 /* PNH: Do we ever get here? See ada_search_struct_field,
7265 find_struct_field. */
7266 error (_("Cannot assign this kind of variant record"));
7268 else if (*index_p == 0)
7269 return ada_value_primitive_field (arg, offset, i, type);
7276 /* Return a string representation of type TYPE. */
7279 type_as_string (struct type *type)
7281 string_file tmp_stream;
7283 type_print (type, "", &tmp_stream, -1);
7285 return tmp_stream.release ();
7288 /* Given a type TYPE, look up the type of the component of type named NAME.
7289 If DISPP is non-null, add its byte displacement from the beginning of a
7290 structure (pointed to by a value) of type TYPE to *DISPP (does not
7291 work for packed fields).
7293 Matches any field whose name has NAME as a prefix, possibly
7296 TYPE can be either a struct or union. If REFOK, TYPE may also
7297 be a (pointer or reference)+ to a struct or union, and the
7298 ultimate target type will be searched.
7300 Looks recursively into variant clauses and parent types.
7302 In the case of homonyms in the tagged types, please refer to the
7303 long explanation in find_struct_field's function documentation.
7305 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7306 TYPE is not a type of the right kind. */
7308 static struct type *
7309 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7313 int parent_offset = -1;
7318 if (refok && type != NULL)
7321 type = ada_check_typedef (type);
7322 if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7324 type = TYPE_TARGET_TYPE (type);
7328 || (type->code () != TYPE_CODE_STRUCT
7329 && type->code () != TYPE_CODE_UNION))
7334 error (_("Type %s is not a structure or union type"),
7335 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7338 type = to_static_fixed_type (type);
7340 for (i = 0; i < type->num_fields (); i += 1)
7342 const char *t_field_name = type->field (i).name ();
7345 if (t_field_name == NULL)
7348 else if (ada_is_parent_field (type, i))
7350 /* This is a field pointing us to the parent type of a tagged
7351 type. As hinted in this function's documentation, we give
7352 preference to fields in the current record first, so what
7353 we do here is just record the index of this field before
7354 we skip it. If it turns out we couldn't find our field
7355 in the current record, then we'll get back to it and search
7356 inside it whether the field might exist in the parent. */
7362 else if (field_name_match (t_field_name, name))
7363 return type->field (i).type ();
7365 else if (ada_is_wrapper_field (type, i))
7367 t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7373 else if (ada_is_variant_part (type, i))
7376 struct type *field_type = ada_check_typedef (type->field (i).type ());
7378 for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7380 /* FIXME pnh 2008/01/26: We check for a field that is
7381 NOT wrapped in a struct, since the compiler sometimes
7382 generates these for unchecked variant types. Revisit
7383 if the compiler changes this practice. */
7384 const char *v_field_name = field_type->field (j).name ();
7386 if (v_field_name != NULL
7387 && field_name_match (v_field_name, name))
7388 t = field_type->field (j).type ();
7390 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7400 /* Field not found so far. If this is a tagged type which
7401 has a parent, try finding that field in the parent now. */
7403 if (parent_offset != -1)
7407 t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7416 const char *name_str = name != NULL ? name : _("<null>");
7418 error (_("Type %s has no component named %s"),
7419 type_as_string (type).c_str (), name_str);
7425 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7426 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7427 represents an unchecked union (that is, the variant part of a
7428 record that is named in an Unchecked_Union pragma). */
7431 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7433 const char *discrim_name = ada_variant_discrim_name (var_type);
7435 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7439 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7440 within OUTER, determine which variant clause (field number in VAR_TYPE,
7441 numbering from 0) is applicable. Returns -1 if none are. */
7444 ada_which_variant_applies (struct type *var_type, struct value *outer)
7448 const char *discrim_name = ada_variant_discrim_name (var_type);
7449 struct value *discrim;
7450 LONGEST discrim_val;
7452 /* Using plain value_from_contents_and_address here causes problems
7453 because we will end up trying to resolve a type that is currently
7454 being constructed. */
7455 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7456 if (discrim == NULL)
7458 discrim_val = value_as_long (discrim);
7461 for (i = 0; i < var_type->num_fields (); i += 1)
7463 if (ada_is_others_clause (var_type, i))
7465 else if (ada_in_variant (discrim_val, var_type, i))
7469 return others_clause;
7474 /* Dynamic-Sized Records */
7476 /* Strategy: The type ostensibly attached to a value with dynamic size
7477 (i.e., a size that is not statically recorded in the debugging
7478 data) does not accurately reflect the size or layout of the value.
7479 Our strategy is to convert these values to values with accurate,
7480 conventional types that are constructed on the fly. */
7482 /* There is a subtle and tricky problem here. In general, we cannot
7483 determine the size of dynamic records without its data. However,
7484 the 'struct value' data structure, which GDB uses to represent
7485 quantities in the inferior process (the target), requires the size
7486 of the type at the time of its allocation in order to reserve space
7487 for GDB's internal copy of the data. That's why the
7488 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7489 rather than struct value*s.
7491 However, GDB's internal history variables ($1, $2, etc.) are
7492 struct value*s containing internal copies of the data that are not, in
7493 general, the same as the data at their corresponding addresses in
7494 the target. Fortunately, the types we give to these values are all
7495 conventional, fixed-size types (as per the strategy described
7496 above), so that we don't usually have to perform the
7497 'to_fixed_xxx_type' conversions to look at their values.
7498 Unfortunately, there is one exception: if one of the internal
7499 history variables is an array whose elements are unconstrained
7500 records, then we will need to create distinct fixed types for each
7501 element selected. */
7503 /* The upshot of all of this is that many routines take a (type, host
7504 address, target address) triple as arguments to represent a value.
7505 The host address, if non-null, is supposed to contain an internal
7506 copy of the relevant data; otherwise, the program is to consult the
7507 target at the target address. */
7509 /* Assuming that VAL0 represents a pointer value, the result of
7510 dereferencing it. Differs from value_ind in its treatment of
7511 dynamic-sized types. */
7514 ada_value_ind (struct value *val0)
7516 struct value *val = value_ind (val0);
7518 if (ada_is_tagged_type (value_type (val), 0))
7519 val = ada_tag_value_at_base_address (val);
7521 return ada_to_fixed_value (val);
7524 /* The value resulting from dereferencing any "reference to"
7525 qualifiers on VAL0. */
7527 static struct value *
7528 ada_coerce_ref (struct value *val0)
7530 if (value_type (val0)->code () == TYPE_CODE_REF)
7532 struct value *val = val0;
7534 val = coerce_ref (val);
7536 if (ada_is_tagged_type (value_type (val), 0))
7537 val = ada_tag_value_at_base_address (val);
7539 return ada_to_fixed_value (val);
7545 /* Return the bit alignment required for field #F of template type TYPE. */
7548 field_alignment (struct type *type, int f)
7550 const char *name = type->field (f).name ();
7554 /* The field name should never be null, unless the debugging information
7555 is somehow malformed. In this case, we assume the field does not
7556 require any alignment. */
7560 len = strlen (name);
7562 if (!isdigit (name[len - 1]))
7565 if (isdigit (name[len - 2]))
7566 align_offset = len - 2;
7568 align_offset = len - 1;
7570 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7571 return TARGET_CHAR_BIT;
7573 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7576 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7578 static struct symbol *
7579 ada_find_any_type_symbol (const char *name)
7583 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7584 if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7587 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7591 /* Find a type named NAME. Ignores ambiguity. This routine will look
7592 solely for types defined by debug info, it will not search the GDB
7595 static struct type *
7596 ada_find_any_type (const char *name)
7598 struct symbol *sym = ada_find_any_type_symbol (name);
7601 return sym->type ();
7606 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7607 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7608 symbol, in which case it is returned. Otherwise, this looks for
7609 symbols whose name is that of NAME_SYM suffixed with "___XR".
7610 Return symbol if found, and NULL otherwise. */
7613 ada_is_renaming_symbol (struct symbol *name_sym)
7615 const char *name = name_sym->linkage_name ();
7616 return strstr (name, "___XR") != NULL;
7619 /* Because of GNAT encoding conventions, several GDB symbols may match a
7620 given type name. If the type denoted by TYPE0 is to be preferred to
7621 that of TYPE1 for purposes of type printing, return non-zero;
7622 otherwise return 0. */
7625 ada_prefer_type (struct type *type0, struct type *type1)
7629 else if (type0 == NULL)
7631 else if (type1->code () == TYPE_CODE_VOID)
7633 else if (type0->code () == TYPE_CODE_VOID)
7635 else if (type1->name () == NULL && type0->name () != NULL)
7637 else if (ada_is_constrained_packed_array_type (type0))
7639 else if (ada_is_array_descriptor_type (type0)
7640 && !ada_is_array_descriptor_type (type1))
7644 const char *type0_name = type0->name ();
7645 const char *type1_name = type1->name ();
7647 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7648 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7654 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7658 ada_type_name (struct type *type)
7662 return type->name ();
7665 /* Search the list of "descriptive" types associated to TYPE for a type
7666 whose name is NAME. */
7668 static struct type *
7669 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7671 struct type *result, *tmp;
7673 if (ada_ignore_descriptive_types_p)
7676 /* If there no descriptive-type info, then there is no parallel type
7678 if (!HAVE_GNAT_AUX_INFO (type))
7681 result = TYPE_DESCRIPTIVE_TYPE (type);
7682 while (result != NULL)
7684 const char *result_name = ada_type_name (result);
7686 if (result_name == NULL)
7688 warning (_("unexpected null name on descriptive type"));
7692 /* If the names match, stop. */
7693 if (strcmp (result_name, name) == 0)
7696 /* Otherwise, look at the next item on the list, if any. */
7697 if (HAVE_GNAT_AUX_INFO (result))
7698 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7702 /* If not found either, try after having resolved the typedef. */
7707 result = check_typedef (result);
7708 if (HAVE_GNAT_AUX_INFO (result))
7709 result = TYPE_DESCRIPTIVE_TYPE (result);
7715 /* If we didn't find a match, see whether this is a packed array. With
7716 older compilers, the descriptive type information is either absent or
7717 irrelevant when it comes to packed arrays so the above lookup fails.
7718 Fall back to using a parallel lookup by name in this case. */
7719 if (result == NULL && ada_is_constrained_packed_array_type (type))
7720 return ada_find_any_type (name);
7725 /* Find a parallel type to TYPE with the specified NAME, using the
7726 descriptive type taken from the debugging information, if available,
7727 and otherwise using the (slower) name-based method. */
7729 static struct type *
7730 ada_find_parallel_type_with_name (struct type *type, const char *name)
7732 struct type *result = NULL;
7734 if (HAVE_GNAT_AUX_INFO (type))
7735 result = find_parallel_type_by_descriptive_type (type, name);
7737 result = ada_find_any_type (name);
7742 /* Same as above, but specify the name of the parallel type by appending
7743 SUFFIX to the name of TYPE. */
7746 ada_find_parallel_type (struct type *type, const char *suffix)
7749 const char *type_name = ada_type_name (type);
7752 if (type_name == NULL)
7755 len = strlen (type_name);
7757 name = (char *) alloca (len + strlen (suffix) + 1);
7759 strcpy (name, type_name);
7760 strcpy (name + len, suffix);
7762 return ada_find_parallel_type_with_name (type, name);
7765 /* If TYPE is a variable-size record type, return the corresponding template
7766 type describing its fields. Otherwise, return NULL. */
7768 static struct type *
7769 dynamic_template_type (struct type *type)
7771 type = ada_check_typedef (type);
7773 if (type == NULL || type->code () != TYPE_CODE_STRUCT
7774 || ada_type_name (type) == NULL)
7778 int len = strlen (ada_type_name (type));
7780 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7783 return ada_find_parallel_type (type, "___XVE");
7787 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7788 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7791 is_dynamic_field (struct type *templ_type, int field_num)
7793 const char *name = templ_type->field (field_num).name ();
7796 && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7797 && strstr (name, "___XVL") != NULL;
7800 /* The index of the variant field of TYPE, or -1 if TYPE does not
7801 represent a variant record type. */
7804 variant_field_index (struct type *type)
7808 if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7811 for (f = 0; f < type->num_fields (); f += 1)
7813 if (ada_is_variant_part (type, f))
7819 /* A record type with no fields. */
7821 static struct type *
7822 empty_record (struct type *templ)
7824 struct type *type = alloc_type_copy (templ);
7826 type->set_code (TYPE_CODE_STRUCT);
7827 INIT_NONE_SPECIFIC (type);
7828 type->set_name ("<empty>");
7829 TYPE_LENGTH (type) = 0;
7833 /* An ordinary record type (with fixed-length fields) that describes
7834 the value of type TYPE at VALADDR or ADDRESS (see comments at
7835 the beginning of this section) VAL according to GNAT conventions.
7836 DVAL0 should describe the (portion of a) record that contains any
7837 necessary discriminants. It should be NULL if value_type (VAL) is
7838 an outer-level type (i.e., as opposed to a branch of a variant.) A
7839 variant field (unless unchecked) is replaced by a particular branch
7842 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7843 length are not statically known are discarded. As a consequence,
7844 VALADDR, ADDRESS and DVAL0 are ignored.
7846 NOTE: Limitations: For now, we assume that dynamic fields and
7847 variants occupy whole numbers of bytes. However, they need not be
7851 ada_template_to_fixed_record_type_1 (struct type *type,
7852 const gdb_byte *valaddr,
7853 CORE_ADDR address, struct value *dval0,
7854 int keep_dynamic_fields)
7856 struct value *mark = value_mark ();
7859 int nfields, bit_len;
7865 /* Compute the number of fields in this record type that are going
7866 to be processed: unless keep_dynamic_fields, this includes only
7867 fields whose position and length are static will be processed. */
7868 if (keep_dynamic_fields)
7869 nfields = type->num_fields ();
7873 while (nfields < type->num_fields ()
7874 && !ada_is_variant_part (type, nfields)
7875 && !is_dynamic_field (type, nfields))
7879 rtype = alloc_type_copy (type);
7880 rtype->set_code (TYPE_CODE_STRUCT);
7881 INIT_NONE_SPECIFIC (rtype);
7882 rtype->set_num_fields (nfields);
7884 ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7885 rtype->set_name (ada_type_name (type));
7886 rtype->set_is_fixed_instance (true);
7892 for (f = 0; f < nfields; f += 1)
7894 off = align_up (off, field_alignment (type, f))
7895 + type->field (f).loc_bitpos ();
7896 rtype->field (f).set_loc_bitpos (off);
7897 TYPE_FIELD_BITSIZE (rtype, f) = 0;
7899 if (ada_is_variant_part (type, f))
7904 else if (is_dynamic_field (type, f))
7906 const gdb_byte *field_valaddr = valaddr;
7907 CORE_ADDR field_address = address;
7908 struct type *field_type =
7909 TYPE_TARGET_TYPE (type->field (f).type ());
7913 /* Using plain value_from_contents_and_address here
7914 causes problems because we will end up trying to
7915 resolve a type that is currently being
7917 dval = value_from_contents_and_address_unresolved (rtype,
7920 rtype = value_type (dval);
7925 /* If the type referenced by this field is an aligner type, we need
7926 to unwrap that aligner type, because its size might not be set.
7927 Keeping the aligner type would cause us to compute the wrong
7928 size for this field, impacting the offset of the all the fields
7929 that follow this one. */
7930 if (ada_is_aligner_type (field_type))
7932 long field_offset = type->field (f).loc_bitpos ();
7934 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7935 field_address = cond_offset_target (field_address, field_offset);
7936 field_type = ada_aligned_type (field_type);
7939 field_valaddr = cond_offset_host (field_valaddr,
7940 off / TARGET_CHAR_BIT);
7941 field_address = cond_offset_target (field_address,
7942 off / TARGET_CHAR_BIT);
7944 /* Get the fixed type of the field. Note that, in this case,
7945 we do not want to get the real type out of the tag: if
7946 the current field is the parent part of a tagged record,
7947 we will get the tag of the object. Clearly wrong: the real
7948 type of the parent is not the real type of the child. We
7949 would end up in an infinite loop. */
7950 field_type = ada_get_base_type (field_type);
7951 field_type = ada_to_fixed_type (field_type, field_valaddr,
7952 field_address, dval, 0);
7954 rtype->field (f).set_type (field_type);
7955 rtype->field (f).set_name (type->field (f).name ());
7956 /* The multiplication can potentially overflow. But because
7957 the field length has been size-checked just above, and
7958 assuming that the maximum size is a reasonable value,
7959 an overflow should not happen in practice. So rather than
7960 adding overflow recovery code to this already complex code,
7961 we just assume that it's not going to happen. */
7963 TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7967 /* Note: If this field's type is a typedef, it is important
7968 to preserve the typedef layer.
7970 Otherwise, we might be transforming a typedef to a fat
7971 pointer (encoding a pointer to an unconstrained array),
7972 into a basic fat pointer (encoding an unconstrained
7973 array). As both types are implemented using the same
7974 structure, the typedef is the only clue which allows us
7975 to distinguish between the two options. Stripping it
7976 would prevent us from printing this field appropriately. */
7977 rtype->field (f).set_type (type->field (f).type ());
7978 rtype->field (f).set_name (type->field (f).name ());
7979 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7981 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7984 struct type *field_type = type->field (f).type ();
7986 /* We need to be careful of typedefs when computing
7987 the length of our field. If this is a typedef,
7988 get the length of the target type, not the length
7990 if (field_type->code () == TYPE_CODE_TYPEDEF)
7991 field_type = ada_typedef_target_type (field_type);
7994 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7997 if (off + fld_bit_len > bit_len)
7998 bit_len = off + fld_bit_len;
8000 TYPE_LENGTH (rtype) =
8001 align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8004 /* We handle the variant part, if any, at the end because of certain
8005 odd cases in which it is re-ordered so as NOT to be the last field of
8006 the record. This can happen in the presence of representation
8008 if (variant_field >= 0)
8010 struct type *branch_type;
8012 off = rtype->field (variant_field).loc_bitpos ();
8016 /* Using plain value_from_contents_and_address here causes
8017 problems because we will end up trying to resolve a type
8018 that is currently being constructed. */
8019 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8021 rtype = value_type (dval);
8027 to_fixed_variant_branch_type
8028 (type->field (variant_field).type (),
8029 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8030 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8031 if (branch_type == NULL)
8033 for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8034 rtype->field (f - 1) = rtype->field (f);
8035 rtype->set_num_fields (rtype->num_fields () - 1);
8039 rtype->field (variant_field).set_type (branch_type);
8040 rtype->field (variant_field).set_name ("S");
8042 TYPE_LENGTH (rtype->field (variant_field).type ()) *
8044 if (off + fld_bit_len > bit_len)
8045 bit_len = off + fld_bit_len;
8046 TYPE_LENGTH (rtype) =
8047 align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8051 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8052 should contain the alignment of that record, which should be a strictly
8053 positive value. If null or negative, then something is wrong, most
8054 probably in the debug info. In that case, we don't round up the size
8055 of the resulting type. If this record is not part of another structure,
8056 the current RTYPE length might be good enough for our purposes. */
8057 if (TYPE_LENGTH (type) <= 0)
8060 warning (_("Invalid type size for `%s' detected: %s."),
8061 rtype->name (), pulongest (TYPE_LENGTH (type)));
8063 warning (_("Invalid type size for <unnamed> detected: %s."),
8064 pulongest (TYPE_LENGTH (type)));
8068 TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
8069 TYPE_LENGTH (type));
8072 value_free_to_mark (mark);
8076 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8079 static struct type *
8080 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8081 CORE_ADDR address, struct value *dval0)
8083 return ada_template_to_fixed_record_type_1 (type, valaddr,
8087 /* An ordinary record type in which ___XVL-convention fields and
8088 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8089 static approximations, containing all possible fields. Uses
8090 no runtime values. Useless for use in values, but that's OK,
8091 since the results are used only for type determinations. Works on both
8092 structs and unions. Representation note: to save space, we memorize
8093 the result of this function in the TYPE_TARGET_TYPE of the
8096 static struct type *
8097 template_to_static_fixed_type (struct type *type0)
8103 /* No need no do anything if the input type is already fixed. */
8104 if (type0->is_fixed_instance ())
8107 /* Likewise if we already have computed the static approximation. */
8108 if (TYPE_TARGET_TYPE (type0) != NULL)
8109 return TYPE_TARGET_TYPE (type0);
8111 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8113 nfields = type0->num_fields ();
8115 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8116 recompute all over next time. */
8117 type0->set_target_type (type);
8119 for (f = 0; f < nfields; f += 1)
8121 struct type *field_type = type0->field (f).type ();
8122 struct type *new_type;
8124 if (is_dynamic_field (type0, f))
8126 field_type = ada_check_typedef (field_type);
8127 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8130 new_type = static_unwrap_type (field_type);
8132 if (new_type != field_type)
8134 /* Clone TYPE0 only the first time we get a new field type. */
8137 type = alloc_type_copy (type0);
8138 type0->set_target_type (type);
8139 type->set_code (type0->code ());
8140 INIT_NONE_SPECIFIC (type);
8141 type->set_num_fields (nfields);
8145 TYPE_ALLOC (type, nfields * sizeof (struct field)));
8146 memcpy (fields, type0->fields (),
8147 sizeof (struct field) * nfields);
8148 type->set_fields (fields);
8150 type->set_name (ada_type_name (type0));
8151 type->set_is_fixed_instance (true);
8152 TYPE_LENGTH (type) = 0;
8154 type->field (f).set_type (new_type);
8155 type->field (f).set_name (type0->field (f).name ());
8162 /* Given an object of type TYPE whose contents are at VALADDR and
8163 whose address in memory is ADDRESS, returns a revision of TYPE,
8164 which should be a non-dynamic-sized record, in which the variant
8165 part, if any, is replaced with the appropriate branch. Looks
8166 for discriminant values in DVAL0, which can be NULL if the record
8167 contains the necessary discriminant values. */
8169 static struct type *
8170 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8171 CORE_ADDR address, struct value *dval0)
8173 struct value *mark = value_mark ();
8176 struct type *branch_type;
8177 int nfields = type->num_fields ();
8178 int variant_field = variant_field_index (type);
8180 if (variant_field == -1)
8185 dval = value_from_contents_and_address (type, valaddr, address);
8186 type = value_type (dval);
8191 rtype = alloc_type_copy (type);
8192 rtype->set_code (TYPE_CODE_STRUCT);
8193 INIT_NONE_SPECIFIC (rtype);
8194 rtype->set_num_fields (nfields);
8197 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8198 memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8199 rtype->set_fields (fields);
8201 rtype->set_name (ada_type_name (type));
8202 rtype->set_is_fixed_instance (true);
8203 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8205 branch_type = to_fixed_variant_branch_type
8206 (type->field (variant_field).type (),
8207 cond_offset_host (valaddr,
8208 type->field (variant_field).loc_bitpos ()
8210 cond_offset_target (address,
8211 type->field (variant_field).loc_bitpos ()
8212 / TARGET_CHAR_BIT), dval);
8213 if (branch_type == NULL)
8217 for (f = variant_field + 1; f < nfields; f += 1)
8218 rtype->field (f - 1) = rtype->field (f);
8219 rtype->set_num_fields (rtype->num_fields () - 1);
8223 rtype->field (variant_field).set_type (branch_type);
8224 rtype->field (variant_field).set_name ("S");
8225 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8226 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8228 TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
8230 value_free_to_mark (mark);
8234 /* An ordinary record type (with fixed-length fields) that describes
8235 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8236 beginning of this section]. Any necessary discriminants' values
8237 should be in DVAL, a record value; it may be NULL if the object
8238 at ADDR itself contains any necessary discriminant values.
8239 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8240 values from the record are needed. Except in the case that DVAL,
8241 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8242 unchecked) is replaced by a particular branch of the variant.
8244 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8245 is questionable and may be removed. It can arise during the
8246 processing of an unconstrained-array-of-record type where all the
8247 variant branches have exactly the same size. This is because in
8248 such cases, the compiler does not bother to use the XVS convention
8249 when encoding the record. I am currently dubious of this
8250 shortcut and suspect the compiler should be altered. FIXME. */
8252 static struct type *
8253 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8254 CORE_ADDR address, struct value *dval)
8256 struct type *templ_type;
8258 if (type0->is_fixed_instance ())
8261 templ_type = dynamic_template_type (type0);
8263 if (templ_type != NULL)
8264 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8265 else if (variant_field_index (type0) >= 0)
8267 if (dval == NULL && valaddr == NULL && address == 0)
8269 return to_record_with_fixed_variant_part (type0, valaddr, address,
8274 type0->set_is_fixed_instance (true);
8280 /* An ordinary record type (with fixed-length fields) that describes
8281 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8282 union type. Any necessary discriminants' values should be in DVAL,
8283 a record value. That is, this routine selects the appropriate
8284 branch of the union at ADDR according to the discriminant value
8285 indicated in the union's type name. Returns VAR_TYPE0 itself if
8286 it represents a variant subject to a pragma Unchecked_Union. */
8288 static struct type *
8289 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8290 CORE_ADDR address, struct value *dval)
8293 struct type *templ_type;
8294 struct type *var_type;
8296 if (var_type0->code () == TYPE_CODE_PTR)
8297 var_type = TYPE_TARGET_TYPE (var_type0);
8299 var_type = var_type0;
8301 templ_type = ada_find_parallel_type (var_type, "___XVU");
8303 if (templ_type != NULL)
8304 var_type = templ_type;
8306 if (is_unchecked_variant (var_type, value_type (dval)))
8308 which = ada_which_variant_applies (var_type, dval);
8311 return empty_record (var_type);
8312 else if (is_dynamic_field (var_type, which))
8313 return to_fixed_record_type
8314 (TYPE_TARGET_TYPE (var_type->field (which).type ()),
8315 valaddr, address, dval);
8316 else if (variant_field_index (var_type->field (which).type ()) >= 0)
8318 to_fixed_record_type
8319 (var_type->field (which).type (), valaddr, address, dval);
8321 return var_type->field (which).type ();
8324 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8325 ENCODING_TYPE, a type following the GNAT conventions for discrete
8326 type encodings, only carries redundant information. */
8329 ada_is_redundant_range_encoding (struct type *range_type,
8330 struct type *encoding_type)
8332 const char *bounds_str;
8336 gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8338 if (get_base_type (range_type)->code ()
8339 != get_base_type (encoding_type)->code ())
8341 /* The compiler probably used a simple base type to describe
8342 the range type instead of the range's actual base type,
8343 expecting us to get the real base type from the encoding
8344 anyway. In this situation, the encoding cannot be ignored
8349 if (is_dynamic_type (range_type))
8352 if (encoding_type->name () == NULL)
8355 bounds_str = strstr (encoding_type->name (), "___XDLU_");
8356 if (bounds_str == NULL)
8359 n = 8; /* Skip "___XDLU_". */
8360 if (!ada_scan_number (bounds_str, n, &lo, &n))
8362 if (range_type->bounds ()->low.const_val () != lo)
8365 n += 2; /* Skip the "__" separator between the two bounds. */
8366 if (!ada_scan_number (bounds_str, n, &hi, &n))
8368 if (range_type->bounds ()->high.const_val () != hi)
8374 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8375 a type following the GNAT encoding for describing array type
8376 indices, only carries redundant information. */
8379 ada_is_redundant_index_type_desc (struct type *array_type,
8380 struct type *desc_type)
8382 struct type *this_layer = check_typedef (array_type);
8385 for (i = 0; i < desc_type->num_fields (); i++)
8387 if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8388 desc_type->field (i).type ()))
8390 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8396 /* Assuming that TYPE0 is an array type describing the type of a value
8397 at ADDR, and that DVAL describes a record containing any
8398 discriminants used in TYPE0, returns a type for the value that
8399 contains no dynamic components (that is, no components whose sizes
8400 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8401 true, gives an error message if the resulting type's size is over
8404 static struct type *
8405 to_fixed_array_type (struct type *type0, struct value *dval,
8408 struct type *index_type_desc;
8409 struct type *result;
8410 int constrained_packed_array_p;
8411 static const char *xa_suffix = "___XA";
8413 type0 = ada_check_typedef (type0);
8414 if (type0->is_fixed_instance ())
8417 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8418 if (constrained_packed_array_p)
8420 type0 = decode_constrained_packed_array_type (type0);
8421 if (type0 == nullptr)
8422 error (_("could not decode constrained packed array type"));
8425 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8427 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8428 encoding suffixed with 'P' may still be generated. If so,
8429 it should be used to find the XA type. */
8431 if (index_type_desc == NULL)
8433 const char *type_name = ada_type_name (type0);
8435 if (type_name != NULL)
8437 const int len = strlen (type_name);
8438 char *name = (char *) alloca (len + strlen (xa_suffix));
8440 if (type_name[len - 1] == 'P')
8442 strcpy (name, type_name);
8443 strcpy (name + len - 1, xa_suffix);
8444 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8449 ada_fixup_array_indexes_type (index_type_desc);
8450 if (index_type_desc != NULL
8451 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8453 /* Ignore this ___XA parallel type, as it does not bring any
8454 useful information. This allows us to avoid creating fixed
8455 versions of the array's index types, which would be identical
8456 to the original ones. This, in turn, can also help avoid
8457 the creation of fixed versions of the array itself. */
8458 index_type_desc = NULL;
8461 if (index_type_desc == NULL)
8463 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8465 /* NOTE: elt_type---the fixed version of elt_type0---should never
8466 depend on the contents of the array in properly constructed
8468 /* Create a fixed version of the array element type.
8469 We're not providing the address of an element here,
8470 and thus the actual object value cannot be inspected to do
8471 the conversion. This should not be a problem, since arrays of
8472 unconstrained objects are not allowed. In particular, all
8473 the elements of an array of a tagged type should all be of
8474 the same type specified in the debugging info. No need to
8475 consult the object tag. */
8476 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8478 /* Make sure we always create a new array type when dealing with
8479 packed array types, since we're going to fix-up the array
8480 type length and element bitsize a little further down. */
8481 if (elt_type0 == elt_type && !constrained_packed_array_p)
8484 result = create_array_type (alloc_type_copy (type0),
8485 elt_type, type0->index_type ());
8490 struct type *elt_type0;
8493 for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8494 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8496 /* NOTE: result---the fixed version of elt_type0---should never
8497 depend on the contents of the array in properly constructed
8499 /* Create a fixed version of the array element type.
8500 We're not providing the address of an element here,
8501 and thus the actual object value cannot be inspected to do
8502 the conversion. This should not be a problem, since arrays of
8503 unconstrained objects are not allowed. In particular, all
8504 the elements of an array of a tagged type should all be of
8505 the same type specified in the debugging info. No need to
8506 consult the object tag. */
8508 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8511 for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8513 struct type *range_type =
8514 to_fixed_range_type (index_type_desc->field (i).type (), dval);
8516 result = create_array_type (alloc_type_copy (elt_type0),
8517 result, range_type);
8518 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8522 /* We want to preserve the type name. This can be useful when
8523 trying to get the type name of a value that has already been
8524 printed (for instance, if the user did "print VAR; whatis $". */
8525 result->set_name (type0->name ());
8527 if (constrained_packed_array_p)
8529 /* So far, the resulting type has been created as if the original
8530 type was a regular (non-packed) array type. As a result, the
8531 bitsize of the array elements needs to be set again, and the array
8532 length needs to be recomputed based on that bitsize. */
8533 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8534 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8536 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8537 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8538 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8539 TYPE_LENGTH (result)++;
8542 result->set_is_fixed_instance (true);
8547 /* A standard type (containing no dynamically sized components)
8548 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8549 DVAL describes a record containing any discriminants used in TYPE0,
8550 and may be NULL if there are none, or if the object of type TYPE at
8551 ADDRESS or in VALADDR contains these discriminants.
8553 If CHECK_TAG is not null, in the case of tagged types, this function
8554 attempts to locate the object's tag and use it to compute the actual
8555 type. However, when ADDRESS is null, we cannot use it to determine the
8556 location of the tag, and therefore compute the tagged type's actual type.
8557 So we return the tagged type without consulting the tag. */
8559 static struct type *
8560 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8561 CORE_ADDR address, struct value *dval, int check_tag)
8563 type = ada_check_typedef (type);
8565 /* Only un-fixed types need to be handled here. */
8566 if (!HAVE_GNAT_AUX_INFO (type))
8569 switch (type->code ())
8573 case TYPE_CODE_STRUCT:
8575 struct type *static_type = to_static_fixed_type (type);
8576 struct type *fixed_record_type =
8577 to_fixed_record_type (type, valaddr, address, NULL);
8579 /* If STATIC_TYPE is a tagged type and we know the object's address,
8580 then we can determine its tag, and compute the object's actual
8581 type from there. Note that we have to use the fixed record
8582 type (the parent part of the record may have dynamic fields
8583 and the way the location of _tag is expressed may depend on
8586 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8589 value_tag_from_contents_and_address
8593 struct type *real_type = type_from_tag (tag);
8595 value_from_contents_and_address (fixed_record_type,
8598 fixed_record_type = value_type (obj);
8599 if (real_type != NULL)
8600 return to_fixed_record_type
8602 value_address (ada_tag_value_at_base_address (obj)), NULL);
8605 /* Check to see if there is a parallel ___XVZ variable.
8606 If there is, then it provides the actual size of our type. */
8607 else if (ada_type_name (fixed_record_type) != NULL)
8609 const char *name = ada_type_name (fixed_record_type);
8611 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8612 bool xvz_found = false;
8615 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8618 xvz_found = get_int_var_value (xvz_name, size);
8620 catch (const gdb_exception_error &except)
8622 /* We found the variable, but somehow failed to read
8623 its value. Rethrow the same error, but with a little
8624 bit more information, to help the user understand
8625 what went wrong (Eg: the variable might have been
8627 throw_error (except.error,
8628 _("unable to read value of %s (%s)"),
8629 xvz_name, except.what ());
8632 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8634 fixed_record_type = copy_type (fixed_record_type);
8635 TYPE_LENGTH (fixed_record_type) = size;
8637 /* The FIXED_RECORD_TYPE may have be a stub. We have
8638 observed this when the debugging info is STABS, and
8639 apparently it is something that is hard to fix.
8641 In practice, we don't need the actual type definition
8642 at all, because the presence of the XVZ variable allows us
8643 to assume that there must be a XVS type as well, which we
8644 should be able to use later, when we need the actual type
8647 In the meantime, pretend that the "fixed" type we are
8648 returning is NOT a stub, because this can cause trouble
8649 when using this type to create new types targeting it.
8650 Indeed, the associated creation routines often check
8651 whether the target type is a stub and will try to replace
8652 it, thus using a type with the wrong size. This, in turn,
8653 might cause the new type to have the wrong size too.
8654 Consider the case of an array, for instance, where the size
8655 of the array is computed from the number of elements in
8656 our array multiplied by the size of its element. */
8657 fixed_record_type->set_is_stub (false);
8660 return fixed_record_type;
8662 case TYPE_CODE_ARRAY:
8663 return to_fixed_array_type (type, dval, 1);
8664 case TYPE_CODE_UNION:
8668 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8672 /* The same as ada_to_fixed_type_1, except that it preserves the type
8673 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8675 The typedef layer needs be preserved in order to differentiate between
8676 arrays and array pointers when both types are implemented using the same
8677 fat pointer. In the array pointer case, the pointer is encoded as
8678 a typedef of the pointer type. For instance, considering:
8680 type String_Access is access String;
8681 S1 : String_Access := null;
8683 To the debugger, S1 is defined as a typedef of type String. But
8684 to the user, it is a pointer. So if the user tries to print S1,
8685 we should not dereference the array, but print the array address
8688 If we didn't preserve the typedef layer, we would lose the fact that
8689 the type is to be presented as a pointer (needs de-reference before
8690 being printed). And we would also use the source-level type name. */
8693 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8694 CORE_ADDR address, struct value *dval, int check_tag)
8697 struct type *fixed_type =
8698 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8700 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8701 then preserve the typedef layer.
8703 Implementation note: We can only check the main-type portion of
8704 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8705 from TYPE now returns a type that has the same instance flags
8706 as TYPE. For instance, if TYPE is a "typedef const", and its
8707 target type is a "struct", then the typedef elimination will return
8708 a "const" version of the target type. See check_typedef for more
8709 details about how the typedef layer elimination is done.
8711 brobecker/2010-11-19: It seems to me that the only case where it is
8712 useful to preserve the typedef layer is when dealing with fat pointers.
8713 Perhaps, we could add a check for that and preserve the typedef layer
8714 only in that situation. But this seems unnecessary so far, probably
8715 because we call check_typedef/ada_check_typedef pretty much everywhere.
8717 if (type->code () == TYPE_CODE_TYPEDEF
8718 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8719 == TYPE_MAIN_TYPE (fixed_type)))
8725 /* A standard (static-sized) type corresponding as well as possible to
8726 TYPE0, but based on no runtime data. */
8728 static struct type *
8729 to_static_fixed_type (struct type *type0)
8736 if (type0->is_fixed_instance ())
8739 type0 = ada_check_typedef (type0);
8741 switch (type0->code ())
8745 case TYPE_CODE_STRUCT:
8746 type = dynamic_template_type (type0);
8748 return template_to_static_fixed_type (type);
8750 return template_to_static_fixed_type (type0);
8751 case TYPE_CODE_UNION:
8752 type = ada_find_parallel_type (type0, "___XVU");
8754 return template_to_static_fixed_type (type);
8756 return template_to_static_fixed_type (type0);
8760 /* A static approximation of TYPE with all type wrappers removed. */
8762 static struct type *
8763 static_unwrap_type (struct type *type)
8765 if (ada_is_aligner_type (type))
8767 struct type *type1 = ada_check_typedef (type)->field (0).type ();
8768 if (ada_type_name (type1) == NULL)
8769 type1->set_name (ada_type_name (type));
8771 return static_unwrap_type (type1);
8775 struct type *raw_real_type = ada_get_base_type (type);
8777 if (raw_real_type == type)
8780 return to_static_fixed_type (raw_real_type);
8784 /* In some cases, incomplete and private types require
8785 cross-references that are not resolved as records (for example,
8787 type FooP is access Foo;
8789 type Foo is array ...;
8790 ). In these cases, since there is no mechanism for producing
8791 cross-references to such types, we instead substitute for FooP a
8792 stub enumeration type that is nowhere resolved, and whose tag is
8793 the name of the actual type. Call these types "non-record stubs". */
8795 /* A type equivalent to TYPE that is not a non-record stub, if one
8796 exists, otherwise TYPE. */
8799 ada_check_typedef (struct type *type)
8804 /* If our type is an access to an unconstrained array, which is encoded
8805 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8806 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8807 what allows us to distinguish between fat pointers that represent
8808 array types, and fat pointers that represent array access types
8809 (in both cases, the compiler implements them as fat pointers). */
8810 if (ada_is_access_to_unconstrained_array (type))
8813 type = check_typedef (type);
8814 if (type == NULL || type->code () != TYPE_CODE_ENUM
8815 || !type->is_stub ()
8816 || type->name () == NULL)
8820 const char *name = type->name ();
8821 struct type *type1 = ada_find_any_type (name);
8826 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8827 stubs pointing to arrays, as we don't create symbols for array
8828 types, only for the typedef-to-array types). If that's the case,
8829 strip the typedef layer. */
8830 if (type1->code () == TYPE_CODE_TYPEDEF)
8831 type1 = ada_check_typedef (type1);
8837 /* A value representing the data at VALADDR/ADDRESS as described by
8838 type TYPE0, but with a standard (static-sized) type that correctly
8839 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8840 type, then return VAL0 [this feature is simply to avoid redundant
8841 creation of struct values]. */
8843 static struct value *
8844 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8847 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8849 if (type == type0 && val0 != NULL)
8852 if (VALUE_LVAL (val0) != lval_memory)
8854 /* Our value does not live in memory; it could be a convenience
8855 variable, for instance. Create a not_lval value using val0's
8857 return value_from_contents (type, value_contents (val0).data ());
8860 return value_from_contents_and_address (type, 0, address);
8863 /* A value representing VAL, but with a standard (static-sized) type
8864 that correctly describes it. Does not necessarily create a new
8868 ada_to_fixed_value (struct value *val)
8870 val = unwrap_value (val);
8871 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8878 /* Table mapping attribute numbers to names.
8879 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8881 static const char * const attribute_names[] = {
8899 ada_attribute_name (enum exp_opcode n)
8901 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8902 return attribute_names[n - OP_ATR_FIRST + 1];
8904 return attribute_names[0];
8907 /* Evaluate the 'POS attribute applied to ARG. */
8910 pos_atr (struct value *arg)
8912 struct value *val = coerce_ref (arg);
8913 struct type *type = value_type (val);
8915 if (!discrete_type_p (type))
8916 error (_("'POS only defined on discrete types"));
8918 gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8919 if (!result.has_value ())
8920 error (_("enumeration value is invalid: can't find 'POS"));
8926 ada_pos_atr (struct type *expect_type,
8927 struct expression *exp,
8928 enum noside noside, enum exp_opcode op,
8931 struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8932 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8933 return value_zero (type, not_lval);
8934 return value_from_longest (type, pos_atr (arg));
8937 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8939 static struct value *
8940 val_atr (struct type *type, LONGEST val)
8942 gdb_assert (discrete_type_p (type));
8943 if (type->code () == TYPE_CODE_RANGE)
8944 type = TYPE_TARGET_TYPE (type);
8945 if (type->code () == TYPE_CODE_ENUM)
8947 if (val < 0 || val >= type->num_fields ())
8948 error (_("argument to 'VAL out of range"));
8949 val = type->field (val).loc_enumval ();
8951 return value_from_longest (type, val);
8955 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8957 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8958 return value_zero (type, not_lval);
8960 if (!discrete_type_p (type))
8961 error (_("'VAL only defined on discrete types"));
8962 if (!integer_type_p (value_type (arg)))
8963 error (_("'VAL requires integral argument"));
8965 return val_atr (type, value_as_long (arg));
8971 /* True if TYPE appears to be an Ada character type.
8972 [At the moment, this is true only for Character and Wide_Character;
8973 It is a heuristic test that could stand improvement]. */
8976 ada_is_character_type (struct type *type)
8980 /* If the type code says it's a character, then assume it really is,
8981 and don't check any further. */
8982 if (type->code () == TYPE_CODE_CHAR)
8985 /* Otherwise, assume it's a character type iff it is a discrete type
8986 with a known character type name. */
8987 name = ada_type_name (type);
8988 return (name != NULL
8989 && (type->code () == TYPE_CODE_INT
8990 || type->code () == TYPE_CODE_RANGE)
8991 && (strcmp (name, "character") == 0
8992 || strcmp (name, "wide_character") == 0
8993 || strcmp (name, "wide_wide_character") == 0
8994 || strcmp (name, "unsigned char") == 0));
8997 /* True if TYPE appears to be an Ada string type. */
9000 ada_is_string_type (struct type *type)
9002 type = ada_check_typedef (type);
9004 && type->code () != TYPE_CODE_PTR
9005 && (ada_is_simple_array_type (type)
9006 || ada_is_array_descriptor_type (type))
9007 && ada_array_arity (type) == 1)
9009 struct type *elttype = ada_array_element_type (type, 1);
9011 return ada_is_character_type (elttype);
9017 /* The compiler sometimes provides a parallel XVS type for a given
9018 PAD type. Normally, it is safe to follow the PAD type directly,
9019 but older versions of the compiler have a bug that causes the offset
9020 of its "F" field to be wrong. Following that field in that case
9021 would lead to incorrect results, but this can be worked around
9022 by ignoring the PAD type and using the associated XVS type instead.
9024 Set to True if the debugger should trust the contents of PAD types.
9025 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9026 static bool trust_pad_over_xvs = true;
9028 /* True if TYPE is a struct type introduced by the compiler to force the
9029 alignment of a value. Such types have a single field with a
9030 distinctive name. */
9033 ada_is_aligner_type (struct type *type)
9035 type = ada_check_typedef (type);
9037 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9040 return (type->code () == TYPE_CODE_STRUCT
9041 && type->num_fields () == 1
9042 && strcmp (type->field (0).name (), "F") == 0);
9045 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9046 the parallel type. */
9049 ada_get_base_type (struct type *raw_type)
9051 struct type *real_type_namer;
9052 struct type *raw_real_type;
9054 if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9057 if (ada_is_aligner_type (raw_type))
9058 /* The encoding specifies that we should always use the aligner type.
9059 So, even if this aligner type has an associated XVS type, we should
9062 According to the compiler gurus, an XVS type parallel to an aligner
9063 type may exist because of a stabs limitation. In stabs, aligner
9064 types are empty because the field has a variable-sized type, and
9065 thus cannot actually be used as an aligner type. As a result,
9066 we need the associated parallel XVS type to decode the type.
9067 Since the policy in the compiler is to not change the internal
9068 representation based on the debugging info format, we sometimes
9069 end up having a redundant XVS type parallel to the aligner type. */
9072 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9073 if (real_type_namer == NULL
9074 || real_type_namer->code () != TYPE_CODE_STRUCT
9075 || real_type_namer->num_fields () != 1)
9078 if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9080 /* This is an older encoding form where the base type needs to be
9081 looked up by name. We prefer the newer encoding because it is
9083 raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9084 if (raw_real_type == NULL)
9087 return raw_real_type;
9090 /* The field in our XVS type is a reference to the base type. */
9091 return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
9094 /* The type of value designated by TYPE, with all aligners removed. */
9097 ada_aligned_type (struct type *type)
9099 if (ada_is_aligner_type (type))
9100 return ada_aligned_type (type->field (0).type ());
9102 return ada_get_base_type (type);
9106 /* The address of the aligned value in an object at address VALADDR
9107 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9110 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9112 if (ada_is_aligner_type (type))
9113 return ada_aligned_value_addr
9114 (type->field (0).type (),
9115 valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9122 /* The printed representation of an enumeration literal with encoded
9123 name NAME. The value is good to the next call of ada_enum_name. */
9125 ada_enum_name (const char *name)
9127 static std::string storage;
9130 /* First, unqualify the enumeration name:
9131 1. Search for the last '.' character. If we find one, then skip
9132 all the preceding characters, the unqualified name starts
9133 right after that dot.
9134 2. Otherwise, we may be debugging on a target where the compiler
9135 translates dots into "__". Search forward for double underscores,
9136 but stop searching when we hit an overloading suffix, which is
9137 of the form "__" followed by digits. */
9139 tmp = strrchr (name, '.');
9144 while ((tmp = strstr (name, "__")) != NULL)
9146 if (isdigit (tmp[2]))
9157 if (name[1] == 'U' || name[1] == 'W')
9160 if (name[1] == 'W' && name[2] == 'W')
9162 /* Also handle the QWW case. */
9165 if (sscanf (name + offset, "%x", &v) != 1)
9168 else if (((name[1] >= '0' && name[1] <= '9')
9169 || (name[1] >= 'a' && name[1] <= 'z'))
9172 storage = string_printf ("'%c'", name[1]);
9173 return storage.c_str ();
9178 if (isascii (v) && isprint (v))
9179 storage = string_printf ("'%c'", v);
9180 else if (name[1] == 'U')
9181 storage = string_printf ("'[\"%02x\"]'", v);
9182 else if (name[2] != 'W')
9183 storage = string_printf ("'[\"%04x\"]'", v);
9185 storage = string_printf ("'[\"%06x\"]'", v);
9187 return storage.c_str ();
9191 tmp = strstr (name, "__");
9193 tmp = strstr (name, "$");
9196 storage = std::string (name, tmp - name);
9197 return storage.c_str ();
9204 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9207 static struct value *
9208 unwrap_value (struct value *val)
9210 struct type *type = ada_check_typedef (value_type (val));
9212 if (ada_is_aligner_type (type))
9214 struct value *v = ada_value_struct_elt (val, "F", 0);
9215 struct type *val_type = ada_check_typedef (value_type (v));
9217 if (ada_type_name (val_type) == NULL)
9218 val_type->set_name (ada_type_name (type));
9220 return unwrap_value (v);
9224 struct type *raw_real_type =
9225 ada_check_typedef (ada_get_base_type (type));
9227 /* If there is no parallel XVS or XVE type, then the value is
9228 already unwrapped. Return it without further modification. */
9229 if ((type == raw_real_type)
9230 && ada_find_parallel_type (type, "___XVE") == NULL)
9234 coerce_unspec_val_to_type
9235 (val, ada_to_fixed_type (raw_real_type, 0,
9236 value_address (val),
9241 /* Given two array types T1 and T2, return nonzero iff both arrays
9242 contain the same number of elements. */
9245 ada_same_array_size_p (struct type *t1, struct type *t2)
9247 LONGEST lo1, hi1, lo2, hi2;
9249 /* Get the array bounds in order to verify that the size of
9250 the two arrays match. */
9251 if (!get_array_bounds (t1, &lo1, &hi1)
9252 || !get_array_bounds (t2, &lo2, &hi2))
9253 error (_("unable to determine array bounds"));
9255 /* To make things easier for size comparison, normalize a bit
9256 the case of empty arrays by making sure that the difference
9257 between upper bound and lower bound is always -1. */
9263 return (hi1 - lo1 == hi2 - lo2);
9266 /* Assuming that VAL is an array of integrals, and TYPE represents
9267 an array with the same number of elements, but with wider integral
9268 elements, return an array "casted" to TYPE. In practice, this
9269 means that the returned array is built by casting each element
9270 of the original array into TYPE's (wider) element type. */
9272 static struct value *
9273 ada_promote_array_of_integrals (struct type *type, struct value *val)
9275 struct type *elt_type = TYPE_TARGET_TYPE (type);
9279 /* Verify that both val and type are arrays of scalars, and
9280 that the size of val's elements is smaller than the size
9281 of type's element. */
9282 gdb_assert (type->code () == TYPE_CODE_ARRAY);
9283 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9284 gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9285 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9286 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9287 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9289 if (!get_array_bounds (type, &lo, &hi))
9290 error (_("unable to determine array bounds"));
9292 value *res = allocate_value (type);
9293 gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9295 /* Promote each array element. */
9296 for (i = 0; i < hi - lo + 1; i++)
9298 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9299 int elt_len = TYPE_LENGTH (elt_type);
9301 copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9307 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9308 return the converted value. */
9310 static struct value *
9311 coerce_for_assign (struct type *type, struct value *val)
9313 struct type *type2 = value_type (val);
9318 type2 = ada_check_typedef (type2);
9319 type = ada_check_typedef (type);
9321 if (type2->code () == TYPE_CODE_PTR
9322 && type->code () == TYPE_CODE_ARRAY)
9324 val = ada_value_ind (val);
9325 type2 = value_type (val);
9328 if (type2->code () == TYPE_CODE_ARRAY
9329 && type->code () == TYPE_CODE_ARRAY)
9331 if (!ada_same_array_size_p (type, type2))
9332 error (_("cannot assign arrays of different length"));
9334 if (is_integral_type (TYPE_TARGET_TYPE (type))
9335 && is_integral_type (TYPE_TARGET_TYPE (type2))
9336 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9337 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9339 /* Allow implicit promotion of the array elements to
9341 return ada_promote_array_of_integrals (type, val);
9344 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9345 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9346 error (_("Incompatible types in assignment"));
9347 deprecated_set_value_type (val, type);
9352 static struct value *
9353 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9356 struct type *type1, *type2;
9359 arg1 = coerce_ref (arg1);
9360 arg2 = coerce_ref (arg2);
9361 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9362 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9364 if (type1->code () != TYPE_CODE_INT
9365 || type2->code () != TYPE_CODE_INT)
9366 return value_binop (arg1, arg2, op);
9375 return value_binop (arg1, arg2, op);
9378 v2 = value_as_long (arg2);
9382 if (op == BINOP_MOD)
9384 else if (op == BINOP_DIV)
9388 gdb_assert (op == BINOP_REM);
9392 error (_("second operand of %s must not be zero."), name);
9395 if (type1->is_unsigned () || op == BINOP_MOD)
9396 return value_binop (arg1, arg2, op);
9398 v1 = value_as_long (arg1);
9403 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9404 v += v > 0 ? -1 : 1;
9412 /* Should not reach this point. */
9416 val = allocate_value (type1);
9417 store_unsigned_integer (value_contents_raw (val).data (),
9418 TYPE_LENGTH (value_type (val)),
9419 type_byte_order (type1), v);
9424 ada_value_equal (struct value *arg1, struct value *arg2)
9426 if (ada_is_direct_array_type (value_type (arg1))
9427 || ada_is_direct_array_type (value_type (arg2)))
9429 struct type *arg1_type, *arg2_type;
9431 /* Automatically dereference any array reference before
9432 we attempt to perform the comparison. */
9433 arg1 = ada_coerce_ref (arg1);
9434 arg2 = ada_coerce_ref (arg2);
9436 arg1 = ada_coerce_to_simple_array (arg1);
9437 arg2 = ada_coerce_to_simple_array (arg2);
9439 arg1_type = ada_check_typedef (value_type (arg1));
9440 arg2_type = ada_check_typedef (value_type (arg2));
9442 if (arg1_type->code () != TYPE_CODE_ARRAY
9443 || arg2_type->code () != TYPE_CODE_ARRAY)
9444 error (_("Attempt to compare array with non-array"));
9445 /* FIXME: The following works only for types whose
9446 representations use all bits (no padding or undefined bits)
9447 and do not have user-defined equality. */
9448 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9449 && memcmp (value_contents (arg1).data (),
9450 value_contents (arg2).data (),
9451 TYPE_LENGTH (arg1_type)) == 0);
9453 return value_equal (arg1, arg2);
9460 check_objfile (const std::unique_ptr<ada_component> &comp,
9461 struct objfile *objfile)
9463 return comp->uses_objfile (objfile);
9466 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9467 component of LHS (a simple array or a record). Does not modify the
9468 inferior's memory, nor does it modify LHS (unless LHS ==
9472 assign_component (struct value *container, struct value *lhs, LONGEST index,
9473 struct expression *exp, operation_up &arg)
9475 scoped_value_mark mark;
9478 struct type *lhs_type = check_typedef (value_type (lhs));
9480 if (lhs_type->code () == TYPE_CODE_ARRAY)
9482 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9483 struct value *index_val = value_from_longest (index_type, index);
9485 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9489 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9490 elt = ada_to_fixed_value (elt);
9493 ada_aggregate_operation *ag_op
9494 = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9495 if (ag_op != nullptr)
9496 ag_op->assign_aggregate (container, elt, exp);
9498 value_assign_to_component (container, elt,
9499 arg->evaluate (nullptr, exp,
9504 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9506 for (const auto &item : m_components)
9507 if (item->uses_objfile (objfile))
9513 ada_aggregate_component::dump (ui_file *stream, int depth)
9515 gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9516 for (const auto &item : m_components)
9517 item->dump (stream, depth + 1);
9521 ada_aggregate_component::assign (struct value *container,
9522 struct value *lhs, struct expression *exp,
9523 std::vector<LONGEST> &indices,
9524 LONGEST low, LONGEST high)
9526 for (auto &item : m_components)
9527 item->assign (container, lhs, exp, indices, low, high);
9530 /* See ada-exp.h. */
9533 ada_aggregate_operation::assign_aggregate (struct value *container,
9535 struct expression *exp)
9537 struct type *lhs_type;
9538 LONGEST low_index, high_index;
9540 container = ada_coerce_ref (container);
9541 if (ada_is_direct_array_type (value_type (container)))
9542 container = ada_coerce_to_simple_array (container);
9543 lhs = ada_coerce_ref (lhs);
9544 if (!deprecated_value_modifiable (lhs))
9545 error (_("Left operand of assignment is not a modifiable lvalue."));
9547 lhs_type = check_typedef (value_type (lhs));
9548 if (ada_is_direct_array_type (lhs_type))
9550 lhs = ada_coerce_to_simple_array (lhs);
9551 lhs_type = check_typedef (value_type (lhs));
9552 low_index = lhs_type->bounds ()->low.const_val ();
9553 high_index = lhs_type->bounds ()->high.const_val ();
9555 else if (lhs_type->code () == TYPE_CODE_STRUCT)
9558 high_index = num_visible_fields (lhs_type) - 1;
9561 error (_("Left-hand side must be array or record."));
9563 std::vector<LONGEST> indices (4);
9564 indices[0] = indices[1] = low_index - 1;
9565 indices[2] = indices[3] = high_index + 1;
9567 std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9568 low_index, high_index);
9574 ada_positional_component::uses_objfile (struct objfile *objfile)
9576 return m_op->uses_objfile (objfile);
9580 ada_positional_component::dump (ui_file *stream, int depth)
9582 gdb_printf (stream, _("%*sPositional, index = %d\n"),
9583 depth, "", m_index);
9584 m_op->dump (stream, depth + 1);
9587 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9588 construct, given that the positions are relative to lower bound
9589 LOW, where HIGH is the upper bound. Record the position in
9590 INDICES. CONTAINER is as for assign_aggregate. */
9592 ada_positional_component::assign (struct value *container,
9593 struct value *lhs, struct expression *exp,
9594 std::vector<LONGEST> &indices,
9595 LONGEST low, LONGEST high)
9597 LONGEST ind = m_index + low;
9599 if (ind - 1 == high)
9600 warning (_("Extra components in aggregate ignored."));
9603 add_component_interval (ind, ind, indices);
9604 assign_component (container, lhs, ind, exp, m_op);
9609 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9611 return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9615 ada_discrete_range_association::dump (ui_file *stream, int depth)
9617 gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9618 m_low->dump (stream, depth + 1);
9619 m_high->dump (stream, depth + 1);
9623 ada_discrete_range_association::assign (struct value *container,
9625 struct expression *exp,
9626 std::vector<LONGEST> &indices,
9627 LONGEST low, LONGEST high,
9630 LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9631 LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9633 if (lower <= upper && (lower < low || upper > high))
9634 error (_("Index in component association out of bounds."));
9636 add_component_interval (lower, upper, indices);
9637 while (lower <= upper)
9639 assign_component (container, lhs, lower, exp, op);
9645 ada_name_association::uses_objfile (struct objfile *objfile)
9647 return m_val->uses_objfile (objfile);
9651 ada_name_association::dump (ui_file *stream, int depth)
9653 gdb_printf (stream, _("%*sName:\n"), depth, "");
9654 m_val->dump (stream, depth + 1);
9658 ada_name_association::assign (struct value *container,
9660 struct expression *exp,
9661 std::vector<LONGEST> &indices,
9662 LONGEST low, LONGEST high,
9667 if (ada_is_direct_array_type (value_type (lhs)))
9668 index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9672 ada_string_operation *strop
9673 = dynamic_cast<ada_string_operation *> (m_val.get ());
9676 if (strop != nullptr)
9677 name = strop->get_name ();
9680 ada_var_value_operation *vvo
9681 = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9683 error (_("Invalid record component association."));
9684 name = vvo->get_symbol ()->natural_name ();
9688 if (! find_struct_field (name, value_type (lhs), 0,
9689 NULL, NULL, NULL, NULL, &index))
9690 error (_("Unknown component name: %s."), name);
9693 add_component_interval (index, index, indices);
9694 assign_component (container, lhs, index, exp, op);
9698 ada_choices_component::uses_objfile (struct objfile *objfile)
9700 if (m_op->uses_objfile (objfile))
9702 for (const auto &item : m_assocs)
9703 if (item->uses_objfile (objfile))
9709 ada_choices_component::dump (ui_file *stream, int depth)
9711 gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9712 m_op->dump (stream, depth + 1);
9713 for (const auto &item : m_assocs)
9714 item->dump (stream, depth + 1);
9717 /* Assign into the components of LHS indexed by the OP_CHOICES
9718 construct at *POS, updating *POS past the construct, given that
9719 the allowable indices are LOW..HIGH. Record the indices assigned
9720 to in INDICES. CONTAINER is as for assign_aggregate. */
9722 ada_choices_component::assign (struct value *container,
9723 struct value *lhs, struct expression *exp,
9724 std::vector<LONGEST> &indices,
9725 LONGEST low, LONGEST high)
9727 for (auto &item : m_assocs)
9728 item->assign (container, lhs, exp, indices, low, high, m_op);
9732 ada_others_component::uses_objfile (struct objfile *objfile)
9734 return m_op->uses_objfile (objfile);
9738 ada_others_component::dump (ui_file *stream, int depth)
9740 gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9741 m_op->dump (stream, depth + 1);
9744 /* Assign the value of the expression in the OP_OTHERS construct in
9745 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9746 have not been previously assigned. The index intervals already assigned
9747 are in INDICES. CONTAINER is as for assign_aggregate. */
9749 ada_others_component::assign (struct value *container,
9750 struct value *lhs, struct expression *exp,
9751 std::vector<LONGEST> &indices,
9752 LONGEST low, LONGEST high)
9754 int num_indices = indices.size ();
9755 for (int i = 0; i < num_indices - 2; i += 2)
9757 for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9758 assign_component (container, lhs, ind, exp, m_op);
9763 ada_assign_operation::evaluate (struct type *expect_type,
9764 struct expression *exp,
9767 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9769 ada_aggregate_operation *ag_op
9770 = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9771 if (ag_op != nullptr)
9773 if (noside != EVAL_NORMAL)
9776 arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9777 return ada_value_assign (arg1, arg1);
9779 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9780 except if the lhs of our assignment is a convenience variable.
9781 In the case of assigning to a convenience variable, the lhs
9782 should be exactly the result of the evaluation of the rhs. */
9783 struct type *type = value_type (arg1);
9784 if (VALUE_LVAL (arg1) == lval_internalvar)
9786 value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9787 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9789 if (VALUE_LVAL (arg1) == lval_internalvar)
9794 arg2 = coerce_for_assign (value_type (arg1), arg2);
9795 return ada_value_assign (arg1, arg2);
9798 } /* namespace expr */
9800 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9801 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9804 add_component_interval (LONGEST low, LONGEST high,
9805 std::vector<LONGEST> &indices)
9809 int size = indices.size ();
9810 for (i = 0; i < size; i += 2) {
9811 if (high >= indices[i] && low <= indices[i + 1])
9815 for (kh = i + 2; kh < size; kh += 2)
9816 if (high < indices[kh])
9818 if (low < indices[i])
9820 indices[i + 1] = indices[kh - 1];
9821 if (high > indices[i + 1])
9822 indices[i + 1] = high;
9823 memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9824 indices.resize (kh - i - 2);
9827 else if (high < indices[i])
9831 indices.resize (indices.size () + 2);
9832 for (j = indices.size () - 1; j >= i + 2; j -= 1)
9833 indices[j] = indices[j - 2];
9835 indices[i + 1] = high;
9838 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9841 static struct value *
9842 ada_value_cast (struct type *type, struct value *arg2)
9844 if (type == ada_check_typedef (value_type (arg2)))
9847 return value_cast (type, arg2);
9850 /* Evaluating Ada expressions, and printing their result.
9851 ------------------------------------------------------
9856 We usually evaluate an Ada expression in order to print its value.
9857 We also evaluate an expression in order to print its type, which
9858 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9859 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9860 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9861 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9864 Evaluating expressions is a little more complicated for Ada entities
9865 than it is for entities in languages such as C. The main reason for
9866 this is that Ada provides types whose definition might be dynamic.
9867 One example of such types is variant records. Or another example
9868 would be an array whose bounds can only be known at run time.
9870 The following description is a general guide as to what should be
9871 done (and what should NOT be done) in order to evaluate an expression
9872 involving such types, and when. This does not cover how the semantic
9873 information is encoded by GNAT as this is covered separatly. For the
9874 document used as the reference for the GNAT encoding, see exp_dbug.ads
9875 in the GNAT sources.
9877 Ideally, we should embed each part of this description next to its
9878 associated code. Unfortunately, the amount of code is so vast right
9879 now that it's hard to see whether the code handling a particular
9880 situation might be duplicated or not. One day, when the code is
9881 cleaned up, this guide might become redundant with the comments
9882 inserted in the code, and we might want to remove it.
9884 2. ``Fixing'' an Entity, the Simple Case:
9885 -----------------------------------------
9887 When evaluating Ada expressions, the tricky issue is that they may
9888 reference entities whose type contents and size are not statically
9889 known. Consider for instance a variant record:
9891 type Rec (Empty : Boolean := True) is record
9894 when False => Value : Integer;
9897 Yes : Rec := (Empty => False, Value => 1);
9898 No : Rec := (empty => True);
9900 The size and contents of that record depends on the value of the
9901 descriminant (Rec.Empty). At this point, neither the debugging
9902 information nor the associated type structure in GDB are able to
9903 express such dynamic types. So what the debugger does is to create
9904 "fixed" versions of the type that applies to the specific object.
9905 We also informally refer to this operation as "fixing" an object,
9906 which means creating its associated fixed type.
9908 Example: when printing the value of variable "Yes" above, its fixed
9909 type would look like this:
9916 On the other hand, if we printed the value of "No", its fixed type
9923 Things become a little more complicated when trying to fix an entity
9924 with a dynamic type that directly contains another dynamic type,
9925 such as an array of variant records, for instance. There are
9926 two possible cases: Arrays, and records.
9928 3. ``Fixing'' Arrays:
9929 ---------------------
9931 The type structure in GDB describes an array in terms of its bounds,
9932 and the type of its elements. By design, all elements in the array
9933 have the same type and we cannot represent an array of variant elements
9934 using the current type structure in GDB. When fixing an array,
9935 we cannot fix the array element, as we would potentially need one
9936 fixed type per element of the array. As a result, the best we can do
9937 when fixing an array is to produce an array whose bounds and size
9938 are correct (allowing us to read it from memory), but without having
9939 touched its element type. Fixing each element will be done later,
9940 when (if) necessary.
9942 Arrays are a little simpler to handle than records, because the same
9943 amount of memory is allocated for each element of the array, even if
9944 the amount of space actually used by each element differs from element
9945 to element. Consider for instance the following array of type Rec:
9947 type Rec_Array is array (1 .. 2) of Rec;
9949 The actual amount of memory occupied by each element might be different
9950 from element to element, depending on the value of their discriminant.
9951 But the amount of space reserved for each element in the array remains
9952 fixed regardless. So we simply need to compute that size using
9953 the debugging information available, from which we can then determine
9954 the array size (we multiply the number of elements of the array by
9955 the size of each element).
9957 The simplest case is when we have an array of a constrained element
9958 type. For instance, consider the following type declarations:
9960 type Bounded_String (Max_Size : Integer) is
9962 Buffer : String (1 .. Max_Size);
9964 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9966 In this case, the compiler describes the array as an array of
9967 variable-size elements (identified by its XVS suffix) for which
9968 the size can be read in the parallel XVZ variable.
9970 In the case of an array of an unconstrained element type, the compiler
9971 wraps the array element inside a private PAD type. This type should not
9972 be shown to the user, and must be "unwrap"'ed before printing. Note
9973 that we also use the adjective "aligner" in our code to designate
9974 these wrapper types.
9976 In some cases, the size allocated for each element is statically
9977 known. In that case, the PAD type already has the correct size,
9978 and the array element should remain unfixed.
9980 But there are cases when this size is not statically known.
9981 For instance, assuming that "Five" is an integer variable:
9983 type Dynamic is array (1 .. Five) of Integer;
9984 type Wrapper (Has_Length : Boolean := False) is record
9987 when True => Length : Integer;
9991 type Wrapper_Array is array (1 .. 2) of Wrapper;
9993 Hello : Wrapper_Array := (others => (Has_Length => True,
9994 Data => (others => 17),
9998 The debugging info would describe variable Hello as being an
9999 array of a PAD type. The size of that PAD type is not statically
10000 known, but can be determined using a parallel XVZ variable.
10001 In that case, a copy of the PAD type with the correct size should
10002 be used for the fixed array.
10004 3. ``Fixing'' record type objects:
10005 ----------------------------------
10007 Things are slightly different from arrays in the case of dynamic
10008 record types. In this case, in order to compute the associated
10009 fixed type, we need to determine the size and offset of each of
10010 its components. This, in turn, requires us to compute the fixed
10011 type of each of these components.
10013 Consider for instance the example:
10015 type Bounded_String (Max_Size : Natural) is record
10016 Str : String (1 .. Max_Size);
10019 My_String : Bounded_String (Max_Size => 10);
10021 In that case, the position of field "Length" depends on the size
10022 of field Str, which itself depends on the value of the Max_Size
10023 discriminant. In order to fix the type of variable My_String,
10024 we need to fix the type of field Str. Therefore, fixing a variant
10025 record requires us to fix each of its components.
10027 However, if a component does not have a dynamic size, the component
10028 should not be fixed. In particular, fields that use a PAD type
10029 should not fixed. Here is an example where this might happen
10030 (assuming type Rec above):
10032 type Container (Big : Boolean) is record
10036 when True => Another : Integer;
10037 when False => null;
10040 My_Container : Container := (Big => False,
10041 First => (Empty => True),
10044 In that example, the compiler creates a PAD type for component First,
10045 whose size is constant, and then positions the component After just
10046 right after it. The offset of component After is therefore constant
10049 The debugger computes the position of each field based on an algorithm
10050 that uses, among other things, the actual position and size of the field
10051 preceding it. Let's now imagine that the user is trying to print
10052 the value of My_Container. If the type fixing was recursive, we would
10053 end up computing the offset of field After based on the size of the
10054 fixed version of field First. And since in our example First has
10055 only one actual field, the size of the fixed type is actually smaller
10056 than the amount of space allocated to that field, and thus we would
10057 compute the wrong offset of field After.
10059 To make things more complicated, we need to watch out for dynamic
10060 components of variant records (identified by the ___XVL suffix in
10061 the component name). Even if the target type is a PAD type, the size
10062 of that type might not be statically known. So the PAD type needs
10063 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10064 we might end up with the wrong size for our component. This can be
10065 observed with the following type declarations:
10067 type Octal is new Integer range 0 .. 7;
10068 type Octal_Array is array (Positive range <>) of Octal;
10069 pragma Pack (Octal_Array);
10071 type Octal_Buffer (Size : Positive) is record
10072 Buffer : Octal_Array (1 .. Size);
10076 In that case, Buffer is a PAD type whose size is unset and needs
10077 to be computed by fixing the unwrapped type.
10079 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10080 ----------------------------------------------------------
10082 Lastly, when should the sub-elements of an entity that remained unfixed
10083 thus far, be actually fixed?
10085 The answer is: Only when referencing that element. For instance
10086 when selecting one component of a record, this specific component
10087 should be fixed at that point in time. Or when printing the value
10088 of a record, each component should be fixed before its value gets
10089 printed. Similarly for arrays, the element of the array should be
10090 fixed when printing each element of the array, or when extracting
10091 one element out of that array. On the other hand, fixing should
10092 not be performed on the elements when taking a slice of an array!
10094 Note that one of the side effects of miscomputing the offset and
10095 size of each field is that we end up also miscomputing the size
10096 of the containing type. This can have adverse results when computing
10097 the value of an entity. GDB fetches the value of an entity based
10098 on the size of its type, and thus a wrong size causes GDB to fetch
10099 the wrong amount of memory. In the case where the computed size is
10100 too small, GDB fetches too little data to print the value of our
10101 entity. Results in this case are unpredictable, as we usually read
10102 past the buffer containing the data =:-o. */
10104 /* A helper function for TERNOP_IN_RANGE. */
10107 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10108 enum noside noside,
10109 value *arg1, value *arg2, value *arg3)
10111 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10112 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10113 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10115 value_from_longest (type,
10116 (value_less (arg1, arg3)
10117 || value_equal (arg1, arg3))
10118 && (value_less (arg2, arg1)
10119 || value_equal (arg2, arg1)));
10122 /* A helper function for UNOP_NEG. */
10125 ada_unop_neg (struct type *expect_type,
10126 struct expression *exp,
10127 enum noside noside, enum exp_opcode op,
10128 struct value *arg1)
10130 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10131 return value_neg (arg1);
10134 /* A helper function for UNOP_IN_RANGE. */
10137 ada_unop_in_range (struct type *expect_type,
10138 struct expression *exp,
10139 enum noside noside, enum exp_opcode op,
10140 struct value *arg1, struct type *type)
10142 struct value *arg2, *arg3;
10143 switch (type->code ())
10146 lim_warning (_("Membership test incompletely implemented; "
10147 "always returns true"));
10148 type = language_bool_type (exp->language_defn, exp->gdbarch);
10149 return value_from_longest (type, (LONGEST) 1);
10151 case TYPE_CODE_RANGE:
10152 arg2 = value_from_longest (type,
10153 type->bounds ()->low.const_val ());
10154 arg3 = value_from_longest (type,
10155 type->bounds ()->high.const_val ());
10156 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10157 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10158 type = language_bool_type (exp->language_defn, exp->gdbarch);
10160 value_from_longest (type,
10161 (value_less (arg1, arg3)
10162 || value_equal (arg1, arg3))
10163 && (value_less (arg2, arg1)
10164 || value_equal (arg2, arg1)));
10168 /* A helper function for OP_ATR_TAG. */
10171 ada_atr_tag (struct type *expect_type,
10172 struct expression *exp,
10173 enum noside noside, enum exp_opcode op,
10174 struct value *arg1)
10176 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10177 return value_zero (ada_tag_type (arg1), not_lval);
10179 return ada_value_tag (arg1);
10182 /* A helper function for OP_ATR_SIZE. */
10185 ada_atr_size (struct type *expect_type,
10186 struct expression *exp,
10187 enum noside noside, enum exp_opcode op,
10188 struct value *arg1)
10190 struct type *type = value_type (arg1);
10192 /* If the argument is a reference, then dereference its type, since
10193 the user is really asking for the size of the actual object,
10194 not the size of the pointer. */
10195 if (type->code () == TYPE_CODE_REF)
10196 type = TYPE_TARGET_TYPE (type);
10198 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10199 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10201 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10202 TARGET_CHAR_BIT * TYPE_LENGTH (type));
10205 /* A helper function for UNOP_ABS. */
10208 ada_abs (struct type *expect_type,
10209 struct expression *exp,
10210 enum noside noside, enum exp_opcode op,
10211 struct value *arg1)
10213 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10214 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10215 return value_neg (arg1);
10220 /* A helper function for BINOP_MUL. */
10223 ada_mult_binop (struct type *expect_type,
10224 struct expression *exp,
10225 enum noside noside, enum exp_opcode op,
10226 struct value *arg1, struct value *arg2)
10228 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10230 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10231 return value_zero (value_type (arg1), not_lval);
10235 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10236 return ada_value_binop (arg1, arg2, op);
10240 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10243 ada_equal_binop (struct type *expect_type,
10244 struct expression *exp,
10245 enum noside noside, enum exp_opcode op,
10246 struct value *arg1, struct value *arg2)
10249 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10253 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10254 tem = ada_value_equal (arg1, arg2);
10256 if (op == BINOP_NOTEQUAL)
10258 struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10259 return value_from_longest (type, (LONGEST) tem);
10262 /* A helper function for TERNOP_SLICE. */
10265 ada_ternop_slice (struct expression *exp,
10266 enum noside noside,
10267 struct value *array, struct value *low_bound_val,
10268 struct value *high_bound_val)
10271 LONGEST high_bound;
10273 low_bound_val = coerce_ref (low_bound_val);
10274 high_bound_val = coerce_ref (high_bound_val);
10275 low_bound = value_as_long (low_bound_val);
10276 high_bound = value_as_long (high_bound_val);
10278 /* If this is a reference to an aligner type, then remove all
10280 if (value_type (array)->code () == TYPE_CODE_REF
10281 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10282 value_type (array)->set_target_type
10283 (ada_aligned_type (TYPE_TARGET_TYPE (value_type (array))));
10285 if (ada_is_any_packed_array_type (value_type (array)))
10286 error (_("cannot slice a packed array"));
10288 /* If this is a reference to an array or an array lvalue,
10289 convert to a pointer. */
10290 if (value_type (array)->code () == TYPE_CODE_REF
10291 || (value_type (array)->code () == TYPE_CODE_ARRAY
10292 && VALUE_LVAL (array) == lval_memory))
10293 array = value_addr (array);
10295 if (noside == EVAL_AVOID_SIDE_EFFECTS
10296 && ada_is_array_descriptor_type (ada_check_typedef
10297 (value_type (array))))
10298 return empty_array (ada_type_of_array (array, 0), low_bound,
10301 array = ada_coerce_to_simple_array_ptr (array);
10303 /* If we have more than one level of pointer indirection,
10304 dereference the value until we get only one level. */
10305 while (value_type (array)->code () == TYPE_CODE_PTR
10306 && (TYPE_TARGET_TYPE (value_type (array))->code ()
10308 array = value_ind (array);
10310 /* Make sure we really do have an array type before going further,
10311 to avoid a SEGV when trying to get the index type or the target
10312 type later down the road if the debug info generated by
10313 the compiler is incorrect or incomplete. */
10314 if (!ada_is_simple_array_type (value_type (array)))
10315 error (_("cannot take slice of non-array"));
10317 if (ada_check_typedef (value_type (array))->code ()
10320 struct type *type0 = ada_check_typedef (value_type (array));
10322 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10323 return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10326 struct type *arr_type0 =
10327 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10329 return ada_value_slice_from_ptr (array, arr_type0,
10330 longest_to_int (low_bound),
10331 longest_to_int (high_bound));
10334 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10336 else if (high_bound < low_bound)
10337 return empty_array (value_type (array), low_bound, high_bound);
10339 return ada_value_slice (array, longest_to_int (low_bound),
10340 longest_to_int (high_bound));
10343 /* A helper function for BINOP_IN_BOUNDS. */
10346 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10347 struct value *arg1, struct value *arg2, int n)
10349 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10351 struct type *type = language_bool_type (exp->language_defn,
10353 return value_zero (type, not_lval);
10356 struct type *type = ada_index_type (value_type (arg2), n, "range");
10358 type = value_type (arg1);
10360 value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10361 arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10363 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10364 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10365 type = language_bool_type (exp->language_defn, exp->gdbarch);
10366 return value_from_longest (type,
10367 (value_less (arg1, arg3)
10368 || value_equal (arg1, arg3))
10369 && (value_less (arg2, arg1)
10370 || value_equal (arg2, arg1)));
10373 /* A helper function for some attribute operations. */
10376 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10377 struct value *arg1, struct type *type_arg, int tem)
10379 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10381 if (type_arg == NULL)
10382 type_arg = value_type (arg1);
10384 if (ada_is_constrained_packed_array_type (type_arg))
10385 type_arg = decode_constrained_packed_array_type (type_arg);
10387 if (!discrete_type_p (type_arg))
10391 default: /* Should never happen. */
10392 error (_("unexpected attribute encountered"));
10395 type_arg = ada_index_type (type_arg, tem,
10396 ada_attribute_name (op));
10398 case OP_ATR_LENGTH:
10399 type_arg = builtin_type (exp->gdbarch)->builtin_int;
10404 return value_zero (type_arg, not_lval);
10406 else if (type_arg == NULL)
10408 arg1 = ada_coerce_ref (arg1);
10410 if (ada_is_constrained_packed_array_type (value_type (arg1)))
10411 arg1 = ada_coerce_to_simple_array (arg1);
10414 if (op == OP_ATR_LENGTH)
10415 type = builtin_type (exp->gdbarch)->builtin_int;
10418 type = ada_index_type (value_type (arg1), tem,
10419 ada_attribute_name (op));
10421 type = builtin_type (exp->gdbarch)->builtin_int;
10426 default: /* Should never happen. */
10427 error (_("unexpected attribute encountered"));
10429 return value_from_longest
10430 (type, ada_array_bound (arg1, tem, 0));
10432 return value_from_longest
10433 (type, ada_array_bound (arg1, tem, 1));
10434 case OP_ATR_LENGTH:
10435 return value_from_longest
10436 (type, ada_array_length (arg1, tem));
10439 else if (discrete_type_p (type_arg))
10441 struct type *range_type;
10442 const char *name = ada_type_name (type_arg);
10445 if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10446 range_type = to_fixed_range_type (type_arg, NULL);
10447 if (range_type == NULL)
10448 range_type = type_arg;
10452 error (_("unexpected attribute encountered"));
10454 return value_from_longest
10455 (range_type, ada_discrete_type_low_bound (range_type));
10457 return value_from_longest
10458 (range_type, ada_discrete_type_high_bound (range_type));
10459 case OP_ATR_LENGTH:
10460 error (_("the 'length attribute applies only to array types"));
10463 else if (type_arg->code () == TYPE_CODE_FLT)
10464 error (_("unimplemented type attribute"));
10469 if (ada_is_constrained_packed_array_type (type_arg))
10470 type_arg = decode_constrained_packed_array_type (type_arg);
10473 if (op == OP_ATR_LENGTH)
10474 type = builtin_type (exp->gdbarch)->builtin_int;
10477 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10479 type = builtin_type (exp->gdbarch)->builtin_int;
10485 error (_("unexpected attribute encountered"));
10487 low = ada_array_bound_from_type (type_arg, tem, 0);
10488 return value_from_longest (type, low);
10490 high = ada_array_bound_from_type (type_arg, tem, 1);
10491 return value_from_longest (type, high);
10492 case OP_ATR_LENGTH:
10493 low = ada_array_bound_from_type (type_arg, tem, 0);
10494 high = ada_array_bound_from_type (type_arg, tem, 1);
10495 return value_from_longest (type, high - low + 1);
10500 /* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
10503 ada_binop_minmax (struct type *expect_type,
10504 struct expression *exp,
10505 enum noside noside, enum exp_opcode op,
10506 struct value *arg1, struct value *arg2)
10508 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10509 return value_zero (value_type (arg1), not_lval);
10512 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10513 return value_binop (arg1, arg2, op);
10517 /* A helper function for BINOP_EXP. */
10520 ada_binop_exp (struct type *expect_type,
10521 struct expression *exp,
10522 enum noside noside, enum exp_opcode op,
10523 struct value *arg1, struct value *arg2)
10525 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10526 return value_zero (value_type (arg1), not_lval);
10529 /* For integer exponentiation operations,
10530 only promote the first argument. */
10531 if (is_integral_type (value_type (arg2)))
10532 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10534 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10536 return value_binop (arg1, arg2, op);
10543 /* See ada-exp.h. */
10546 ada_resolvable::replace (operation_up &&owner,
10547 struct expression *exp,
10548 bool deprocedure_p,
10549 bool parse_completion,
10550 innermost_block_tracker *tracker,
10551 struct type *context_type)
10553 if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10554 return (make_operation<ada_funcall_operation>
10555 (std::move (owner),
10556 std::vector<operation_up> ()));
10557 return std::move (owner);
10560 /* Convert the character literal whose value would be VAL to the
10561 appropriate value of type TYPE, if there is a translation.
10562 Otherwise return VAL. Hence, in an enumeration type ('A', 'B'),
10563 the literal 'A' (VAL == 65), returns 0. */
10566 convert_char_literal (struct type *type, LONGEST val)
10573 type = check_typedef (type);
10574 if (type->code () != TYPE_CODE_ENUM)
10577 if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10578 xsnprintf (name, sizeof (name), "Q%c", (int) val);
10579 else if (val >= 0 && val < 256)
10580 xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10581 else if (val >= 0 && val < 0x10000)
10582 xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10584 xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10585 size_t len = strlen (name);
10586 for (f = 0; f < type->num_fields (); f += 1)
10588 /* Check the suffix because an enum constant in a package will
10589 have a name like "pkg__QUxx". This is safe enough because we
10590 already have the correct type, and because mangling means
10591 there can't be clashes. */
10592 const char *ename = type->field (f).name ();
10593 size_t elen = strlen (ename);
10595 if (elen >= len && strcmp (name, ename + elen - len) == 0)
10596 return type->field (f).loc_enumval ();
10602 ada_char_operation::evaluate (struct type *expect_type,
10603 struct expression *exp,
10604 enum noside noside)
10606 value *result = long_const_operation::evaluate (expect_type, exp, noside);
10607 if (expect_type != nullptr)
10608 result = ada_value_cast (expect_type, result);
10612 /* See ada-exp.h. */
10615 ada_char_operation::replace (operation_up &&owner,
10616 struct expression *exp,
10617 bool deprocedure_p,
10618 bool parse_completion,
10619 innermost_block_tracker *tracker,
10620 struct type *context_type)
10622 operation_up result = std::move (owner);
10624 if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10626 gdb_assert (result.get () == this);
10627 std::get<0> (m_storage) = context_type;
10628 std::get<1> (m_storage)
10629 = convert_char_literal (context_type, std::get<1> (m_storage));
10636 ada_wrapped_operation::evaluate (struct type *expect_type,
10637 struct expression *exp,
10638 enum noside noside)
10640 value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10641 if (noside == EVAL_NORMAL)
10642 result = unwrap_value (result);
10644 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10645 then we need to perform the conversion manually, because
10646 evaluate_subexp_standard doesn't do it. This conversion is
10647 necessary in Ada because the different kinds of float/fixed
10648 types in Ada have different representations.
10650 Similarly, we need to perform the conversion from OP_LONG
10652 if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10653 result = ada_value_cast (expect_type, result);
10659 ada_string_operation::evaluate (struct type *expect_type,
10660 struct expression *exp,
10661 enum noside noside)
10663 struct type *char_type;
10664 if (expect_type != nullptr && ada_is_string_type (expect_type))
10665 char_type = ada_array_element_type (expect_type, 1);
10667 char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10669 const std::string &str = std::get<0> (m_storage);
10670 const char *encoding;
10671 switch (TYPE_LENGTH (char_type))
10675 /* Simply copy over the data -- this isn't perhaps strictly
10676 correct according to the encodings, but it is gdb's
10677 historical behavior. */
10678 struct type *stringtype
10679 = lookup_array_range_type (char_type, 1, str.length ());
10680 struct value *val = allocate_value (stringtype);
10681 memcpy (value_contents_raw (val).data (), str.c_str (),
10687 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10688 encoding = "UTF-16BE";
10690 encoding = "UTF-16LE";
10694 if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10695 encoding = "UTF-32BE";
10697 encoding = "UTF-32LE";
10701 error (_("unexpected character type size %s"),
10702 pulongest (TYPE_LENGTH (char_type)));
10705 auto_obstack converted;
10706 convert_between_encodings (host_charset (), encoding,
10707 (const gdb_byte *) str.c_str (),
10709 &converted, translit_none);
10711 struct type *stringtype
10712 = lookup_array_range_type (char_type, 1,
10713 obstack_object_size (&converted)
10714 / TYPE_LENGTH (char_type));
10715 struct value *val = allocate_value (stringtype);
10716 memcpy (value_contents_raw (val).data (),
10717 obstack_base (&converted),
10718 obstack_object_size (&converted));
10723 ada_concat_operation::evaluate (struct type *expect_type,
10724 struct expression *exp,
10725 enum noside noside)
10727 /* If one side is a literal, evaluate the other side first so that
10728 the expected type can be set properly. */
10729 const operation_up &lhs_expr = std::get<0> (m_storage);
10730 const operation_up &rhs_expr = std::get<1> (m_storage);
10733 if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10735 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10736 lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10738 else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10740 rhs = rhs_expr->evaluate (nullptr, exp, noside);
10741 struct type *rhs_type = check_typedef (value_type (rhs));
10742 struct type *elt_type = nullptr;
10743 if (rhs_type->code () == TYPE_CODE_ARRAY)
10744 elt_type = TYPE_TARGET_TYPE (rhs_type);
10745 lhs = lhs_expr->evaluate (elt_type, exp, noside);
10747 else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10749 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10750 rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10752 else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10754 lhs = lhs_expr->evaluate (nullptr, exp, noside);
10755 struct type *lhs_type = check_typedef (value_type (lhs));
10756 struct type *elt_type = nullptr;
10757 if (lhs_type->code () == TYPE_CODE_ARRAY)
10758 elt_type = TYPE_TARGET_TYPE (lhs_type);
10759 rhs = rhs_expr->evaluate (elt_type, exp, noside);
10762 return concat_operation::evaluate (expect_type, exp, noside);
10764 return value_concat (lhs, rhs);
10768 ada_qual_operation::evaluate (struct type *expect_type,
10769 struct expression *exp,
10770 enum noside noside)
10772 struct type *type = std::get<1> (m_storage);
10773 return std::get<0> (m_storage)->evaluate (type, exp, noside);
10777 ada_ternop_range_operation::evaluate (struct type *expect_type,
10778 struct expression *exp,
10779 enum noside noside)
10781 value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10782 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10783 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10784 return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10788 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10789 struct expression *exp,
10790 enum noside noside)
10792 value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10793 value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10795 auto do_op = [=] (LONGEST x, LONGEST y)
10797 if (std::get<0> (m_storage) == BINOP_ADD)
10802 if (value_type (arg1)->code () == TYPE_CODE_PTR)
10803 return (value_from_longest
10804 (value_type (arg1),
10805 do_op (value_as_long (arg1), value_as_long (arg2))));
10806 if (value_type (arg2)->code () == TYPE_CODE_PTR)
10807 return (value_from_longest
10808 (value_type (arg2),
10809 do_op (value_as_long (arg1), value_as_long (arg2))));
10810 /* Preserve the original type for use by the range case below.
10811 We cannot cast the result to a reference type, so if ARG1 is
10812 a reference type, find its underlying type. */
10813 struct type *type = value_type (arg1);
10814 while (type->code () == TYPE_CODE_REF)
10815 type = TYPE_TARGET_TYPE (type);
10816 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10817 arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10818 /* We need to special-case the result with a range.
10819 This is done for the benefit of "ptype". gdb's Ada support
10820 historically used the LHS to set the result type here, so
10821 preserve this behavior. */
10822 if (type->code () == TYPE_CODE_RANGE)
10823 arg1 = value_cast (type, arg1);
10828 ada_unop_atr_operation::evaluate (struct type *expect_type,
10829 struct expression *exp,
10830 enum noside noside)
10832 struct type *type_arg = nullptr;
10833 value *val = nullptr;
10835 if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10837 value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10838 EVAL_AVOID_SIDE_EFFECTS);
10839 type_arg = value_type (tem);
10842 val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10844 return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10845 val, type_arg, std::get<2> (m_storage));
10849 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10850 struct expression *exp,
10851 enum noside noside)
10853 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10854 return value_zero (expect_type, not_lval);
10856 const bound_minimal_symbol &b = std::get<0> (m_storage);
10857 value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10859 val = ada_value_cast (expect_type, val);
10861 /* Follow the Ada language semantics that do not allow taking
10862 an address of the result of a cast (view conversion in Ada). */
10863 if (VALUE_LVAL (val) == lval_memory)
10865 if (value_lazy (val))
10866 value_fetch_lazy (val);
10867 VALUE_LVAL (val) = not_lval;
10873 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10874 struct expression *exp,
10875 enum noside noside)
10877 value *val = evaluate_var_value (noside,
10878 std::get<0> (m_storage).block,
10879 std::get<0> (m_storage).symbol);
10881 val = ada_value_cast (expect_type, val);
10883 /* Follow the Ada language semantics that do not allow taking
10884 an address of the result of a cast (view conversion in Ada). */
10885 if (VALUE_LVAL (val) == lval_memory)
10887 if (value_lazy (val))
10888 value_fetch_lazy (val);
10889 VALUE_LVAL (val) = not_lval;
10895 ada_var_value_operation::evaluate (struct type *expect_type,
10896 struct expression *exp,
10897 enum noside noside)
10899 symbol *sym = std::get<0> (m_storage).symbol;
10901 if (sym->domain () == UNDEF_DOMAIN)
10902 /* Only encountered when an unresolved symbol occurs in a
10903 context other than a function call, in which case, it is
10905 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10906 sym->print_name ());
10908 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10910 struct type *type = static_unwrap_type (sym->type ());
10911 /* Check to see if this is a tagged type. We also need to handle
10912 the case where the type is a reference to a tagged type, but
10913 we have to be careful to exclude pointers to tagged types.
10914 The latter should be shown as usual (as a pointer), whereas
10915 a reference should mostly be transparent to the user. */
10916 if (ada_is_tagged_type (type, 0)
10917 || (type->code () == TYPE_CODE_REF
10918 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10920 /* Tagged types are a little special in the fact that the real
10921 type is dynamic and can only be determined by inspecting the
10922 object's tag. This means that we need to get the object's
10923 value first (EVAL_NORMAL) and then extract the actual object
10926 Note that we cannot skip the final step where we extract
10927 the object type from its tag, because the EVAL_NORMAL phase
10928 results in dynamic components being resolved into fixed ones.
10929 This can cause problems when trying to print the type
10930 description of tagged types whose parent has a dynamic size:
10931 We use the type name of the "_parent" component in order
10932 to print the name of the ancestor type in the type description.
10933 If that component had a dynamic size, the resolution into
10934 a fixed type would result in the loss of that type name,
10935 thus preventing us from printing the name of the ancestor
10936 type in the type description. */
10937 value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10939 if (type->code () != TYPE_CODE_REF)
10941 struct type *actual_type;
10943 actual_type = type_from_tag (ada_value_tag (arg1));
10944 if (actual_type == NULL)
10945 /* If, for some reason, we were unable to determine
10946 the actual type from the tag, then use the static
10947 approximation that we just computed as a fallback.
10948 This can happen if the debugging information is
10949 incomplete, for instance. */
10950 actual_type = type;
10951 return value_zero (actual_type, not_lval);
10955 /* In the case of a ref, ada_coerce_ref takes care
10956 of determining the actual type. But the evaluation
10957 should return a ref as it should be valid to ask
10958 for its address; so rebuild a ref after coerce. */
10959 arg1 = ada_coerce_ref (arg1);
10960 return value_ref (arg1, TYPE_CODE_REF);
10964 /* Records and unions for which GNAT encodings have been
10965 generated need to be statically fixed as well.
10966 Otherwise, non-static fixing produces a type where
10967 all dynamic properties are removed, which prevents "ptype"
10968 from being able to completely describe the type.
10969 For instance, a case statement in a variant record would be
10970 replaced by the relevant components based on the actual
10971 value of the discriminants. */
10972 if ((type->code () == TYPE_CODE_STRUCT
10973 && dynamic_template_type (type) != NULL)
10974 || (type->code () == TYPE_CODE_UNION
10975 && ada_find_parallel_type (type, "___XVU") != NULL))
10976 return value_zero (to_static_fixed_type (type), not_lval);
10979 value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10980 return ada_to_fixed_value (arg1);
10984 ada_var_value_operation::resolve (struct expression *exp,
10985 bool deprocedure_p,
10986 bool parse_completion,
10987 innermost_block_tracker *tracker,
10988 struct type *context_type)
10990 symbol *sym = std::get<0> (m_storage).symbol;
10991 if (sym->domain () == UNDEF_DOMAIN)
10993 block_symbol resolved
10994 = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10995 context_type, parse_completion,
10996 deprocedure_p, tracker);
10997 std::get<0> (m_storage) = resolved;
11001 && (std::get<0> (m_storage).symbol->type ()->code ()
11002 == TYPE_CODE_FUNC))
11009 ada_atr_val_operation::evaluate (struct type *expect_type,
11010 struct expression *exp,
11011 enum noside noside)
11013 value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11014 return ada_val_atr (noside, std::get<0> (m_storage), arg);
11018 ada_unop_ind_operation::evaluate (struct type *expect_type,
11019 struct expression *exp,
11020 enum noside noside)
11022 value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11024 struct type *type = ada_check_typedef (value_type (arg1));
11025 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11027 if (ada_is_array_descriptor_type (type))
11028 /* GDB allows dereferencing GNAT array descriptors. */
11030 struct type *arrType = ada_type_of_array (arg1, 0);
11032 if (arrType == NULL)
11033 error (_("Attempt to dereference null array pointer."));
11034 return value_at_lazy (arrType, 0);
11036 else if (type->code () == TYPE_CODE_PTR
11037 || type->code () == TYPE_CODE_REF
11038 /* In C you can dereference an array to get the 1st elt. */
11039 || type->code () == TYPE_CODE_ARRAY)
11041 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11042 only be determined by inspecting the object's tag.
11043 This means that we need to evaluate completely the
11044 expression in order to get its type. */
11046 if ((type->code () == TYPE_CODE_REF
11047 || type->code () == TYPE_CODE_PTR)
11048 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11050 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11052 type = value_type (ada_value_ind (arg1));
11056 type = to_static_fixed_type
11058 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11060 return value_zero (type, lval_memory);
11062 else if (type->code () == TYPE_CODE_INT)
11064 /* GDB allows dereferencing an int. */
11065 if (expect_type == NULL)
11066 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11071 to_static_fixed_type (ada_aligned_type (expect_type));
11072 return value_zero (expect_type, lval_memory);
11076 error (_("Attempt to take contents of a non-pointer value."));
11078 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11079 type = ada_check_typedef (value_type (arg1));
11081 if (type->code () == TYPE_CODE_INT)
11082 /* GDB allows dereferencing an int. If we were given
11083 the expect_type, then use that as the target type.
11084 Otherwise, assume that the target type is an int. */
11086 if (expect_type != NULL)
11087 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11090 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11091 (CORE_ADDR) value_as_address (arg1));
11094 if (ada_is_array_descriptor_type (type))
11095 /* GDB allows dereferencing GNAT array descriptors. */
11096 return ada_coerce_to_simple_array (arg1);
11098 return ada_value_ind (arg1);
11102 ada_structop_operation::evaluate (struct type *expect_type,
11103 struct expression *exp,
11104 enum noside noside)
11106 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11107 const char *str = std::get<1> (m_storage).c_str ();
11108 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11111 struct type *type1 = value_type (arg1);
11113 if (ada_is_tagged_type (type1, 1))
11115 type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11117 /* If the field is not found, check if it exists in the
11118 extension of this object's type. This means that we
11119 need to evaluate completely the expression. */
11123 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11125 arg1 = ada_value_struct_elt (arg1, str, 0);
11126 arg1 = unwrap_value (arg1);
11127 type = value_type (ada_to_fixed_value (arg1));
11131 type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11133 return value_zero (ada_aligned_type (type), lval_memory);
11137 arg1 = ada_value_struct_elt (arg1, str, 0);
11138 arg1 = unwrap_value (arg1);
11139 return ada_to_fixed_value (arg1);
11144 ada_funcall_operation::evaluate (struct type *expect_type,
11145 struct expression *exp,
11146 enum noside noside)
11148 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11149 int nargs = args_up.size ();
11150 std::vector<value *> argvec (nargs);
11151 operation_up &callee_op = std::get<0> (m_storage);
11153 ada_var_value_operation *avv
11154 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11156 && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11157 error (_("Unexpected unresolved symbol, %s, during evaluation"),
11158 avv->get_symbol ()->print_name ());
11160 value *callee = callee_op->evaluate (nullptr, exp, noside);
11161 for (int i = 0; i < args_up.size (); ++i)
11162 argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11164 if (ada_is_constrained_packed_array_type
11165 (desc_base_type (value_type (callee))))
11166 callee = ada_coerce_to_simple_array (callee);
11167 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11168 && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11169 /* This is a packed array that has already been fixed, and
11170 therefore already coerced to a simple array. Nothing further
11173 else if (value_type (callee)->code () == TYPE_CODE_REF)
11175 /* Make sure we dereference references so that all the code below
11176 feels like it's really handling the referenced value. Wrapping
11177 types (for alignment) may be there, so make sure we strip them as
11179 callee = ada_to_fixed_value (coerce_ref (callee));
11181 else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11182 && VALUE_LVAL (callee) == lval_memory)
11183 callee = value_addr (callee);
11185 struct type *type = ada_check_typedef (value_type (callee));
11187 /* Ada allows us to implicitly dereference arrays when subscripting
11188 them. So, if this is an array typedef (encoding use for array
11189 access types encoded as fat pointers), strip it now. */
11190 if (type->code () == TYPE_CODE_TYPEDEF)
11191 type = ada_typedef_target_type (type);
11193 if (type->code () == TYPE_CODE_PTR)
11195 switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
11197 case TYPE_CODE_FUNC:
11198 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11200 case TYPE_CODE_ARRAY:
11202 case TYPE_CODE_STRUCT:
11203 if (noside != EVAL_AVOID_SIDE_EFFECTS)
11204 callee = ada_value_ind (callee);
11205 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11208 error (_("cannot subscript or call something of type `%s'"),
11209 ada_type_name (value_type (callee)));
11214 switch (type->code ())
11216 case TYPE_CODE_FUNC:
11217 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11219 if (TYPE_TARGET_TYPE (type) == NULL)
11220 error_call_unknown_return_type (NULL);
11221 return allocate_value (TYPE_TARGET_TYPE (type));
11223 return call_function_by_hand (callee, NULL, argvec);
11224 case TYPE_CODE_INTERNAL_FUNCTION:
11225 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11226 /* We don't know anything about what the internal
11227 function might return, but we have to return
11229 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11232 return call_internal_function (exp->gdbarch, exp->language_defn,
11236 case TYPE_CODE_STRUCT:
11240 arity = ada_array_arity (type);
11241 type = ada_array_element_type (type, nargs);
11243 error (_("cannot subscript or call a record"));
11244 if (arity != nargs)
11245 error (_("wrong number of subscripts; expecting %d"), arity);
11246 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11247 return value_zero (ada_aligned_type (type), lval_memory);
11249 unwrap_value (ada_value_subscript
11250 (callee, nargs, argvec.data ()));
11252 case TYPE_CODE_ARRAY:
11253 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11255 type = ada_array_element_type (type, nargs);
11257 error (_("element type of array unknown"));
11259 return value_zero (ada_aligned_type (type), lval_memory);
11262 unwrap_value (ada_value_subscript
11263 (ada_coerce_to_simple_array (callee),
11264 nargs, argvec.data ()));
11265 case TYPE_CODE_PTR: /* Pointer to array */
11266 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11268 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11269 type = ada_array_element_type (type, nargs);
11271 error (_("element type of array unknown"));
11273 return value_zero (ada_aligned_type (type), lval_memory);
11276 unwrap_value (ada_value_ptr_subscript (callee, nargs,
11280 error (_("Attempt to index or call something other than an "
11281 "array or function"));
11286 ada_funcall_operation::resolve (struct expression *exp,
11287 bool deprocedure_p,
11288 bool parse_completion,
11289 innermost_block_tracker *tracker,
11290 struct type *context_type)
11292 operation_up &callee_op = std::get<0> (m_storage);
11294 ada_var_value_operation *avv
11295 = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11296 if (avv == nullptr)
11299 symbol *sym = avv->get_symbol ();
11300 if (sym->domain () != UNDEF_DOMAIN)
11303 const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11304 int nargs = args_up.size ();
11305 std::vector<value *> argvec (nargs);
11307 for (int i = 0; i < args_up.size (); ++i)
11308 argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11310 const block *block = avv->get_block ();
11311 block_symbol resolved
11312 = ada_resolve_funcall (sym, block,
11313 context_type, parse_completion,
11314 nargs, argvec.data (),
11317 std::get<0> (m_storage)
11318 = make_operation<ada_var_value_operation> (resolved);
11323 ada_ternop_slice_operation::resolve (struct expression *exp,
11324 bool deprocedure_p,
11325 bool parse_completion,
11326 innermost_block_tracker *tracker,
11327 struct type *context_type)
11329 /* Historically this check was done during resolution, so we
11330 continue that here. */
11331 value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11332 EVAL_AVOID_SIDE_EFFECTS);
11333 if (ada_is_any_packed_array_type (value_type (v)))
11334 error (_("cannot slice a packed array"));
11342 /* Return non-zero iff TYPE represents a System.Address type. */
11345 ada_is_system_address_type (struct type *type)
11347 return (type->name () && strcmp (type->name (), "system__address") == 0);
11354 /* Scan STR beginning at position K for a discriminant name, and
11355 return the value of that discriminant field of DVAL in *PX. If
11356 PNEW_K is not null, put the position of the character beyond the
11357 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11358 not alter *PX and *PNEW_K if unsuccessful. */
11361 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11364 static std::string storage;
11365 const char *pstart, *pend, *bound;
11366 struct value *bound_val;
11368 if (dval == NULL || str == NULL || str[k] == '\0')
11372 pend = strstr (pstart, "__");
11376 k += strlen (bound);
11380 int len = pend - pstart;
11382 /* Strip __ and beyond. */
11383 storage = std::string (pstart, len);
11384 bound = storage.c_str ();
11388 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11389 if (bound_val == NULL)
11392 *px = value_as_long (bound_val);
11393 if (pnew_k != NULL)
11398 /* Value of variable named NAME. Only exact matches are considered.
11399 If no such variable found, then if ERR_MSG is null, returns 0, and
11400 otherwise causes an error with message ERR_MSG. */
11402 static struct value *
11403 get_var_value (const char *name, const char *err_msg)
11405 std::string quoted_name = add_angle_brackets (name);
11407 lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11409 std::vector<struct block_symbol> syms
11410 = ada_lookup_symbol_list_worker (lookup_name,
11411 get_selected_block (0),
11414 if (syms.size () != 1)
11416 if (err_msg == NULL)
11419 error (("%s"), err_msg);
11422 return value_of_variable (syms[0].symbol, syms[0].block);
11425 /* Value of integer variable named NAME in the current environment.
11426 If no such variable is found, returns false. Otherwise, sets VALUE
11427 to the variable's value and returns true. */
11430 get_int_var_value (const char *name, LONGEST &value)
11432 struct value *var_val = get_var_value (name, 0);
11437 value = value_as_long (var_val);
11442 /* Return a range type whose base type is that of the range type named
11443 NAME in the current environment, and whose bounds are calculated
11444 from NAME according to the GNAT range encoding conventions.
11445 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11446 corresponding range type from debug information; fall back to using it
11447 if symbol lookup fails. If a new type must be created, allocate it
11448 like ORIG_TYPE was. The bounds information, in general, is encoded
11449 in NAME, the base type given in the named range type. */
11451 static struct type *
11452 to_fixed_range_type (struct type *raw_type, struct value *dval)
11455 struct type *base_type;
11456 const char *subtype_info;
11458 gdb_assert (raw_type != NULL);
11459 gdb_assert (raw_type->name () != NULL);
11461 if (raw_type->code () == TYPE_CODE_RANGE)
11462 base_type = TYPE_TARGET_TYPE (raw_type);
11464 base_type = raw_type;
11466 name = raw_type->name ();
11467 subtype_info = strstr (name, "___XD");
11468 if (subtype_info == NULL)
11470 LONGEST L = ada_discrete_type_low_bound (raw_type);
11471 LONGEST U = ada_discrete_type_high_bound (raw_type);
11473 if (L < INT_MIN || U > INT_MAX)
11476 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11481 int prefix_len = subtype_info - name;
11484 const char *bounds_str;
11488 bounds_str = strchr (subtype_info, '_');
11491 if (*subtype_info == 'L')
11493 if (!ada_scan_number (bounds_str, n, &L, &n)
11494 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11496 if (bounds_str[n] == '_')
11498 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11504 std::string name_buf = std::string (name, prefix_len) + "___L";
11505 if (!get_int_var_value (name_buf.c_str (), L))
11507 lim_warning (_("Unknown lower bound, using 1."));
11512 if (*subtype_info == 'U')
11514 if (!ada_scan_number (bounds_str, n, &U, &n)
11515 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11520 std::string name_buf = std::string (name, prefix_len) + "___U";
11521 if (!get_int_var_value (name_buf.c_str (), U))
11523 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11528 type = create_static_range_type (alloc_type_copy (raw_type),
11530 /* create_static_range_type alters the resulting type's length
11531 to match the size of the base_type, which is not what we want.
11532 Set it back to the original range type's length. */
11533 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11534 type->set_name (name);
11539 /* True iff NAME is the name of a range type. */
11542 ada_is_range_type_name (const char *name)
11544 return (name != NULL && strstr (name, "___XD"));
11548 /* Modular types */
11550 /* True iff TYPE is an Ada modular type. */
11553 ada_is_modular_type (struct type *type)
11555 struct type *subranged_type = get_base_type (type);
11557 return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11558 && subranged_type->code () == TYPE_CODE_INT
11559 && subranged_type->is_unsigned ());
11562 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11565 ada_modulus (struct type *type)
11567 const dynamic_prop &high = type->bounds ()->high;
11569 if (high.kind () == PROP_CONST)
11570 return (ULONGEST) high.const_val () + 1;
11572 /* If TYPE is unresolved, the high bound might be a location list. Return
11573 0, for lack of a better value to return. */
11578 /* Ada exception catchpoint support:
11579 ---------------------------------
11581 We support 3 kinds of exception catchpoints:
11582 . catchpoints on Ada exceptions
11583 . catchpoints on unhandled Ada exceptions
11584 . catchpoints on failed assertions
11586 Exceptions raised during failed assertions, or unhandled exceptions
11587 could perfectly be caught with the general catchpoint on Ada exceptions.
11588 However, we can easily differentiate these two special cases, and having
11589 the option to distinguish these two cases from the rest can be useful
11590 to zero-in on certain situations.
11592 Exception catchpoints are a specialized form of breakpoint,
11593 since they rely on inserting breakpoints inside known routines
11594 of the GNAT runtime. The implementation therefore uses a standard
11595 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11598 Support in the runtime for exception catchpoints have been changed
11599 a few times already, and these changes affect the implementation
11600 of these catchpoints. In order to be able to support several
11601 variants of the runtime, we use a sniffer that will determine
11602 the runtime variant used by the program being debugged. */
11604 /* Ada's standard exceptions.
11606 The Ada 83 standard also defined Numeric_Error. But there so many
11607 situations where it was unclear from the Ada 83 Reference Manual
11608 (RM) whether Constraint_Error or Numeric_Error should be raised,
11609 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11610 Interpretation saying that anytime the RM says that Numeric_Error
11611 should be raised, the implementation may raise Constraint_Error.
11612 Ada 95 went one step further and pretty much removed Numeric_Error
11613 from the list of standard exceptions (it made it a renaming of
11614 Constraint_Error, to help preserve compatibility when compiling
11615 an Ada83 compiler). As such, we do not include Numeric_Error from
11616 this list of standard exceptions. */
11618 static const char * const standard_exc[] = {
11619 "constraint_error",
11625 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11627 /* A structure that describes how to support exception catchpoints
11628 for a given executable. */
11630 struct exception_support_info
11632 /* The name of the symbol to break on in order to insert
11633 a catchpoint on exceptions. */
11634 const char *catch_exception_sym;
11636 /* The name of the symbol to break on in order to insert
11637 a catchpoint on unhandled exceptions. */
11638 const char *catch_exception_unhandled_sym;
11640 /* The name of the symbol to break on in order to insert
11641 a catchpoint on failed assertions. */
11642 const char *catch_assert_sym;
11644 /* The name of the symbol to break on in order to insert
11645 a catchpoint on exception handling. */
11646 const char *catch_handlers_sym;
11648 /* Assuming that the inferior just triggered an unhandled exception
11649 catchpoint, this function is responsible for returning the address
11650 in inferior memory where the name of that exception is stored.
11651 Return zero if the address could not be computed. */
11652 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11655 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11656 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11658 /* The following exception support info structure describes how to
11659 implement exception catchpoints with the latest version of the
11660 Ada runtime (as of 2019-08-??). */
11662 static const struct exception_support_info default_exception_support_info =
11664 "__gnat_debug_raise_exception", /* catch_exception_sym */
11665 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11666 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11667 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11668 ada_unhandled_exception_name_addr
11671 /* The following exception support info structure describes how to
11672 implement exception catchpoints with an earlier version of the
11673 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11675 static const struct exception_support_info exception_support_info_v0 =
11677 "__gnat_debug_raise_exception", /* catch_exception_sym */
11678 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11679 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11680 "__gnat_begin_handler", /* catch_handlers_sym */
11681 ada_unhandled_exception_name_addr
11684 /* The following exception support info structure describes how to
11685 implement exception catchpoints with a slightly older version
11686 of the Ada runtime. */
11688 static const struct exception_support_info exception_support_info_fallback =
11690 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11691 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11692 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11693 "__gnat_begin_handler", /* catch_handlers_sym */
11694 ada_unhandled_exception_name_addr_from_raise
11697 /* Return nonzero if we can detect the exception support routines
11698 described in EINFO.
11700 This function errors out if an abnormal situation is detected
11701 (for instance, if we find the exception support routines, but
11702 that support is found to be incomplete). */
11705 ada_has_this_exception_support (const struct exception_support_info *einfo)
11707 struct symbol *sym;
11709 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11710 that should be compiled with debugging information. As a result, we
11711 expect to find that symbol in the symtabs. */
11713 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11716 /* Perhaps we did not find our symbol because the Ada runtime was
11717 compiled without debugging info, or simply stripped of it.
11718 It happens on some GNU/Linux distributions for instance, where
11719 users have to install a separate debug package in order to get
11720 the runtime's debugging info. In that situation, let the user
11721 know why we cannot insert an Ada exception catchpoint.
11723 Note: Just for the purpose of inserting our Ada exception
11724 catchpoint, we could rely purely on the associated minimal symbol.
11725 But we would be operating in degraded mode anyway, since we are
11726 still lacking the debugging info needed later on to extract
11727 the name of the exception being raised (this name is printed in
11728 the catchpoint message, and is also used when trying to catch
11729 a specific exception). We do not handle this case for now. */
11730 struct bound_minimal_symbol msym
11731 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11733 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11734 error (_("Your Ada runtime appears to be missing some debugging "
11735 "information.\nCannot insert Ada exception catchpoint "
11736 "in this configuration."));
11741 /* Make sure that the symbol we found corresponds to a function. */
11743 if (sym->aclass () != LOC_BLOCK)
11745 error (_("Symbol \"%s\" is not a function (class = %d)"),
11746 sym->linkage_name (), sym->aclass ());
11750 sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11753 struct bound_minimal_symbol msym
11754 = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11756 if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11757 error (_("Your Ada runtime appears to be missing some debugging "
11758 "information.\nCannot insert Ada exception catchpoint "
11759 "in this configuration."));
11764 /* Make sure that the symbol we found corresponds to a function. */
11766 if (sym->aclass () != LOC_BLOCK)
11768 error (_("Symbol \"%s\" is not a function (class = %d)"),
11769 sym->linkage_name (), sym->aclass ());
11776 /* Inspect the Ada runtime and determine which exception info structure
11777 should be used to provide support for exception catchpoints.
11779 This function will always set the per-inferior exception_info,
11780 or raise an error. */
11783 ada_exception_support_info_sniffer (void)
11785 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11787 /* If the exception info is already known, then no need to recompute it. */
11788 if (data->exception_info != NULL)
11791 /* Check the latest (default) exception support info. */
11792 if (ada_has_this_exception_support (&default_exception_support_info))
11794 data->exception_info = &default_exception_support_info;
11798 /* Try the v0 exception suport info. */
11799 if (ada_has_this_exception_support (&exception_support_info_v0))
11801 data->exception_info = &exception_support_info_v0;
11805 /* Try our fallback exception suport info. */
11806 if (ada_has_this_exception_support (&exception_support_info_fallback))
11808 data->exception_info = &exception_support_info_fallback;
11812 /* Sometimes, it is normal for us to not be able to find the routine
11813 we are looking for. This happens when the program is linked with
11814 the shared version of the GNAT runtime, and the program has not been
11815 started yet. Inform the user of these two possible causes if
11818 if (ada_update_initial_language (language_unknown) != language_ada)
11819 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11821 /* If the symbol does not exist, then check that the program is
11822 already started, to make sure that shared libraries have been
11823 loaded. If it is not started, this may mean that the symbol is
11824 in a shared library. */
11826 if (inferior_ptid.pid () == 0)
11827 error (_("Unable to insert catchpoint. Try to start the program first."));
11829 /* At this point, we know that we are debugging an Ada program and
11830 that the inferior has been started, but we still are not able to
11831 find the run-time symbols. That can mean that we are in
11832 configurable run time mode, or that a-except as been optimized
11833 out by the linker... In any case, at this point it is not worth
11834 supporting this feature. */
11836 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11839 /* True iff FRAME is very likely to be that of a function that is
11840 part of the runtime system. This is all very heuristic, but is
11841 intended to be used as advice as to what frames are uninteresting
11845 is_known_support_routine (struct frame_info *frame)
11847 enum language func_lang;
11849 const char *fullname;
11851 /* If this code does not have any debugging information (no symtab),
11852 This cannot be any user code. */
11854 symtab_and_line sal = find_frame_sal (frame);
11855 if (sal.symtab == NULL)
11858 /* If there is a symtab, but the associated source file cannot be
11859 located, then assume this is not user code: Selecting a frame
11860 for which we cannot display the code would not be very helpful
11861 for the user. This should also take care of case such as VxWorks
11862 where the kernel has some debugging info provided for a few units. */
11864 fullname = symtab_to_fullname (sal.symtab);
11865 if (access (fullname, R_OK) != 0)
11868 /* Check the unit filename against the Ada runtime file naming.
11869 We also check the name of the objfile against the name of some
11870 known system libraries that sometimes come with debugging info
11873 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11875 re_comp (known_runtime_file_name_patterns[i]);
11876 if (re_exec (lbasename (sal.symtab->filename)))
11878 if (sal.symtab->compunit ()->objfile () != NULL
11879 && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11883 /* Check whether the function is a GNAT-generated entity. */
11885 gdb::unique_xmalloc_ptr<char> func_name
11886 = find_frame_funname (frame, &func_lang, NULL);
11887 if (func_name == NULL)
11890 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11892 re_comp (known_auxiliary_function_name_patterns[i]);
11893 if (re_exec (func_name.get ()))
11900 /* Find the first frame that contains debugging information and that is not
11901 part of the Ada run-time, starting from FI and moving upward. */
11904 ada_find_printable_frame (struct frame_info *fi)
11906 for (; fi != NULL; fi = get_prev_frame (fi))
11908 if (!is_known_support_routine (fi))
11917 /* Assuming that the inferior just triggered an unhandled exception
11918 catchpoint, return the address in inferior memory where the name
11919 of the exception is stored.
11921 Return zero if the address could not be computed. */
11924 ada_unhandled_exception_name_addr (void)
11926 return parse_and_eval_address ("e.full_name");
11929 /* Same as ada_unhandled_exception_name_addr, except that this function
11930 should be used when the inferior uses an older version of the runtime,
11931 where the exception name needs to be extracted from a specific frame
11932 several frames up in the callstack. */
11935 ada_unhandled_exception_name_addr_from_raise (void)
11938 struct frame_info *fi;
11939 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11941 /* To determine the name of this exception, we need to select
11942 the frame corresponding to RAISE_SYM_NAME. This frame is
11943 at least 3 levels up, so we simply skip the first 3 frames
11944 without checking the name of their associated function. */
11945 fi = get_current_frame ();
11946 for (frame_level = 0; frame_level < 3; frame_level += 1)
11948 fi = get_prev_frame (fi);
11952 enum language func_lang;
11954 gdb::unique_xmalloc_ptr<char> func_name
11955 = find_frame_funname (fi, &func_lang, NULL);
11956 if (func_name != NULL)
11958 if (strcmp (func_name.get (),
11959 data->exception_info->catch_exception_sym) == 0)
11960 break; /* We found the frame we were looking for... */
11962 fi = get_prev_frame (fi);
11969 return parse_and_eval_address ("id.full_name");
11972 /* Assuming the inferior just triggered an Ada exception catchpoint
11973 (of any type), return the address in inferior memory where the name
11974 of the exception is stored, if applicable.
11976 Assumes the selected frame is the current frame.
11978 Return zero if the address could not be computed, or if not relevant. */
11981 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11983 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11987 case ada_catch_exception:
11988 return (parse_and_eval_address ("e.full_name"));
11991 case ada_catch_exception_unhandled:
11992 return data->exception_info->unhandled_exception_name_addr ();
11995 case ada_catch_handlers:
11996 return 0; /* The runtimes does not provide access to the exception
12000 case ada_catch_assert:
12001 return 0; /* Exception name is not relevant in this case. */
12005 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12009 return 0; /* Should never be reached. */
12012 /* Assuming the inferior is stopped at an exception catchpoint,
12013 return the message which was associated to the exception, if
12014 available. Return NULL if the message could not be retrieved.
12016 Note: The exception message can be associated to an exception
12017 either through the use of the Raise_Exception function, or
12018 more simply (Ada 2005 and later), via:
12020 raise Exception_Name with "exception message";
12024 static gdb::unique_xmalloc_ptr<char>
12025 ada_exception_message_1 (void)
12027 struct value *e_msg_val;
12030 /* For runtimes that support this feature, the exception message
12031 is passed as an unbounded string argument called "message". */
12032 e_msg_val = parse_and_eval ("message");
12033 if (e_msg_val == NULL)
12034 return NULL; /* Exception message not supported. */
12036 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12037 gdb_assert (e_msg_val != NULL);
12038 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12040 /* If the message string is empty, then treat it as if there was
12041 no exception message. */
12042 if (e_msg_len <= 0)
12045 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12046 read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12048 e_msg.get ()[e_msg_len] = '\0';
12053 /* Same as ada_exception_message_1, except that all exceptions are
12054 contained here (returning NULL instead). */
12056 static gdb::unique_xmalloc_ptr<char>
12057 ada_exception_message (void)
12059 gdb::unique_xmalloc_ptr<char> e_msg;
12063 e_msg = ada_exception_message_1 ();
12065 catch (const gdb_exception_error &e)
12067 e_msg.reset (nullptr);
12073 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12074 any error that ada_exception_name_addr_1 might cause to be thrown.
12075 When an error is intercepted, a warning with the error message is printed,
12076 and zero is returned. */
12079 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12081 CORE_ADDR result = 0;
12085 result = ada_exception_name_addr_1 (ex);
12088 catch (const gdb_exception_error &e)
12090 warning (_("failed to get exception name: %s"), e.what ());
12097 static std::string ada_exception_catchpoint_cond_string
12098 (const char *excep_string,
12099 enum ada_exception_catchpoint_kind ex);
12101 /* Ada catchpoints.
12103 In the case of catchpoints on Ada exceptions, the catchpoint will
12104 stop the target on every exception the program throws. When a user
12105 specifies the name of a specific exception, we translate this
12106 request into a condition expression (in text form), and then parse
12107 it into an expression stored in each of the catchpoint's locations.
12108 We then use this condition to check whether the exception that was
12109 raised is the one the user is interested in. If not, then the
12110 target is resumed again. We store the name of the requested
12111 exception, in order to be able to re-set the condition expression
12112 when symbols change. */
12114 /* An instance of this type is used to represent an Ada catchpoint. */
12116 struct ada_catchpoint : public code_breakpoint
12118 ada_catchpoint (struct gdbarch *gdbarch_,
12119 enum ada_exception_catchpoint_kind kind,
12120 struct symtab_and_line sal,
12121 const char *addr_string_,
12125 : code_breakpoint (gdbarch_, bp_catchpoint),
12128 add_location (sal);
12130 /* Unlike most code_breakpoint types, Ada catchpoints are
12131 pspace-specific. */
12132 gdb_assert (sal.pspace != nullptr);
12133 this->pspace = sal.pspace;
12137 struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12139 loc_gdbarch = gdbarch;
12141 describe_other_breakpoints (loc_gdbarch,
12142 sal.pspace, sal.pc, sal.section, -1);
12143 /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12144 version for exception catchpoints, because two catchpoints
12145 used for different exception names will use the same address.
12146 In this case, a "breakpoint ... also set at..." warning is
12147 unproductive. Besides, the warning phrasing is also a bit
12148 inappropriate, we should use the word catchpoint, and tell
12149 the user what type of catchpoint it is. The above is good
12150 enough for now, though. */
12153 enable_state = enabled ? bp_enabled : bp_disabled;
12154 disposition = tempflag ? disp_del : disp_donttouch;
12155 locspec = string_to_location_spec (&addr_string_,
12156 language_def (language_ada));
12157 language = language_ada;
12160 struct bp_location *allocate_location () override;
12161 void re_set () override;
12162 void check_status (struct bpstat *bs) override;
12163 enum print_stop_action print_it (const bpstat *bs) const override;
12164 bool print_one (bp_location **) const override;
12165 void print_mention () const override;
12166 void print_recreate (struct ui_file *fp) const override;
12168 /* The name of the specific exception the user specified. */
12169 std::string excep_string;
12171 /* What kind of catchpoint this is. */
12172 enum ada_exception_catchpoint_kind m_kind;
12175 /* An instance of this type is used to represent an Ada catchpoint
12176 breakpoint location. */
12178 class ada_catchpoint_location : public bp_location
12181 explicit ada_catchpoint_location (ada_catchpoint *owner)
12182 : bp_location (owner, bp_loc_software_breakpoint)
12185 /* The condition that checks whether the exception that was raised
12186 is the specific exception the user specified on catchpoint
12188 expression_up excep_cond_expr;
12191 /* Parse the exception condition string in the context of each of the
12192 catchpoint's locations, and store them for later evaluation. */
12195 create_excep_cond_exprs (struct ada_catchpoint *c,
12196 enum ada_exception_catchpoint_kind ex)
12198 /* Nothing to do if there's no specific exception to catch. */
12199 if (c->excep_string.empty ())
12202 /* Same if there are no locations... */
12203 if (c->loc == NULL)
12206 /* Compute the condition expression in text form, from the specific
12207 expection we want to catch. */
12208 std::string cond_string
12209 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12211 /* Iterate over all the catchpoint's locations, and parse an
12212 expression for each. */
12213 for (bp_location *bl : c->locations ())
12215 struct ada_catchpoint_location *ada_loc
12216 = (struct ada_catchpoint_location *) bl;
12219 if (!bl->shlib_disabled)
12223 s = cond_string.c_str ();
12226 exp = parse_exp_1 (&s, bl->address,
12227 block_for_pc (bl->address),
12230 catch (const gdb_exception_error &e)
12232 warning (_("failed to reevaluate internal exception condition "
12233 "for catchpoint %d: %s"),
12234 c->number, e.what ());
12238 ada_loc->excep_cond_expr = std::move (exp);
12242 /* Implement the ALLOCATE_LOCATION method in the structure for all
12243 exception catchpoint kinds. */
12245 struct bp_location *
12246 ada_catchpoint::allocate_location ()
12248 return new ada_catchpoint_location (this);
12251 /* Implement the RE_SET method in the structure for all exception
12252 catchpoint kinds. */
12255 ada_catchpoint::re_set ()
12257 /* Call the base class's method. This updates the catchpoint's
12259 this->code_breakpoint::re_set ();
12261 /* Reparse the exception conditional expressions. One for each
12263 create_excep_cond_exprs (this, m_kind);
12266 /* Returns true if we should stop for this breakpoint hit. If the
12267 user specified a specific exception, we only want to cause a stop
12268 if the program thrown that exception. */
12271 should_stop_exception (const struct bp_location *bl)
12273 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12274 const struct ada_catchpoint_location *ada_loc
12275 = (const struct ada_catchpoint_location *) bl;
12278 struct internalvar *var = lookup_internalvar ("_ada_exception");
12279 if (c->m_kind == ada_catch_assert)
12280 clear_internalvar (var);
12287 if (c->m_kind == ada_catch_handlers)
12288 expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12289 ".all.occurrence.id");
12293 struct value *exc = parse_and_eval (expr);
12294 set_internalvar (var, exc);
12296 catch (const gdb_exception_error &ex)
12298 clear_internalvar (var);
12302 /* With no specific exception, should always stop. */
12303 if (c->excep_string.empty ())
12306 if (ada_loc->excep_cond_expr == NULL)
12308 /* We will have a NULL expression if back when we were creating
12309 the expressions, this location's had failed to parse. */
12316 struct value *mark;
12318 mark = value_mark ();
12319 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12320 value_free_to_mark (mark);
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 (__FILE__, __LINE__, _("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 (__FILE__, __LINE__, _("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 (__FILE__, __LINE__, _("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 (__FILE__, __LINE__,
12680 _("unexpected catchpoint kind (%d)"), ex);
12684 /* Return the condition that will be used to match the current exception
12685 being raised with the exception that the user wants to catch. This
12686 assumes that this condition is used when the inferior just triggered
12687 an exception catchpoint.
12688 EX: the type of catchpoints used for catching Ada exceptions. */
12691 ada_exception_catchpoint_cond_string (const char *excep_string,
12692 enum ada_exception_catchpoint_kind ex)
12694 bool is_standard_exc = false;
12695 std::string result;
12697 if (ex == ada_catch_handlers)
12699 /* For exception handlers catchpoints, the condition string does
12700 not use the same parameter as for the other exceptions. */
12701 result = ("long_integer (GNAT_GCC_exception_Access"
12702 "(gcc_exception).all.occurrence.id)");
12705 result = "long_integer (e)";
12707 /* The standard exceptions are a special case. They are defined in
12708 runtime units that have been compiled without debugging info; if
12709 EXCEP_STRING is the not-fully-qualified name of a standard
12710 exception (e.g. "constraint_error") then, during the evaluation
12711 of the condition expression, the symbol lookup on this name would
12712 *not* return this standard exception. The catchpoint condition
12713 may then be set only on user-defined exceptions which have the
12714 same not-fully-qualified name (e.g. my_package.constraint_error).
12716 To avoid this unexcepted behavior, these standard exceptions are
12717 systematically prefixed by "standard". This means that "catch
12718 exception constraint_error" is rewritten into "catch exception
12719 standard.constraint_error".
12721 If an exception named constraint_error is defined in another package of
12722 the inferior program, then the only way to specify this exception as a
12723 breakpoint condition is to use its fully-qualified named:
12724 e.g. my_package.constraint_error. */
12726 for (const char *name : standard_exc)
12728 if (strcmp (name, excep_string) == 0)
12730 is_standard_exc = true;
12737 if (is_standard_exc)
12738 string_appendf (result, "long_integer (&standard.%s)", excep_string);
12740 string_appendf (result, "long_integer (&%s)", excep_string);
12745 /* Return the symtab_and_line that should be used to insert an exception
12746 catchpoint of the TYPE kind.
12748 ADDR_STRING returns the name of the function where the real
12749 breakpoint that implements the catchpoints is set, depending on the
12750 type of catchpoint we need to create. */
12752 static struct symtab_and_line
12753 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12754 std::string *addr_string)
12756 const char *sym_name;
12757 struct symbol *sym;
12759 /* First, find out which exception support info to use. */
12760 ada_exception_support_info_sniffer ();
12762 /* Then lookup the function on which we will break in order to catch
12763 the Ada exceptions requested by the user. */
12764 sym_name = ada_exception_sym_name (ex);
12765 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12768 error (_("Catchpoint symbol not found: %s"), sym_name);
12770 if (sym->aclass () != LOC_BLOCK)
12771 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12773 /* Set ADDR_STRING. */
12774 *addr_string = sym_name;
12776 return find_function_start_sal (sym, 1);
12779 /* Create an Ada exception catchpoint.
12781 EX_KIND is the kind of exception catchpoint to be created.
12783 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12784 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12785 of the exception to which this catchpoint applies.
12787 COND_STRING, if not empty, is the catchpoint condition.
12789 TEMPFLAG, if nonzero, means that the underlying breakpoint
12790 should be temporary.
12792 FROM_TTY is the usual argument passed to all commands implementations. */
12795 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12796 enum ada_exception_catchpoint_kind ex_kind,
12797 const std::string &excep_string,
12798 const std::string &cond_string,
12803 std::string addr_string;
12804 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12806 std::unique_ptr<ada_catchpoint> c
12807 (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12808 tempflag, disabled, from_tty));
12809 c->excep_string = excep_string;
12810 create_excep_cond_exprs (c.get (), ex_kind);
12811 if (!cond_string.empty ())
12812 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12813 install_breakpoint (0, std::move (c), 1);
12816 /* Implement the "catch exception" command. */
12819 catch_ada_exception_command (const char *arg_entry, int from_tty,
12820 struct cmd_list_element *command)
12822 const char *arg = arg_entry;
12823 struct gdbarch *gdbarch = get_current_arch ();
12825 enum ada_exception_catchpoint_kind ex_kind;
12826 std::string excep_string;
12827 std::string cond_string;
12829 tempflag = command->context () == CATCH_TEMPORARY;
12833 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12835 create_ada_exception_catchpoint (gdbarch, ex_kind,
12836 excep_string, cond_string,
12837 tempflag, 1 /* enabled */,
12841 /* Implement the "catch handlers" command. */
12844 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12845 struct cmd_list_element *command)
12847 const char *arg = arg_entry;
12848 struct gdbarch *gdbarch = get_current_arch ();
12850 enum ada_exception_catchpoint_kind ex_kind;
12851 std::string excep_string;
12852 std::string cond_string;
12854 tempflag = command->context () == CATCH_TEMPORARY;
12858 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12860 create_ada_exception_catchpoint (gdbarch, ex_kind,
12861 excep_string, cond_string,
12862 tempflag, 1 /* enabled */,
12866 /* Completion function for the Ada "catch" commands. */
12869 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12870 const char *text, const char *word)
12872 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12874 for (const ada_exc_info &info : exceptions)
12876 if (startswith (info.name, word))
12877 tracker.add_completion (make_unique_xstrdup (info.name));
12881 /* Split the arguments specified in a "catch assert" command.
12883 ARGS contains the command's arguments (or the empty string if
12884 no arguments were passed).
12886 If ARGS contains a condition, set COND_STRING to that condition
12887 (the memory needs to be deallocated after use). */
12890 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12892 args = skip_spaces (args);
12894 /* Check whether a condition was provided. */
12895 if (startswith (args, "if")
12896 && (isspace (args[2]) || args[2] == '\0'))
12899 args = skip_spaces (args);
12900 if (args[0] == '\0')
12901 error (_("condition missing after `if' keyword"));
12902 cond_string.assign (args);
12905 /* Otherwise, there should be no other argument at the end of
12907 else if (args[0] != '\0')
12908 error (_("Junk at end of arguments."));
12911 /* Implement the "catch assert" command. */
12914 catch_assert_command (const char *arg_entry, int from_tty,
12915 struct cmd_list_element *command)
12917 const char *arg = arg_entry;
12918 struct gdbarch *gdbarch = get_current_arch ();
12920 std::string cond_string;
12922 tempflag = command->context () == CATCH_TEMPORARY;
12926 catch_ada_assert_command_split (arg, cond_string);
12927 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12929 tempflag, 1 /* enabled */,
12933 /* Return non-zero if the symbol SYM is an Ada exception object. */
12936 ada_is_exception_sym (struct symbol *sym)
12938 const char *type_name = sym->type ()->name ();
12940 return (sym->aclass () != LOC_TYPEDEF
12941 && sym->aclass () != LOC_BLOCK
12942 && sym->aclass () != LOC_CONST
12943 && sym->aclass () != LOC_UNRESOLVED
12944 && type_name != NULL && strcmp (type_name, "exception") == 0);
12947 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12948 Ada exception object. This matches all exceptions except the ones
12949 defined by the Ada language. */
12952 ada_is_non_standard_exception_sym (struct symbol *sym)
12954 if (!ada_is_exception_sym (sym))
12957 for (const char *name : standard_exc)
12958 if (strcmp (sym->linkage_name (), name) == 0)
12959 return 0; /* A standard exception. */
12961 /* Numeric_Error is also a standard exception, so exclude it.
12962 See the STANDARD_EXC description for more details as to why
12963 this exception is not listed in that array. */
12964 if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12970 /* A helper function for std::sort, comparing two struct ada_exc_info
12973 The comparison is determined first by exception name, and then
12974 by exception address. */
12977 ada_exc_info::operator< (const ada_exc_info &other) const
12981 result = strcmp (name, other.name);
12984 if (result == 0 && addr < other.addr)
12990 ada_exc_info::operator== (const ada_exc_info &other) const
12992 return addr == other.addr && strcmp (name, other.name) == 0;
12995 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12996 routine, but keeping the first SKIP elements untouched.
12998 All duplicates are also removed. */
13001 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13004 std::sort (exceptions->begin () + skip, exceptions->end ());
13005 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13006 exceptions->end ());
13009 /* Add all exceptions defined by the Ada standard whose name match
13010 a regular expression.
13012 If PREG is not NULL, then this regexp_t object is used to
13013 perform the symbol name matching. Otherwise, no name-based
13014 filtering is performed.
13016 EXCEPTIONS is a vector of exceptions to which matching exceptions
13020 ada_add_standard_exceptions (compiled_regex *preg,
13021 std::vector<ada_exc_info> *exceptions)
13023 for (const char *name : standard_exc)
13025 if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13027 struct bound_minimal_symbol msymbol
13028 = ada_lookup_simple_minsym (name);
13030 if (msymbol.minsym != NULL)
13032 struct ada_exc_info info
13033 = {name, msymbol.value_address ()};
13035 exceptions->push_back (info);
13041 /* Add all Ada exceptions defined locally and accessible from the given
13044 If PREG is not NULL, then this regexp_t object is used to
13045 perform the symbol name matching. Otherwise, no name-based
13046 filtering is performed.
13048 EXCEPTIONS is a vector of exceptions to which matching exceptions
13052 ada_add_exceptions_from_frame (compiled_regex *preg,
13053 struct frame_info *frame,
13054 std::vector<ada_exc_info> *exceptions)
13056 const struct block *block = get_frame_block (frame, 0);
13060 struct block_iterator iter;
13061 struct symbol *sym;
13063 ALL_BLOCK_SYMBOLS (block, iter, sym)
13065 switch (sym->aclass ())
13072 if (ada_is_exception_sym (sym))
13074 struct ada_exc_info info = {sym->print_name (),
13075 sym->value_address ()};
13077 exceptions->push_back (info);
13081 if (block->function () != NULL)
13083 block = block->superblock ();
13087 /* Return true if NAME matches PREG or if PREG is NULL. */
13090 name_matches_regex (const char *name, compiled_regex *preg)
13092 return (preg == NULL
13093 || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13096 /* Add all exceptions defined globally whose name name match
13097 a regular expression, excluding standard exceptions.
13099 The reason we exclude standard exceptions is that they need
13100 to be handled separately: Standard exceptions are defined inside
13101 a runtime unit which is normally not compiled with debugging info,
13102 and thus usually do not show up in our symbol search. However,
13103 if the unit was in fact built with debugging info, we need to
13104 exclude them because they would duplicate the entry we found
13105 during the special loop that specifically searches for those
13106 standard exceptions.
13108 If PREG is not NULL, then this regexp_t object is used to
13109 perform the symbol name matching. Otherwise, no name-based
13110 filtering is performed.
13112 EXCEPTIONS is a vector of exceptions to which matching exceptions
13116 ada_add_global_exceptions (compiled_regex *preg,
13117 std::vector<ada_exc_info> *exceptions)
13119 /* In Ada, the symbol "search name" is a linkage name, whereas the
13120 regular expression used to do the matching refers to the natural
13121 name. So match against the decoded name. */
13122 expand_symtabs_matching (NULL,
13123 lookup_name_info::match_any (),
13124 [&] (const char *search_name)
13126 std::string decoded = ada_decode (search_name);
13127 return name_matches_regex (decoded.c_str (), preg);
13130 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13133 for (objfile *objfile : current_program_space->objfiles ())
13135 for (compunit_symtab *s : objfile->compunits ())
13137 const struct blockvector *bv = s->blockvector ();
13140 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13142 const struct block *b = bv->block (i);
13143 struct block_iterator iter;
13144 struct symbol *sym;
13146 ALL_BLOCK_SYMBOLS (b, iter, sym)
13147 if (ada_is_non_standard_exception_sym (sym)
13148 && name_matches_regex (sym->natural_name (), preg))
13150 struct ada_exc_info info
13151 = {sym->print_name (), sym->value_address ()};
13153 exceptions->push_back (info);
13160 /* Implements ada_exceptions_list with the regular expression passed
13161 as a regex_t, rather than a string.
13163 If not NULL, PREG is used to filter out exceptions whose names
13164 do not match. Otherwise, all exceptions are listed. */
13166 static std::vector<ada_exc_info>
13167 ada_exceptions_list_1 (compiled_regex *preg)
13169 std::vector<ada_exc_info> result;
13172 /* First, list the known standard exceptions. These exceptions
13173 need to be handled separately, as they are usually defined in
13174 runtime units that have been compiled without debugging info. */
13176 ada_add_standard_exceptions (preg, &result);
13178 /* Next, find all exceptions whose scope is local and accessible
13179 from the currently selected frame. */
13181 if (has_stack_frames ())
13183 prev_len = result.size ();
13184 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13186 if (result.size () > prev_len)
13187 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13190 /* Add all exceptions whose scope is global. */
13192 prev_len = result.size ();
13193 ada_add_global_exceptions (preg, &result);
13194 if (result.size () > prev_len)
13195 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13200 /* Return a vector of ada_exc_info.
13202 If REGEXP is NULL, all exceptions are included in the result.
13203 Otherwise, it should contain a valid regular expression,
13204 and only the exceptions whose names match that regular expression
13205 are included in the result.
13207 The exceptions are sorted in the following order:
13208 - Standard exceptions (defined by the Ada language), in
13209 alphabetical order;
13210 - Exceptions only visible from the current frame, in
13211 alphabetical order;
13212 - Exceptions whose scope is global, in alphabetical order. */
13214 std::vector<ada_exc_info>
13215 ada_exceptions_list (const char *regexp)
13217 if (regexp == NULL)
13218 return ada_exceptions_list_1 (NULL);
13220 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13221 return ada_exceptions_list_1 (®);
13224 /* Implement the "info exceptions" command. */
13227 info_exceptions_command (const char *regexp, int from_tty)
13229 struct gdbarch *gdbarch = get_current_arch ();
13231 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13233 if (regexp != NULL)
13235 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13237 gdb_printf (_("All defined Ada exceptions:\n"));
13239 for (const ada_exc_info &info : exceptions)
13240 gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13244 /* Language vector */
13246 /* symbol_name_matcher_ftype adapter for wild_match. */
13249 do_wild_match (const char *symbol_search_name,
13250 const lookup_name_info &lookup_name,
13251 completion_match_result *comp_match_res)
13253 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13256 /* symbol_name_matcher_ftype adapter for full_match. */
13259 do_full_match (const char *symbol_search_name,
13260 const lookup_name_info &lookup_name,
13261 completion_match_result *comp_match_res)
13263 const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13265 /* If both symbols start with "_ada_", just let the loop below
13266 handle the comparison. However, if only the symbol name starts
13267 with "_ada_", skip the prefix and let the match proceed as
13269 if (startswith (symbol_search_name, "_ada_")
13270 && !startswith (lname, "_ada"))
13271 symbol_search_name += 5;
13272 /* Likewise for ghost entities. */
13273 if (startswith (symbol_search_name, "___ghost_")
13274 && !startswith (lname, "___ghost_"))
13275 symbol_search_name += 9;
13277 int uscore_count = 0;
13278 while (*lname != '\0')
13280 if (*symbol_search_name != *lname)
13282 if (*symbol_search_name == 'B' && uscore_count == 2
13283 && symbol_search_name[1] == '_')
13285 symbol_search_name += 2;
13286 while (isdigit (*symbol_search_name))
13287 ++symbol_search_name;
13288 if (symbol_search_name[0] == '_'
13289 && symbol_search_name[1] == '_')
13291 symbol_search_name += 2;
13298 if (*symbol_search_name == '_')
13303 ++symbol_search_name;
13307 return is_name_suffix (symbol_search_name);
13310 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13313 do_exact_match (const char *symbol_search_name,
13314 const lookup_name_info &lookup_name,
13315 completion_match_result *comp_match_res)
13317 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13320 /* Build the Ada lookup name for LOOKUP_NAME. */
13322 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13324 gdb::string_view user_name = lookup_name.name ();
13326 if (!user_name.empty () && user_name[0] == '<')
13328 if (user_name.back () == '>')
13330 = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13333 = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13334 m_encoded_p = true;
13335 m_verbatim_p = true;
13336 m_wild_match_p = false;
13337 m_standard_p = false;
13341 m_verbatim_p = false;
13343 m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13347 const char *folded = ada_fold_name (user_name);
13348 m_encoded_name = ada_encode_1 (folded, false);
13349 if (m_encoded_name.empty ())
13350 m_encoded_name = gdb::to_string (user_name);
13353 m_encoded_name = gdb::to_string (user_name);
13355 /* Handle the 'package Standard' special case. See description
13356 of m_standard_p. */
13357 if (startswith (m_encoded_name.c_str (), "standard__"))
13359 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13360 m_standard_p = true;
13363 m_standard_p = false;
13365 /* If the name contains a ".", then the user is entering a fully
13366 qualified entity name, and the match must not be done in wild
13367 mode. Similarly, if the user wants to complete what looks
13368 like an encoded name, the match must not be done in wild
13369 mode. Also, in the standard__ special case always do
13370 non-wild matching. */
13372 = (lookup_name.match_type () != symbol_name_match_type::FULL
13375 && user_name.find ('.') == std::string::npos);
13379 /* symbol_name_matcher_ftype method for Ada. This only handles
13380 completion mode. */
13383 ada_symbol_name_matches (const char *symbol_search_name,
13384 const lookup_name_info &lookup_name,
13385 completion_match_result *comp_match_res)
13387 return lookup_name.ada ().matches (symbol_search_name,
13388 lookup_name.match_type (),
13392 /* A name matcher that matches the symbol name exactly, with
13396 literal_symbol_name_matcher (const char *symbol_search_name,
13397 const lookup_name_info &lookup_name,
13398 completion_match_result *comp_match_res)
13400 gdb::string_view name_view = lookup_name.name ();
13402 if (lookup_name.completion_mode ()
13403 ? (strncmp (symbol_search_name, name_view.data (),
13404 name_view.size ()) == 0)
13405 : symbol_search_name == name_view)
13407 if (comp_match_res != NULL)
13408 comp_match_res->set_match (symbol_search_name);
13415 /* Implement the "get_symbol_name_matcher" language_defn method for
13418 static symbol_name_matcher_ftype *
13419 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13421 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13422 return literal_symbol_name_matcher;
13424 if (lookup_name.completion_mode ())
13425 return ada_symbol_name_matches;
13428 if (lookup_name.ada ().wild_match_p ())
13429 return do_wild_match;
13430 else if (lookup_name.ada ().verbatim_p ())
13431 return do_exact_match;
13433 return do_full_match;
13437 /* Class representing the Ada language. */
13439 class ada_language : public language_defn
13443 : language_defn (language_ada)
13446 /* See language.h. */
13448 const char *name () const override
13451 /* See language.h. */
13453 const char *natural_name () const override
13456 /* See language.h. */
13458 const std::vector<const char *> &filename_extensions () const override
13460 static const std::vector<const char *> extensions
13461 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13465 /* Print an array element index using the Ada syntax. */
13467 void print_array_index (struct type *index_type,
13469 struct ui_file *stream,
13470 const value_print_options *options) const override
13472 struct value *index_value = val_atr (index_type, index);
13474 value_print (index_value, stream, options);
13475 gdb_printf (stream, " => ");
13478 /* Implement the "read_var_value" language_defn method for Ada. */
13480 struct value *read_var_value (struct symbol *var,
13481 const struct block *var_block,
13482 struct frame_info *frame) const override
13484 /* The only case where default_read_var_value is not sufficient
13485 is when VAR is a renaming... */
13486 if (frame != nullptr)
13488 const struct block *frame_block = get_frame_block (frame, NULL);
13489 if (frame_block != nullptr && ada_is_renaming_symbol (var))
13490 return ada_read_renaming_var_value (var, frame_block);
13493 /* This is a typical case where we expect the default_read_var_value
13494 function to work. */
13495 return language_defn::read_var_value (var, var_block, frame);
13498 /* See language.h. */
13499 bool symbol_printing_suppressed (struct symbol *symbol) const override
13501 return symbol->is_artificial ();
13504 /* See language.h. */
13505 void language_arch_info (struct gdbarch *gdbarch,
13506 struct language_arch_info *lai) const override
13508 const struct builtin_type *builtin = builtin_type (gdbarch);
13510 /* Helper function to allow shorter lines below. */
13511 auto add = [&] (struct type *t)
13513 lai->add_primitive_type (t);
13516 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13518 add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13519 0, "long_integer"));
13520 add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13521 0, "short_integer"));
13522 struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13524 lai->set_string_char_type (char_type);
13526 add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13527 add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13528 add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13529 "float", gdbarch_float_format (gdbarch)));
13530 add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13531 "long_float", gdbarch_double_format (gdbarch)));
13532 add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13533 0, "long_long_integer"));
13534 add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13536 gdbarch_long_double_format (gdbarch)));
13537 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13539 add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13541 add (builtin->builtin_void);
13543 struct type *system_addr_ptr
13544 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13546 system_addr_ptr->set_name ("system__address");
13547 add (system_addr_ptr);
13549 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13550 type. This is a signed integral type whose size is the same as
13551 the size of addresses. */
13552 unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13553 add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13554 "storage_offset"));
13556 lai->set_bool_type (builtin->builtin_bool);
13559 /* See language.h. */
13561 bool iterate_over_symbols
13562 (const struct block *block, const lookup_name_info &name,
13563 domain_enum domain,
13564 gdb::function_view<symbol_found_callback_ftype> callback) const override
13566 std::vector<struct block_symbol> results
13567 = ada_lookup_symbol_list_worker (name, block, domain, 0);
13568 for (block_symbol &sym : results)
13570 if (!callback (&sym))
13577 /* See language.h. */
13578 bool sniff_from_mangled_name
13579 (const char *mangled,
13580 gdb::unique_xmalloc_ptr<char> *out) const override
13582 std::string demangled = ada_decode (mangled);
13586 if (demangled != mangled && demangled[0] != '<')
13588 /* Set the gsymbol language to Ada, but still return 0.
13589 Two reasons for that:
13591 1. For Ada, we prefer computing the symbol's decoded name
13592 on the fly rather than pre-compute it, in order to save
13593 memory (Ada projects are typically very large).
13595 2. There are some areas in the definition of the GNAT
13596 encoding where, with a bit of bad luck, we might be able
13597 to decode a non-Ada symbol, generating an incorrect
13598 demangled name (Eg: names ending with "TB" for instance
13599 are identified as task bodies and so stripped from
13600 the decoded name returned).
13602 Returning true, here, but not setting *DEMANGLED, helps us get
13603 a little bit of the best of both worlds. Because we're last,
13604 we should not affect any of the other languages that were
13605 able to demangle the symbol before us; we get to correctly
13606 tag Ada symbols as such; and even if we incorrectly tagged a
13607 non-Ada symbol, which should be rare, any routing through the
13608 Ada language should be transparent (Ada tries to behave much
13609 like C/C++ with non-Ada symbols). */
13616 /* See language.h. */
13618 gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13619 int options) const override
13621 return make_unique_xstrdup (ada_decode (mangled).c_str ());
13624 /* See language.h. */
13626 void print_type (struct type *type, const char *varstring,
13627 struct ui_file *stream, int show, int level,
13628 const struct type_print_options *flags) const override
13630 ada_print_type (type, varstring, stream, show, level, flags);
13633 /* See language.h. */
13635 const char *word_break_characters (void) const override
13637 return ada_completer_word_break_characters;
13640 /* See language.h. */
13642 void collect_symbol_completion_matches (completion_tracker &tracker,
13643 complete_symbol_mode mode,
13644 symbol_name_match_type name_match_type,
13645 const char *text, const char *word,
13646 enum type_code code) const override
13648 struct symbol *sym;
13649 const struct block *b, *surrounding_static_block = 0;
13650 struct block_iterator iter;
13652 gdb_assert (code == TYPE_CODE_UNDEF);
13654 lookup_name_info lookup_name (text, name_match_type, true);
13656 /* First, look at the partial symtab symbols. */
13657 expand_symtabs_matching (NULL,
13661 SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13664 /* At this point scan through the misc symbol vectors and add each
13665 symbol you find to the list. Eventually we want to ignore
13666 anything that isn't a text symbol (everything else will be
13667 handled by the psymtab code above). */
13669 for (objfile *objfile : current_program_space->objfiles ())
13671 for (minimal_symbol *msymbol : objfile->msymbols ())
13675 if (completion_skip_symbol (mode, msymbol))
13678 language symbol_language = msymbol->language ();
13680 /* Ada minimal symbols won't have their language set to Ada. If
13681 we let completion_list_add_name compare using the
13682 default/C-like matcher, then when completing e.g., symbols in a
13683 package named "pck", we'd match internal Ada symbols like
13684 "pckS", which are invalid in an Ada expression, unless you wrap
13685 them in '<' '>' to request a verbatim match.
13687 Unfortunately, some Ada encoded names successfully demangle as
13688 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13689 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13690 with the wrong language set. Paper over that issue here. */
13691 if (symbol_language == language_auto
13692 || symbol_language == language_cplus)
13693 symbol_language = language_ada;
13695 completion_list_add_name (tracker,
13697 msymbol->linkage_name (),
13698 lookup_name, text, word);
13702 /* Search upwards from currently selected frame (so that we can
13703 complete on local vars. */
13705 for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13707 if (!b->superblock ())
13708 surrounding_static_block = b; /* For elmin of dups */
13710 ALL_BLOCK_SYMBOLS (b, iter, sym)
13712 if (completion_skip_symbol (mode, sym))
13715 completion_list_add_name (tracker,
13717 sym->linkage_name (),
13718 lookup_name, text, word);
13722 /* Go through the symtabs and check the externs and statics for
13723 symbols which match. */
13725 for (objfile *objfile : current_program_space->objfiles ())
13727 for (compunit_symtab *s : objfile->compunits ())
13730 b = s->blockvector ()->global_block ();
13731 ALL_BLOCK_SYMBOLS (b, iter, sym)
13733 if (completion_skip_symbol (mode, sym))
13736 completion_list_add_name (tracker,
13738 sym->linkage_name (),
13739 lookup_name, text, word);
13744 for (objfile *objfile : current_program_space->objfiles ())
13746 for (compunit_symtab *s : objfile->compunits ())
13749 b = s->blockvector ()->static_block ();
13750 /* Don't do this block twice. */
13751 if (b == surrounding_static_block)
13753 ALL_BLOCK_SYMBOLS (b, iter, sym)
13755 if (completion_skip_symbol (mode, sym))
13758 completion_list_add_name (tracker,
13760 sym->linkage_name (),
13761 lookup_name, text, word);
13767 /* See language.h. */
13769 gdb::unique_xmalloc_ptr<char> watch_location_expression
13770 (struct type *type, CORE_ADDR addr) const override
13772 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13773 std::string name = type_to_string (type);
13774 return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13777 /* See language.h. */
13779 void value_print (struct value *val, struct ui_file *stream,
13780 const struct value_print_options *options) const override
13782 return ada_value_print (val, stream, options);
13785 /* See language.h. */
13787 void value_print_inner
13788 (struct value *val, struct ui_file *stream, int recurse,
13789 const struct value_print_options *options) const override
13791 return ada_value_print_inner (val, stream, recurse, options);
13794 /* See language.h. */
13796 struct block_symbol lookup_symbol_nonlocal
13797 (const char *name, const struct block *block,
13798 const domain_enum domain) const override
13800 struct block_symbol sym;
13802 sym = ada_lookup_symbol (name, block_static_block (block), domain);
13803 if (sym.symbol != NULL)
13806 /* If we haven't found a match at this point, try the primitive
13807 types. In other languages, this search is performed before
13808 searching for global symbols in order to short-circuit that
13809 global-symbol search if it happens that the name corresponds
13810 to a primitive type. But we cannot do the same in Ada, because
13811 it is perfectly legitimate for a program to declare a type which
13812 has the same name as a standard type. If looking up a type in
13813 that situation, we have traditionally ignored the primitive type
13814 in favor of user-defined types. This is why, unlike most other
13815 languages, we search the primitive types this late and only after
13816 having searched the global symbols without success. */
13818 if (domain == VAR_DOMAIN)
13820 struct gdbarch *gdbarch;
13823 gdbarch = target_gdbarch ();
13825 gdbarch = block_gdbarch (block);
13827 = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13828 if (sym.symbol != NULL)
13835 /* See language.h. */
13837 int parser (struct parser_state *ps) const override
13839 warnings_issued = 0;
13840 return ada_parse (ps);
13843 /* See language.h. */
13845 void emitchar (int ch, struct type *chtype,
13846 struct ui_file *stream, int quoter) const override
13848 ada_emit_char (ch, chtype, stream, quoter, 1);
13851 /* See language.h. */
13853 void printchar (int ch, struct type *chtype,
13854 struct ui_file *stream) const override
13856 ada_printchar (ch, chtype, stream);
13859 /* See language.h. */
13861 void printstr (struct ui_file *stream, struct type *elttype,
13862 const gdb_byte *string, unsigned int length,
13863 const char *encoding, int force_ellipses,
13864 const struct value_print_options *options) const override
13866 ada_printstr (stream, elttype, string, length, encoding,
13867 force_ellipses, options);
13870 /* See language.h. */
13872 void print_typedef (struct type *type, struct symbol *new_symbol,
13873 struct ui_file *stream) const override
13875 ada_print_typedef (type, new_symbol, stream);
13878 /* See language.h. */
13880 bool is_string_type_p (struct type *type) const override
13882 return ada_is_string_type (type);
13885 /* See language.h. */
13887 const char *struct_too_deep_ellipsis () const override
13888 { return "(...)"; }
13890 /* See language.h. */
13892 bool c_style_arrays_p () const override
13895 /* See language.h. */
13897 bool store_sym_names_in_linkage_form_p () const override
13900 /* See language.h. */
13902 const struct lang_varobj_ops *varobj_ops () const override
13903 { return &ada_varobj_ops; }
13906 /* See language.h. */
13908 symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13909 (const lookup_name_info &lookup_name) const override
13911 return ada_get_symbol_name_matcher (lookup_name);
13915 /* Single instance of the Ada language class. */
13917 static ada_language ada_language_defn;
13919 /* Command-list for the "set/show ada" prefix command. */
13920 static struct cmd_list_element *set_ada_list;
13921 static struct cmd_list_element *show_ada_list;
13923 /* This module's 'new_objfile' observer. */
13926 ada_new_objfile_observer (struct objfile *objfile)
13928 ada_clear_symbol_cache ();
13931 /* This module's 'free_objfile' observer. */
13934 ada_free_objfile_observer (struct objfile *objfile)
13936 ada_clear_symbol_cache ();
13939 /* Charsets known to GNAT. */
13940 static const char * const gnat_source_charsets[] =
13942 /* Note that code below assumes that the default comes first.
13943 Latin-1 is the default here, because that is also GNAT's
13953 /* Note that this value is special-cased in the encoder and
13959 void _initialize_ada_language ();
13961 _initialize_ada_language ()
13963 add_setshow_prefix_cmd
13965 _("Prefix command for changing Ada-specific settings."),
13966 _("Generic command for showing Ada-specific settings."),
13967 &set_ada_list, &show_ada_list,
13968 &setlist, &showlist);
13970 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13971 &trust_pad_over_xvs, _("\
13972 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13973 Show whether an optimization trusting PAD types over XVS types is activated."),
13975 This is related to the encoding used by the GNAT compiler. The debugger\n\
13976 should normally trust the contents of PAD types, but certain older versions\n\
13977 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13978 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13979 work around this bug. It is always safe to turn this option \"off\", but\n\
13980 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13981 this option to \"off\" unless necessary."),
13982 NULL, NULL, &set_ada_list, &show_ada_list);
13984 add_setshow_boolean_cmd ("print-signatures", class_vars,
13985 &print_signatures, _("\
13986 Enable or disable the output of formal and return types for functions in the \
13987 overloads selection menu."), _("\
13988 Show whether the output of formal and return types for functions in the \
13989 overloads selection menu is activated."),
13990 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13992 ada_source_charset = gnat_source_charsets[0];
13993 add_setshow_enum_cmd ("source-charset", class_files,
13994 gnat_source_charsets,
13995 &ada_source_charset, _("\
13996 Set the Ada source character set."), _("\
13997 Show the Ada source character set."), _("\
13998 The character set used for Ada source files.\n\
13999 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14001 &set_ada_list, &show_ada_list);
14003 add_catch_command ("exception", _("\
14004 Catch Ada exceptions, when raised.\n\
14005 Usage: catch exception [ARG] [if CONDITION]\n\
14006 Without any argument, stop when any Ada exception is raised.\n\
14007 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14008 being raised does not have a handler (and will therefore lead to the task's\n\
14010 Otherwise, the catchpoint only stops when the name of the exception being\n\
14011 raised is the same as ARG.\n\
14012 CONDITION is a boolean expression that is evaluated to see whether the\n\
14013 exception should cause a stop."),
14014 catch_ada_exception_command,
14015 catch_ada_completer,
14019 add_catch_command ("handlers", _("\
14020 Catch Ada exceptions, when handled.\n\
14021 Usage: catch handlers [ARG] [if CONDITION]\n\
14022 Without any argument, stop when any Ada exception is handled.\n\
14023 With an argument, catch only exceptions with the given name.\n\
14024 CONDITION is a boolean expression that is evaluated to see whether the\n\
14025 exception should cause a stop."),
14026 catch_ada_handlers_command,
14027 catch_ada_completer,
14030 add_catch_command ("assert", _("\
14031 Catch failed Ada assertions, when raised.\n\
14032 Usage: catch assert [if CONDITION]\n\
14033 CONDITION is a boolean expression that is evaluated to see whether the\n\
14034 exception should cause a stop."),
14035 catch_assert_command,
14040 add_info ("exceptions", info_exceptions_command,
14042 List all Ada exception names.\n\
14043 Usage: info exceptions [REGEXP]\n\
14044 If a regular expression is passed as an argument, only those matching\n\
14045 the regular expression are listed."));
14047 add_setshow_prefix_cmd ("ada", class_maintenance,
14048 _("Set Ada maintenance-related variables."),
14049 _("Show Ada maintenance-related variables."),
14050 &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14051 &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14053 add_setshow_boolean_cmd
14054 ("ignore-descriptive-types", class_maintenance,
14055 &ada_ignore_descriptive_types_p,
14056 _("Set whether descriptive types generated by GNAT should be ignored."),
14057 _("Show whether descriptive types generated by GNAT should be ignored."),
14059 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14060 DWARF attribute."),
14061 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14063 decoded_names_store = htab_create_alloc (256, htab_hash_string,
14065 NULL, xcalloc, xfree);
14067 /* The ada-lang observers. */
14068 gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14069 gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14070 gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");