1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2019 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_regex.h"
29 #include "expression.h"
30 #include "parser-defs.h"
37 #include "breakpoint.h"
40 #include "gdb_obstack.h"
42 #include "completer.h"
47 #include "dictionary.h"
51 #include "observable.h"
52 #include "gdbsupport/vec.h"
54 #include "gdbsupport/gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "gdbsupport/function-view.h"
64 #include "gdbsupport/byte-vector.h"
68 /* Define whether or not the C operator '/' truncates towards zero for
69 differently signed operands (truncation direction is undefined in C).
70 Copied from valarith.c. */
72 #ifndef TRUNCATION_TOWARDS_ZERO
73 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
76 static struct type *desc_base_type (struct type *);
78 static struct type *desc_bounds_type (struct type *);
80 static struct value *desc_bounds (struct value *);
82 static int fat_pntr_bounds_bitpos (struct type *);
84 static int fat_pntr_bounds_bitsize (struct type *);
86 static struct type *desc_data_target_type (struct type *);
88 static struct value *desc_data (struct value *);
90 static int fat_pntr_data_bitpos (struct type *);
92 static int fat_pntr_data_bitsize (struct type *);
94 static struct value *desc_one_bound (struct value *, int, int);
96 static int desc_bound_bitpos (struct type *, int, int);
98 static int desc_bound_bitsize (struct type *, int, int);
100 static struct type *desc_index_type (struct type *, int);
102 static int desc_arity (struct type *);
104 static int ada_type_match (struct type *, struct type *, int);
106 static int ada_args_match (struct symbol *, struct value **, int);
108 static struct value *make_array_descriptor (struct type *, struct value *);
110 static void ada_add_block_symbols (struct obstack *,
111 const struct block *,
112 const lookup_name_info &lookup_name,
113 domain_enum, struct objfile *);
115 static void ada_add_all_symbols (struct obstack *, const struct block *,
116 const lookup_name_info &lookup_name,
117 domain_enum, int, int *);
119 static int is_nonfunction (struct block_symbol *, int);
121 static void add_defn_to_vec (struct obstack *, struct symbol *,
122 const struct block *);
124 static int num_defns_collected (struct obstack *);
126 static struct block_symbol *defns_collected (struct obstack *, int);
128 static struct value *resolve_subexp (expression_up *, int *, int,
130 innermost_block_tracker *);
132 static void replace_operator_with_call (expression_up *, int, int, int,
133 struct symbol *, const struct block *);
135 static int possible_user_operator_p (enum exp_opcode, struct value **);
137 static const char *ada_op_name (enum exp_opcode);
139 static const char *ada_decoded_op_name (enum exp_opcode);
141 static int numeric_type_p (struct type *);
143 static int integer_type_p (struct type *);
145 static int scalar_type_p (struct type *);
147 static int discrete_type_p (struct type *);
149 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
152 static struct value *evaluate_subexp_type (struct expression *, int *);
154 static struct type *ada_find_parallel_type_with_name (struct type *,
157 static int is_dynamic_field (struct type *, int);
159 static struct type *to_fixed_variant_branch_type (struct type *,
161 CORE_ADDR, struct value *);
163 static struct type *to_fixed_array_type (struct type *, struct value *, int);
165 static struct type *to_fixed_range_type (struct type *, struct value *);
167 static struct type *to_static_fixed_type (struct type *);
168 static struct type *static_unwrap_type (struct type *type);
170 static struct value *unwrap_value (struct value *);
172 static struct type *constrained_packed_array_type (struct type *, long *);
174 static struct type *decode_constrained_packed_array_type (struct type *);
176 static long decode_packed_array_bitsize (struct type *);
178 static struct value *decode_constrained_packed_array (struct value *);
180 static int ada_is_packed_array_type (struct type *);
182 static int ada_is_unconstrained_packed_array_type (struct type *);
184 static struct value *value_subscript_packed (struct value *, int,
187 static struct value *coerce_unspec_val_to_type (struct value *,
190 static int lesseq_defined_than (struct symbol *, struct symbol *);
192 static int equiv_types (struct type *, struct type *);
194 static int is_name_suffix (const char *);
196 static int advance_wild_match (const char **, const char *, int);
198 static bool wild_match (const char *name, const char *patn);
200 static struct value *ada_coerce_ref (struct value *);
202 static LONGEST pos_atr (struct value *);
204 static struct value *value_pos_atr (struct type *, struct value *);
206 static struct value *value_val_atr (struct type *, struct value *);
208 static struct symbol *standard_lookup (const char *, const struct block *,
211 static struct value *ada_search_struct_field (const char *, struct value *, int,
214 static struct value *ada_value_primitive_field (struct value *, int, int,
217 static int find_struct_field (const char *, struct type *, int,
218 struct type **, int *, int *, int *, int *);
220 static int ada_resolve_function (struct block_symbol *, int,
221 struct value **, int, const char *,
224 static int ada_is_direct_array_type (struct type *);
226 static void ada_language_arch_info (struct gdbarch *,
227 struct language_arch_info *);
229 static struct value *ada_index_struct_field (int, struct value *, int,
232 static struct value *assign_aggregate (struct value *, struct value *,
236 static void aggregate_assign_from_choices (struct value *, struct value *,
238 int *, LONGEST *, int *,
239 int, LONGEST, LONGEST);
241 static void aggregate_assign_positional (struct value *, struct value *,
243 int *, LONGEST *, int *, int,
247 static void aggregate_assign_others (struct value *, struct value *,
249 int *, LONGEST *, int, LONGEST, LONGEST);
252 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
255 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
258 static void ada_forward_operator_length (struct expression *, int, int *,
261 static struct type *ada_find_any_type (const char *name);
263 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
264 (const lookup_name_info &lookup_name);
268 /* The result of a symbol lookup to be stored in our symbol cache. */
272 /* The name used to perform the lookup. */
274 /* The namespace used during the lookup. */
276 /* The symbol returned by the lookup, or NULL if no matching symbol
279 /* The block where the symbol was found, or NULL if no matching
281 const struct block *block;
282 /* A pointer to the next entry with the same hash. */
283 struct cache_entry *next;
286 /* The Ada symbol cache, used to store the result of Ada-mode symbol
287 lookups in the course of executing the user's commands.
289 The cache is implemented using a simple, fixed-sized hash.
290 The size is fixed on the grounds that there are not likely to be
291 all that many symbols looked up during any given session, regardless
292 of the size of the symbol table. If we decide to go to a resizable
293 table, let's just use the stuff from libiberty instead. */
295 #define HASH_SIZE 1009
297 struct ada_symbol_cache
299 /* An obstack used to store the entries in our cache. */
300 struct obstack cache_space;
302 /* The root of the hash table used to implement our symbol cache. */
303 struct cache_entry *root[HASH_SIZE];
306 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
308 /* Maximum-sized dynamic type. */
309 static unsigned int varsize_limit;
311 static const char ada_completer_word_break_characters[] =
313 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
315 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
318 /* The name of the symbol to use to get the name of the main subprogram. */
319 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
320 = "__gnat_ada_main_program_name";
322 /* Limit on the number of warnings to raise per expression evaluation. */
323 static int warning_limit = 2;
325 /* Number of warning messages issued; reset to 0 by cleanups after
326 expression evaluation. */
327 static int warnings_issued = 0;
329 static const char *known_runtime_file_name_patterns[] = {
330 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
333 static const char *known_auxiliary_function_name_patterns[] = {
334 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
337 /* Maintenance-related settings for this module. */
339 static struct cmd_list_element *maint_set_ada_cmdlist;
340 static struct cmd_list_element *maint_show_ada_cmdlist;
342 /* Implement the "maintenance set ada" (prefix) command. */
345 maint_set_ada_cmd (const char *args, int from_tty)
347 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
351 /* Implement the "maintenance show ada" (prefix) command. */
354 maint_show_ada_cmd (const char *args, int from_tty)
356 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
359 /* The "maintenance ada set/show ignore-descriptive-type" value. */
361 static int ada_ignore_descriptive_types_p = 0;
363 /* Inferior-specific data. */
365 /* Per-inferior data for this module. */
367 struct ada_inferior_data
369 /* The ada__tags__type_specific_data type, which is used when decoding
370 tagged types. With older versions of GNAT, this type was directly
371 accessible through a component ("tsd") in the object tag. But this
372 is no longer the case, so we cache it for each inferior. */
373 struct type *tsd_type = nullptr;
375 /* The exception_support_info data. This data is used to determine
376 how to implement support for Ada exception catchpoints in a given
378 const struct exception_support_info *exception_info = nullptr;
381 /* Our key to this module's inferior data. */
382 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
384 /* Return our inferior data for the given inferior (INF).
386 This function always returns a valid pointer to an allocated
387 ada_inferior_data structure. If INF's inferior data has not
388 been previously set, this functions creates a new one with all
389 fields set to zero, sets INF's inferior to it, and then returns
390 a pointer to that newly allocated ada_inferior_data. */
392 static struct ada_inferior_data *
393 get_ada_inferior_data (struct inferior *inf)
395 struct ada_inferior_data *data;
397 data = ada_inferior_data.get (inf);
399 data = ada_inferior_data.emplace (inf);
404 /* Perform all necessary cleanups regarding our module's inferior data
405 that is required after the inferior INF just exited. */
408 ada_inferior_exit (struct inferior *inf)
410 ada_inferior_data.clear (inf);
414 /* program-space-specific data. */
416 /* This module's per-program-space data. */
417 struct ada_pspace_data
421 if (sym_cache != NULL)
422 ada_free_symbol_cache (sym_cache);
425 /* The Ada symbol cache. */
426 struct ada_symbol_cache *sym_cache = nullptr;
429 /* Key to our per-program-space data. */
430 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
432 /* Return this module's data for the given program space (PSPACE).
433 If not is found, add a zero'ed one now.
435 This function always returns a valid object. */
437 static struct ada_pspace_data *
438 get_ada_pspace_data (struct program_space *pspace)
440 struct ada_pspace_data *data;
442 data = ada_pspace_data_handle.get (pspace);
444 data = ada_pspace_data_handle.emplace (pspace);
451 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
452 all typedef layers have been peeled. Otherwise, return TYPE.
454 Normally, we really expect a typedef type to only have 1 typedef layer.
455 In other words, we really expect the target type of a typedef type to be
456 a non-typedef type. This is particularly true for Ada units, because
457 the language does not have a typedef vs not-typedef distinction.
458 In that respect, the Ada compiler has been trying to eliminate as many
459 typedef definitions in the debugging information, since they generally
460 do not bring any extra information (we still use typedef under certain
461 circumstances related mostly to the GNAT encoding).
463 Unfortunately, we have seen situations where the debugging information
464 generated by the compiler leads to such multiple typedef layers. For
465 instance, consider the following example with stabs:
467 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
468 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
470 This is an error in the debugging information which causes type
471 pck__float_array___XUP to be defined twice, and the second time,
472 it is defined as a typedef of a typedef.
474 This is on the fringe of legality as far as debugging information is
475 concerned, and certainly unexpected. But it is easy to handle these
476 situations correctly, so we can afford to be lenient in this case. */
479 ada_typedef_target_type (struct type *type)
481 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
482 type = TYPE_TARGET_TYPE (type);
486 /* Given DECODED_NAME a string holding a symbol name in its
487 decoded form (ie using the Ada dotted notation), returns
488 its unqualified name. */
491 ada_unqualified_name (const char *decoded_name)
495 /* If the decoded name starts with '<', it means that the encoded
496 name does not follow standard naming conventions, and thus that
497 it is not your typical Ada symbol name. Trying to unqualify it
498 is therefore pointless and possibly erroneous. */
499 if (decoded_name[0] == '<')
502 result = strrchr (decoded_name, '.');
504 result++; /* Skip the dot... */
506 result = decoded_name;
511 /* Return a string starting with '<', followed by STR, and '>'. */
514 add_angle_brackets (const char *str)
516 return string_printf ("<%s>", str);
520 ada_get_gdb_completer_word_break_characters (void)
522 return ada_completer_word_break_characters;
525 /* Print an array element index using the Ada syntax. */
528 ada_print_array_index (struct value *index_value, struct ui_file *stream,
529 const struct value_print_options *options)
531 LA_VALUE_PRINT (index_value, stream, options);
532 fprintf_filtered (stream, " => ");
535 /* la_watch_location_expression for Ada. */
537 gdb::unique_xmalloc_ptr<char>
538 ada_watch_location_expression (struct type *type, CORE_ADDR addr)
540 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
541 std::string name = type_to_string (type);
542 return gdb::unique_xmalloc_ptr<char>
543 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
546 /* Assuming VECT points to an array of *SIZE objects of size
547 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
548 updating *SIZE as necessary and returning the (new) array. */
551 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
553 if (*size < min_size)
556 if (*size < min_size)
558 vect = xrealloc (vect, *size * element_size);
563 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
564 suffix of FIELD_NAME beginning "___". */
567 field_name_match (const char *field_name, const char *target)
569 int len = strlen (target);
572 (strncmp (field_name, target, len) == 0
573 && (field_name[len] == '\0'
574 || (startswith (field_name + len, "___")
575 && strcmp (field_name + strlen (field_name) - 6,
580 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
581 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
582 and return its index. This function also handles fields whose name
583 have ___ suffixes because the compiler sometimes alters their name
584 by adding such a suffix to represent fields with certain constraints.
585 If the field could not be found, return a negative number if
586 MAYBE_MISSING is set. Otherwise raise an error. */
589 ada_get_field_index (const struct type *type, const char *field_name,
593 struct type *struct_type = check_typedef ((struct type *) type);
595 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
596 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
600 error (_("Unable to find field %s in struct %s. Aborting"),
601 field_name, TYPE_NAME (struct_type));
606 /* The length of the prefix of NAME prior to any "___" suffix. */
609 ada_name_prefix_len (const char *name)
615 const char *p = strstr (name, "___");
618 return strlen (name);
624 /* Return non-zero if SUFFIX is a suffix of STR.
625 Return zero if STR is null. */
628 is_suffix (const char *str, const char *suffix)
635 len2 = strlen (suffix);
636 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
639 /* The contents of value VAL, treated as a value of type TYPE. The
640 result is an lval in memory if VAL is. */
642 static struct value *
643 coerce_unspec_val_to_type (struct value *val, struct type *type)
645 type = ada_check_typedef (type);
646 if (value_type (val) == type)
650 struct value *result;
652 /* Make sure that the object size is not unreasonable before
653 trying to allocate some memory for it. */
654 ada_ensure_varsize_limit (type);
657 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
658 result = allocate_value_lazy (type);
661 result = allocate_value (type);
662 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
664 set_value_component_location (result, val);
665 set_value_bitsize (result, value_bitsize (val));
666 set_value_bitpos (result, value_bitpos (val));
667 if (VALUE_LVAL (result) == lval_memory)
668 set_value_address (result, value_address (val));
673 static const gdb_byte *
674 cond_offset_host (const gdb_byte *valaddr, long offset)
679 return valaddr + offset;
683 cond_offset_target (CORE_ADDR address, long offset)
688 return address + offset;
691 /* Issue a warning (as for the definition of warning in utils.c, but
692 with exactly one argument rather than ...), unless the limit on the
693 number of warnings has passed during the evaluation of the current
696 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
697 provided by "complaint". */
698 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
701 lim_warning (const char *format, ...)
705 va_start (args, format);
706 warnings_issued += 1;
707 if (warnings_issued <= warning_limit)
708 vwarning (format, args);
713 /* Issue an error if the size of an object of type T is unreasonable,
714 i.e. if it would be a bad idea to allocate a value of this type in
718 ada_ensure_varsize_limit (const struct type *type)
720 if (TYPE_LENGTH (type) > varsize_limit)
721 error (_("object size is larger than varsize-limit"));
724 /* Maximum value of a SIZE-byte signed integer type. */
726 max_of_size (int size)
728 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
730 return top_bit | (top_bit - 1);
733 /* Minimum value of a SIZE-byte signed integer type. */
735 min_of_size (int size)
737 return -max_of_size (size) - 1;
740 /* Maximum value of a SIZE-byte unsigned integer type. */
742 umax_of_size (int size)
744 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
746 return top_bit | (top_bit - 1);
749 /* Maximum value of integral type T, as a signed quantity. */
751 max_of_type (struct type *t)
753 if (TYPE_UNSIGNED (t))
754 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
756 return max_of_size (TYPE_LENGTH (t));
759 /* Minimum value of integral type T, as a signed quantity. */
761 min_of_type (struct type *t)
763 if (TYPE_UNSIGNED (t))
766 return min_of_size (TYPE_LENGTH (t));
769 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
771 ada_discrete_type_high_bound (struct type *type)
773 type = resolve_dynamic_type (type, NULL, 0);
774 switch (TYPE_CODE (type))
776 case TYPE_CODE_RANGE:
777 return TYPE_HIGH_BOUND (type);
779 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
784 return max_of_type (type);
786 error (_("Unexpected type in ada_discrete_type_high_bound."));
790 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
792 ada_discrete_type_low_bound (struct type *type)
794 type = resolve_dynamic_type (type, NULL, 0);
795 switch (TYPE_CODE (type))
797 case TYPE_CODE_RANGE:
798 return TYPE_LOW_BOUND (type);
800 return TYPE_FIELD_ENUMVAL (type, 0);
805 return min_of_type (type);
807 error (_("Unexpected type in ada_discrete_type_low_bound."));
811 /* The identity on non-range types. For range types, the underlying
812 non-range scalar type. */
815 get_base_type (struct type *type)
817 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
819 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
821 type = TYPE_TARGET_TYPE (type);
826 /* Return a decoded version of the given VALUE. This means returning
827 a value whose type is obtained by applying all the GNAT-specific
828 encondings, making the resulting type a static but standard description
829 of the initial type. */
832 ada_get_decoded_value (struct value *value)
834 struct type *type = ada_check_typedef (value_type (value));
836 if (ada_is_array_descriptor_type (type)
837 || (ada_is_constrained_packed_array_type (type)
838 && TYPE_CODE (type) != TYPE_CODE_PTR))
840 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
841 value = ada_coerce_to_simple_array_ptr (value);
843 value = ada_coerce_to_simple_array (value);
846 value = ada_to_fixed_value (value);
851 /* Same as ada_get_decoded_value, but with the given TYPE.
852 Because there is no associated actual value for this type,
853 the resulting type might be a best-effort approximation in
854 the case of dynamic types. */
857 ada_get_decoded_type (struct type *type)
859 type = to_static_fixed_type (type);
860 if (ada_is_constrained_packed_array_type (type))
861 type = ada_coerce_to_simple_array_type (type);
867 /* Language Selection */
869 /* If the main program is in Ada, return language_ada, otherwise return LANG
870 (the main program is in Ada iif the adainit symbol is found). */
873 ada_update_initial_language (enum language lang)
875 if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
881 /* If the main procedure is written in Ada, then return its name.
882 The result is good until the next call. Return NULL if the main
883 procedure doesn't appear to be in Ada. */
888 struct bound_minimal_symbol msym;
889 static gdb::unique_xmalloc_ptr<char> main_program_name;
891 /* For Ada, the name of the main procedure is stored in a specific
892 string constant, generated by the binder. Look for that symbol,
893 extract its address, and then read that string. If we didn't find
894 that string, then most probably the main procedure is not written
896 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
898 if (msym.minsym != NULL)
900 CORE_ADDR main_program_name_addr;
903 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
904 if (main_program_name_addr == 0)
905 error (_("Invalid address for Ada main program name."));
907 target_read_string (main_program_name_addr, &main_program_name,
912 return main_program_name.get ();
915 /* The main procedure doesn't seem to be in Ada. */
921 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
924 const struct ada_opname_map ada_opname_table[] = {
925 {"Oadd", "\"+\"", BINOP_ADD},
926 {"Osubtract", "\"-\"", BINOP_SUB},
927 {"Omultiply", "\"*\"", BINOP_MUL},
928 {"Odivide", "\"/\"", BINOP_DIV},
929 {"Omod", "\"mod\"", BINOP_MOD},
930 {"Orem", "\"rem\"", BINOP_REM},
931 {"Oexpon", "\"**\"", BINOP_EXP},
932 {"Olt", "\"<\"", BINOP_LESS},
933 {"Ole", "\"<=\"", BINOP_LEQ},
934 {"Ogt", "\">\"", BINOP_GTR},
935 {"Oge", "\">=\"", BINOP_GEQ},
936 {"Oeq", "\"=\"", BINOP_EQUAL},
937 {"One", "\"/=\"", BINOP_NOTEQUAL},
938 {"Oand", "\"and\"", BINOP_BITWISE_AND},
939 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
940 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
941 {"Oconcat", "\"&\"", BINOP_CONCAT},
942 {"Oabs", "\"abs\"", UNOP_ABS},
943 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
944 {"Oadd", "\"+\"", UNOP_PLUS},
945 {"Osubtract", "\"-\"", UNOP_NEG},
949 /* The "encoded" form of DECODED, according to GNAT conventions. The
950 result is valid until the next call to ada_encode. If
951 THROW_ERRORS, throw an error if invalid operator name is found.
952 Otherwise, return NULL in that case. */
955 ada_encode_1 (const char *decoded, bool throw_errors)
957 static char *encoding_buffer = NULL;
958 static size_t encoding_buffer_size = 0;
965 GROW_VECT (encoding_buffer, encoding_buffer_size,
966 2 * strlen (decoded) + 10);
969 for (p = decoded; *p != '\0'; p += 1)
973 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
978 const struct ada_opname_map *mapping;
980 for (mapping = ada_opname_table;
981 mapping->encoded != NULL
982 && !startswith (p, mapping->decoded); mapping += 1)
984 if (mapping->encoded == NULL)
987 error (_("invalid Ada operator name: %s"), p);
991 strcpy (encoding_buffer + k, mapping->encoded);
992 k += strlen (mapping->encoded);
997 encoding_buffer[k] = *p;
1002 encoding_buffer[k] = '\0';
1003 return encoding_buffer;
1006 /* The "encoded" form of DECODED, according to GNAT conventions.
1007 The result is valid until the next call to ada_encode. */
1010 ada_encode (const char *decoded)
1012 return ada_encode_1 (decoded, true);
1015 /* Return NAME folded to lower case, or, if surrounded by single
1016 quotes, unfolded, but with the quotes stripped away. Result good
1020 ada_fold_name (const char *name)
1022 static char *fold_buffer = NULL;
1023 static size_t fold_buffer_size = 0;
1025 int len = strlen (name);
1026 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1028 if (name[0] == '\'')
1030 strncpy (fold_buffer, name + 1, len - 2);
1031 fold_buffer[len - 2] = '\000';
1037 for (i = 0; i <= len; i += 1)
1038 fold_buffer[i] = tolower (name[i]);
1044 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1047 is_lower_alphanum (const char c)
1049 return (isdigit (c) || (isalpha (c) && islower (c)));
1052 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1053 This function saves in LEN the length of that same symbol name but
1054 without either of these suffixes:
1060 These are suffixes introduced by the compiler for entities such as
1061 nested subprogram for instance, in order to avoid name clashes.
1062 They do not serve any purpose for the debugger. */
1065 ada_remove_trailing_digits (const char *encoded, int *len)
1067 if (*len > 1 && isdigit (encoded[*len - 1]))
1071 while (i > 0 && isdigit (encoded[i]))
1073 if (i >= 0 && encoded[i] == '.')
1075 else if (i >= 0 && encoded[i] == '$')
1077 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1079 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1084 /* Remove the suffix introduced by the compiler for protected object
1088 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1090 /* Remove trailing N. */
1092 /* Protected entry subprograms are broken into two
1093 separate subprograms: The first one is unprotected, and has
1094 a 'N' suffix; the second is the protected version, and has
1095 the 'P' suffix. The second calls the first one after handling
1096 the protection. Since the P subprograms are internally generated,
1097 we leave these names undecoded, giving the user a clue that this
1098 entity is internal. */
1101 && encoded[*len - 1] == 'N'
1102 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1106 /* If ENCODED follows the GNAT entity encoding conventions, then return
1107 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1108 replaced by ENCODED.
1110 The resulting string is valid until the next call of ada_decode.
1111 If the string is unchanged by decoding, the original string pointer
1115 ada_decode (const char *encoded)
1122 static char *decoding_buffer = NULL;
1123 static size_t decoding_buffer_size = 0;
1125 /* With function descriptors on PPC64, the value of a symbol named
1126 ".FN", if it exists, is the entry point of the function "FN". */
1127 if (encoded[0] == '.')
1130 /* The name of the Ada main procedure starts with "_ada_".
1131 This prefix is not part of the decoded name, so skip this part
1132 if we see this prefix. */
1133 if (startswith (encoded, "_ada_"))
1136 /* If the name starts with '_', then it is not a properly encoded
1137 name, so do not attempt to decode it. Similarly, if the name
1138 starts with '<', the name should not be decoded. */
1139 if (encoded[0] == '_' || encoded[0] == '<')
1142 len0 = strlen (encoded);
1144 ada_remove_trailing_digits (encoded, &len0);
1145 ada_remove_po_subprogram_suffix (encoded, &len0);
1147 /* Remove the ___X.* suffix if present. Do not forget to verify that
1148 the suffix is located before the current "end" of ENCODED. We want
1149 to avoid re-matching parts of ENCODED that have previously been
1150 marked as discarded (by decrementing LEN0). */
1151 p = strstr (encoded, "___");
1152 if (p != NULL && p - encoded < len0 - 3)
1160 /* Remove any trailing TKB suffix. It tells us that this symbol
1161 is for the body of a task, but that information does not actually
1162 appear in the decoded name. */
1164 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1167 /* Remove any trailing TB suffix. The TB suffix is slightly different
1168 from the TKB suffix because it is used for non-anonymous task
1171 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1174 /* Remove trailing "B" suffixes. */
1175 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1177 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1180 /* Make decoded big enough for possible expansion by operator name. */
1182 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1183 decoded = decoding_buffer;
1185 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1187 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1190 while ((i >= 0 && isdigit (encoded[i]))
1191 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1193 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1195 else if (encoded[i] == '$')
1199 /* The first few characters that are not alphabetic are not part
1200 of any encoding we use, so we can copy them over verbatim. */
1202 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1203 decoded[j] = encoded[i];
1208 /* Is this a symbol function? */
1209 if (at_start_name && encoded[i] == 'O')
1213 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1215 int op_len = strlen (ada_opname_table[k].encoded);
1216 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1218 && !isalnum (encoded[i + op_len]))
1220 strcpy (decoded + j, ada_opname_table[k].decoded);
1223 j += strlen (ada_opname_table[k].decoded);
1227 if (ada_opname_table[k].encoded != NULL)
1232 /* Replace "TK__" with "__", which will eventually be translated
1233 into "." (just below). */
1235 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1238 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1239 be translated into "." (just below). These are internal names
1240 generated for anonymous blocks inside which our symbol is nested. */
1242 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1243 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1244 && isdigit (encoded [i+4]))
1248 while (k < len0 && isdigit (encoded[k]))
1249 k++; /* Skip any extra digit. */
1251 /* Double-check that the "__B_{DIGITS}+" sequence we found
1252 is indeed followed by "__". */
1253 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1257 /* Remove _E{DIGITS}+[sb] */
1259 /* Just as for protected object subprograms, there are 2 categories
1260 of subprograms created by the compiler for each entry. The first
1261 one implements the actual entry code, and has a suffix following
1262 the convention above; the second one implements the barrier and
1263 uses the same convention as above, except that the 'E' is replaced
1266 Just as above, we do not decode the name of barrier functions
1267 to give the user a clue that the code he is debugging has been
1268 internally generated. */
1270 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1271 && isdigit (encoded[i+2]))
1275 while (k < len0 && isdigit (encoded[k]))
1279 && (encoded[k] == 'b' || encoded[k] == 's'))
1282 /* Just as an extra precaution, make sure that if this
1283 suffix is followed by anything else, it is a '_'.
1284 Otherwise, we matched this sequence by accident. */
1286 || (k < len0 && encoded[k] == '_'))
1291 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1292 the GNAT front-end in protected object subprograms. */
1295 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1297 /* Backtrack a bit up until we reach either the begining of
1298 the encoded name, or "__". Make sure that we only find
1299 digits or lowercase characters. */
1300 const char *ptr = encoded + i - 1;
1302 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1305 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1309 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1311 /* This is a X[bn]* sequence not separated from the previous
1312 part of the name with a non-alpha-numeric character (in other
1313 words, immediately following an alpha-numeric character), then
1314 verify that it is placed at the end of the encoded name. If
1315 not, then the encoding is not valid and we should abort the
1316 decoding. Otherwise, just skip it, it is used in body-nested
1320 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1324 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1326 /* Replace '__' by '.'. */
1334 /* It's a character part of the decoded name, so just copy it
1336 decoded[j] = encoded[i];
1341 decoded[j] = '\000';
1343 /* Decoded names should never contain any uppercase character.
1344 Double-check this, and abort the decoding if we find one. */
1346 for (i = 0; decoded[i] != '\0'; i += 1)
1347 if (isupper (decoded[i]) || decoded[i] == ' ')
1350 if (strcmp (decoded, encoded) == 0)
1356 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1357 decoded = decoding_buffer;
1358 if (encoded[0] == '<')
1359 strcpy (decoded, encoded);
1361 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1366 /* Table for keeping permanent unique copies of decoded names. Once
1367 allocated, names in this table are never released. While this is a
1368 storage leak, it should not be significant unless there are massive
1369 changes in the set of decoded names in successive versions of a
1370 symbol table loaded during a single session. */
1371 static struct htab *decoded_names_store;
1373 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1374 in the language-specific part of GSYMBOL, if it has not been
1375 previously computed. Tries to save the decoded name in the same
1376 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1377 in any case, the decoded symbol has a lifetime at least that of
1379 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1380 const, but nevertheless modified to a semantically equivalent form
1381 when a decoded name is cached in it. */
1384 ada_decode_symbol (const struct general_symbol_info *arg)
1386 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1387 const char **resultp =
1388 &gsymbol->language_specific.demangled_name;
1390 if (!gsymbol->ada_mangled)
1392 const char *decoded = ada_decode (gsymbol->name);
1393 struct obstack *obstack = gsymbol->language_specific.obstack;
1395 gsymbol->ada_mangled = 1;
1397 if (obstack != NULL)
1399 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1402 /* Sometimes, we can't find a corresponding objfile, in
1403 which case, we put the result on the heap. Since we only
1404 decode when needed, we hope this usually does not cause a
1405 significant memory leak (FIXME). */
1407 char **slot = (char **) htab_find_slot (decoded_names_store,
1411 *slot = xstrdup (decoded);
1420 ada_la_decode (const char *encoded, int options)
1422 return xstrdup (ada_decode (encoded));
1425 /* Implement la_sniff_from_mangled_name for Ada. */
1428 ada_sniff_from_mangled_name (const char *mangled, char **out)
1430 const char *demangled = ada_decode (mangled);
1434 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1436 /* Set the gsymbol language to Ada, but still return 0.
1437 Two reasons for that:
1439 1. For Ada, we prefer computing the symbol's decoded name
1440 on the fly rather than pre-compute it, in order to save
1441 memory (Ada projects are typically very large).
1443 2. There are some areas in the definition of the GNAT
1444 encoding where, with a bit of bad luck, we might be able
1445 to decode a non-Ada symbol, generating an incorrect
1446 demangled name (Eg: names ending with "TB" for instance
1447 are identified as task bodies and so stripped from
1448 the decoded name returned).
1450 Returning 1, here, but not setting *DEMANGLED, helps us get a
1451 little bit of the best of both worlds. Because we're last,
1452 we should not affect any of the other languages that were
1453 able to demangle the symbol before us; we get to correctly
1454 tag Ada symbols as such; and even if we incorrectly tagged a
1455 non-Ada symbol, which should be rare, any routing through the
1456 Ada language should be transparent (Ada tries to behave much
1457 like C/C++ with non-Ada symbols). */
1468 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1469 generated by the GNAT compiler to describe the index type used
1470 for each dimension of an array, check whether it follows the latest
1471 known encoding. If not, fix it up to conform to the latest encoding.
1472 Otherwise, do nothing. This function also does nothing if
1473 INDEX_DESC_TYPE is NULL.
1475 The GNAT encoding used to describle the array index type evolved a bit.
1476 Initially, the information would be provided through the name of each
1477 field of the structure type only, while the type of these fields was
1478 described as unspecified and irrelevant. The debugger was then expected
1479 to perform a global type lookup using the name of that field in order
1480 to get access to the full index type description. Because these global
1481 lookups can be very expensive, the encoding was later enhanced to make
1482 the global lookup unnecessary by defining the field type as being
1483 the full index type description.
1485 The purpose of this routine is to allow us to support older versions
1486 of the compiler by detecting the use of the older encoding, and by
1487 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1488 we essentially replace each field's meaningless type by the associated
1492 ada_fixup_array_indexes_type (struct type *index_desc_type)
1496 if (index_desc_type == NULL)
1498 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1500 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1501 to check one field only, no need to check them all). If not, return
1504 If our INDEX_DESC_TYPE was generated using the older encoding,
1505 the field type should be a meaningless integer type whose name
1506 is not equal to the field name. */
1507 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1508 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1509 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1512 /* Fixup each field of INDEX_DESC_TYPE. */
1513 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1515 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1516 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1519 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1523 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1525 static const char *bound_name[] = {
1526 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1527 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1530 /* Maximum number of array dimensions we are prepared to handle. */
1532 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1535 /* The desc_* routines return primitive portions of array descriptors
1538 /* The descriptor or array type, if any, indicated by TYPE; removes
1539 level of indirection, if needed. */
1541 static struct type *
1542 desc_base_type (struct type *type)
1546 type = ada_check_typedef (type);
1547 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1548 type = ada_typedef_target_type (type);
1551 && (TYPE_CODE (type) == TYPE_CODE_PTR
1552 || TYPE_CODE (type) == TYPE_CODE_REF))
1553 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1558 /* True iff TYPE indicates a "thin" array pointer type. */
1561 is_thin_pntr (struct type *type)
1564 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1565 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1568 /* The descriptor type for thin pointer type TYPE. */
1570 static struct type *
1571 thin_descriptor_type (struct type *type)
1573 struct type *base_type = desc_base_type (type);
1575 if (base_type == NULL)
1577 if (is_suffix (ada_type_name (base_type), "___XVE"))
1581 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1583 if (alt_type == NULL)
1590 /* A pointer to the array data for thin-pointer value VAL. */
1592 static struct value *
1593 thin_data_pntr (struct value *val)
1595 struct type *type = ada_check_typedef (value_type (val));
1596 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1598 data_type = lookup_pointer_type (data_type);
1600 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1601 return value_cast (data_type, value_copy (val));
1603 return value_from_longest (data_type, value_address (val));
1606 /* True iff TYPE indicates a "thick" array pointer type. */
1609 is_thick_pntr (struct type *type)
1611 type = desc_base_type (type);
1612 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1613 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1616 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1617 pointer to one, the type of its bounds data; otherwise, NULL. */
1619 static struct type *
1620 desc_bounds_type (struct type *type)
1624 type = desc_base_type (type);
1628 else if (is_thin_pntr (type))
1630 type = thin_descriptor_type (type);
1633 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1635 return ada_check_typedef (r);
1637 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1639 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1641 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1646 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1647 one, a pointer to its bounds data. Otherwise NULL. */
1649 static struct value *
1650 desc_bounds (struct value *arr)
1652 struct type *type = ada_check_typedef (value_type (arr));
1654 if (is_thin_pntr (type))
1656 struct type *bounds_type =
1657 desc_bounds_type (thin_descriptor_type (type));
1660 if (bounds_type == NULL)
1661 error (_("Bad GNAT array descriptor"));
1663 /* NOTE: The following calculation is not really kosher, but
1664 since desc_type is an XVE-encoded type (and shouldn't be),
1665 the correct calculation is a real pain. FIXME (and fix GCC). */
1666 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1667 addr = value_as_long (arr);
1669 addr = value_address (arr);
1672 value_from_longest (lookup_pointer_type (bounds_type),
1673 addr - TYPE_LENGTH (bounds_type));
1676 else if (is_thick_pntr (type))
1678 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1679 _("Bad GNAT array descriptor"));
1680 struct type *p_bounds_type = value_type (p_bounds);
1683 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1685 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1687 if (TYPE_STUB (target_type))
1688 p_bounds = value_cast (lookup_pointer_type
1689 (ada_check_typedef (target_type)),
1693 error (_("Bad GNAT array descriptor"));
1701 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1702 position of the field containing the address of the bounds data. */
1705 fat_pntr_bounds_bitpos (struct type *type)
1707 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1710 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1711 size of the field containing the address of the bounds data. */
1714 fat_pntr_bounds_bitsize (struct type *type)
1716 type = desc_base_type (type);
1718 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1719 return TYPE_FIELD_BITSIZE (type, 1);
1721 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1724 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1725 pointer to one, the type of its array data (a array-with-no-bounds type);
1726 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1729 static struct type *
1730 desc_data_target_type (struct type *type)
1732 type = desc_base_type (type);
1734 /* NOTE: The following is bogus; see comment in desc_bounds. */
1735 if (is_thin_pntr (type))
1736 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1737 else if (is_thick_pntr (type))
1739 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1742 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1743 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1749 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1752 static struct value *
1753 desc_data (struct value *arr)
1755 struct type *type = value_type (arr);
1757 if (is_thin_pntr (type))
1758 return thin_data_pntr (arr);
1759 else if (is_thick_pntr (type))
1760 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1761 _("Bad GNAT array descriptor"));
1767 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1768 position of the field containing the address of the data. */
1771 fat_pntr_data_bitpos (struct type *type)
1773 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1776 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1777 size of the field containing the address of the data. */
1780 fat_pntr_data_bitsize (struct type *type)
1782 type = desc_base_type (type);
1784 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1785 return TYPE_FIELD_BITSIZE (type, 0);
1787 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1790 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1791 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1792 bound, if WHICH is 1. The first bound is I=1. */
1794 static struct value *
1795 desc_one_bound (struct value *bounds, int i, int which)
1797 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1798 _("Bad GNAT array descriptor bounds"));
1801 /* If BOUNDS is an array-bounds structure type, return the bit position
1802 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1803 bound, if WHICH is 1. The first bound is I=1. */
1806 desc_bound_bitpos (struct type *type, int i, int which)
1808 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1811 /* If BOUNDS is an array-bounds structure type, return the bit field size
1812 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1813 bound, if WHICH is 1. The first bound is I=1. */
1816 desc_bound_bitsize (struct type *type, int i, int which)
1818 type = desc_base_type (type);
1820 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1821 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1823 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1826 /* If TYPE is the type of an array-bounds structure, the type of its
1827 Ith bound (numbering from 1). Otherwise, NULL. */
1829 static struct type *
1830 desc_index_type (struct type *type, int i)
1832 type = desc_base_type (type);
1834 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1835 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1840 /* The number of index positions in the array-bounds type TYPE.
1841 Return 0 if TYPE is NULL. */
1844 desc_arity (struct type *type)
1846 type = desc_base_type (type);
1849 return TYPE_NFIELDS (type) / 2;
1853 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1854 an array descriptor type (representing an unconstrained array
1858 ada_is_direct_array_type (struct type *type)
1862 type = ada_check_typedef (type);
1863 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1864 || ada_is_array_descriptor_type (type));
1867 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1871 ada_is_array_type (struct type *type)
1874 && (TYPE_CODE (type) == TYPE_CODE_PTR
1875 || TYPE_CODE (type) == TYPE_CODE_REF))
1876 type = TYPE_TARGET_TYPE (type);
1877 return ada_is_direct_array_type (type);
1880 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1883 ada_is_simple_array_type (struct type *type)
1887 type = ada_check_typedef (type);
1888 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1889 || (TYPE_CODE (type) == TYPE_CODE_PTR
1890 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1891 == TYPE_CODE_ARRAY));
1894 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1897 ada_is_array_descriptor_type (struct type *type)
1899 struct type *data_type = desc_data_target_type (type);
1903 type = ada_check_typedef (type);
1904 return (data_type != NULL
1905 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1906 && desc_arity (desc_bounds_type (type)) > 0);
1909 /* Non-zero iff type is a partially mal-formed GNAT array
1910 descriptor. FIXME: This is to compensate for some problems with
1911 debugging output from GNAT. Re-examine periodically to see if it
1915 ada_is_bogus_array_descriptor (struct type *type)
1919 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1920 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1921 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1922 && !ada_is_array_descriptor_type (type);
1926 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1927 (fat pointer) returns the type of the array data described---specifically,
1928 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1929 in from the descriptor; otherwise, they are left unspecified. If
1930 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1931 returns NULL. The result is simply the type of ARR if ARR is not
1934 ada_type_of_array (struct value *arr, int bounds)
1936 if (ada_is_constrained_packed_array_type (value_type (arr)))
1937 return decode_constrained_packed_array_type (value_type (arr));
1939 if (!ada_is_array_descriptor_type (value_type (arr)))
1940 return value_type (arr);
1944 struct type *array_type =
1945 ada_check_typedef (desc_data_target_type (value_type (arr)));
1947 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1948 TYPE_FIELD_BITSIZE (array_type, 0) =
1949 decode_packed_array_bitsize (value_type (arr));
1955 struct type *elt_type;
1957 struct value *descriptor;
1959 elt_type = ada_array_element_type (value_type (arr), -1);
1960 arity = ada_array_arity (value_type (arr));
1962 if (elt_type == NULL || arity == 0)
1963 return ada_check_typedef (value_type (arr));
1965 descriptor = desc_bounds (arr);
1966 if (value_as_long (descriptor) == 0)
1970 struct type *range_type = alloc_type_copy (value_type (arr));
1971 struct type *array_type = alloc_type_copy (value_type (arr));
1972 struct value *low = desc_one_bound (descriptor, arity, 0);
1973 struct value *high = desc_one_bound (descriptor, arity, 1);
1976 create_static_range_type (range_type, value_type (low),
1977 longest_to_int (value_as_long (low)),
1978 longest_to_int (value_as_long (high)));
1979 elt_type = create_array_type (array_type, elt_type, range_type);
1981 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1983 /* We need to store the element packed bitsize, as well as
1984 recompute the array size, because it was previously
1985 computed based on the unpacked element size. */
1986 LONGEST lo = value_as_long (low);
1987 LONGEST hi = value_as_long (high);
1989 TYPE_FIELD_BITSIZE (elt_type, 0) =
1990 decode_packed_array_bitsize (value_type (arr));
1991 /* If the array has no element, then the size is already
1992 zero, and does not need to be recomputed. */
1996 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1998 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2003 return lookup_pointer_type (elt_type);
2007 /* If ARR does not represent an array, returns ARR unchanged.
2008 Otherwise, returns either a standard GDB array with bounds set
2009 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2010 GDB array. Returns NULL if ARR is a null fat pointer. */
2013 ada_coerce_to_simple_array_ptr (struct value *arr)
2015 if (ada_is_array_descriptor_type (value_type (arr)))
2017 struct type *arrType = ada_type_of_array (arr, 1);
2019 if (arrType == NULL)
2021 return value_cast (arrType, value_copy (desc_data (arr)));
2023 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2024 return decode_constrained_packed_array (arr);
2029 /* If ARR does not represent an array, returns ARR unchanged.
2030 Otherwise, returns a standard GDB array describing ARR (which may
2031 be ARR itself if it already is in the proper form). */
2034 ada_coerce_to_simple_array (struct value *arr)
2036 if (ada_is_array_descriptor_type (value_type (arr)))
2038 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2041 error (_("Bounds unavailable for null array pointer."));
2042 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2043 return value_ind (arrVal);
2045 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2046 return decode_constrained_packed_array (arr);
2051 /* If TYPE represents a GNAT array type, return it translated to an
2052 ordinary GDB array type (possibly with BITSIZE fields indicating
2053 packing). For other types, is the identity. */
2056 ada_coerce_to_simple_array_type (struct type *type)
2058 if (ada_is_constrained_packed_array_type (type))
2059 return decode_constrained_packed_array_type (type);
2061 if (ada_is_array_descriptor_type (type))
2062 return ada_check_typedef (desc_data_target_type (type));
2067 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2070 ada_is_packed_array_type (struct type *type)
2074 type = desc_base_type (type);
2075 type = ada_check_typedef (type);
2077 ada_type_name (type) != NULL
2078 && strstr (ada_type_name (type), "___XP") != NULL;
2081 /* Non-zero iff TYPE represents a standard GNAT constrained
2082 packed-array type. */
2085 ada_is_constrained_packed_array_type (struct type *type)
2087 return ada_is_packed_array_type (type)
2088 && !ada_is_array_descriptor_type (type);
2091 /* Non-zero iff TYPE represents an array descriptor for a
2092 unconstrained packed-array type. */
2095 ada_is_unconstrained_packed_array_type (struct type *type)
2097 return ada_is_packed_array_type (type)
2098 && ada_is_array_descriptor_type (type);
2101 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2102 return the size of its elements in bits. */
2105 decode_packed_array_bitsize (struct type *type)
2107 const char *raw_name;
2111 /* Access to arrays implemented as fat pointers are encoded as a typedef
2112 of the fat pointer type. We need the name of the fat pointer type
2113 to do the decoding, so strip the typedef layer. */
2114 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2115 type = ada_typedef_target_type (type);
2117 raw_name = ada_type_name (ada_check_typedef (type));
2119 raw_name = ada_type_name (desc_base_type (type));
2124 tail = strstr (raw_name, "___XP");
2125 gdb_assert (tail != NULL);
2127 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2130 (_("could not understand bit size information on packed array"));
2137 /* Given that TYPE is a standard GDB array type with all bounds filled
2138 in, and that the element size of its ultimate scalar constituents
2139 (that is, either its elements, or, if it is an array of arrays, its
2140 elements' elements, etc.) is *ELT_BITS, return an identical type,
2141 but with the bit sizes of its elements (and those of any
2142 constituent arrays) recorded in the BITSIZE components of its
2143 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2146 Note that, for arrays whose index type has an XA encoding where
2147 a bound references a record discriminant, getting that discriminant,
2148 and therefore the actual value of that bound, is not possible
2149 because none of the given parameters gives us access to the record.
2150 This function assumes that it is OK in the context where it is being
2151 used to return an array whose bounds are still dynamic and where
2152 the length is arbitrary. */
2154 static struct type *
2155 constrained_packed_array_type (struct type *type, long *elt_bits)
2157 struct type *new_elt_type;
2158 struct type *new_type;
2159 struct type *index_type_desc;
2160 struct type *index_type;
2161 LONGEST low_bound, high_bound;
2163 type = ada_check_typedef (type);
2164 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2167 index_type_desc = ada_find_parallel_type (type, "___XA");
2168 if (index_type_desc)
2169 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2172 index_type = TYPE_INDEX_TYPE (type);
2174 new_type = alloc_type_copy (type);
2176 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2178 create_array_type (new_type, new_elt_type, index_type);
2179 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2180 TYPE_NAME (new_type) = ada_type_name (type);
2182 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2183 && is_dynamic_type (check_typedef (index_type)))
2184 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2185 low_bound = high_bound = 0;
2186 if (high_bound < low_bound)
2187 *elt_bits = TYPE_LENGTH (new_type) = 0;
2190 *elt_bits *= (high_bound - low_bound + 1);
2191 TYPE_LENGTH (new_type) =
2192 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2195 TYPE_FIXED_INSTANCE (new_type) = 1;
2199 /* The array type encoded by TYPE, where
2200 ada_is_constrained_packed_array_type (TYPE). */
2202 static struct type *
2203 decode_constrained_packed_array_type (struct type *type)
2205 const char *raw_name = ada_type_name (ada_check_typedef (type));
2208 struct type *shadow_type;
2212 raw_name = ada_type_name (desc_base_type (type));
2217 name = (char *) alloca (strlen (raw_name) + 1);
2218 tail = strstr (raw_name, "___XP");
2219 type = desc_base_type (type);
2221 memcpy (name, raw_name, tail - raw_name);
2222 name[tail - raw_name] = '\000';
2224 shadow_type = ada_find_parallel_type_with_name (type, name);
2226 if (shadow_type == NULL)
2228 lim_warning (_("could not find bounds information on packed array"));
2231 shadow_type = check_typedef (shadow_type);
2233 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2235 lim_warning (_("could not understand bounds "
2236 "information on packed array"));
2240 bits = decode_packed_array_bitsize (type);
2241 return constrained_packed_array_type (shadow_type, &bits);
2244 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2245 array, returns a simple array that denotes that array. Its type is a
2246 standard GDB array type except that the BITSIZEs of the array
2247 target types are set to the number of bits in each element, and the
2248 type length is set appropriately. */
2250 static struct value *
2251 decode_constrained_packed_array (struct value *arr)
2255 /* If our value is a pointer, then dereference it. Likewise if
2256 the value is a reference. Make sure that this operation does not
2257 cause the target type to be fixed, as this would indirectly cause
2258 this array to be decoded. The rest of the routine assumes that
2259 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2260 and "value_ind" routines to perform the dereferencing, as opposed
2261 to using "ada_coerce_ref" or "ada_value_ind". */
2262 arr = coerce_ref (arr);
2263 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2264 arr = value_ind (arr);
2266 type = decode_constrained_packed_array_type (value_type (arr));
2269 error (_("can't unpack array"));
2273 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2274 && ada_is_modular_type (value_type (arr)))
2276 /* This is a (right-justified) modular type representing a packed
2277 array with no wrapper. In order to interpret the value through
2278 the (left-justified) packed array type we just built, we must
2279 first left-justify it. */
2280 int bit_size, bit_pos;
2283 mod = ada_modulus (value_type (arr)) - 1;
2290 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2291 arr = ada_value_primitive_packed_val (arr, NULL,
2292 bit_pos / HOST_CHAR_BIT,
2293 bit_pos % HOST_CHAR_BIT,
2298 return coerce_unspec_val_to_type (arr, type);
2302 /* The value of the element of packed array ARR at the ARITY indices
2303 given in IND. ARR must be a simple array. */
2305 static struct value *
2306 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2309 int bits, elt_off, bit_off;
2310 long elt_total_bit_offset;
2311 struct type *elt_type;
2315 elt_total_bit_offset = 0;
2316 elt_type = ada_check_typedef (value_type (arr));
2317 for (i = 0; i < arity; i += 1)
2319 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2320 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2322 (_("attempt to do packed indexing of "
2323 "something other than a packed array"));
2326 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2327 LONGEST lowerbound, upperbound;
2330 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2332 lim_warning (_("don't know bounds of array"));
2333 lowerbound = upperbound = 0;
2336 idx = pos_atr (ind[i]);
2337 if (idx < lowerbound || idx > upperbound)
2338 lim_warning (_("packed array index %ld out of bounds"),
2340 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2341 elt_total_bit_offset += (idx - lowerbound) * bits;
2342 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2345 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2346 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2348 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2353 /* Non-zero iff TYPE includes negative integer values. */
2356 has_negatives (struct type *type)
2358 switch (TYPE_CODE (type))
2363 return !TYPE_UNSIGNED (type);
2364 case TYPE_CODE_RANGE:
2365 return TYPE_LOW_BOUND (type) < 0;
2369 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2370 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2371 the unpacked buffer.
2373 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2374 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2376 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2379 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2381 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2384 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2385 gdb_byte *unpacked, int unpacked_len,
2386 int is_big_endian, int is_signed_type,
2389 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2390 int src_idx; /* Index into the source area */
2391 int src_bytes_left; /* Number of source bytes left to process. */
2392 int srcBitsLeft; /* Number of source bits left to move */
2393 int unusedLS; /* Number of bits in next significant
2394 byte of source that are unused */
2396 int unpacked_idx; /* Index into the unpacked buffer */
2397 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2399 unsigned long accum; /* Staging area for bits being transferred */
2400 int accumSize; /* Number of meaningful bits in accum */
2403 /* Transmit bytes from least to most significant; delta is the direction
2404 the indices move. */
2405 int delta = is_big_endian ? -1 : 1;
2407 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2409 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2410 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2411 bit_size, unpacked_len);
2413 srcBitsLeft = bit_size;
2414 src_bytes_left = src_len;
2415 unpacked_bytes_left = unpacked_len;
2420 src_idx = src_len - 1;
2422 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2426 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2432 unpacked_idx = unpacked_len - 1;
2436 /* Non-scalar values must be aligned at a byte boundary... */
2438 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2439 /* ... And are placed at the beginning (most-significant) bytes
2441 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2442 unpacked_bytes_left = unpacked_idx + 1;
2447 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2449 src_idx = unpacked_idx = 0;
2450 unusedLS = bit_offset;
2453 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2458 while (src_bytes_left > 0)
2460 /* Mask for removing bits of the next source byte that are not
2461 part of the value. */
2462 unsigned int unusedMSMask =
2463 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2465 /* Sign-extend bits for this byte. */
2466 unsigned int signMask = sign & ~unusedMSMask;
2469 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2470 accumSize += HOST_CHAR_BIT - unusedLS;
2471 if (accumSize >= HOST_CHAR_BIT)
2473 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2474 accumSize -= HOST_CHAR_BIT;
2475 accum >>= HOST_CHAR_BIT;
2476 unpacked_bytes_left -= 1;
2477 unpacked_idx += delta;
2479 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2481 src_bytes_left -= 1;
2484 while (unpacked_bytes_left > 0)
2486 accum |= sign << accumSize;
2487 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2488 accumSize -= HOST_CHAR_BIT;
2491 accum >>= HOST_CHAR_BIT;
2492 unpacked_bytes_left -= 1;
2493 unpacked_idx += delta;
2497 /* Create a new value of type TYPE from the contents of OBJ starting
2498 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2499 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2500 assigning through the result will set the field fetched from.
2501 VALADDR is ignored unless OBJ is NULL, in which case,
2502 VALADDR+OFFSET must address the start of storage containing the
2503 packed value. The value returned in this case is never an lval.
2504 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2507 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2508 long offset, int bit_offset, int bit_size,
2512 const gdb_byte *src; /* First byte containing data to unpack */
2514 const int is_scalar = is_scalar_type (type);
2515 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2516 gdb::byte_vector staging;
2518 type = ada_check_typedef (type);
2521 src = valaddr + offset;
2523 src = value_contents (obj) + offset;
2525 if (is_dynamic_type (type))
2527 /* The length of TYPE might by dynamic, so we need to resolve
2528 TYPE in order to know its actual size, which we then use
2529 to create the contents buffer of the value we return.
2530 The difficulty is that the data containing our object is
2531 packed, and therefore maybe not at a byte boundary. So, what
2532 we do, is unpack the data into a byte-aligned buffer, and then
2533 use that buffer as our object's value for resolving the type. */
2534 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2535 staging.resize (staging_len);
2537 ada_unpack_from_contents (src, bit_offset, bit_size,
2538 staging.data (), staging.size (),
2539 is_big_endian, has_negatives (type),
2541 type = resolve_dynamic_type (type, staging.data (), 0);
2542 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2544 /* This happens when the length of the object is dynamic,
2545 and is actually smaller than the space reserved for it.
2546 For instance, in an array of variant records, the bit_size
2547 we're given is the array stride, which is constant and
2548 normally equal to the maximum size of its element.
2549 But, in reality, each element only actually spans a portion
2551 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2557 v = allocate_value (type);
2558 src = valaddr + offset;
2560 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2562 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2565 v = value_at (type, value_address (obj) + offset);
2566 buf = (gdb_byte *) alloca (src_len);
2567 read_memory (value_address (v), buf, src_len);
2572 v = allocate_value (type);
2573 src = value_contents (obj) + offset;
2578 long new_offset = offset;
2580 set_value_component_location (v, obj);
2581 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2582 set_value_bitsize (v, bit_size);
2583 if (value_bitpos (v) >= HOST_CHAR_BIT)
2586 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2588 set_value_offset (v, new_offset);
2590 /* Also set the parent value. This is needed when trying to
2591 assign a new value (in inferior memory). */
2592 set_value_parent (v, obj);
2595 set_value_bitsize (v, bit_size);
2596 unpacked = value_contents_writeable (v);
2600 memset (unpacked, 0, TYPE_LENGTH (type));
2604 if (staging.size () == TYPE_LENGTH (type))
2606 /* Small short-cut: If we've unpacked the data into a buffer
2607 of the same size as TYPE's length, then we can reuse that,
2608 instead of doing the unpacking again. */
2609 memcpy (unpacked, staging.data (), staging.size ());
2612 ada_unpack_from_contents (src, bit_offset, bit_size,
2613 unpacked, TYPE_LENGTH (type),
2614 is_big_endian, has_negatives (type), is_scalar);
2619 /* Store the contents of FROMVAL into the location of TOVAL.
2620 Return a new value with the location of TOVAL and contents of
2621 FROMVAL. Handles assignment into packed fields that have
2622 floating-point or non-scalar types. */
2624 static struct value *
2625 ada_value_assign (struct value *toval, struct value *fromval)
2627 struct type *type = value_type (toval);
2628 int bits = value_bitsize (toval);
2630 toval = ada_coerce_ref (toval);
2631 fromval = ada_coerce_ref (fromval);
2633 if (ada_is_direct_array_type (value_type (toval)))
2634 toval = ada_coerce_to_simple_array (toval);
2635 if (ada_is_direct_array_type (value_type (fromval)))
2636 fromval = ada_coerce_to_simple_array (fromval);
2638 if (!deprecated_value_modifiable (toval))
2639 error (_("Left operand of assignment is not a modifiable lvalue."));
2641 if (VALUE_LVAL (toval) == lval_memory
2643 && (TYPE_CODE (type) == TYPE_CODE_FLT
2644 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2646 int len = (value_bitpos (toval)
2647 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2649 gdb_byte *buffer = (gdb_byte *) alloca (len);
2651 CORE_ADDR to_addr = value_address (toval);
2653 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2654 fromval = value_cast (type, fromval);
2656 read_memory (to_addr, buffer, len);
2657 from_size = value_bitsize (fromval);
2659 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2661 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2662 ULONGEST from_offset = 0;
2663 if (is_big_endian && is_scalar_type (value_type (fromval)))
2664 from_offset = from_size - bits;
2665 copy_bitwise (buffer, value_bitpos (toval),
2666 value_contents (fromval), from_offset,
2667 bits, is_big_endian);
2668 write_memory_with_notification (to_addr, buffer, len);
2670 val = value_copy (toval);
2671 memcpy (value_contents_raw (val), value_contents (fromval),
2672 TYPE_LENGTH (type));
2673 deprecated_set_value_type (val, type);
2678 return value_assign (toval, fromval);
2682 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2683 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2684 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2685 COMPONENT, and not the inferior's memory. The current contents
2686 of COMPONENT are ignored.
2688 Although not part of the initial design, this function also works
2689 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2690 had a null address, and COMPONENT had an address which is equal to
2691 its offset inside CONTAINER. */
2694 value_assign_to_component (struct value *container, struct value *component,
2697 LONGEST offset_in_container =
2698 (LONGEST) (value_address (component) - value_address (container));
2699 int bit_offset_in_container =
2700 value_bitpos (component) - value_bitpos (container);
2703 val = value_cast (value_type (component), val);
2705 if (value_bitsize (component) == 0)
2706 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2708 bits = value_bitsize (component);
2710 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2714 if (is_scalar_type (check_typedef (value_type (component))))
2716 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2719 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2720 value_bitpos (container) + bit_offset_in_container,
2721 value_contents (val), src_offset, bits, 1);
2724 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2725 value_bitpos (container) + bit_offset_in_container,
2726 value_contents (val), 0, bits, 0);
2729 /* Determine if TYPE is an access to an unconstrained array. */
2732 ada_is_access_to_unconstrained_array (struct type *type)
2734 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2735 && is_thick_pntr (ada_typedef_target_type (type)));
2738 /* The value of the element of array ARR at the ARITY indices given in IND.
2739 ARR may be either a simple array, GNAT array descriptor, or pointer
2743 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2747 struct type *elt_type;
2749 elt = ada_coerce_to_simple_array (arr);
2751 elt_type = ada_check_typedef (value_type (elt));
2752 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2753 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2754 return value_subscript_packed (elt, arity, ind);
2756 for (k = 0; k < arity; k += 1)
2758 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2760 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2761 error (_("too many subscripts (%d expected)"), k);
2763 elt = value_subscript (elt, pos_atr (ind[k]));
2765 if (ada_is_access_to_unconstrained_array (saved_elt_type)
2766 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2768 /* The element is a typedef to an unconstrained array,
2769 except that the value_subscript call stripped the
2770 typedef layer. The typedef layer is GNAT's way to
2771 specify that the element is, at the source level, an
2772 access to the unconstrained array, rather than the
2773 unconstrained array. So, we need to restore that
2774 typedef layer, which we can do by forcing the element's
2775 type back to its original type. Otherwise, the returned
2776 value is going to be printed as the array, rather
2777 than as an access. Another symptom of the same issue
2778 would be that an expression trying to dereference the
2779 element would also be improperly rejected. */
2780 deprecated_set_value_type (elt, saved_elt_type);
2783 elt_type = ada_check_typedef (value_type (elt));
2789 /* Assuming ARR is a pointer to a GDB array, the value of the element
2790 of *ARR at the ARITY indices given in IND.
2791 Does not read the entire array into memory.
2793 Note: Unlike what one would expect, this function is used instead of
2794 ada_value_subscript for basically all non-packed array types. The reason
2795 for this is that a side effect of doing our own pointer arithmetics instead
2796 of relying on value_subscript is that there is no implicit typedef peeling.
2797 This is important for arrays of array accesses, where it allows us to
2798 preserve the fact that the array's element is an array access, where the
2799 access part os encoded in a typedef layer. */
2801 static struct value *
2802 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2805 struct value *array_ind = ada_value_ind (arr);
2807 = check_typedef (value_enclosing_type (array_ind));
2809 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2810 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2811 return value_subscript_packed (array_ind, arity, ind);
2813 for (k = 0; k < arity; k += 1)
2816 struct value *lwb_value;
2818 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2819 error (_("too many subscripts (%d expected)"), k);
2820 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2822 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2823 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2824 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2825 type = TYPE_TARGET_TYPE (type);
2828 return value_ind (arr);
2831 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2832 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2833 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2834 this array is LOW, as per Ada rules. */
2835 static struct value *
2836 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2839 struct type *type0 = ada_check_typedef (type);
2840 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2841 struct type *index_type
2842 = create_static_range_type (NULL, base_index_type, low, high);
2843 struct type *slice_type = create_array_type_with_stride
2844 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2845 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2846 TYPE_FIELD_BITSIZE (type0, 0));
2847 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2848 LONGEST base_low_pos, low_pos;
2851 if (!discrete_position (base_index_type, low, &low_pos)
2852 || !discrete_position (base_index_type, base_low, &base_low_pos))
2854 warning (_("unable to get positions in slice, use bounds instead"));
2856 base_low_pos = base_low;
2859 base = value_as_address (array_ptr)
2860 + ((low_pos - base_low_pos)
2861 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2862 return value_at_lazy (slice_type, base);
2866 static struct value *
2867 ada_value_slice (struct value *array, int low, int high)
2869 struct type *type = ada_check_typedef (value_type (array));
2870 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2871 struct type *index_type
2872 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2873 struct type *slice_type = create_array_type_with_stride
2874 (NULL, TYPE_TARGET_TYPE (type), index_type,
2875 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2876 TYPE_FIELD_BITSIZE (type, 0));
2877 LONGEST low_pos, high_pos;
2879 if (!discrete_position (base_index_type, low, &low_pos)
2880 || !discrete_position (base_index_type, high, &high_pos))
2882 warning (_("unable to get positions in slice, use bounds instead"));
2887 return value_cast (slice_type,
2888 value_slice (array, low, high_pos - low_pos + 1));
2891 /* If type is a record type in the form of a standard GNAT array
2892 descriptor, returns the number of dimensions for type. If arr is a
2893 simple array, returns the number of "array of"s that prefix its
2894 type designation. Otherwise, returns 0. */
2897 ada_array_arity (struct type *type)
2904 type = desc_base_type (type);
2907 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2908 return desc_arity (desc_bounds_type (type));
2910 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2913 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2919 /* If TYPE is a record type in the form of a standard GNAT array
2920 descriptor or a simple array type, returns the element type for
2921 TYPE after indexing by NINDICES indices, or by all indices if
2922 NINDICES is -1. Otherwise, returns NULL. */
2925 ada_array_element_type (struct type *type, int nindices)
2927 type = desc_base_type (type);
2929 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2932 struct type *p_array_type;
2934 p_array_type = desc_data_target_type (type);
2936 k = ada_array_arity (type);
2940 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2941 if (nindices >= 0 && k > nindices)
2943 while (k > 0 && p_array_type != NULL)
2945 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2948 return p_array_type;
2950 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2952 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2954 type = TYPE_TARGET_TYPE (type);
2963 /* The type of nth index in arrays of given type (n numbering from 1).
2964 Does not examine memory. Throws an error if N is invalid or TYPE
2965 is not an array type. NAME is the name of the Ada attribute being
2966 evaluated ('range, 'first, 'last, or 'length); it is used in building
2967 the error message. */
2969 static struct type *
2970 ada_index_type (struct type *type, int n, const char *name)
2972 struct type *result_type;
2974 type = desc_base_type (type);
2976 if (n < 0 || n > ada_array_arity (type))
2977 error (_("invalid dimension number to '%s"), name);
2979 if (ada_is_simple_array_type (type))
2983 for (i = 1; i < n; i += 1)
2984 type = TYPE_TARGET_TYPE (type);
2985 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2986 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2987 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2988 perhaps stabsread.c would make more sense. */
2989 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2994 result_type = desc_index_type (desc_bounds_type (type), n);
2995 if (result_type == NULL)
2996 error (_("attempt to take bound of something that is not an array"));
3002 /* Given that arr is an array type, returns the lower bound of the
3003 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3004 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3005 array-descriptor type. It works for other arrays with bounds supplied
3006 by run-time quantities other than discriminants. */
3009 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3011 struct type *type, *index_type_desc, *index_type;
3014 gdb_assert (which == 0 || which == 1);
3016 if (ada_is_constrained_packed_array_type (arr_type))
3017 arr_type = decode_constrained_packed_array_type (arr_type);
3019 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3020 return (LONGEST) - which;
3022 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3023 type = TYPE_TARGET_TYPE (arr_type);
3027 if (TYPE_FIXED_INSTANCE (type))
3029 /* The array has already been fixed, so we do not need to
3030 check the parallel ___XA type again. That encoding has
3031 already been applied, so ignore it now. */
3032 index_type_desc = NULL;
3036 index_type_desc = ada_find_parallel_type (type, "___XA");
3037 ada_fixup_array_indexes_type (index_type_desc);
3040 if (index_type_desc != NULL)
3041 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3045 struct type *elt_type = check_typedef (type);
3047 for (i = 1; i < n; i++)
3048 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3050 index_type = TYPE_INDEX_TYPE (elt_type);
3054 (LONGEST) (which == 0
3055 ? ada_discrete_type_low_bound (index_type)
3056 : ada_discrete_type_high_bound (index_type));
3059 /* Given that arr is an array value, returns the lower bound of the
3060 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3061 WHICH is 1. This routine will also work for arrays with bounds
3062 supplied by run-time quantities other than discriminants. */
3065 ada_array_bound (struct value *arr, int n, int which)
3067 struct type *arr_type;
3069 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3070 arr = value_ind (arr);
3071 arr_type = value_enclosing_type (arr);
3073 if (ada_is_constrained_packed_array_type (arr_type))
3074 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3075 else if (ada_is_simple_array_type (arr_type))
3076 return ada_array_bound_from_type (arr_type, n, which);
3078 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3081 /* Given that arr is an array value, returns the length of the
3082 nth index. This routine will also work for arrays with bounds
3083 supplied by run-time quantities other than discriminants.
3084 Does not work for arrays indexed by enumeration types with representation
3085 clauses at the moment. */
3088 ada_array_length (struct value *arr, int n)
3090 struct type *arr_type, *index_type;
3093 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3094 arr = value_ind (arr);
3095 arr_type = value_enclosing_type (arr);
3097 if (ada_is_constrained_packed_array_type (arr_type))
3098 return ada_array_length (decode_constrained_packed_array (arr), n);
3100 if (ada_is_simple_array_type (arr_type))
3102 low = ada_array_bound_from_type (arr_type, n, 0);
3103 high = ada_array_bound_from_type (arr_type, n, 1);
3107 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3108 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3111 arr_type = check_typedef (arr_type);
3112 index_type = ada_index_type (arr_type, n, "length");
3113 if (index_type != NULL)
3115 struct type *base_type;
3116 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3117 base_type = TYPE_TARGET_TYPE (index_type);
3119 base_type = index_type;
3121 low = pos_atr (value_from_longest (base_type, low));
3122 high = pos_atr (value_from_longest (base_type, high));
3124 return high - low + 1;
3127 /* An array whose type is that of ARR_TYPE (an array type), with
3128 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3129 less than LOW, then LOW-1 is used. */
3131 static struct value *
3132 empty_array (struct type *arr_type, int low, int high)
3134 struct type *arr_type0 = ada_check_typedef (arr_type);
3135 struct type *index_type
3136 = create_static_range_type
3137 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low,
3138 high < low ? low - 1 : high);
3139 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3141 return allocate_value (create_array_type (NULL, elt_type, index_type));
3145 /* Name resolution */
3147 /* The "decoded" name for the user-definable Ada operator corresponding
3151 ada_decoded_op_name (enum exp_opcode op)
3155 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3157 if (ada_opname_table[i].op == op)
3158 return ada_opname_table[i].decoded;
3160 error (_("Could not find operator name for opcode"));
3164 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3165 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3166 undefined namespace) and converts operators that are
3167 user-defined into appropriate function calls. If CONTEXT_TYPE is
3168 non-null, it provides a preferred result type [at the moment, only
3169 type void has any effect---causing procedures to be preferred over
3170 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3171 return type is preferred. May change (expand) *EXP. */
3174 resolve (expression_up *expp, int void_context_p, int parse_completion,
3175 innermost_block_tracker *tracker)
3177 struct type *context_type = NULL;
3181 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3183 resolve_subexp (expp, &pc, 1, context_type, parse_completion, tracker);
3186 /* Resolve the operator of the subexpression beginning at
3187 position *POS of *EXPP. "Resolving" consists of replacing
3188 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3189 with their resolutions, replacing built-in operators with
3190 function calls to user-defined operators, where appropriate, and,
3191 when DEPROCEDURE_P is non-zero, converting function-valued variables
3192 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3193 are as in ada_resolve, above. */
3195 static struct value *
3196 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3197 struct type *context_type, int parse_completion,
3198 innermost_block_tracker *tracker)
3202 struct expression *exp; /* Convenience: == *expp. */
3203 enum exp_opcode op = (*expp)->elts[pc].opcode;
3204 struct value **argvec; /* Vector of operand types (alloca'ed). */
3205 int nargs; /* Number of operands. */
3212 /* Pass one: resolve operands, saving their types and updating *pos,
3217 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3218 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3223 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3225 nargs = longest_to_int (exp->elts[pc + 1].longconst);
3230 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3235 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
3236 parse_completion, tracker);
3239 case OP_ATR_MODULUS:
3249 case TERNOP_IN_RANGE:
3250 case BINOP_IN_BOUNDS:
3256 case OP_DISCRETE_RANGE:
3258 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3267 arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3269 resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
3271 resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
3289 case BINOP_LOGICAL_AND:
3290 case BINOP_LOGICAL_OR:
3291 case BINOP_BITWISE_AND:
3292 case BINOP_BITWISE_IOR:
3293 case BINOP_BITWISE_XOR:
3296 case BINOP_NOTEQUAL:
3303 case BINOP_SUBSCRIPT:
3311 case UNOP_LOGICAL_NOT:
3321 case OP_VAR_MSYM_VALUE:
3328 case OP_INTERNALVAR:
3338 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3341 case STRUCTOP_STRUCT:
3342 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3355 error (_("Unexpected operator during name resolution"));
3358 argvec = XALLOCAVEC (struct value *, nargs + 1);
3359 for (i = 0; i < nargs; i += 1)
3360 argvec[i] = resolve_subexp (expp, pos, 1, NULL, parse_completion,
3365 /* Pass two: perform any resolution on principal operator. */
3372 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3374 std::vector<struct block_symbol> candidates;
3378 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3379 (exp->elts[pc + 2].symbol),
3380 exp->elts[pc + 1].block, VAR_DOMAIN,
3383 if (n_candidates > 1)
3385 /* Types tend to get re-introduced locally, so if there
3386 are any local symbols that are not types, first filter
3389 for (j = 0; j < n_candidates; j += 1)
3390 switch (SYMBOL_CLASS (candidates[j].symbol))
3395 case LOC_REGPARM_ADDR:
3403 if (j < n_candidates)
3406 while (j < n_candidates)
3408 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3410 candidates[j] = candidates[n_candidates - 1];
3419 if (n_candidates == 0)
3420 error (_("No definition found for %s"),
3421 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3422 else if (n_candidates == 1)
3424 else if (deprocedure_p
3425 && !is_nonfunction (candidates.data (), n_candidates))
3427 i = ada_resolve_function
3428 (candidates.data (), n_candidates, NULL, 0,
3429 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3430 context_type, parse_completion);
3432 error (_("Could not find a match for %s"),
3433 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3437 printf_filtered (_("Multiple matches for %s\n"),
3438 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3439 user_select_syms (candidates.data (), n_candidates, 1);
3443 exp->elts[pc + 1].block = candidates[i].block;
3444 exp->elts[pc + 2].symbol = candidates[i].symbol;
3445 tracker->update (candidates[i]);
3449 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3452 replace_operator_with_call (expp, pc, 0, 4,
3453 exp->elts[pc + 2].symbol,
3454 exp->elts[pc + 1].block);
3461 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3462 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3464 std::vector<struct block_symbol> candidates;
3468 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3469 (exp->elts[pc + 5].symbol),
3470 exp->elts[pc + 4].block, VAR_DOMAIN,
3473 if (n_candidates == 1)
3477 i = ada_resolve_function
3478 (candidates.data (), n_candidates,
3480 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3481 context_type, parse_completion);
3483 error (_("Could not find a match for %s"),
3484 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3487 exp->elts[pc + 4].block = candidates[i].block;
3488 exp->elts[pc + 5].symbol = candidates[i].symbol;
3489 tracker->update (candidates[i]);
3500 case BINOP_BITWISE_AND:
3501 case BINOP_BITWISE_IOR:
3502 case BINOP_BITWISE_XOR:
3504 case BINOP_NOTEQUAL:
3512 case UNOP_LOGICAL_NOT:
3514 if (possible_user_operator_p (op, argvec))
3516 std::vector<struct block_symbol> candidates;
3520 ada_lookup_symbol_list (ada_decoded_op_name (op),
3524 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3525 nargs, ada_decoded_op_name (op), NULL,
3530 replace_operator_with_call (expp, pc, nargs, 1,
3531 candidates[i].symbol,
3532 candidates[i].block);
3543 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3544 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3545 exp->elts[pc + 1].objfile,
3546 exp->elts[pc + 2].msymbol);
3548 return evaluate_subexp_type (exp, pos);
3551 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3552 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3554 /* The term "match" here is rather loose. The match is heuristic and
3558 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3560 ftype = ada_check_typedef (ftype);
3561 atype = ada_check_typedef (atype);
3563 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3564 ftype = TYPE_TARGET_TYPE (ftype);
3565 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3566 atype = TYPE_TARGET_TYPE (atype);
3568 switch (TYPE_CODE (ftype))
3571 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3573 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3574 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3575 TYPE_TARGET_TYPE (atype), 0);
3578 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3580 case TYPE_CODE_ENUM:
3581 case TYPE_CODE_RANGE:
3582 switch (TYPE_CODE (atype))
3585 case TYPE_CODE_ENUM:
3586 case TYPE_CODE_RANGE:
3592 case TYPE_CODE_ARRAY:
3593 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3594 || ada_is_array_descriptor_type (atype));
3596 case TYPE_CODE_STRUCT:
3597 if (ada_is_array_descriptor_type (ftype))
3598 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3599 || ada_is_array_descriptor_type (atype));
3601 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3602 && !ada_is_array_descriptor_type (atype));
3604 case TYPE_CODE_UNION:
3606 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3610 /* Return non-zero if the formals of FUNC "sufficiently match" the
3611 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3612 may also be an enumeral, in which case it is treated as a 0-
3613 argument function. */
3616 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3619 struct type *func_type = SYMBOL_TYPE (func);
3621 if (SYMBOL_CLASS (func) == LOC_CONST
3622 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3623 return (n_actuals == 0);
3624 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3627 if (TYPE_NFIELDS (func_type) != n_actuals)
3630 for (i = 0; i < n_actuals; i += 1)
3632 if (actuals[i] == NULL)
3636 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3638 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3640 if (!ada_type_match (ftype, atype, 1))
3647 /* False iff function type FUNC_TYPE definitely does not produce a value
3648 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3649 FUNC_TYPE is not a valid function type with a non-null return type
3650 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3653 return_match (struct type *func_type, struct type *context_type)
3655 struct type *return_type;
3657 if (func_type == NULL)
3660 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3661 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3663 return_type = get_base_type (func_type);
3664 if (return_type == NULL)
3667 context_type = get_base_type (context_type);
3669 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3670 return context_type == NULL || return_type == context_type;
3671 else if (context_type == NULL)
3672 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3674 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3678 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3679 function (if any) that matches the types of the NARGS arguments in
3680 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3681 that returns that type, then eliminate matches that don't. If
3682 CONTEXT_TYPE is void and there is at least one match that does not
3683 return void, eliminate all matches that do.
3685 Asks the user if there is more than one match remaining. Returns -1
3686 if there is no such symbol or none is selected. NAME is used
3687 solely for messages. May re-arrange and modify SYMS in
3688 the process; the index returned is for the modified vector. */
3691 ada_resolve_function (struct block_symbol syms[],
3692 int nsyms, struct value **args, int nargs,
3693 const char *name, struct type *context_type,
3694 int parse_completion)
3698 int m; /* Number of hits */
3701 /* In the first pass of the loop, we only accept functions matching
3702 context_type. If none are found, we add a second pass of the loop
3703 where every function is accepted. */
3704 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3706 for (k = 0; k < nsyms; k += 1)
3708 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3710 if (ada_args_match (syms[k].symbol, args, nargs)
3711 && (fallback || return_match (type, context_type)))
3719 /* If we got multiple matches, ask the user which one to use. Don't do this
3720 interactive thing during completion, though, as the purpose of the
3721 completion is providing a list of all possible matches. Prompting the
3722 user to filter it down would be completely unexpected in this case. */
3725 else if (m > 1 && !parse_completion)
3727 printf_filtered (_("Multiple matches for %s\n"), name);
3728 user_select_syms (syms, m, 1);
3734 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3735 in a listing of choices during disambiguation (see sort_choices, below).
3736 The idea is that overloadings of a subprogram name from the
3737 same package should sort in their source order. We settle for ordering
3738 such symbols by their trailing number (__N or $N). */
3741 encoded_ordered_before (const char *N0, const char *N1)
3745 else if (N0 == NULL)
3751 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3753 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3755 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3756 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3761 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3764 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3766 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3767 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3769 return (strcmp (N0, N1) < 0);
3773 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3777 sort_choices (struct block_symbol syms[], int nsyms)
3781 for (i = 1; i < nsyms; i += 1)
3783 struct block_symbol sym = syms[i];
3786 for (j = i - 1; j >= 0; j -= 1)
3788 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3789 SYMBOL_LINKAGE_NAME (sym.symbol)))
3791 syms[j + 1] = syms[j];
3797 /* Whether GDB should display formals and return types for functions in the
3798 overloads selection menu. */
3799 static int print_signatures = 1;
3801 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3802 all but functions, the signature is just the name of the symbol. For
3803 functions, this is the name of the function, the list of types for formals
3804 and the return type (if any). */
3807 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3808 const struct type_print_options *flags)
3810 struct type *type = SYMBOL_TYPE (sym);
3812 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3813 if (!print_signatures
3815 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3818 if (TYPE_NFIELDS (type) > 0)
3822 fprintf_filtered (stream, " (");
3823 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3826 fprintf_filtered (stream, "; ");
3827 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3830 fprintf_filtered (stream, ")");
3832 if (TYPE_TARGET_TYPE (type) != NULL
3833 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3835 fprintf_filtered (stream, " return ");
3836 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3840 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3841 by asking the user (if necessary), returning the number selected,
3842 and setting the first elements of SYMS items. Error if no symbols
3845 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3846 to be re-integrated one of these days. */
3849 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3852 int *chosen = XALLOCAVEC (int , nsyms);
3854 int first_choice = (max_results == 1) ? 1 : 2;
3855 const char *select_mode = multiple_symbols_select_mode ();
3857 if (max_results < 1)
3858 error (_("Request to select 0 symbols!"));
3862 if (select_mode == multiple_symbols_cancel)
3864 canceled because the command is ambiguous\n\
3865 See set/show multiple-symbol."));
3867 /* If select_mode is "all", then return all possible symbols.
3868 Only do that if more than one symbol can be selected, of course.
3869 Otherwise, display the menu as usual. */
3870 if (select_mode == multiple_symbols_all && max_results > 1)
3873 printf_filtered (_("[0] cancel\n"));
3874 if (max_results > 1)
3875 printf_filtered (_("[1] all\n"));
3877 sort_choices (syms, nsyms);
3879 for (i = 0; i < nsyms; i += 1)
3881 if (syms[i].symbol == NULL)
3884 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3886 struct symtab_and_line sal =
3887 find_function_start_sal (syms[i].symbol, 1);
3889 printf_filtered ("[%d] ", i + first_choice);
3890 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3891 &type_print_raw_options);
3892 if (sal.symtab == NULL)
3893 printf_filtered (_(" at <no source file available>:%d\n"),
3896 printf_filtered (_(" at %s:%d\n"),
3897 symtab_to_filename_for_display (sal.symtab),
3904 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3905 && SYMBOL_TYPE (syms[i].symbol) != NULL
3906 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3907 struct symtab *symtab = NULL;
3909 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3910 symtab = symbol_symtab (syms[i].symbol);
3912 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3914 printf_filtered ("[%d] ", i + first_choice);
3915 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3916 &type_print_raw_options);
3917 printf_filtered (_(" at %s:%d\n"),
3918 symtab_to_filename_for_display (symtab),
3919 SYMBOL_LINE (syms[i].symbol));
3921 else if (is_enumeral
3922 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3924 printf_filtered (("[%d] "), i + first_choice);
3925 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3926 gdb_stdout, -1, 0, &type_print_raw_options);
3927 printf_filtered (_("'(%s) (enumeral)\n"),
3928 SYMBOL_PRINT_NAME (syms[i].symbol));
3932 printf_filtered ("[%d] ", i + first_choice);
3933 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3934 &type_print_raw_options);
3937 printf_filtered (is_enumeral
3938 ? _(" in %s (enumeral)\n")
3940 symtab_to_filename_for_display (symtab));
3942 printf_filtered (is_enumeral
3943 ? _(" (enumeral)\n")
3949 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3952 for (i = 0; i < n_chosen; i += 1)
3953 syms[i] = syms[chosen[i]];
3958 /* Read and validate a set of numeric choices from the user in the
3959 range 0 .. N_CHOICES-1. Place the results in increasing
3960 order in CHOICES[0 .. N-1], and return N.
3962 The user types choices as a sequence of numbers on one line
3963 separated by blanks, encoding them as follows:
3965 + A choice of 0 means to cancel the selection, throwing an error.
3966 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3967 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3969 The user is not allowed to choose more than MAX_RESULTS values.
3971 ANNOTATION_SUFFIX, if present, is used to annotate the input
3972 prompts (for use with the -f switch). */
3975 get_selections (int *choices, int n_choices, int max_results,
3976 int is_all_choice, const char *annotation_suffix)
3981 int first_choice = is_all_choice ? 2 : 1;
3983 prompt = getenv ("PS2");
3987 args = command_line_input (prompt, annotation_suffix);
3990 error_no_arg (_("one or more choice numbers"));
3994 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3995 order, as given in args. Choices are validated. */
4001 args = skip_spaces (args);
4002 if (*args == '\0' && n_chosen == 0)
4003 error_no_arg (_("one or more choice numbers"));
4004 else if (*args == '\0')
4007 choice = strtol (args, &args2, 10);
4008 if (args == args2 || choice < 0
4009 || choice > n_choices + first_choice - 1)
4010 error (_("Argument must be choice number"));
4014 error (_("cancelled"));
4016 if (choice < first_choice)
4018 n_chosen = n_choices;
4019 for (j = 0; j < n_choices; j += 1)
4023 choice -= first_choice;
4025 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4029 if (j < 0 || choice != choices[j])
4033 for (k = n_chosen - 1; k > j; k -= 1)
4034 choices[k + 1] = choices[k];
4035 choices[j + 1] = choice;
4040 if (n_chosen > max_results)
4041 error (_("Select no more than %d of the above"), max_results);
4046 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4047 on the function identified by SYM and BLOCK, and taking NARGS
4048 arguments. Update *EXPP as needed to hold more space. */
4051 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4052 int oplen, struct symbol *sym,
4053 const struct block *block)
4055 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4056 symbol, -oplen for operator being replaced). */
4057 struct expression *newexp = (struct expression *)
4058 xzalloc (sizeof (struct expression)
4059 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4060 struct expression *exp = expp->get ();
4062 newexp->nelts = exp->nelts + 7 - oplen;
4063 newexp->language_defn = exp->language_defn;
4064 newexp->gdbarch = exp->gdbarch;
4065 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4066 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4067 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4069 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4070 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4072 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4073 newexp->elts[pc + 4].block = block;
4074 newexp->elts[pc + 5].symbol = sym;
4076 expp->reset (newexp);
4079 /* Type-class predicates */
4081 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4085 numeric_type_p (struct type *type)
4091 switch (TYPE_CODE (type))
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 (type))
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 (type))
4139 case TYPE_CODE_RANGE:
4140 case TYPE_CODE_ENUM:
4149 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4152 discrete_type_p (struct type *type)
4158 switch (TYPE_CODE (type))
4161 case TYPE_CODE_RANGE:
4162 case TYPE_CODE_ENUM:
4163 case TYPE_CODE_BOOL:
4171 /* Returns non-zero if OP with operands in the vector ARGS could be
4172 a user-defined function. Errs on the side of pre-defined operators
4173 (i.e., result 0). */
4176 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4178 struct type *type0 =
4179 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4180 struct type *type1 =
4181 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4195 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4199 case BINOP_BITWISE_AND:
4200 case BINOP_BITWISE_IOR:
4201 case BINOP_BITWISE_XOR:
4202 return (!(integer_type_p (type0) && integer_type_p (type1)));
4205 case BINOP_NOTEQUAL:
4210 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4213 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4216 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4220 case UNOP_LOGICAL_NOT:
4222 return (!numeric_type_p (type0));
4231 1. In the following, we assume that a renaming type's name may
4232 have an ___XD suffix. It would be nice if this went away at some
4234 2. We handle both the (old) purely type-based representation of
4235 renamings and the (new) variable-based encoding. At some point,
4236 it is devoutly to be hoped that the former goes away
4237 (FIXME: hilfinger-2007-07-09).
4238 3. Subprogram renamings are not implemented, although the XRS
4239 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4241 /* If SYM encodes a renaming,
4243 <renaming> renames <renamed entity>,
4245 sets *LEN to the length of the renamed entity's name,
4246 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4247 the string describing the subcomponent selected from the renamed
4248 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4249 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4250 are undefined). Otherwise, returns a value indicating the category
4251 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4252 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4253 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4254 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4255 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4256 may be NULL, in which case they are not assigned.
4258 [Currently, however, GCC does not generate subprogram renamings.] */
4260 enum ada_renaming_category
4261 ada_parse_renaming (struct symbol *sym,
4262 const char **renamed_entity, int *len,
4263 const char **renaming_expr)
4265 enum ada_renaming_category kind;
4270 return ADA_NOT_RENAMING;
4271 switch (SYMBOL_CLASS (sym))
4274 return ADA_NOT_RENAMING;
4278 case LOC_OPTIMIZED_OUT:
4279 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4281 return ADA_NOT_RENAMING;
4285 kind = ADA_OBJECT_RENAMING;
4289 kind = ADA_EXCEPTION_RENAMING;
4293 kind = ADA_PACKAGE_RENAMING;
4297 kind = ADA_SUBPROGRAM_RENAMING;
4301 return ADA_NOT_RENAMING;
4305 if (renamed_entity != NULL)
4306 *renamed_entity = info;
4307 suffix = strstr (info, "___XE");
4308 if (suffix == NULL || suffix == info)
4309 return ADA_NOT_RENAMING;
4311 *len = strlen (info) - strlen (suffix);
4313 if (renaming_expr != NULL)
4314 *renaming_expr = suffix;
4318 /* Compute the value of the given RENAMING_SYM, which is expected to
4319 be a symbol encoding a renaming expression. BLOCK is the block
4320 used to evaluate the renaming. */
4322 static struct value *
4323 ada_read_renaming_var_value (struct symbol *renaming_sym,
4324 const struct block *block)
4326 const char *sym_name;
4328 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4329 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4330 return evaluate_expression (expr.get ());
4334 /* Evaluation: Function Calls */
4336 /* Return an lvalue containing the value VAL. This is the identity on
4337 lvalues, and otherwise has the side-effect of allocating memory
4338 in the inferior where a copy of the value contents is copied. */
4340 static struct value *
4341 ensure_lval (struct value *val)
4343 if (VALUE_LVAL (val) == not_lval
4344 || VALUE_LVAL (val) == lval_internalvar)
4346 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4347 const CORE_ADDR addr =
4348 value_as_long (value_allocate_space_in_inferior (len));
4350 VALUE_LVAL (val) = lval_memory;
4351 set_value_address (val, addr);
4352 write_memory (addr, value_contents (val), len);
4358 /* Return the value ACTUAL, converted to be an appropriate value for a
4359 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4360 allocating any necessary descriptors (fat pointers), or copies of
4361 values not residing in memory, updating it as needed. */
4364 ada_convert_actual (struct value *actual, struct type *formal_type0)
4366 struct type *actual_type = ada_check_typedef (value_type (actual));
4367 struct type *formal_type = ada_check_typedef (formal_type0);
4368 struct type *formal_target =
4369 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4370 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4371 struct type *actual_target =
4372 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4373 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4375 if (ada_is_array_descriptor_type (formal_target)
4376 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4377 return make_array_descriptor (formal_type, actual);
4378 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4379 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4381 struct value *result;
4383 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4384 && ada_is_array_descriptor_type (actual_target))
4385 result = desc_data (actual);
4386 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4388 if (VALUE_LVAL (actual) != lval_memory)
4392 actual_type = ada_check_typedef (value_type (actual));
4393 val = allocate_value (actual_type);
4394 memcpy ((char *) value_contents_raw (val),
4395 (char *) value_contents (actual),
4396 TYPE_LENGTH (actual_type));
4397 actual = ensure_lval (val);
4399 result = value_addr (actual);
4403 return value_cast_pointers (formal_type, result, 0);
4405 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4406 return ada_value_ind (actual);
4407 else if (ada_is_aligner_type (formal_type))
4409 /* We need to turn this parameter into an aligner type
4411 struct value *aligner = allocate_value (formal_type);
4412 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4414 value_assign_to_component (aligner, component, actual);
4421 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4422 type TYPE. This is usually an inefficient no-op except on some targets
4423 (such as AVR) where the representation of a pointer and an address
4427 value_pointer (struct value *value, struct type *type)
4429 struct gdbarch *gdbarch = get_type_arch (type);
4430 unsigned len = TYPE_LENGTH (type);
4431 gdb_byte *buf = (gdb_byte *) alloca (len);
4434 addr = value_address (value);
4435 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4436 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4441 /* Push a descriptor of type TYPE for array value ARR on the stack at
4442 *SP, updating *SP to reflect the new descriptor. Return either
4443 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4444 to-descriptor type rather than a descriptor type), a struct value *
4445 representing a pointer to this descriptor. */
4447 static struct value *
4448 make_array_descriptor (struct type *type, struct value *arr)
4450 struct type *bounds_type = desc_bounds_type (type);
4451 struct type *desc_type = desc_base_type (type);
4452 struct value *descriptor = allocate_value (desc_type);
4453 struct value *bounds = allocate_value (bounds_type);
4456 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4459 modify_field (value_type (bounds), value_contents_writeable (bounds),
4460 ada_array_bound (arr, i, 0),
4461 desc_bound_bitpos (bounds_type, i, 0),
4462 desc_bound_bitsize (bounds_type, i, 0));
4463 modify_field (value_type (bounds), value_contents_writeable (bounds),
4464 ada_array_bound (arr, i, 1),
4465 desc_bound_bitpos (bounds_type, i, 1),
4466 desc_bound_bitsize (bounds_type, i, 1));
4469 bounds = ensure_lval (bounds);
4471 modify_field (value_type (descriptor),
4472 value_contents_writeable (descriptor),
4473 value_pointer (ensure_lval (arr),
4474 TYPE_FIELD_TYPE (desc_type, 0)),
4475 fat_pntr_data_bitpos (desc_type),
4476 fat_pntr_data_bitsize (desc_type));
4478 modify_field (value_type (descriptor),
4479 value_contents_writeable (descriptor),
4480 value_pointer (bounds,
4481 TYPE_FIELD_TYPE (desc_type, 1)),
4482 fat_pntr_bounds_bitpos (desc_type),
4483 fat_pntr_bounds_bitsize (desc_type));
4485 descriptor = ensure_lval (descriptor);
4487 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4488 return value_addr (descriptor);
4493 /* Symbol Cache Module */
4495 /* Performance measurements made as of 2010-01-15 indicate that
4496 this cache does bring some noticeable improvements. Depending
4497 on the type of entity being printed, the cache can make it as much
4498 as an order of magnitude faster than without it.
4500 The descriptive type DWARF extension has significantly reduced
4501 the need for this cache, at least when DWARF is being used. However,
4502 even in this case, some expensive name-based symbol searches are still
4503 sometimes necessary - to find an XVZ variable, mostly. */
4505 /* Initialize the contents of SYM_CACHE. */
4508 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4510 obstack_init (&sym_cache->cache_space);
4511 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4514 /* Free the memory used by SYM_CACHE. */
4517 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4519 obstack_free (&sym_cache->cache_space, NULL);
4523 /* Return the symbol cache associated to the given program space PSPACE.
4524 If not allocated for this PSPACE yet, allocate and initialize one. */
4526 static struct ada_symbol_cache *
4527 ada_get_symbol_cache (struct program_space *pspace)
4529 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4531 if (pspace_data->sym_cache == NULL)
4533 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4534 ada_init_symbol_cache (pspace_data->sym_cache);
4537 return pspace_data->sym_cache;
4540 /* Clear all entries from the symbol cache. */
4543 ada_clear_symbol_cache (void)
4545 struct ada_symbol_cache *sym_cache
4546 = ada_get_symbol_cache (current_program_space);
4548 obstack_free (&sym_cache->cache_space, NULL);
4549 ada_init_symbol_cache (sym_cache);
4552 /* Search our cache for an entry matching NAME and DOMAIN.
4553 Return it if found, or NULL otherwise. */
4555 static struct cache_entry **
4556 find_entry (const char *name, domain_enum domain)
4558 struct ada_symbol_cache *sym_cache
4559 = ada_get_symbol_cache (current_program_space);
4560 int h = msymbol_hash (name) % HASH_SIZE;
4561 struct cache_entry **e;
4563 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4565 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4571 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4572 Return 1 if found, 0 otherwise.
4574 If an entry was found and SYM is not NULL, set *SYM to the entry's
4575 SYM. Same principle for BLOCK if not NULL. */
4578 lookup_cached_symbol (const char *name, domain_enum domain,
4579 struct symbol **sym, const struct block **block)
4581 struct cache_entry **e = find_entry (name, domain);
4588 *block = (*e)->block;
4592 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4593 in domain DOMAIN, save this result in our symbol cache. */
4596 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4597 const struct block *block)
4599 struct ada_symbol_cache *sym_cache
4600 = ada_get_symbol_cache (current_program_space);
4603 struct cache_entry *e;
4605 /* Symbols for builtin types don't have a block.
4606 For now don't cache such symbols. */
4607 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4610 /* If the symbol is a local symbol, then do not cache it, as a search
4611 for that symbol depends on the context. To determine whether
4612 the symbol is local or not, we check the block where we found it
4613 against the global and static blocks of its associated symtab. */
4615 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4616 GLOBAL_BLOCK) != block
4617 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4618 STATIC_BLOCK) != block)
4621 h = msymbol_hash (name) % HASH_SIZE;
4622 e = XOBNEW (&sym_cache->cache_space, cache_entry);
4623 e->next = sym_cache->root[h];
4624 sym_cache->root[h] = e;
4626 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4627 strcpy (copy, name);
4635 /* Return the symbol name match type that should be used used when
4636 searching for all symbols matching LOOKUP_NAME.
4638 LOOKUP_NAME is expected to be a symbol name after transformation
4641 static symbol_name_match_type
4642 name_match_type_from_name (const char *lookup_name)
4644 return (strstr (lookup_name, "__") == NULL
4645 ? symbol_name_match_type::WILD
4646 : symbol_name_match_type::FULL);
4649 /* Return the result of a standard (literal, C-like) lookup of NAME in
4650 given DOMAIN, visible from lexical block BLOCK. */
4652 static struct symbol *
4653 standard_lookup (const char *name, const struct block *block,
4656 /* Initialize it just to avoid a GCC false warning. */
4657 struct block_symbol sym = {};
4659 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4661 ada_lookup_encoded_symbol (name, block, domain, &sym);
4662 cache_symbol (name, domain, sym.symbol, sym.block);
4667 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4668 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4669 since they contend in overloading in the same way. */
4671 is_nonfunction (struct block_symbol syms[], int n)
4675 for (i = 0; i < n; i += 1)
4676 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4677 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4678 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4684 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4685 struct types. Otherwise, they may not. */
4688 equiv_types (struct type *type0, struct type *type1)
4692 if (type0 == NULL || type1 == NULL
4693 || TYPE_CODE (type0) != TYPE_CODE (type1))
4695 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4696 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4697 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4698 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4704 /* True iff SYM0 represents the same entity as SYM1, or one that is
4705 no more defined than that of SYM1. */
4708 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4712 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4713 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4716 switch (SYMBOL_CLASS (sym0))
4722 struct type *type0 = SYMBOL_TYPE (sym0);
4723 struct type *type1 = SYMBOL_TYPE (sym1);
4724 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4725 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4726 int len0 = strlen (name0);
4729 TYPE_CODE (type0) == TYPE_CODE (type1)
4730 && (equiv_types (type0, type1)
4731 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4732 && startswith (name1 + len0, "___XV")));
4735 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4736 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4742 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4743 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4746 add_defn_to_vec (struct obstack *obstackp,
4748 const struct block *block)
4751 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4753 /* Do not try to complete stub types, as the debugger is probably
4754 already scanning all symbols matching a certain name at the
4755 time when this function is called. Trying to replace the stub
4756 type by its associated full type will cause us to restart a scan
4757 which may lead to an infinite recursion. Instead, the client
4758 collecting the matching symbols will end up collecting several
4759 matches, with at least one of them complete. It can then filter
4760 out the stub ones if needed. */
4762 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4764 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4766 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4768 prevDefns[i].symbol = sym;
4769 prevDefns[i].block = block;
4775 struct block_symbol info;
4779 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4783 /* Number of block_symbol structures currently collected in current vector in
4787 num_defns_collected (struct obstack *obstackp)
4789 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4792 /* Vector of block_symbol structures currently collected in current vector in
4793 OBSTACKP. If FINISH, close off the vector and return its final address. */
4795 static struct block_symbol *
4796 defns_collected (struct obstack *obstackp, int finish)
4799 return (struct block_symbol *) obstack_finish (obstackp);
4801 return (struct block_symbol *) obstack_base (obstackp);
4804 /* Return a bound minimal symbol matching NAME according to Ada
4805 decoding rules. Returns an invalid symbol if there is no such
4806 minimal symbol. Names prefixed with "standard__" are handled
4807 specially: "standard__" is first stripped off, and only static and
4808 global symbols are searched. */
4810 struct bound_minimal_symbol
4811 ada_lookup_simple_minsym (const char *name)
4813 struct bound_minimal_symbol result;
4815 memset (&result, 0, sizeof (result));
4817 symbol_name_match_type match_type = name_match_type_from_name (name);
4818 lookup_name_info lookup_name (name, match_type);
4820 symbol_name_matcher_ftype *match_name
4821 = ada_get_symbol_name_matcher (lookup_name);
4823 for (objfile *objfile : current_program_space->objfiles ())
4825 for (minimal_symbol *msymbol : objfile->msymbols ())
4827 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4828 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4830 result.minsym = msymbol;
4831 result.objfile = objfile;
4840 /* Return all the bound minimal symbols matching NAME according to Ada
4841 decoding rules. Returns an empty vector if there is no such
4842 minimal symbol. Names prefixed with "standard__" are handled
4843 specially: "standard__" is first stripped off, and only static and
4844 global symbols are searched. */
4846 static std::vector<struct bound_minimal_symbol>
4847 ada_lookup_simple_minsyms (const char *name)
4849 std::vector<struct bound_minimal_symbol> result;
4851 symbol_name_match_type match_type = name_match_type_from_name (name);
4852 lookup_name_info lookup_name (name, match_type);
4854 symbol_name_matcher_ftype *match_name
4855 = ada_get_symbol_name_matcher (lookup_name);
4857 for (objfile *objfile : current_program_space->objfiles ())
4859 for (minimal_symbol *msymbol : objfile->msymbols ())
4861 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4862 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4863 result.push_back ({msymbol, objfile});
4870 /* For all subprograms that statically enclose the subprogram of the
4871 selected frame, add symbols matching identifier NAME in DOMAIN
4872 and their blocks to the list of data in OBSTACKP, as for
4873 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4874 with a wildcard prefix. */
4877 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4878 const lookup_name_info &lookup_name,
4883 /* True if TYPE is definitely an artificial type supplied to a symbol
4884 for which no debugging information was given in the symbol file. */
4887 is_nondebugging_type (struct type *type)
4889 const char *name = ada_type_name (type);
4891 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4894 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4895 that are deemed "identical" for practical purposes.
4897 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4898 types and that their number of enumerals is identical (in other
4899 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4902 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4906 /* The heuristic we use here is fairly conservative. We consider
4907 that 2 enumerate types are identical if they have the same
4908 number of enumerals and that all enumerals have the same
4909 underlying value and name. */
4911 /* All enums in the type should have an identical underlying value. */
4912 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4913 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4916 /* All enumerals should also have the same name (modulo any numerical
4918 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4920 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4921 const char *name_2 = TYPE_FIELD_NAME (type2, i);
4922 int len_1 = strlen (name_1);
4923 int len_2 = strlen (name_2);
4925 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4926 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4928 || strncmp (TYPE_FIELD_NAME (type1, i),
4929 TYPE_FIELD_NAME (type2, i),
4937 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4938 that are deemed "identical" for practical purposes. Sometimes,
4939 enumerals are not strictly identical, but their types are so similar
4940 that they can be considered identical.
4942 For instance, consider the following code:
4944 type Color is (Black, Red, Green, Blue, White);
4945 type RGB_Color is new Color range Red .. Blue;
4947 Type RGB_Color is a subrange of an implicit type which is a copy
4948 of type Color. If we call that implicit type RGB_ColorB ("B" is
4949 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4950 As a result, when an expression references any of the enumeral
4951 by name (Eg. "print green"), the expression is technically
4952 ambiguous and the user should be asked to disambiguate. But
4953 doing so would only hinder the user, since it wouldn't matter
4954 what choice he makes, the outcome would always be the same.
4955 So, for practical purposes, we consider them as the same. */
4958 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4962 /* Before performing a thorough comparison check of each type,
4963 we perform a series of inexpensive checks. We expect that these
4964 checks will quickly fail in the vast majority of cases, and thus
4965 help prevent the unnecessary use of a more expensive comparison.
4966 Said comparison also expects us to make some of these checks
4967 (see ada_identical_enum_types_p). */
4969 /* Quick check: All symbols should have an enum type. */
4970 for (i = 0; i < syms.size (); i++)
4971 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
4974 /* Quick check: They should all have the same value. */
4975 for (i = 1; i < syms.size (); i++)
4976 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4979 /* Quick check: They should all have the same number of enumerals. */
4980 for (i = 1; i < syms.size (); i++)
4981 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
4982 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
4985 /* All the sanity checks passed, so we might have a set of
4986 identical enumeration types. Perform a more complete
4987 comparison of the type of each symbol. */
4988 for (i = 1; i < syms.size (); i++)
4989 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4990 SYMBOL_TYPE (syms[0].symbol)))
4996 /* Remove any non-debugging symbols in SYMS that definitely
4997 duplicate other symbols in the list (The only case I know of where
4998 this happens is when object files containing stabs-in-ecoff are
4999 linked with files containing ordinary ecoff debugging symbols (or no
5000 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5001 Returns the number of items in the modified list. */
5004 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5008 /* We should never be called with less than 2 symbols, as there
5009 cannot be any extra symbol in that case. But it's easy to
5010 handle, since we have nothing to do in that case. */
5011 if (syms->size () < 2)
5012 return syms->size ();
5015 while (i < syms->size ())
5019 /* If two symbols have the same name and one of them is a stub type,
5020 the get rid of the stub. */
5022 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5023 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
5025 for (j = 0; j < syms->size (); j++)
5028 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5029 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5030 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5031 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
5036 /* Two symbols with the same name, same class and same address
5037 should be identical. */
5039 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5040 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5041 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
5043 for (j = 0; j < syms->size (); j += 1)
5046 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5047 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5048 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5049 && SYMBOL_CLASS ((*syms)[i].symbol)
5050 == SYMBOL_CLASS ((*syms)[j].symbol)
5051 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5052 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
5058 syms->erase (syms->begin () + i);
5063 /* If all the remaining symbols are identical enumerals, then
5064 just keep the first one and discard the rest.
5066 Unlike what we did previously, we do not discard any entry
5067 unless they are ALL identical. This is because the symbol
5068 comparison is not a strict comparison, but rather a practical
5069 comparison. If all symbols are considered identical, then
5070 we can just go ahead and use the first one and discard the rest.
5071 But if we cannot reduce the list to a single element, we have
5072 to ask the user to disambiguate anyways. And if we have to
5073 present a multiple-choice menu, it's less confusing if the list
5074 isn't missing some choices that were identical and yet distinct. */
5075 if (symbols_are_identical_enums (*syms))
5078 return syms->size ();
5081 /* Given a type that corresponds to a renaming entity, use the type name
5082 to extract the scope (package name or function name, fully qualified,
5083 and following the GNAT encoding convention) where this renaming has been
5087 xget_renaming_scope (struct type *renaming_type)
5089 /* The renaming types adhere to the following convention:
5090 <scope>__<rename>___<XR extension>.
5091 So, to extract the scope, we search for the "___XR" extension,
5092 and then backtrack until we find the first "__". */
5094 const char *name = TYPE_NAME (renaming_type);
5095 const char *suffix = strstr (name, "___XR");
5098 /* Now, backtrack a bit until we find the first "__". Start looking
5099 at suffix - 3, as the <rename> part is at least one character long. */
5101 for (last = suffix - 3; last > name; last--)
5102 if (last[0] == '_' && last[1] == '_')
5105 /* Make a copy of scope and return it. */
5106 return std::string (name, last);
5109 /* Return nonzero if NAME corresponds to a package name. */
5112 is_package_name (const char *name)
5114 /* Here, We take advantage of the fact that no symbols are generated
5115 for packages, while symbols are generated for each function.
5116 So the condition for NAME represent a package becomes equivalent
5117 to NAME not existing in our list of symbols. There is only one
5118 small complication with library-level functions (see below). */
5120 /* If it is a function that has not been defined at library level,
5121 then we should be able to look it up in the symbols. */
5122 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5125 /* Library-level function names start with "_ada_". See if function
5126 "_ada_" followed by NAME can be found. */
5128 /* Do a quick check that NAME does not contain "__", since library-level
5129 functions names cannot contain "__" in them. */
5130 if (strstr (name, "__") != NULL)
5133 std::string fun_name = string_printf ("_ada_%s", name);
5135 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5138 /* Return nonzero if SYM corresponds to a renaming entity that is
5139 not visible from FUNCTION_NAME. */
5142 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5144 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5147 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5149 /* If the rename has been defined in a package, then it is visible. */
5150 if (is_package_name (scope.c_str ()))
5153 /* Check that the rename is in the current function scope by checking
5154 that its name starts with SCOPE. */
5156 /* If the function name starts with "_ada_", it means that it is
5157 a library-level function. Strip this prefix before doing the
5158 comparison, as the encoding for the renaming does not contain
5160 if (startswith (function_name, "_ada_"))
5163 return !startswith (function_name, scope.c_str ());
5166 /* Remove entries from SYMS that corresponds to a renaming entity that
5167 is not visible from the function associated with CURRENT_BLOCK or
5168 that is superfluous due to the presence of more specific renaming
5169 information. Places surviving symbols in the initial entries of
5170 SYMS and returns the number of surviving symbols.
5173 First, in cases where an object renaming is implemented as a
5174 reference variable, GNAT may produce both the actual reference
5175 variable and the renaming encoding. In this case, we discard the
5178 Second, GNAT emits a type following a specified encoding for each renaming
5179 entity. Unfortunately, STABS currently does not support the definition
5180 of types that are local to a given lexical block, so all renamings types
5181 are emitted at library level. As a consequence, if an application
5182 contains two renaming entities using the same name, and a user tries to
5183 print the value of one of these entities, the result of the ada symbol
5184 lookup will also contain the wrong renaming type.
5186 This function partially covers for this limitation by attempting to
5187 remove from the SYMS list renaming symbols that should be visible
5188 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5189 method with the current information available. The implementation
5190 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5192 - When the user tries to print a rename in a function while there
5193 is another rename entity defined in a package: Normally, the
5194 rename in the function has precedence over the rename in the
5195 package, so the latter should be removed from the list. This is
5196 currently not the case.
5198 - This function will incorrectly remove valid renames if
5199 the CURRENT_BLOCK corresponds to a function which symbol name
5200 has been changed by an "Export" pragma. As a consequence,
5201 the user will be unable to print such rename entities. */
5204 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5205 const struct block *current_block)
5207 struct symbol *current_function;
5208 const char *current_function_name;
5210 int is_new_style_renaming;
5212 /* If there is both a renaming foo___XR... encoded as a variable and
5213 a simple variable foo in the same block, discard the latter.
5214 First, zero out such symbols, then compress. */
5215 is_new_style_renaming = 0;
5216 for (i = 0; i < syms->size (); i += 1)
5218 struct symbol *sym = (*syms)[i].symbol;
5219 const struct block *block = (*syms)[i].block;
5223 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5225 name = SYMBOL_LINKAGE_NAME (sym);
5226 suffix = strstr (name, "___XR");
5230 int name_len = suffix - name;
5233 is_new_style_renaming = 1;
5234 for (j = 0; j < syms->size (); j += 1)
5235 if (i != j && (*syms)[j].symbol != NULL
5236 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
5238 && block == (*syms)[j].block)
5239 (*syms)[j].symbol = NULL;
5242 if (is_new_style_renaming)
5246 for (j = k = 0; j < syms->size (); j += 1)
5247 if ((*syms)[j].symbol != NULL)
5249 (*syms)[k] = (*syms)[j];
5255 /* Extract the function name associated to CURRENT_BLOCK.
5256 Abort if unable to do so. */
5258 if (current_block == NULL)
5259 return syms->size ();
5261 current_function = block_linkage_function (current_block);
5262 if (current_function == NULL)
5263 return syms->size ();
5265 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5266 if (current_function_name == NULL)
5267 return syms->size ();
5269 /* Check each of the symbols, and remove it from the list if it is
5270 a type corresponding to a renaming that is out of the scope of
5271 the current block. */
5274 while (i < syms->size ())
5276 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5277 == ADA_OBJECT_RENAMING
5278 && old_renaming_is_invisible ((*syms)[i].symbol,
5279 current_function_name))
5280 syms->erase (syms->begin () + i);
5285 return syms->size ();
5288 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5289 whose name and domain match NAME and DOMAIN respectively.
5290 If no match was found, then extend the search to "enclosing"
5291 routines (in other words, if we're inside a nested function,
5292 search the symbols defined inside the enclosing functions).
5293 If WILD_MATCH_P is nonzero, perform the naming matching in
5294 "wild" mode (see function "wild_match" for more info).
5296 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5299 ada_add_local_symbols (struct obstack *obstackp,
5300 const lookup_name_info &lookup_name,
5301 const struct block *block, domain_enum domain)
5303 int block_depth = 0;
5305 while (block != NULL)
5308 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5310 /* If we found a non-function match, assume that's the one. */
5311 if (is_nonfunction (defns_collected (obstackp, 0),
5312 num_defns_collected (obstackp)))
5315 block = BLOCK_SUPERBLOCK (block);
5318 /* If no luck so far, try to find NAME as a local symbol in some lexically
5319 enclosing subprogram. */
5320 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5321 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5324 /* An object of this type is used as the user_data argument when
5325 calling the map_matching_symbols method. */
5329 struct objfile *objfile;
5330 struct obstack *obstackp;
5331 struct symbol *arg_sym;
5335 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5336 to a list of symbols. DATA0 is a pointer to a struct match_data *
5337 containing the obstack that collects the symbol list, the file that SYM
5338 must come from, a flag indicating whether a non-argument symbol has
5339 been found in the current block, and the last argument symbol
5340 passed in SYM within the current block (if any). When SYM is null,
5341 marking the end of a block, the argument symbol is added if no
5342 other has been found. */
5345 aux_add_nonlocal_symbols (const struct block *block, struct symbol *sym,
5348 struct match_data *data = (struct match_data *) data0;
5352 if (!data->found_sym && data->arg_sym != NULL)
5353 add_defn_to_vec (data->obstackp,
5354 fixup_symbol_section (data->arg_sym, data->objfile),
5356 data->found_sym = 0;
5357 data->arg_sym = NULL;
5361 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5363 else if (SYMBOL_IS_ARGUMENT (sym))
5364 data->arg_sym = sym;
5367 data->found_sym = 1;
5368 add_defn_to_vec (data->obstackp,
5369 fixup_symbol_section (sym, data->objfile),
5376 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5377 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5378 symbols to OBSTACKP. Return whether we found such symbols. */
5381 ada_add_block_renamings (struct obstack *obstackp,
5382 const struct block *block,
5383 const lookup_name_info &lookup_name,
5386 struct using_direct *renaming;
5387 int defns_mark = num_defns_collected (obstackp);
5389 symbol_name_matcher_ftype *name_match
5390 = ada_get_symbol_name_matcher (lookup_name);
5392 for (renaming = block_using (block);
5394 renaming = renaming->next)
5398 /* Avoid infinite recursions: skip this renaming if we are actually
5399 already traversing it.
5401 Currently, symbol lookup in Ada don't use the namespace machinery from
5402 C++/Fortran support: skip namespace imports that use them. */
5403 if (renaming->searched
5404 || (renaming->import_src != NULL
5405 && renaming->import_src[0] != '\0')
5406 || (renaming->import_dest != NULL
5407 && renaming->import_dest[0] != '\0'))
5409 renaming->searched = 1;
5411 /* TODO: here, we perform another name-based symbol lookup, which can
5412 pull its own multiple overloads. In theory, we should be able to do
5413 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5414 not a simple name. But in order to do this, we would need to enhance
5415 the DWARF reader to associate a symbol to this renaming, instead of a
5416 name. So, for now, we do something simpler: re-use the C++/Fortran
5417 namespace machinery. */
5418 r_name = (renaming->alias != NULL
5420 : renaming->declaration);
5421 if (name_match (r_name, lookup_name, NULL))
5423 lookup_name_info decl_lookup_name (renaming->declaration,
5424 lookup_name.match_type ());
5425 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5428 renaming->searched = 0;
5430 return num_defns_collected (obstackp) != defns_mark;
5433 /* Implements compare_names, but only applying the comparision using
5434 the given CASING. */
5437 compare_names_with_case (const char *string1, const char *string2,
5438 enum case_sensitivity casing)
5440 while (*string1 != '\0' && *string2 != '\0')
5444 if (isspace (*string1) || isspace (*string2))
5445 return strcmp_iw_ordered (string1, string2);
5447 if (casing == case_sensitive_off)
5449 c1 = tolower (*string1);
5450 c2 = tolower (*string2);
5467 return strcmp_iw_ordered (string1, string2);
5469 if (*string2 == '\0')
5471 if (is_name_suffix (string1))
5478 if (*string2 == '(')
5479 return strcmp_iw_ordered (string1, string2);
5482 if (casing == case_sensitive_off)
5483 return tolower (*string1) - tolower (*string2);
5485 return *string1 - *string2;
5490 /* Compare STRING1 to STRING2, with results as for strcmp.
5491 Compatible with strcmp_iw_ordered in that...
5493 strcmp_iw_ordered (STRING1, STRING2) <= 0
5497 compare_names (STRING1, STRING2) <= 0
5499 (they may differ as to what symbols compare equal). */
5502 compare_names (const char *string1, const char *string2)
5506 /* Similar to what strcmp_iw_ordered does, we need to perform
5507 a case-insensitive comparison first, and only resort to
5508 a second, case-sensitive, comparison if the first one was
5509 not sufficient to differentiate the two strings. */
5511 result = compare_names_with_case (string1, string2, case_sensitive_off);
5513 result = compare_names_with_case (string1, string2, case_sensitive_on);
5518 /* Convenience function to get at the Ada encoded lookup name for
5519 LOOKUP_NAME, as a C string. */
5522 ada_lookup_name (const lookup_name_info &lookup_name)
5524 return lookup_name.ada ().lookup_name ().c_str ();
5527 /* Add to OBSTACKP all non-local symbols whose name and domain match
5528 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5529 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5530 symbols otherwise. */
5533 add_nonlocal_symbols (struct obstack *obstackp,
5534 const lookup_name_info &lookup_name,
5535 domain_enum domain, int global)
5537 struct match_data data;
5539 memset (&data, 0, sizeof data);
5540 data.obstackp = obstackp;
5542 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5544 for (objfile *objfile : current_program_space->objfiles ())
5546 data.objfile = objfile;
5549 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5551 aux_add_nonlocal_symbols, &data,
5552 symbol_name_match_type::WILD,
5555 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5557 aux_add_nonlocal_symbols, &data,
5558 symbol_name_match_type::FULL,
5561 for (compunit_symtab *cu : objfile->compunits ())
5563 const struct block *global_block
5564 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5566 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5572 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5574 const char *name = ada_lookup_name (lookup_name);
5575 std::string name1 = std::string ("<_ada_") + name + '>';
5577 for (objfile *objfile : current_program_space->objfiles ())
5579 data.objfile = objfile;
5580 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5582 aux_add_nonlocal_symbols,
5584 symbol_name_match_type::FULL,
5590 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5591 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5592 returning the number of matches. Add these to OBSTACKP.
5594 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5595 symbol match within the nest of blocks whose innermost member is BLOCK,
5596 is the one match returned (no other matches in that or
5597 enclosing blocks is returned). If there are any matches in or
5598 surrounding BLOCK, then these alone are returned.
5600 Names prefixed with "standard__" are handled specially:
5601 "standard__" is first stripped off (by the lookup_name
5602 constructor), and only static and global symbols are searched.
5604 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5605 to lookup global symbols. */
5608 ada_add_all_symbols (struct obstack *obstackp,
5609 const struct block *block,
5610 const lookup_name_info &lookup_name,
5613 int *made_global_lookup_p)
5617 if (made_global_lookup_p)
5618 *made_global_lookup_p = 0;
5620 /* Special case: If the user specifies a symbol name inside package
5621 Standard, do a non-wild matching of the symbol name without
5622 the "standard__" prefix. This was primarily introduced in order
5623 to allow the user to specifically access the standard exceptions
5624 using, for instance, Standard.Constraint_Error when Constraint_Error
5625 is ambiguous (due to the user defining its own Constraint_Error
5626 entity inside its program). */
5627 if (lookup_name.ada ().standard_p ())
5630 /* Check the non-global symbols. If we have ANY match, then we're done. */
5635 ada_add_local_symbols (obstackp, lookup_name, block, domain);
5638 /* In the !full_search case we're are being called by
5639 ada_iterate_over_symbols, and we don't want to search
5641 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5643 if (num_defns_collected (obstackp) > 0 || !full_search)
5647 /* No non-global symbols found. Check our cache to see if we have
5648 already performed this search before. If we have, then return
5651 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5652 domain, &sym, &block))
5655 add_defn_to_vec (obstackp, sym, block);
5659 if (made_global_lookup_p)
5660 *made_global_lookup_p = 1;
5662 /* Search symbols from all global blocks. */
5664 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5666 /* Now add symbols from all per-file blocks if we've gotten no hits
5667 (not strictly correct, but perhaps better than an error). */
5669 if (num_defns_collected (obstackp) == 0)
5670 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5673 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5674 is non-zero, enclosing scope and in global scopes, returning the number of
5676 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5677 found and the blocks and symbol tables (if any) in which they were
5680 When full_search is non-zero, any non-function/non-enumeral
5681 symbol match within the nest of blocks whose innermost member is BLOCK,
5682 is the one match returned (no other matches in that or
5683 enclosing blocks is returned). If there are any matches in or
5684 surrounding BLOCK, then these alone are returned.
5686 Names prefixed with "standard__" are handled specially: "standard__"
5687 is first stripped off, and only static and global symbols are searched. */
5690 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5691 const struct block *block,
5693 std::vector<struct block_symbol> *results,
5696 int syms_from_global_search;
5698 auto_obstack obstack;
5700 ada_add_all_symbols (&obstack, block, lookup_name,
5701 domain, full_search, &syms_from_global_search);
5703 ndefns = num_defns_collected (&obstack);
5705 struct block_symbol *base = defns_collected (&obstack, 1);
5706 for (int i = 0; i < ndefns; ++i)
5707 results->push_back (base[i]);
5709 ndefns = remove_extra_symbols (results);
5711 if (ndefns == 0 && full_search && syms_from_global_search)
5712 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5714 if (ndefns == 1 && full_search && syms_from_global_search)
5715 cache_symbol (ada_lookup_name (lookup_name), domain,
5716 (*results)[0].symbol, (*results)[0].block);
5718 ndefns = remove_irrelevant_renamings (results, block);
5723 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5724 in global scopes, returning the number of matches, and filling *RESULTS
5725 with (SYM,BLOCK) tuples.
5727 See ada_lookup_symbol_list_worker for further details. */
5730 ada_lookup_symbol_list (const char *name, const struct block *block,
5732 std::vector<struct block_symbol> *results)
5734 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5735 lookup_name_info lookup_name (name, name_match_type);
5737 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5740 /* Implementation of the la_iterate_over_symbols method. */
5743 ada_iterate_over_symbols
5744 (const struct block *block, const lookup_name_info &name,
5746 gdb::function_view<symbol_found_callback_ftype> callback)
5749 std::vector<struct block_symbol> results;
5751 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5753 for (i = 0; i < ndefs; ++i)
5755 if (!callback (&results[i]))
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 = std::string ("<") + 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;
5796 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5798 if (n_candidates == 0)
5801 block_symbol info = candidates[0];
5802 info.symbol = fixup_symbol_section (info.symbol, NULL);
5806 static struct block_symbol
5807 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5809 const struct block *block,
5810 const domain_enum domain)
5812 struct block_symbol sym;
5814 sym = ada_lookup_symbol (name, block_static_block (block), domain);
5815 if (sym.symbol != NULL)
5818 /* If we haven't found a match at this point, try the primitive
5819 types. In other languages, this search is performed before
5820 searching for global symbols in order to short-circuit that
5821 global-symbol search if it happens that the name corresponds
5822 to a primitive type. But we cannot do the same in Ada, because
5823 it is perfectly legitimate for a program to declare a type which
5824 has the same name as a standard type. If looking up a type in
5825 that situation, we have traditionally ignored the primitive type
5826 in favor of user-defined types. This is why, unlike most other
5827 languages, we search the primitive types this late and only after
5828 having searched the global symbols without success. */
5830 if (domain == VAR_DOMAIN)
5832 struct gdbarch *gdbarch;
5835 gdbarch = target_gdbarch ();
5837 gdbarch = block_gdbarch (block);
5838 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5839 if (sym.symbol != NULL)
5847 /* True iff STR is a possible encoded suffix of a normal Ada name
5848 that is to be ignored for matching purposes. Suffixes of parallel
5849 names (e.g., XVE) are not included here. Currently, the possible suffixes
5850 are given by any of the regular expressions:
5852 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5853 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5854 TKB [subprogram suffix for task bodies]
5855 _E[0-9]+[bs]$ [protected object entry suffixes]
5856 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5858 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5859 match is performed. This sequence is used to differentiate homonyms,
5860 is an optional part of a valid name suffix. */
5863 is_name_suffix (const char *str)
5866 const char *matching;
5867 const int len = strlen (str);
5869 /* Skip optional leading __[0-9]+. */
5871 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5874 while (isdigit (str[0]))
5880 if (str[0] == '.' || str[0] == '$')
5883 while (isdigit (matching[0]))
5885 if (matching[0] == '\0')
5891 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5894 while (isdigit (matching[0]))
5896 if (matching[0] == '\0')
5900 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5902 if (strcmp (str, "TKB") == 0)
5906 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5907 with a N at the end. Unfortunately, the compiler uses the same
5908 convention for other internal types it creates. So treating
5909 all entity names that end with an "N" as a name suffix causes
5910 some regressions. For instance, consider the case of an enumerated
5911 type. To support the 'Image attribute, it creates an array whose
5913 Having a single character like this as a suffix carrying some
5914 information is a bit risky. Perhaps we should change the encoding
5915 to be something like "_N" instead. In the meantime, do not do
5916 the following check. */
5917 /* Protected Object Subprograms */
5918 if (len == 1 && str [0] == 'N')
5923 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5926 while (isdigit (matching[0]))
5928 if ((matching[0] == 'b' || matching[0] == 's')
5929 && matching [1] == '\0')
5933 /* ??? We should not modify STR directly, as we are doing below. This
5934 is fine in this case, but may become problematic later if we find
5935 that this alternative did not work, and want to try matching
5936 another one from the begining of STR. Since we modified it, we
5937 won't be able to find the begining of the string anymore! */
5941 while (str[0] != '_' && str[0] != '\0')
5943 if (str[0] != 'n' && str[0] != 'b')
5949 if (str[0] == '\000')
5954 if (str[1] != '_' || str[2] == '\000')
5958 if (strcmp (str + 3, "JM") == 0)
5960 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5961 the LJM suffix in favor of the JM one. But we will
5962 still accept LJM as a valid suffix for a reasonable
5963 amount of time, just to allow ourselves to debug programs
5964 compiled using an older version of GNAT. */
5965 if (strcmp (str + 3, "LJM") == 0)
5969 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5970 || str[4] == 'U' || str[4] == 'P')
5972 if (str[4] == 'R' && str[5] != 'T')
5976 if (!isdigit (str[2]))
5978 for (k = 3; str[k] != '\0'; k += 1)
5979 if (!isdigit (str[k]) && str[k] != '_')
5983 if (str[0] == '$' && isdigit (str[1]))
5985 for (k = 2; str[k] != '\0'; k += 1)
5986 if (!isdigit (str[k]) && str[k] != '_')
5993 /* Return non-zero if the string starting at NAME and ending before
5994 NAME_END contains no capital letters. */
5997 is_valid_name_for_wild_match (const char *name0)
5999 const char *decoded_name = ada_decode (name0);
6002 /* If the decoded name starts with an angle bracket, it means that
6003 NAME0 does not follow the GNAT encoding format. It should then
6004 not be allowed as a possible wild match. */
6005 if (decoded_name[0] == '<')
6008 for (i=0; decoded_name[i] != '\0'; i++)
6009 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6015 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6016 that could start a simple name. Assumes that *NAMEP points into
6017 the string beginning at NAME0. */
6020 advance_wild_match (const char **namep, const char *name0, int target0)
6022 const char *name = *namep;
6032 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6035 if (name == name0 + 5 && startswith (name0, "_ada"))
6040 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6041 || name[2] == target0))
6049 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6059 /* Return true iff NAME encodes a name of the form prefix.PATN.
6060 Ignores any informational suffixes of NAME (i.e., for which
6061 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6065 wild_match (const char *name, const char *patn)
6068 const char *name0 = name;
6072 const char *match = name;
6076 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6079 if (*p == '\0' && is_name_suffix (name))
6080 return match == name0 || is_valid_name_for_wild_match (name0);
6082 if (name[-1] == '_')
6085 if (!advance_wild_match (&name, name0, *patn))
6090 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6091 any trailing suffixes that encode debugging information or leading
6092 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6093 information that is ignored). */
6096 full_match (const char *sym_name, const char *search_name)
6098 size_t search_name_len = strlen (search_name);
6100 if (strncmp (sym_name, search_name, search_name_len) == 0
6101 && is_name_suffix (sym_name + search_name_len))
6104 if (startswith (sym_name, "_ada_")
6105 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6106 && is_name_suffix (sym_name + search_name_len + 5))
6112 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6113 *defn_symbols, updating the list of symbols in OBSTACKP (if
6114 necessary). OBJFILE is the section containing BLOCK. */
6117 ada_add_block_symbols (struct obstack *obstackp,
6118 const struct block *block,
6119 const lookup_name_info &lookup_name,
6120 domain_enum domain, struct objfile *objfile)
6122 struct block_iterator iter;
6123 /* A matching argument symbol, if any. */
6124 struct symbol *arg_sym;
6125 /* Set true when we find a matching non-argument symbol. */
6131 for (sym = block_iter_match_first (block, lookup_name, &iter);
6133 sym = block_iter_match_next (lookup_name, &iter))
6135 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6136 SYMBOL_DOMAIN (sym), domain))
6138 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6140 if (SYMBOL_IS_ARGUMENT (sym))
6145 add_defn_to_vec (obstackp,
6146 fixup_symbol_section (sym, objfile),
6153 /* Handle renamings. */
6155 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6158 if (!found_sym && arg_sym != NULL)
6160 add_defn_to_vec (obstackp,
6161 fixup_symbol_section (arg_sym, objfile),
6165 if (!lookup_name.ada ().wild_match_p ())
6169 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6170 const char *name = ada_lookup_name.c_str ();
6171 size_t name_len = ada_lookup_name.size ();
6173 ALL_BLOCK_SYMBOLS (block, iter, sym)
6175 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6176 SYMBOL_DOMAIN (sym), domain))
6180 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6183 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6185 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6190 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6192 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6194 if (SYMBOL_IS_ARGUMENT (sym))
6199 add_defn_to_vec (obstackp,
6200 fixup_symbol_section (sym, objfile),
6208 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6209 They aren't parameters, right? */
6210 if (!found_sym && arg_sym != NULL)
6212 add_defn_to_vec (obstackp,
6213 fixup_symbol_section (arg_sym, objfile),
6220 /* Symbol Completion */
6225 ada_lookup_name_info::matches
6226 (const char *sym_name,
6227 symbol_name_match_type match_type,
6228 completion_match_result *comp_match_res) const
6231 const char *text = m_encoded_name.c_str ();
6232 size_t text_len = m_encoded_name.size ();
6234 /* First, test against the fully qualified name of the symbol. */
6236 if (strncmp (sym_name, text, text_len) == 0)
6239 if (match && !m_encoded_p)
6241 /* One needed check before declaring a positive match is to verify
6242 that iff we are doing a verbatim match, the decoded version
6243 of the symbol name starts with '<'. Otherwise, this symbol name
6244 is not a suitable completion. */
6245 const char *sym_name_copy = sym_name;
6246 bool has_angle_bracket;
6248 sym_name = ada_decode (sym_name);
6249 has_angle_bracket = (sym_name[0] == '<');
6250 match = (has_angle_bracket == m_verbatim_p);
6251 sym_name = sym_name_copy;
6254 if (match && !m_verbatim_p)
6256 /* When doing non-verbatim match, another check that needs to
6257 be done is to verify that the potentially matching symbol name
6258 does not include capital letters, because the ada-mode would
6259 not be able to understand these symbol names without the
6260 angle bracket notation. */
6263 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6268 /* Second: Try wild matching... */
6270 if (!match && m_wild_match_p)
6272 /* Since we are doing wild matching, this means that TEXT
6273 may represent an unqualified symbol name. We therefore must
6274 also compare TEXT against the unqualified name of the symbol. */
6275 sym_name = ada_unqualified_name (ada_decode (sym_name));
6277 if (strncmp (sym_name, text, text_len) == 0)
6281 /* Finally: If we found a match, prepare the result to return. */
6286 if (comp_match_res != NULL)
6288 std::string &match_str = comp_match_res->match.storage ();
6291 match_str = ada_decode (sym_name);
6295 match_str = add_angle_brackets (sym_name);
6297 match_str = sym_name;
6301 comp_match_res->set_match (match_str.c_str ());
6307 /* Add the list of possible symbol names completing TEXT to TRACKER.
6308 WORD is the entire command on which completion is made. */
6311 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6312 complete_symbol_mode mode,
6313 symbol_name_match_type name_match_type,
6314 const char *text, const char *word,
6315 enum type_code code)
6318 const struct block *b, *surrounding_static_block = 0;
6319 struct block_iterator iter;
6321 gdb_assert (code == TYPE_CODE_UNDEF);
6323 lookup_name_info lookup_name (text, name_match_type, true);
6325 /* First, look at the partial symtab symbols. */
6326 expand_symtabs_matching (NULL,
6332 /* At this point scan through the misc symbol vectors and add each
6333 symbol you find to the list. Eventually we want to ignore
6334 anything that isn't a text symbol (everything else will be
6335 handled by the psymtab code above). */
6337 for (objfile *objfile : current_program_space->objfiles ())
6339 for (minimal_symbol *msymbol : objfile->msymbols ())
6343 if (completion_skip_symbol (mode, msymbol))
6346 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6348 /* Ada minimal symbols won't have their language set to Ada. If
6349 we let completion_list_add_name compare using the
6350 default/C-like matcher, then when completing e.g., symbols in a
6351 package named "pck", we'd match internal Ada symbols like
6352 "pckS", which are invalid in an Ada expression, unless you wrap
6353 them in '<' '>' to request a verbatim match.
6355 Unfortunately, some Ada encoded names successfully demangle as
6356 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6357 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6358 with the wrong language set. Paper over that issue here. */
6359 if (symbol_language == language_auto
6360 || symbol_language == language_cplus)
6361 symbol_language = language_ada;
6363 completion_list_add_name (tracker,
6365 MSYMBOL_LINKAGE_NAME (msymbol),
6366 lookup_name, text, word);
6370 /* Search upwards from currently selected frame (so that we can
6371 complete on local vars. */
6373 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6375 if (!BLOCK_SUPERBLOCK (b))
6376 surrounding_static_block = b; /* For elmin of dups */
6378 ALL_BLOCK_SYMBOLS (b, iter, sym)
6380 if (completion_skip_symbol (mode, sym))
6383 completion_list_add_name (tracker,
6384 SYMBOL_LANGUAGE (sym),
6385 SYMBOL_LINKAGE_NAME (sym),
6386 lookup_name, text, word);
6390 /* Go through the symtabs and check the externs and statics for
6391 symbols which match. */
6393 for (objfile *objfile : current_program_space->objfiles ())
6395 for (compunit_symtab *s : objfile->compunits ())
6398 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6399 ALL_BLOCK_SYMBOLS (b, iter, sym)
6401 if (completion_skip_symbol (mode, sym))
6404 completion_list_add_name (tracker,
6405 SYMBOL_LANGUAGE (sym),
6406 SYMBOL_LINKAGE_NAME (sym),
6407 lookup_name, text, word);
6412 for (objfile *objfile : current_program_space->objfiles ())
6414 for (compunit_symtab *s : objfile->compunits ())
6417 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6418 /* Don't do this block twice. */
6419 if (b == surrounding_static_block)
6421 ALL_BLOCK_SYMBOLS (b, iter, sym)
6423 if (completion_skip_symbol (mode, sym))
6426 completion_list_add_name (tracker,
6427 SYMBOL_LANGUAGE (sym),
6428 SYMBOL_LINKAGE_NAME (sym),
6429 lookup_name, text, word);
6437 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6438 for tagged types. */
6441 ada_is_dispatch_table_ptr_type (struct type *type)
6445 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6448 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6452 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6455 /* Return non-zero if TYPE is an interface tag. */
6458 ada_is_interface_tag (struct type *type)
6460 const char *name = TYPE_NAME (type);
6465 return (strcmp (name, "ada__tags__interface_tag") == 0);
6468 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6469 to be invisible to users. */
6472 ada_is_ignored_field (struct type *type, int field_num)
6474 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6477 /* Check the name of that field. */
6479 const char *name = TYPE_FIELD_NAME (type, field_num);
6481 /* Anonymous field names should not be printed.
6482 brobecker/2007-02-20: I don't think this can actually happen
6483 but we don't want to print the value of annonymous fields anyway. */
6487 /* Normally, fields whose name start with an underscore ("_")
6488 are fields that have been internally generated by the compiler,
6489 and thus should not be printed. The "_parent" field is special,
6490 however: This is a field internally generated by the compiler
6491 for tagged types, and it contains the components inherited from
6492 the parent type. This field should not be printed as is, but
6493 should not be ignored either. */
6494 if (name[0] == '_' && !startswith (name, "_parent"))
6498 /* If this is the dispatch table of a tagged type or an interface tag,
6500 if (ada_is_tagged_type (type, 1)
6501 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6502 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6505 /* Not a special field, so it should not be ignored. */
6509 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6510 pointer or reference type whose ultimate target has a tag field. */
6513 ada_is_tagged_type (struct type *type, int refok)
6515 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6518 /* True iff TYPE represents the type of X'Tag */
6521 ada_is_tag_type (struct type *type)
6523 type = ada_check_typedef (type);
6525 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6529 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6531 return (name != NULL
6532 && strcmp (name, "ada__tags__dispatch_table") == 0);
6536 /* The type of the tag on VAL. */
6539 ada_tag_type (struct value *val)
6541 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6544 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6545 retired at Ada 05). */
6548 is_ada95_tag (struct value *tag)
6550 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6553 /* The value of the tag on VAL. */
6556 ada_value_tag (struct value *val)
6558 return ada_value_struct_elt (val, "_tag", 0);
6561 /* The value of the tag on the object of type TYPE whose contents are
6562 saved at VALADDR, if it is non-null, or is at memory address
6565 static struct value *
6566 value_tag_from_contents_and_address (struct type *type,
6567 const gdb_byte *valaddr,
6570 int tag_byte_offset;
6571 struct type *tag_type;
6573 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6576 const gdb_byte *valaddr1 = ((valaddr == NULL)
6578 : valaddr + tag_byte_offset);
6579 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6581 return value_from_contents_and_address (tag_type, valaddr1, address1);
6586 static struct type *
6587 type_from_tag (struct value *tag)
6589 const char *type_name = ada_tag_name (tag);
6591 if (type_name != NULL)
6592 return ada_find_any_type (ada_encode (type_name));
6596 /* Given a value OBJ of a tagged type, return a value of this
6597 type at the base address of the object. The base address, as
6598 defined in Ada.Tags, it is the address of the primary tag of
6599 the object, and therefore where the field values of its full
6600 view can be fetched. */
6603 ada_tag_value_at_base_address (struct value *obj)
6606 LONGEST offset_to_top = 0;
6607 struct type *ptr_type, *obj_type;
6609 CORE_ADDR base_address;
6611 obj_type = value_type (obj);
6613 /* It is the responsability of the caller to deref pointers. */
6615 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6616 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6619 tag = ada_value_tag (obj);
6623 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6625 if (is_ada95_tag (tag))
6628 ptr_type = language_lookup_primitive_type
6629 (language_def (language_ada), target_gdbarch(), "storage_offset");
6630 ptr_type = lookup_pointer_type (ptr_type);
6631 val = value_cast (ptr_type, tag);
6635 /* It is perfectly possible that an exception be raised while
6636 trying to determine the base address, just like for the tag;
6637 see ada_tag_name for more details. We do not print the error
6638 message for the same reason. */
6642 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6645 catch (const gdb_exception_error &e)
6650 /* If offset is null, nothing to do. */
6652 if (offset_to_top == 0)
6655 /* -1 is a special case in Ada.Tags; however, what should be done
6656 is not quite clear from the documentation. So do nothing for
6659 if (offset_to_top == -1)
6662 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6663 from the base address. This was however incompatible with
6664 C++ dispatch table: C++ uses a *negative* value to *add*
6665 to the base address. Ada's convention has therefore been
6666 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6667 use the same convention. Here, we support both cases by
6668 checking the sign of OFFSET_TO_TOP. */
6670 if (offset_to_top > 0)
6671 offset_to_top = -offset_to_top;
6673 base_address = value_address (obj) + offset_to_top;
6674 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6676 /* Make sure that we have a proper tag at the new address.
6677 Otherwise, offset_to_top is bogus (which can happen when
6678 the object is not initialized yet). */
6683 obj_type = type_from_tag (tag);
6688 return value_from_contents_and_address (obj_type, NULL, base_address);
6691 /* Return the "ada__tags__type_specific_data" type. */
6693 static struct type *
6694 ada_get_tsd_type (struct inferior *inf)
6696 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6698 if (data->tsd_type == 0)
6699 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6700 return data->tsd_type;
6703 /* Return the TSD (type-specific data) associated to the given TAG.
6704 TAG is assumed to be the tag of a tagged-type entity.
6706 May return NULL if we are unable to get the TSD. */
6708 static struct value *
6709 ada_get_tsd_from_tag (struct value *tag)
6714 /* First option: The TSD is simply stored as a field of our TAG.
6715 Only older versions of GNAT would use this format, but we have
6716 to test it first, because there are no visible markers for
6717 the current approach except the absence of that field. */
6719 val = ada_value_struct_elt (tag, "tsd", 1);
6723 /* Try the second representation for the dispatch table (in which
6724 there is no explicit 'tsd' field in the referent of the tag pointer,
6725 and instead the tsd pointer is stored just before the dispatch
6728 type = ada_get_tsd_type (current_inferior());
6731 type = lookup_pointer_type (lookup_pointer_type (type));
6732 val = value_cast (type, tag);
6735 return value_ind (value_ptradd (val, -1));
6738 /* Given the TSD of a tag (type-specific data), return a string
6739 containing the name of the associated type.
6741 The returned value is good until the next call. May return NULL
6742 if we are unable to determine the tag name. */
6745 ada_tag_name_from_tsd (struct value *tsd)
6747 static char name[1024];
6751 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6754 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6755 for (p = name; *p != '\0'; p += 1)
6761 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6764 Return NULL if the TAG is not an Ada tag, or if we were unable to
6765 determine the name of that tag. The result is good until the next
6769 ada_tag_name (struct value *tag)
6773 if (!ada_is_tag_type (value_type (tag)))
6776 /* It is perfectly possible that an exception be raised while trying
6777 to determine the TAG's name, even under normal circumstances:
6778 The associated variable may be uninitialized or corrupted, for
6779 instance. We do not let any exception propagate past this point.
6780 instead we return NULL.
6782 We also do not print the error message either (which often is very
6783 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6784 the caller print a more meaningful message if necessary. */
6787 struct value *tsd = ada_get_tsd_from_tag (tag);
6790 name = ada_tag_name_from_tsd (tsd);
6792 catch (const gdb_exception_error &e)
6799 /* The parent type of TYPE, or NULL if none. */
6802 ada_parent_type (struct type *type)
6806 type = ada_check_typedef (type);
6808 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6811 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6812 if (ada_is_parent_field (type, i))
6814 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6816 /* If the _parent field is a pointer, then dereference it. */
6817 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6818 parent_type = TYPE_TARGET_TYPE (parent_type);
6819 /* If there is a parallel XVS type, get the actual base type. */
6820 parent_type = ada_get_base_type (parent_type);
6822 return ada_check_typedef (parent_type);
6828 /* True iff field number FIELD_NUM of structure type TYPE contains the
6829 parent-type (inherited) fields of a derived type. Assumes TYPE is
6830 a structure type with at least FIELD_NUM+1 fields. */
6833 ada_is_parent_field (struct type *type, int field_num)
6835 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6837 return (name != NULL
6838 && (startswith (name, "PARENT")
6839 || startswith (name, "_parent")));
6842 /* True iff field number FIELD_NUM of structure type TYPE is a
6843 transparent wrapper field (which should be silently traversed when doing
6844 field selection and flattened when printing). Assumes TYPE is a
6845 structure type with at least FIELD_NUM+1 fields. Such fields are always
6849 ada_is_wrapper_field (struct type *type, int field_num)
6851 const char *name = TYPE_FIELD_NAME (type, field_num);
6853 if (name != NULL && strcmp (name, "RETVAL") == 0)
6855 /* This happens in functions with "out" or "in out" parameters
6856 which are passed by copy. For such functions, GNAT describes
6857 the function's return type as being a struct where the return
6858 value is in a field called RETVAL, and where the other "out"
6859 or "in out" parameters are fields of that struct. This is not
6864 return (name != NULL
6865 && (startswith (name, "PARENT")
6866 || strcmp (name, "REP") == 0
6867 || startswith (name, "_parent")
6868 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6871 /* True iff field number FIELD_NUM of structure or union type TYPE
6872 is a variant wrapper. Assumes TYPE is a structure type with at least
6873 FIELD_NUM+1 fields. */
6876 ada_is_variant_part (struct type *type, int field_num)
6878 /* Only Ada types are eligible. */
6879 if (!ADA_TYPE_P (type))
6882 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6884 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6885 || (is_dynamic_field (type, field_num)
6886 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6887 == TYPE_CODE_UNION)));
6890 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6891 whose discriminants are contained in the record type OUTER_TYPE,
6892 returns the type of the controlling discriminant for the variant.
6893 May return NULL if the type could not be found. */
6896 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6898 const char *name = ada_variant_discrim_name (var_type);
6900 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6903 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6904 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6905 represents a 'when others' clause; otherwise 0. */
6908 ada_is_others_clause (struct type *type, int field_num)
6910 const char *name = TYPE_FIELD_NAME (type, field_num);
6912 return (name != NULL && name[0] == 'O');
6915 /* Assuming that TYPE0 is the type of the variant part of a record,
6916 returns the name of the discriminant controlling the variant.
6917 The value is valid until the next call to ada_variant_discrim_name. */
6920 ada_variant_discrim_name (struct type *type0)
6922 static char *result = NULL;
6923 static size_t result_len = 0;
6926 const char *discrim_end;
6927 const char *discrim_start;
6929 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6930 type = TYPE_TARGET_TYPE (type0);
6934 name = ada_type_name (type);
6936 if (name == NULL || name[0] == '\000')
6939 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6942 if (startswith (discrim_end, "___XVN"))
6945 if (discrim_end == name)
6948 for (discrim_start = discrim_end; discrim_start != name + 3;
6951 if (discrim_start == name + 1)
6953 if ((discrim_start > name + 3
6954 && startswith (discrim_start - 3, "___"))
6955 || discrim_start[-1] == '.')
6959 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6960 strncpy (result, discrim_start, discrim_end - discrim_start);
6961 result[discrim_end - discrim_start] = '\0';
6965 /* Scan STR for a subtype-encoded number, beginning at position K.
6966 Put the position of the character just past the number scanned in
6967 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6968 Return 1 if there was a valid number at the given position, and 0
6969 otherwise. A "subtype-encoded" number consists of the absolute value
6970 in decimal, followed by the letter 'm' to indicate a negative number.
6971 Assumes 0m does not occur. */
6974 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6978 if (!isdigit (str[k]))
6981 /* Do it the hard way so as not to make any assumption about
6982 the relationship of unsigned long (%lu scan format code) and
6985 while (isdigit (str[k]))
6987 RU = RU * 10 + (str[k] - '0');
6994 *R = (-(LONGEST) (RU - 1)) - 1;
7000 /* NOTE on the above: Technically, C does not say what the results of
7001 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7002 number representable as a LONGEST (although either would probably work
7003 in most implementations). When RU>0, the locution in the then branch
7004 above is always equivalent to the negative of RU. */
7011 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7012 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7013 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7016 ada_in_variant (LONGEST val, struct type *type, int field_num)
7018 const char *name = TYPE_FIELD_NAME (type, field_num);
7032 if (!ada_scan_number (name, p + 1, &W, &p))
7042 if (!ada_scan_number (name, p + 1, &L, &p)
7043 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7045 if (val >= L && val <= U)
7057 /* FIXME: Lots of redundancy below. Try to consolidate. */
7059 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7060 ARG_TYPE, extract and return the value of one of its (non-static)
7061 fields. FIELDNO says which field. Differs from value_primitive_field
7062 only in that it can handle packed values of arbitrary type. */
7064 static struct value *
7065 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7066 struct type *arg_type)
7070 arg_type = ada_check_typedef (arg_type);
7071 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7073 /* Handle packed fields. It might be that the field is not packed
7074 relative to its containing structure, but the structure itself is
7075 packed; in this case we must take the bit-field path. */
7076 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
7078 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7079 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7081 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7082 offset + bit_pos / 8,
7083 bit_pos % 8, bit_size, type);
7086 return value_primitive_field (arg1, offset, fieldno, arg_type);
7089 /* Find field with name NAME in object of type TYPE. If found,
7090 set the following for each argument that is non-null:
7091 - *FIELD_TYPE_P to the field's type;
7092 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7093 an object of that type;
7094 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7095 - *BIT_SIZE_P to its size in bits if the field is packed, and
7097 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7098 fields up to but not including the desired field, or by the total
7099 number of fields if not found. A NULL value of NAME never
7100 matches; the function just counts visible fields in this case.
7102 Notice that we need to handle when a tagged record hierarchy
7103 has some components with the same name, like in this scenario:
7105 type Top_T is tagged record
7111 type Middle_T is new Top.Top_T with record
7112 N : Character := 'a';
7116 type Bottom_T is new Middle.Middle_T with record
7118 C : Character := '5';
7120 A : Character := 'J';
7123 Let's say we now have a variable declared and initialized as follow:
7125 TC : Top_A := new Bottom_T;
7127 And then we use this variable to call this function
7129 procedure Assign (Obj: in out Top_T; TV : Integer);
7133 Assign (Top_T (B), 12);
7135 Now, we're in the debugger, and we're inside that procedure
7136 then and we want to print the value of obj.c:
7138 Usually, the tagged record or one of the parent type owns the
7139 component to print and there's no issue but in this particular
7140 case, what does it mean to ask for Obj.C? Since the actual
7141 type for object is type Bottom_T, it could mean two things: type
7142 component C from the Middle_T view, but also component C from
7143 Bottom_T. So in that "undefined" case, when the component is
7144 not found in the non-resolved type (which includes all the
7145 components of the parent type), then resolve it and see if we
7146 get better luck once expanded.
7148 In the case of homonyms in the derived tagged type, we don't
7149 guaranty anything, and pick the one that's easiest for us
7152 Returns 1 if found, 0 otherwise. */
7155 find_struct_field (const char *name, struct type *type, int offset,
7156 struct type **field_type_p,
7157 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7161 int parent_offset = -1;
7163 type = ada_check_typedef (type);
7165 if (field_type_p != NULL)
7166 *field_type_p = NULL;
7167 if (byte_offset_p != NULL)
7169 if (bit_offset_p != NULL)
7171 if (bit_size_p != NULL)
7174 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7176 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7177 int fld_offset = offset + bit_pos / 8;
7178 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7180 if (t_field_name == NULL)
7183 else if (ada_is_parent_field (type, i))
7185 /* This is a field pointing us to the parent type of a tagged
7186 type. As hinted in this function's documentation, we give
7187 preference to fields in the current record first, so what
7188 we do here is just record the index of this field before
7189 we skip it. If it turns out we couldn't find our field
7190 in the current record, then we'll get back to it and search
7191 inside it whether the field might exist in the parent. */
7197 else if (name != NULL && field_name_match (t_field_name, name))
7199 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7201 if (field_type_p != NULL)
7202 *field_type_p = TYPE_FIELD_TYPE (type, i);
7203 if (byte_offset_p != NULL)
7204 *byte_offset_p = fld_offset;
7205 if (bit_offset_p != NULL)
7206 *bit_offset_p = bit_pos % 8;
7207 if (bit_size_p != NULL)
7208 *bit_size_p = bit_size;
7211 else if (ada_is_wrapper_field (type, i))
7213 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7214 field_type_p, byte_offset_p, bit_offset_p,
7215 bit_size_p, index_p))
7218 else if (ada_is_variant_part (type, i))
7220 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7223 struct type *field_type
7224 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7226 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7228 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7230 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7231 field_type_p, byte_offset_p,
7232 bit_offset_p, bit_size_p, index_p))
7236 else if (index_p != NULL)
7240 /* Field not found so far. If this is a tagged type which
7241 has a parent, try finding that field in the parent now. */
7243 if (parent_offset != -1)
7245 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7246 int fld_offset = offset + bit_pos / 8;
7248 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7249 fld_offset, field_type_p, byte_offset_p,
7250 bit_offset_p, bit_size_p, index_p))
7257 /* Number of user-visible fields in record type TYPE. */
7260 num_visible_fields (struct type *type)
7265 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7269 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7270 and search in it assuming it has (class) type TYPE.
7271 If found, return value, else return NULL.
7273 Searches recursively through wrapper fields (e.g., '_parent').
7275 In the case of homonyms in the tagged types, please refer to the
7276 long explanation in find_struct_field's function documentation. */
7278 static struct value *
7279 ada_search_struct_field (const char *name, struct value *arg, int offset,
7283 int parent_offset = -1;
7285 type = ada_check_typedef (type);
7286 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7288 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7290 if (t_field_name == NULL)
7293 else if (ada_is_parent_field (type, i))
7295 /* This is a field pointing us to the parent type of a tagged
7296 type. As hinted in this function's documentation, we give
7297 preference to fields in the current record first, so what
7298 we do here is just record the index of this field before
7299 we skip it. If it turns out we couldn't find our field
7300 in the current record, then we'll get back to it and search
7301 inside it whether the field might exist in the parent. */
7307 else if (field_name_match (t_field_name, name))
7308 return ada_value_primitive_field (arg, offset, i, type);
7310 else if (ada_is_wrapper_field (type, i))
7312 struct value *v = /* Do not let indent join lines here. */
7313 ada_search_struct_field (name, arg,
7314 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7315 TYPE_FIELD_TYPE (type, i));
7321 else if (ada_is_variant_part (type, i))
7323 /* PNH: Do we ever get here? See find_struct_field. */
7325 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7327 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7329 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7331 struct value *v = ada_search_struct_field /* Force line
7334 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7335 TYPE_FIELD_TYPE (field_type, j));
7343 /* Field not found so far. If this is a tagged type which
7344 has a parent, try finding that field in the parent now. */
7346 if (parent_offset != -1)
7348 struct value *v = ada_search_struct_field (
7349 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7350 TYPE_FIELD_TYPE (type, parent_offset));
7359 static struct value *ada_index_struct_field_1 (int *, struct value *,
7360 int, struct type *);
7363 /* Return field #INDEX in ARG, where the index is that returned by
7364 * find_struct_field through its INDEX_P argument. Adjust the address
7365 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7366 * If found, return value, else return NULL. */
7368 static struct value *
7369 ada_index_struct_field (int index, struct value *arg, int offset,
7372 return ada_index_struct_field_1 (&index, arg, offset, type);
7376 /* Auxiliary function for ada_index_struct_field. Like
7377 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7380 static struct value *
7381 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7385 type = ada_check_typedef (type);
7387 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7389 if (TYPE_FIELD_NAME (type, i) == NULL)
7391 else if (ada_is_wrapper_field (type, i))
7393 struct value *v = /* Do not let indent join lines here. */
7394 ada_index_struct_field_1 (index_p, arg,
7395 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7396 TYPE_FIELD_TYPE (type, i));
7402 else if (ada_is_variant_part (type, i))
7404 /* PNH: Do we ever get here? See ada_search_struct_field,
7405 find_struct_field. */
7406 error (_("Cannot assign this kind of variant record"));
7408 else if (*index_p == 0)
7409 return ada_value_primitive_field (arg, offset, i, type);
7416 /* Given ARG, a value of type (pointer or reference to a)*
7417 structure/union, extract the component named NAME from the ultimate
7418 target structure/union and return it as a value with its
7421 The routine searches for NAME among all members of the structure itself
7422 and (recursively) among all members of any wrapper members
7425 If NO_ERR, then simply return NULL in case of error, rather than
7429 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7431 struct type *t, *t1;
7436 t1 = t = ada_check_typedef (value_type (arg));
7437 if (TYPE_CODE (t) == TYPE_CODE_REF)
7439 t1 = TYPE_TARGET_TYPE (t);
7442 t1 = ada_check_typedef (t1);
7443 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7445 arg = coerce_ref (arg);
7450 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7452 t1 = TYPE_TARGET_TYPE (t);
7455 t1 = ada_check_typedef (t1);
7456 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7458 arg = value_ind (arg);
7465 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7469 v = ada_search_struct_field (name, arg, 0, t);
7472 int bit_offset, bit_size, byte_offset;
7473 struct type *field_type;
7476 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7477 address = value_address (ada_value_ind (arg));
7479 address = value_address (ada_coerce_ref (arg));
7481 /* Check to see if this is a tagged type. We also need to handle
7482 the case where the type is a reference to a tagged type, but
7483 we have to be careful to exclude pointers to tagged types.
7484 The latter should be shown as usual (as a pointer), whereas
7485 a reference should mostly be transparent to the user. */
7487 if (ada_is_tagged_type (t1, 0)
7488 || (TYPE_CODE (t1) == TYPE_CODE_REF
7489 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7491 /* We first try to find the searched field in the current type.
7492 If not found then let's look in the fixed type. */
7494 if (!find_struct_field (name, t1, 0,
7495 &field_type, &byte_offset, &bit_offset,
7504 /* Convert to fixed type in all cases, so that we have proper
7505 offsets to each field in unconstrained record types. */
7506 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7507 address, NULL, check_tag);
7509 if (find_struct_field (name, t1, 0,
7510 &field_type, &byte_offset, &bit_offset,
7515 if (TYPE_CODE (t) == TYPE_CODE_REF)
7516 arg = ada_coerce_ref (arg);
7518 arg = ada_value_ind (arg);
7519 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7520 bit_offset, bit_size,
7524 v = value_at_lazy (field_type, address + byte_offset);
7528 if (v != NULL || no_err)
7531 error (_("There is no member named %s."), name);
7537 error (_("Attempt to extract a component of "
7538 "a value that is not a record."));
7541 /* Return a string representation of type TYPE. */
7544 type_as_string (struct type *type)
7546 string_file tmp_stream;
7548 type_print (type, "", &tmp_stream, -1);
7550 return std::move (tmp_stream.string ());
7553 /* Given a type TYPE, look up the type of the component of type named NAME.
7554 If DISPP is non-null, add its byte displacement from the beginning of a
7555 structure (pointed to by a value) of type TYPE to *DISPP (does not
7556 work for packed fields).
7558 Matches any field whose name has NAME as a prefix, possibly
7561 TYPE can be either a struct or union. If REFOK, TYPE may also
7562 be a (pointer or reference)+ to a struct or union, and the
7563 ultimate target type will be searched.
7565 Looks recursively into variant clauses and parent types.
7567 In the case of homonyms in the tagged types, please refer to the
7568 long explanation in find_struct_field's function documentation.
7570 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7571 TYPE is not a type of the right kind. */
7573 static struct type *
7574 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7578 int parent_offset = -1;
7583 if (refok && type != NULL)
7586 type = ada_check_typedef (type);
7587 if (TYPE_CODE (type) != TYPE_CODE_PTR
7588 && TYPE_CODE (type) != TYPE_CODE_REF)
7590 type = TYPE_TARGET_TYPE (type);
7594 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7595 && TYPE_CODE (type) != TYPE_CODE_UNION))
7600 error (_("Type %s is not a structure or union type"),
7601 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7604 type = to_static_fixed_type (type);
7606 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7608 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7611 if (t_field_name == NULL)
7614 else if (ada_is_parent_field (type, i))
7616 /* This is a field pointing us to the parent type of a tagged
7617 type. As hinted in this function's documentation, we give
7618 preference to fields in the current record first, so what
7619 we do here is just record the index of this field before
7620 we skip it. If it turns out we couldn't find our field
7621 in the current record, then we'll get back to it and search
7622 inside it whether the field might exist in the parent. */
7628 else if (field_name_match (t_field_name, name))
7629 return TYPE_FIELD_TYPE (type, i);
7631 else if (ada_is_wrapper_field (type, i))
7633 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7639 else if (ada_is_variant_part (type, i))
7642 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7645 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7647 /* FIXME pnh 2008/01/26: We check for a field that is
7648 NOT wrapped in a struct, since the compiler sometimes
7649 generates these for unchecked variant types. Revisit
7650 if the compiler changes this practice. */
7651 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7653 if (v_field_name != NULL
7654 && field_name_match (v_field_name, name))
7655 t = TYPE_FIELD_TYPE (field_type, j);
7657 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7668 /* Field not found so far. If this is a tagged type which
7669 has a parent, try finding that field in the parent now. */
7671 if (parent_offset != -1)
7675 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7684 const char *name_str = name != NULL ? name : _("<null>");
7686 error (_("Type %s has no component named %s"),
7687 type_as_string (type).c_str (), name_str);
7693 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7694 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7695 represents an unchecked union (that is, the variant part of a
7696 record that is named in an Unchecked_Union pragma). */
7699 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7701 const char *discrim_name = ada_variant_discrim_name (var_type);
7703 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7707 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7708 within a value of type OUTER_TYPE that is stored in GDB at
7709 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7710 numbering from 0) is applicable. Returns -1 if none are. */
7713 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7714 const gdb_byte *outer_valaddr)
7718 const char *discrim_name = ada_variant_discrim_name (var_type);
7719 struct value *outer;
7720 struct value *discrim;
7721 LONGEST discrim_val;
7723 /* Using plain value_from_contents_and_address here causes problems
7724 because we will end up trying to resolve a type that is currently
7725 being constructed. */
7726 outer = value_from_contents_and_address_unresolved (outer_type,
7728 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7729 if (discrim == NULL)
7731 discrim_val = value_as_long (discrim);
7734 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7736 if (ada_is_others_clause (var_type, i))
7738 else if (ada_in_variant (discrim_val, var_type, i))
7742 return others_clause;
7747 /* Dynamic-Sized Records */
7749 /* Strategy: The type ostensibly attached to a value with dynamic size
7750 (i.e., a size that is not statically recorded in the debugging
7751 data) does not accurately reflect the size or layout of the value.
7752 Our strategy is to convert these values to values with accurate,
7753 conventional types that are constructed on the fly. */
7755 /* There is a subtle and tricky problem here. In general, we cannot
7756 determine the size of dynamic records without its data. However,
7757 the 'struct value' data structure, which GDB uses to represent
7758 quantities in the inferior process (the target), requires the size
7759 of the type at the time of its allocation in order to reserve space
7760 for GDB's internal copy of the data. That's why the
7761 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7762 rather than struct value*s.
7764 However, GDB's internal history variables ($1, $2, etc.) are
7765 struct value*s containing internal copies of the data that are not, in
7766 general, the same as the data at their corresponding addresses in
7767 the target. Fortunately, the types we give to these values are all
7768 conventional, fixed-size types (as per the strategy described
7769 above), so that we don't usually have to perform the
7770 'to_fixed_xxx_type' conversions to look at their values.
7771 Unfortunately, there is one exception: if one of the internal
7772 history variables is an array whose elements are unconstrained
7773 records, then we will need to create distinct fixed types for each
7774 element selected. */
7776 /* The upshot of all of this is that many routines take a (type, host
7777 address, target address) triple as arguments to represent a value.
7778 The host address, if non-null, is supposed to contain an internal
7779 copy of the relevant data; otherwise, the program is to consult the
7780 target at the target address. */
7782 /* Assuming that VAL0 represents a pointer value, the result of
7783 dereferencing it. Differs from value_ind in its treatment of
7784 dynamic-sized types. */
7787 ada_value_ind (struct value *val0)
7789 struct value *val = value_ind (val0);
7791 if (ada_is_tagged_type (value_type (val), 0))
7792 val = ada_tag_value_at_base_address (val);
7794 return ada_to_fixed_value (val);
7797 /* The value resulting from dereferencing any "reference to"
7798 qualifiers on VAL0. */
7800 static struct value *
7801 ada_coerce_ref (struct value *val0)
7803 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7805 struct value *val = val0;
7807 val = coerce_ref (val);
7809 if (ada_is_tagged_type (value_type (val), 0))
7810 val = ada_tag_value_at_base_address (val);
7812 return ada_to_fixed_value (val);
7818 /* Return OFF rounded upward if necessary to a multiple of
7819 ALIGNMENT (a power of 2). */
7822 align_value (unsigned int off, unsigned int alignment)
7824 return (off + alignment - 1) & ~(alignment - 1);
7827 /* Return the bit alignment required for field #F of template type TYPE. */
7830 field_alignment (struct type *type, int f)
7832 const char *name = TYPE_FIELD_NAME (type, f);
7836 /* The field name should never be null, unless the debugging information
7837 is somehow malformed. In this case, we assume the field does not
7838 require any alignment. */
7842 len = strlen (name);
7844 if (!isdigit (name[len - 1]))
7847 if (isdigit (name[len - 2]))
7848 align_offset = len - 2;
7850 align_offset = len - 1;
7852 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7853 return TARGET_CHAR_BIT;
7855 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7858 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7860 static struct symbol *
7861 ada_find_any_type_symbol (const char *name)
7865 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7866 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7869 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7873 /* Find a type named NAME. Ignores ambiguity. This routine will look
7874 solely for types defined by debug info, it will not search the GDB
7877 static struct type *
7878 ada_find_any_type (const char *name)
7880 struct symbol *sym = ada_find_any_type_symbol (name);
7883 return SYMBOL_TYPE (sym);
7888 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7889 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7890 symbol, in which case it is returned. Otherwise, this looks for
7891 symbols whose name is that of NAME_SYM suffixed with "___XR".
7892 Return symbol if found, and NULL otherwise. */
7895 ada_is_renaming_symbol (struct symbol *name_sym)
7897 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
7898 return strstr (name, "___XR") != NULL;
7901 /* Because of GNAT encoding conventions, several GDB symbols may match a
7902 given type name. If the type denoted by TYPE0 is to be preferred to
7903 that of TYPE1 for purposes of type printing, return non-zero;
7904 otherwise return 0. */
7907 ada_prefer_type (struct type *type0, struct type *type1)
7911 else if (type0 == NULL)
7913 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7915 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7917 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7919 else if (ada_is_constrained_packed_array_type (type0))
7921 else if (ada_is_array_descriptor_type (type0)
7922 && !ada_is_array_descriptor_type (type1))
7926 const char *type0_name = TYPE_NAME (type0);
7927 const char *type1_name = TYPE_NAME (type1);
7929 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7930 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7936 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7940 ada_type_name (struct type *type)
7944 return TYPE_NAME (type);
7947 /* Search the list of "descriptive" types associated to TYPE for a type
7948 whose name is NAME. */
7950 static struct type *
7951 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7953 struct type *result, *tmp;
7955 if (ada_ignore_descriptive_types_p)
7958 /* If there no descriptive-type info, then there is no parallel type
7960 if (!HAVE_GNAT_AUX_INFO (type))
7963 result = TYPE_DESCRIPTIVE_TYPE (type);
7964 while (result != NULL)
7966 const char *result_name = ada_type_name (result);
7968 if (result_name == NULL)
7970 warning (_("unexpected null name on descriptive type"));
7974 /* If the names match, stop. */
7975 if (strcmp (result_name, name) == 0)
7978 /* Otherwise, look at the next item on the list, if any. */
7979 if (HAVE_GNAT_AUX_INFO (result))
7980 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7984 /* If not found either, try after having resolved the typedef. */
7989 result = check_typedef (result);
7990 if (HAVE_GNAT_AUX_INFO (result))
7991 result = TYPE_DESCRIPTIVE_TYPE (result);
7997 /* If we didn't find a match, see whether this is a packed array. With
7998 older compilers, the descriptive type information is either absent or
7999 irrelevant when it comes to packed arrays so the above lookup fails.
8000 Fall back to using a parallel lookup by name in this case. */
8001 if (result == NULL && ada_is_constrained_packed_array_type (type))
8002 return ada_find_any_type (name);
8007 /* Find a parallel type to TYPE with the specified NAME, using the
8008 descriptive type taken from the debugging information, if available,
8009 and otherwise using the (slower) name-based method. */
8011 static struct type *
8012 ada_find_parallel_type_with_name (struct type *type, const char *name)
8014 struct type *result = NULL;
8016 if (HAVE_GNAT_AUX_INFO (type))
8017 result = find_parallel_type_by_descriptive_type (type, name);
8019 result = ada_find_any_type (name);
8024 /* Same as above, but specify the name of the parallel type by appending
8025 SUFFIX to the name of TYPE. */
8028 ada_find_parallel_type (struct type *type, const char *suffix)
8031 const char *type_name = ada_type_name (type);
8034 if (type_name == NULL)
8037 len = strlen (type_name);
8039 name = (char *) alloca (len + strlen (suffix) + 1);
8041 strcpy (name, type_name);
8042 strcpy (name + len, suffix);
8044 return ada_find_parallel_type_with_name (type, name);
8047 /* If TYPE is a variable-size record type, return the corresponding template
8048 type describing its fields. Otherwise, return NULL. */
8050 static struct type *
8051 dynamic_template_type (struct type *type)
8053 type = ada_check_typedef (type);
8055 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8056 || ada_type_name (type) == NULL)
8060 int len = strlen (ada_type_name (type));
8062 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8065 return ada_find_parallel_type (type, "___XVE");
8069 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8070 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8073 is_dynamic_field (struct type *templ_type, int field_num)
8075 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8078 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8079 && strstr (name, "___XVL") != NULL;
8082 /* The index of the variant field of TYPE, or -1 if TYPE does not
8083 represent a variant record type. */
8086 variant_field_index (struct type *type)
8090 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8093 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8095 if (ada_is_variant_part (type, f))
8101 /* A record type with no fields. */
8103 static struct type *
8104 empty_record (struct type *templ)
8106 struct type *type = alloc_type_copy (templ);
8108 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8109 TYPE_NFIELDS (type) = 0;
8110 TYPE_FIELDS (type) = NULL;
8111 INIT_NONE_SPECIFIC (type);
8112 TYPE_NAME (type) = "<empty>";
8113 TYPE_LENGTH (type) = 0;
8117 /* An ordinary record type (with fixed-length fields) that describes
8118 the value of type TYPE at VALADDR or ADDRESS (see comments at
8119 the beginning of this section) VAL according to GNAT conventions.
8120 DVAL0 should describe the (portion of a) record that contains any
8121 necessary discriminants. It should be NULL if value_type (VAL) is
8122 an outer-level type (i.e., as opposed to a branch of a variant.) A
8123 variant field (unless unchecked) is replaced by a particular branch
8126 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8127 length are not statically known are discarded. As a consequence,
8128 VALADDR, ADDRESS and DVAL0 are ignored.
8130 NOTE: Limitations: For now, we assume that dynamic fields and
8131 variants occupy whole numbers of bytes. However, they need not be
8135 ada_template_to_fixed_record_type_1 (struct type *type,
8136 const gdb_byte *valaddr,
8137 CORE_ADDR address, struct value *dval0,
8138 int keep_dynamic_fields)
8140 struct value *mark = value_mark ();
8143 int nfields, bit_len;
8149 /* Compute the number of fields in this record type that are going
8150 to be processed: unless keep_dynamic_fields, this includes only
8151 fields whose position and length are static will be processed. */
8152 if (keep_dynamic_fields)
8153 nfields = TYPE_NFIELDS (type);
8157 while (nfields < TYPE_NFIELDS (type)
8158 && !ada_is_variant_part (type, nfields)
8159 && !is_dynamic_field (type, nfields))
8163 rtype = alloc_type_copy (type);
8164 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8165 INIT_NONE_SPECIFIC (rtype);
8166 TYPE_NFIELDS (rtype) = nfields;
8167 TYPE_FIELDS (rtype) = (struct field *)
8168 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8169 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8170 TYPE_NAME (rtype) = ada_type_name (type);
8171 TYPE_FIXED_INSTANCE (rtype) = 1;
8177 for (f = 0; f < nfields; f += 1)
8179 off = align_value (off, field_alignment (type, f))
8180 + TYPE_FIELD_BITPOS (type, f);
8181 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8182 TYPE_FIELD_BITSIZE (rtype, f) = 0;
8184 if (ada_is_variant_part (type, f))
8189 else if (is_dynamic_field (type, f))
8191 const gdb_byte *field_valaddr = valaddr;
8192 CORE_ADDR field_address = address;
8193 struct type *field_type =
8194 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8198 /* rtype's length is computed based on the run-time
8199 value of discriminants. If the discriminants are not
8200 initialized, the type size may be completely bogus and
8201 GDB may fail to allocate a value for it. So check the
8202 size first before creating the value. */
8203 ada_ensure_varsize_limit (rtype);
8204 /* Using plain value_from_contents_and_address here
8205 causes problems because we will end up trying to
8206 resolve a type that is currently being
8208 dval = value_from_contents_and_address_unresolved (rtype,
8211 rtype = value_type (dval);
8216 /* If the type referenced by this field is an aligner type, we need
8217 to unwrap that aligner type, because its size might not be set.
8218 Keeping the aligner type would cause us to compute the wrong
8219 size for this field, impacting the offset of the all the fields
8220 that follow this one. */
8221 if (ada_is_aligner_type (field_type))
8223 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8225 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8226 field_address = cond_offset_target (field_address, field_offset);
8227 field_type = ada_aligned_type (field_type);
8230 field_valaddr = cond_offset_host (field_valaddr,
8231 off / TARGET_CHAR_BIT);
8232 field_address = cond_offset_target (field_address,
8233 off / TARGET_CHAR_BIT);
8235 /* Get the fixed type of the field. Note that, in this case,
8236 we do not want to get the real type out of the tag: if
8237 the current field is the parent part of a tagged record,
8238 we will get the tag of the object. Clearly wrong: the real
8239 type of the parent is not the real type of the child. We
8240 would end up in an infinite loop. */
8241 field_type = ada_get_base_type (field_type);
8242 field_type = ada_to_fixed_type (field_type, field_valaddr,
8243 field_address, dval, 0);
8244 /* If the field size is already larger than the maximum
8245 object size, then the record itself will necessarily
8246 be larger than the maximum object size. We need to make
8247 this check now, because the size might be so ridiculously
8248 large (due to an uninitialized variable in the inferior)
8249 that it would cause an overflow when adding it to the
8251 ada_ensure_varsize_limit (field_type);
8253 TYPE_FIELD_TYPE (rtype, f) = field_type;
8254 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8255 /* The multiplication can potentially overflow. But because
8256 the field length has been size-checked just above, and
8257 assuming that the maximum size is a reasonable value,
8258 an overflow should not happen in practice. So rather than
8259 adding overflow recovery code to this already complex code,
8260 we just assume that it's not going to happen. */
8262 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8266 /* Note: If this field's type is a typedef, it is important
8267 to preserve the typedef layer.
8269 Otherwise, we might be transforming a typedef to a fat
8270 pointer (encoding a pointer to an unconstrained array),
8271 into a basic fat pointer (encoding an unconstrained
8272 array). As both types are implemented using the same
8273 structure, the typedef is the only clue which allows us
8274 to distinguish between the two options. Stripping it
8275 would prevent us from printing this field appropriately. */
8276 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8277 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8278 if (TYPE_FIELD_BITSIZE (type, f) > 0)
8280 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8283 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8285 /* We need to be careful of typedefs when computing
8286 the length of our field. If this is a typedef,
8287 get the length of the target type, not the length
8289 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8290 field_type = ada_typedef_target_type (field_type);
8293 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8296 if (off + fld_bit_len > bit_len)
8297 bit_len = off + fld_bit_len;
8299 TYPE_LENGTH (rtype) =
8300 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8303 /* We handle the variant part, if any, at the end because of certain
8304 odd cases in which it is re-ordered so as NOT to be the last field of
8305 the record. This can happen in the presence of representation
8307 if (variant_field >= 0)
8309 struct type *branch_type;
8311 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8315 /* Using plain value_from_contents_and_address here causes
8316 problems because we will end up trying to resolve a type
8317 that is currently being constructed. */
8318 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8320 rtype = value_type (dval);
8326 to_fixed_variant_branch_type
8327 (TYPE_FIELD_TYPE (type, variant_field),
8328 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8329 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8330 if (branch_type == NULL)
8332 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8333 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8334 TYPE_NFIELDS (rtype) -= 1;
8338 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8339 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8341 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8343 if (off + fld_bit_len > bit_len)
8344 bit_len = off + fld_bit_len;
8345 TYPE_LENGTH (rtype) =
8346 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8350 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8351 should contain the alignment of that record, which should be a strictly
8352 positive value. If null or negative, then something is wrong, most
8353 probably in the debug info. In that case, we don't round up the size
8354 of the resulting type. If this record is not part of another structure,
8355 the current RTYPE length might be good enough for our purposes. */
8356 if (TYPE_LENGTH (type) <= 0)
8358 if (TYPE_NAME (rtype))
8359 warning (_("Invalid type size for `%s' detected: %s."),
8360 TYPE_NAME (rtype), pulongest (TYPE_LENGTH (type)));
8362 warning (_("Invalid type size for <unnamed> detected: %s."),
8363 pulongest (TYPE_LENGTH (type)));
8367 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8368 TYPE_LENGTH (type));
8371 value_free_to_mark (mark);
8372 if (TYPE_LENGTH (rtype) > varsize_limit)
8373 error (_("record type with dynamic size is larger than varsize-limit"));
8377 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8380 static struct type *
8381 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8382 CORE_ADDR address, struct value *dval0)
8384 return ada_template_to_fixed_record_type_1 (type, valaddr,
8388 /* An ordinary record type in which ___XVL-convention fields and
8389 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8390 static approximations, containing all possible fields. Uses
8391 no runtime values. Useless for use in values, but that's OK,
8392 since the results are used only for type determinations. Works on both
8393 structs and unions. Representation note: to save space, we memorize
8394 the result of this function in the TYPE_TARGET_TYPE of the
8397 static struct type *
8398 template_to_static_fixed_type (struct type *type0)
8404 /* No need no do anything if the input type is already fixed. */
8405 if (TYPE_FIXED_INSTANCE (type0))
8408 /* Likewise if we already have computed the static approximation. */
8409 if (TYPE_TARGET_TYPE (type0) != NULL)
8410 return TYPE_TARGET_TYPE (type0);
8412 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8414 nfields = TYPE_NFIELDS (type0);
8416 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8417 recompute all over next time. */
8418 TYPE_TARGET_TYPE (type0) = type;
8420 for (f = 0; f < nfields; f += 1)
8422 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8423 struct type *new_type;
8425 if (is_dynamic_field (type0, f))
8427 field_type = ada_check_typedef (field_type);
8428 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8431 new_type = static_unwrap_type (field_type);
8433 if (new_type != field_type)
8435 /* Clone TYPE0 only the first time we get a new field type. */
8438 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8439 TYPE_CODE (type) = TYPE_CODE (type0);
8440 INIT_NONE_SPECIFIC (type);
8441 TYPE_NFIELDS (type) = nfields;
8442 TYPE_FIELDS (type) = (struct field *)
8443 TYPE_ALLOC (type, nfields * sizeof (struct field));
8444 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8445 sizeof (struct field) * nfields);
8446 TYPE_NAME (type) = ada_type_name (type0);
8447 TYPE_FIXED_INSTANCE (type) = 1;
8448 TYPE_LENGTH (type) = 0;
8450 TYPE_FIELD_TYPE (type, f) = new_type;
8451 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8458 /* Given an object of type TYPE whose contents are at VALADDR and
8459 whose address in memory is ADDRESS, returns a revision of TYPE,
8460 which should be a non-dynamic-sized record, in which the variant
8461 part, if any, is replaced with the appropriate branch. Looks
8462 for discriminant values in DVAL0, which can be NULL if the record
8463 contains the necessary discriminant values. */
8465 static struct type *
8466 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8467 CORE_ADDR address, struct value *dval0)
8469 struct value *mark = value_mark ();
8472 struct type *branch_type;
8473 int nfields = TYPE_NFIELDS (type);
8474 int variant_field = variant_field_index (type);
8476 if (variant_field == -1)
8481 dval = value_from_contents_and_address (type, valaddr, address);
8482 type = value_type (dval);
8487 rtype = alloc_type_copy (type);
8488 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8489 INIT_NONE_SPECIFIC (rtype);
8490 TYPE_NFIELDS (rtype) = nfields;
8491 TYPE_FIELDS (rtype) =
8492 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8493 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8494 sizeof (struct field) * nfields);
8495 TYPE_NAME (rtype) = ada_type_name (type);
8496 TYPE_FIXED_INSTANCE (rtype) = 1;
8497 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8499 branch_type = to_fixed_variant_branch_type
8500 (TYPE_FIELD_TYPE (type, variant_field),
8501 cond_offset_host (valaddr,
8502 TYPE_FIELD_BITPOS (type, variant_field)
8504 cond_offset_target (address,
8505 TYPE_FIELD_BITPOS (type, variant_field)
8506 / TARGET_CHAR_BIT), dval);
8507 if (branch_type == NULL)
8511 for (f = variant_field + 1; f < nfields; f += 1)
8512 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8513 TYPE_NFIELDS (rtype) -= 1;
8517 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8518 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8519 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8520 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8522 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8524 value_free_to_mark (mark);
8528 /* An ordinary record type (with fixed-length fields) that describes
8529 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8530 beginning of this section]. Any necessary discriminants' values
8531 should be in DVAL, a record value; it may be NULL if the object
8532 at ADDR itself contains any necessary discriminant values.
8533 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8534 values from the record are needed. Except in the case that DVAL,
8535 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8536 unchecked) is replaced by a particular branch of the variant.
8538 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8539 is questionable and may be removed. It can arise during the
8540 processing of an unconstrained-array-of-record type where all the
8541 variant branches have exactly the same size. This is because in
8542 such cases, the compiler does not bother to use the XVS convention
8543 when encoding the record. I am currently dubious of this
8544 shortcut and suspect the compiler should be altered. FIXME. */
8546 static struct type *
8547 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8548 CORE_ADDR address, struct value *dval)
8550 struct type *templ_type;
8552 if (TYPE_FIXED_INSTANCE (type0))
8555 templ_type = dynamic_template_type (type0);
8557 if (templ_type != NULL)
8558 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8559 else if (variant_field_index (type0) >= 0)
8561 if (dval == NULL && valaddr == NULL && address == 0)
8563 return to_record_with_fixed_variant_part (type0, valaddr, address,
8568 TYPE_FIXED_INSTANCE (type0) = 1;
8574 /* An ordinary record type (with fixed-length fields) that describes
8575 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8576 union type. Any necessary discriminants' values should be in DVAL,
8577 a record value. That is, this routine selects the appropriate
8578 branch of the union at ADDR according to the discriminant value
8579 indicated in the union's type name. Returns VAR_TYPE0 itself if
8580 it represents a variant subject to a pragma Unchecked_Union. */
8582 static struct type *
8583 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8584 CORE_ADDR address, struct value *dval)
8587 struct type *templ_type;
8588 struct type *var_type;
8590 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8591 var_type = TYPE_TARGET_TYPE (var_type0);
8593 var_type = var_type0;
8595 templ_type = ada_find_parallel_type (var_type, "___XVU");
8597 if (templ_type != NULL)
8598 var_type = templ_type;
8600 if (is_unchecked_variant (var_type, value_type (dval)))
8603 ada_which_variant_applies (var_type,
8604 value_type (dval), value_contents (dval));
8607 return empty_record (var_type);
8608 else if (is_dynamic_field (var_type, which))
8609 return to_fixed_record_type
8610 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8611 valaddr, address, dval);
8612 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8614 to_fixed_record_type
8615 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8617 return TYPE_FIELD_TYPE (var_type, which);
8620 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8621 ENCODING_TYPE, a type following the GNAT conventions for discrete
8622 type encodings, only carries redundant information. */
8625 ada_is_redundant_range_encoding (struct type *range_type,
8626 struct type *encoding_type)
8628 const char *bounds_str;
8632 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8634 if (TYPE_CODE (get_base_type (range_type))
8635 != TYPE_CODE (get_base_type (encoding_type)))
8637 /* The compiler probably used a simple base type to describe
8638 the range type instead of the range's actual base type,
8639 expecting us to get the real base type from the encoding
8640 anyway. In this situation, the encoding cannot be ignored
8645 if (is_dynamic_type (range_type))
8648 if (TYPE_NAME (encoding_type) == NULL)
8651 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8652 if (bounds_str == NULL)
8655 n = 8; /* Skip "___XDLU_". */
8656 if (!ada_scan_number (bounds_str, n, &lo, &n))
8658 if (TYPE_LOW_BOUND (range_type) != lo)
8661 n += 2; /* Skip the "__" separator between the two bounds. */
8662 if (!ada_scan_number (bounds_str, n, &hi, &n))
8664 if (TYPE_HIGH_BOUND (range_type) != hi)
8670 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8671 a type following the GNAT encoding for describing array type
8672 indices, only carries redundant information. */
8675 ada_is_redundant_index_type_desc (struct type *array_type,
8676 struct type *desc_type)
8678 struct type *this_layer = check_typedef (array_type);
8681 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8683 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8684 TYPE_FIELD_TYPE (desc_type, i)))
8686 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8692 /* Assuming that TYPE0 is an array type describing the type of a value
8693 at ADDR, and that DVAL describes a record containing any
8694 discriminants used in TYPE0, returns a type for the value that
8695 contains no dynamic components (that is, no components whose sizes
8696 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8697 true, gives an error message if the resulting type's size is over
8700 static struct type *
8701 to_fixed_array_type (struct type *type0, struct value *dval,
8704 struct type *index_type_desc;
8705 struct type *result;
8706 int constrained_packed_array_p;
8707 static const char *xa_suffix = "___XA";
8709 type0 = ada_check_typedef (type0);
8710 if (TYPE_FIXED_INSTANCE (type0))
8713 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8714 if (constrained_packed_array_p)
8715 type0 = decode_constrained_packed_array_type (type0);
8717 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8719 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8720 encoding suffixed with 'P' may still be generated. If so,
8721 it should be used to find the XA type. */
8723 if (index_type_desc == NULL)
8725 const char *type_name = ada_type_name (type0);
8727 if (type_name != NULL)
8729 const int len = strlen (type_name);
8730 char *name = (char *) alloca (len + strlen (xa_suffix));
8732 if (type_name[len - 1] == 'P')
8734 strcpy (name, type_name);
8735 strcpy (name + len - 1, xa_suffix);
8736 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8741 ada_fixup_array_indexes_type (index_type_desc);
8742 if (index_type_desc != NULL
8743 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8745 /* Ignore this ___XA parallel type, as it does not bring any
8746 useful information. This allows us to avoid creating fixed
8747 versions of the array's index types, which would be identical
8748 to the original ones. This, in turn, can also help avoid
8749 the creation of fixed versions of the array itself. */
8750 index_type_desc = NULL;
8753 if (index_type_desc == NULL)
8755 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8757 /* NOTE: elt_type---the fixed version of elt_type0---should never
8758 depend on the contents of the array in properly constructed
8760 /* Create a fixed version of the array element type.
8761 We're not providing the address of an element here,
8762 and thus the actual object value cannot be inspected to do
8763 the conversion. This should not be a problem, since arrays of
8764 unconstrained objects are not allowed. In particular, all
8765 the elements of an array of a tagged type should all be of
8766 the same type specified in the debugging info. No need to
8767 consult the object tag. */
8768 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8770 /* Make sure we always create a new array type when dealing with
8771 packed array types, since we're going to fix-up the array
8772 type length and element bitsize a little further down. */
8773 if (elt_type0 == elt_type && !constrained_packed_array_p)
8776 result = create_array_type (alloc_type_copy (type0),
8777 elt_type, TYPE_INDEX_TYPE (type0));
8782 struct type *elt_type0;
8785 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8786 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8788 /* NOTE: result---the fixed version of elt_type0---should never
8789 depend on the contents of the array in properly constructed
8791 /* Create a fixed version of the array element type.
8792 We're not providing the address of an element here,
8793 and thus the actual object value cannot be inspected to do
8794 the conversion. This should not be a problem, since arrays of
8795 unconstrained objects are not allowed. In particular, all
8796 the elements of an array of a tagged type should all be of
8797 the same type specified in the debugging info. No need to
8798 consult the object tag. */
8800 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8803 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8805 struct type *range_type =
8806 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8808 result = create_array_type (alloc_type_copy (elt_type0),
8809 result, range_type);
8810 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8812 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8813 error (_("array type with dynamic size is larger than varsize-limit"));
8816 /* We want to preserve the type name. This can be useful when
8817 trying to get the type name of a value that has already been
8818 printed (for instance, if the user did "print VAR; whatis $". */
8819 TYPE_NAME (result) = TYPE_NAME (type0);
8821 if (constrained_packed_array_p)
8823 /* So far, the resulting type has been created as if the original
8824 type was a regular (non-packed) array type. As a result, the
8825 bitsize of the array elements needs to be set again, and the array
8826 length needs to be recomputed based on that bitsize. */
8827 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8828 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8830 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8831 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8832 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8833 TYPE_LENGTH (result)++;
8836 TYPE_FIXED_INSTANCE (result) = 1;
8841 /* A standard type (containing no dynamically sized components)
8842 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8843 DVAL describes a record containing any discriminants used in TYPE0,
8844 and may be NULL if there are none, or if the object of type TYPE at
8845 ADDRESS or in VALADDR contains these discriminants.
8847 If CHECK_TAG is not null, in the case of tagged types, this function
8848 attempts to locate the object's tag and use it to compute the actual
8849 type. However, when ADDRESS is null, we cannot use it to determine the
8850 location of the tag, and therefore compute the tagged type's actual type.
8851 So we return the tagged type without consulting the tag. */
8853 static struct type *
8854 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8855 CORE_ADDR address, struct value *dval, int check_tag)
8857 type = ada_check_typedef (type);
8859 /* Only un-fixed types need to be handled here. */
8860 if (!HAVE_GNAT_AUX_INFO (type))
8863 switch (TYPE_CODE (type))
8867 case TYPE_CODE_STRUCT:
8869 struct type *static_type = to_static_fixed_type (type);
8870 struct type *fixed_record_type =
8871 to_fixed_record_type (type, valaddr, address, NULL);
8873 /* If STATIC_TYPE is a tagged type and we know the object's address,
8874 then we can determine its tag, and compute the object's actual
8875 type from there. Note that we have to use the fixed record
8876 type (the parent part of the record may have dynamic fields
8877 and the way the location of _tag is expressed may depend on
8880 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8883 value_tag_from_contents_and_address
8887 struct type *real_type = type_from_tag (tag);
8889 value_from_contents_and_address (fixed_record_type,
8892 fixed_record_type = value_type (obj);
8893 if (real_type != NULL)
8894 return to_fixed_record_type
8896 value_address (ada_tag_value_at_base_address (obj)), NULL);
8899 /* Check to see if there is a parallel ___XVZ variable.
8900 If there is, then it provides the actual size of our type. */
8901 else if (ada_type_name (fixed_record_type) != NULL)
8903 const char *name = ada_type_name (fixed_record_type);
8905 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8906 bool xvz_found = false;
8909 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8912 xvz_found = get_int_var_value (xvz_name, size);
8914 catch (const gdb_exception_error &except)
8916 /* We found the variable, but somehow failed to read
8917 its value. Rethrow the same error, but with a little
8918 bit more information, to help the user understand
8919 what went wrong (Eg: the variable might have been
8921 throw_error (except.error,
8922 _("unable to read value of %s (%s)"),
8923 xvz_name, except.what ());
8926 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8928 fixed_record_type = copy_type (fixed_record_type);
8929 TYPE_LENGTH (fixed_record_type) = size;
8931 /* The FIXED_RECORD_TYPE may have be a stub. We have
8932 observed this when the debugging info is STABS, and
8933 apparently it is something that is hard to fix.
8935 In practice, we don't need the actual type definition
8936 at all, because the presence of the XVZ variable allows us
8937 to assume that there must be a XVS type as well, which we
8938 should be able to use later, when we need the actual type
8941 In the meantime, pretend that the "fixed" type we are
8942 returning is NOT a stub, because this can cause trouble
8943 when using this type to create new types targeting it.
8944 Indeed, the associated creation routines often check
8945 whether the target type is a stub and will try to replace
8946 it, thus using a type with the wrong size. This, in turn,
8947 might cause the new type to have the wrong size too.
8948 Consider the case of an array, for instance, where the size
8949 of the array is computed from the number of elements in
8950 our array multiplied by the size of its element. */
8951 TYPE_STUB (fixed_record_type) = 0;
8954 return fixed_record_type;
8956 case TYPE_CODE_ARRAY:
8957 return to_fixed_array_type (type, dval, 1);
8958 case TYPE_CODE_UNION:
8962 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8966 /* The same as ada_to_fixed_type_1, except that it preserves the type
8967 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8969 The typedef layer needs be preserved in order to differentiate between
8970 arrays and array pointers when both types are implemented using the same
8971 fat pointer. In the array pointer case, the pointer is encoded as
8972 a typedef of the pointer type. For instance, considering:
8974 type String_Access is access String;
8975 S1 : String_Access := null;
8977 To the debugger, S1 is defined as a typedef of type String. But
8978 to the user, it is a pointer. So if the user tries to print S1,
8979 we should not dereference the array, but print the array address
8982 If we didn't preserve the typedef layer, we would lose the fact that
8983 the type is to be presented as a pointer (needs de-reference before
8984 being printed). And we would also use the source-level type name. */
8987 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8988 CORE_ADDR address, struct value *dval, int check_tag)
8991 struct type *fixed_type =
8992 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8994 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8995 then preserve the typedef layer.
8997 Implementation note: We can only check the main-type portion of
8998 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8999 from TYPE now returns a type that has the same instance flags
9000 as TYPE. For instance, if TYPE is a "typedef const", and its
9001 target type is a "struct", then the typedef elimination will return
9002 a "const" version of the target type. See check_typedef for more
9003 details about how the typedef layer elimination is done.
9005 brobecker/2010-11-19: It seems to me that the only case where it is
9006 useful to preserve the typedef layer is when dealing with fat pointers.
9007 Perhaps, we could add a check for that and preserve the typedef layer
9008 only in that situation. But this seems unecessary so far, probably
9009 because we call check_typedef/ada_check_typedef pretty much everywhere.
9011 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9012 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
9013 == TYPE_MAIN_TYPE (fixed_type)))
9019 /* A standard (static-sized) type corresponding as well as possible to
9020 TYPE0, but based on no runtime data. */
9022 static struct type *
9023 to_static_fixed_type (struct type *type0)
9030 if (TYPE_FIXED_INSTANCE (type0))
9033 type0 = ada_check_typedef (type0);
9035 switch (TYPE_CODE (type0))
9039 case TYPE_CODE_STRUCT:
9040 type = dynamic_template_type (type0);
9042 return template_to_static_fixed_type (type);
9044 return template_to_static_fixed_type (type0);
9045 case TYPE_CODE_UNION:
9046 type = ada_find_parallel_type (type0, "___XVU");
9048 return template_to_static_fixed_type (type);
9050 return template_to_static_fixed_type (type0);
9054 /* A static approximation of TYPE with all type wrappers removed. */
9056 static struct type *
9057 static_unwrap_type (struct type *type)
9059 if (ada_is_aligner_type (type))
9061 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9062 if (ada_type_name (type1) == NULL)
9063 TYPE_NAME (type1) = ada_type_name (type);
9065 return static_unwrap_type (type1);
9069 struct type *raw_real_type = ada_get_base_type (type);
9071 if (raw_real_type == type)
9074 return to_static_fixed_type (raw_real_type);
9078 /* In some cases, incomplete and private types require
9079 cross-references that are not resolved as records (for example,
9081 type FooP is access Foo;
9083 type Foo is array ...;
9084 ). In these cases, since there is no mechanism for producing
9085 cross-references to such types, we instead substitute for FooP a
9086 stub enumeration type that is nowhere resolved, and whose tag is
9087 the name of the actual type. Call these types "non-record stubs". */
9089 /* A type equivalent to TYPE that is not a non-record stub, if one
9090 exists, otherwise TYPE. */
9093 ada_check_typedef (struct type *type)
9098 /* If our type is an access to an unconstrained array, which is encoded
9099 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9100 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9101 what allows us to distinguish between fat pointers that represent
9102 array types, and fat pointers that represent array access types
9103 (in both cases, the compiler implements them as fat pointers). */
9104 if (ada_is_access_to_unconstrained_array (type))
9107 type = check_typedef (type);
9108 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9109 || !TYPE_STUB (type)
9110 || TYPE_NAME (type) == NULL)
9114 const char *name = TYPE_NAME (type);
9115 struct type *type1 = ada_find_any_type (name);
9120 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9121 stubs pointing to arrays, as we don't create symbols for array
9122 types, only for the typedef-to-array types). If that's the case,
9123 strip the typedef layer. */
9124 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9125 type1 = ada_check_typedef (type1);
9131 /* A value representing the data at VALADDR/ADDRESS as described by
9132 type TYPE0, but with a standard (static-sized) type that correctly
9133 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9134 type, then return VAL0 [this feature is simply to avoid redundant
9135 creation of struct values]. */
9137 static struct value *
9138 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9141 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9143 if (type == type0 && val0 != NULL)
9146 if (VALUE_LVAL (val0) != lval_memory)
9148 /* Our value does not live in memory; it could be a convenience
9149 variable, for instance. Create a not_lval value using val0's
9151 return value_from_contents (type, value_contents (val0));
9154 return value_from_contents_and_address (type, 0, address);
9157 /* A value representing VAL, but with a standard (static-sized) type
9158 that correctly describes it. Does not necessarily create a new
9162 ada_to_fixed_value (struct value *val)
9164 val = unwrap_value (val);
9165 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
9172 /* Table mapping attribute numbers to names.
9173 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9175 static const char *attribute_names[] = {
9193 ada_attribute_name (enum exp_opcode n)
9195 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9196 return attribute_names[n - OP_ATR_FIRST + 1];
9198 return attribute_names[0];
9201 /* Evaluate the 'POS attribute applied to ARG. */
9204 pos_atr (struct value *arg)
9206 struct value *val = coerce_ref (arg);
9207 struct type *type = value_type (val);
9210 if (!discrete_type_p (type))
9211 error (_("'POS only defined on discrete types"));
9213 if (!discrete_position (type, value_as_long (val), &result))
9214 error (_("enumeration value is invalid: can't find 'POS"));
9219 static struct value *
9220 value_pos_atr (struct type *type, struct value *arg)
9222 return value_from_longest (type, pos_atr (arg));
9225 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9227 static struct value *
9228 value_val_atr (struct type *type, struct value *arg)
9230 if (!discrete_type_p (type))
9231 error (_("'VAL only defined on discrete types"));
9232 if (!integer_type_p (value_type (arg)))
9233 error (_("'VAL requires integral argument"));
9235 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9237 long pos = value_as_long (arg);
9239 if (pos < 0 || pos >= TYPE_NFIELDS (type))
9240 error (_("argument to 'VAL out of range"));
9241 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9244 return value_from_longest (type, value_as_long (arg));
9250 /* True if TYPE appears to be an Ada character type.
9251 [At the moment, this is true only for Character and Wide_Character;
9252 It is a heuristic test that could stand improvement]. */
9255 ada_is_character_type (struct type *type)
9259 /* If the type code says it's a character, then assume it really is,
9260 and don't check any further. */
9261 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9264 /* Otherwise, assume it's a character type iff it is a discrete type
9265 with a known character type name. */
9266 name = ada_type_name (type);
9267 return (name != NULL
9268 && (TYPE_CODE (type) == TYPE_CODE_INT
9269 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9270 && (strcmp (name, "character") == 0
9271 || strcmp (name, "wide_character") == 0
9272 || strcmp (name, "wide_wide_character") == 0
9273 || strcmp (name, "unsigned char") == 0));
9276 /* True if TYPE appears to be an Ada string type. */
9279 ada_is_string_type (struct type *type)
9281 type = ada_check_typedef (type);
9283 && TYPE_CODE (type) != TYPE_CODE_PTR
9284 && (ada_is_simple_array_type (type)
9285 || ada_is_array_descriptor_type (type))
9286 && ada_array_arity (type) == 1)
9288 struct type *elttype = ada_array_element_type (type, 1);
9290 return ada_is_character_type (elttype);
9296 /* The compiler sometimes provides a parallel XVS type for a given
9297 PAD type. Normally, it is safe to follow the PAD type directly,
9298 but older versions of the compiler have a bug that causes the offset
9299 of its "F" field to be wrong. Following that field in that case
9300 would lead to incorrect results, but this can be worked around
9301 by ignoring the PAD type and using the associated XVS type instead.
9303 Set to True if the debugger should trust the contents of PAD types.
9304 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9305 static int trust_pad_over_xvs = 1;
9307 /* True if TYPE is a struct type introduced by the compiler to force the
9308 alignment of a value. Such types have a single field with a
9309 distinctive name. */
9312 ada_is_aligner_type (struct type *type)
9314 type = ada_check_typedef (type);
9316 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9319 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9320 && TYPE_NFIELDS (type) == 1
9321 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9324 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9325 the parallel type. */
9328 ada_get_base_type (struct type *raw_type)
9330 struct type *real_type_namer;
9331 struct type *raw_real_type;
9333 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9336 if (ada_is_aligner_type (raw_type))
9337 /* The encoding specifies that we should always use the aligner type.
9338 So, even if this aligner type has an associated XVS type, we should
9341 According to the compiler gurus, an XVS type parallel to an aligner
9342 type may exist because of a stabs limitation. In stabs, aligner
9343 types are empty because the field has a variable-sized type, and
9344 thus cannot actually be used as an aligner type. As a result,
9345 we need the associated parallel XVS type to decode the type.
9346 Since the policy in the compiler is to not change the internal
9347 representation based on the debugging info format, we sometimes
9348 end up having a redundant XVS type parallel to the aligner type. */
9351 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9352 if (real_type_namer == NULL
9353 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9354 || TYPE_NFIELDS (real_type_namer) != 1)
9357 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9359 /* This is an older encoding form where the base type needs to be
9360 looked up by name. We prefer the newer enconding because it is
9362 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9363 if (raw_real_type == NULL)
9366 return raw_real_type;
9369 /* The field in our XVS type is a reference to the base type. */
9370 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9373 /* The type of value designated by TYPE, with all aligners removed. */
9376 ada_aligned_type (struct type *type)
9378 if (ada_is_aligner_type (type))
9379 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9381 return ada_get_base_type (type);
9385 /* The address of the aligned value in an object at address VALADDR
9386 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9389 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9391 if (ada_is_aligner_type (type))
9392 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9394 TYPE_FIELD_BITPOS (type,
9395 0) / TARGET_CHAR_BIT);
9402 /* The printed representation of an enumeration literal with encoded
9403 name NAME. The value is good to the next call of ada_enum_name. */
9405 ada_enum_name (const char *name)
9407 static char *result;
9408 static size_t result_len = 0;
9411 /* First, unqualify the enumeration name:
9412 1. Search for the last '.' character. If we find one, then skip
9413 all the preceding characters, the unqualified name starts
9414 right after that dot.
9415 2. Otherwise, we may be debugging on a target where the compiler
9416 translates dots into "__". Search forward for double underscores,
9417 but stop searching when we hit an overloading suffix, which is
9418 of the form "__" followed by digits. */
9420 tmp = strrchr (name, '.');
9425 while ((tmp = strstr (name, "__")) != NULL)
9427 if (isdigit (tmp[2]))
9438 if (name[1] == 'U' || name[1] == 'W')
9440 if (sscanf (name + 2, "%x", &v) != 1)
9446 GROW_VECT (result, result_len, 16);
9447 if (isascii (v) && isprint (v))
9448 xsnprintf (result, result_len, "'%c'", v);
9449 else if (name[1] == 'U')
9450 xsnprintf (result, result_len, "[\"%02x\"]", v);
9452 xsnprintf (result, result_len, "[\"%04x\"]", v);
9458 tmp = strstr (name, "__");
9460 tmp = strstr (name, "$");
9463 GROW_VECT (result, result_len, tmp - name + 1);
9464 strncpy (result, name, tmp - name);
9465 result[tmp - name] = '\0';
9473 /* Evaluate the subexpression of EXP starting at *POS as for
9474 evaluate_type, updating *POS to point just past the evaluated
9477 static struct value *
9478 evaluate_subexp_type (struct expression *exp, int *pos)
9480 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9483 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9486 static struct value *
9487 unwrap_value (struct value *val)
9489 struct type *type = ada_check_typedef (value_type (val));
9491 if (ada_is_aligner_type (type))
9493 struct value *v = ada_value_struct_elt (val, "F", 0);
9494 struct type *val_type = ada_check_typedef (value_type (v));
9496 if (ada_type_name (val_type) == NULL)
9497 TYPE_NAME (val_type) = ada_type_name (type);
9499 return unwrap_value (v);
9503 struct type *raw_real_type =
9504 ada_check_typedef (ada_get_base_type (type));
9506 /* If there is no parallel XVS or XVE type, then the value is
9507 already unwrapped. Return it without further modification. */
9508 if ((type == raw_real_type)
9509 && ada_find_parallel_type (type, "___XVE") == NULL)
9513 coerce_unspec_val_to_type
9514 (val, ada_to_fixed_type (raw_real_type, 0,
9515 value_address (val),
9520 static struct value *
9521 cast_from_fixed (struct type *type, struct value *arg)
9523 struct value *scale = ada_scaling_factor (value_type (arg));
9524 arg = value_cast (value_type (scale), arg);
9526 arg = value_binop (arg, scale, BINOP_MUL);
9527 return value_cast (type, arg);
9530 static struct value *
9531 cast_to_fixed (struct type *type, struct value *arg)
9533 if (type == value_type (arg))
9536 struct value *scale = ada_scaling_factor (type);
9537 if (ada_is_fixed_point_type (value_type (arg)))
9538 arg = cast_from_fixed (value_type (scale), arg);
9540 arg = value_cast (value_type (scale), arg);
9542 arg = value_binop (arg, scale, BINOP_DIV);
9543 return value_cast (type, arg);
9546 /* Given two array types T1 and T2, return nonzero iff both arrays
9547 contain the same number of elements. */
9550 ada_same_array_size_p (struct type *t1, struct type *t2)
9552 LONGEST lo1, hi1, lo2, hi2;
9554 /* Get the array bounds in order to verify that the size of
9555 the two arrays match. */
9556 if (!get_array_bounds (t1, &lo1, &hi1)
9557 || !get_array_bounds (t2, &lo2, &hi2))
9558 error (_("unable to determine array bounds"));
9560 /* To make things easier for size comparison, normalize a bit
9561 the case of empty arrays by making sure that the difference
9562 between upper bound and lower bound is always -1. */
9568 return (hi1 - lo1 == hi2 - lo2);
9571 /* Assuming that VAL is an array of integrals, and TYPE represents
9572 an array with the same number of elements, but with wider integral
9573 elements, return an array "casted" to TYPE. In practice, this
9574 means that the returned array is built by casting each element
9575 of the original array into TYPE's (wider) element type. */
9577 static struct value *
9578 ada_promote_array_of_integrals (struct type *type, struct value *val)
9580 struct type *elt_type = TYPE_TARGET_TYPE (type);
9585 /* Verify that both val and type are arrays of scalars, and
9586 that the size of val's elements is smaller than the size
9587 of type's element. */
9588 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9589 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9590 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9591 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9592 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9593 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9595 if (!get_array_bounds (type, &lo, &hi))
9596 error (_("unable to determine array bounds"));
9598 res = allocate_value (type);
9600 /* Promote each array element. */
9601 for (i = 0; i < hi - lo + 1; i++)
9603 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9605 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9606 value_contents_all (elt), TYPE_LENGTH (elt_type));
9612 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9613 return the converted value. */
9615 static struct value *
9616 coerce_for_assign (struct type *type, struct value *val)
9618 struct type *type2 = value_type (val);
9623 type2 = ada_check_typedef (type2);
9624 type = ada_check_typedef (type);
9626 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9627 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9629 val = ada_value_ind (val);
9630 type2 = value_type (val);
9633 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9634 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9636 if (!ada_same_array_size_p (type, type2))
9637 error (_("cannot assign arrays of different length"));
9639 if (is_integral_type (TYPE_TARGET_TYPE (type))
9640 && is_integral_type (TYPE_TARGET_TYPE (type2))
9641 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9642 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9644 /* Allow implicit promotion of the array elements to
9646 return ada_promote_array_of_integrals (type, val);
9649 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9650 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9651 error (_("Incompatible types in assignment"));
9652 deprecated_set_value_type (val, type);
9657 static struct value *
9658 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9661 struct type *type1, *type2;
9664 arg1 = coerce_ref (arg1);
9665 arg2 = coerce_ref (arg2);
9666 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9667 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9669 if (TYPE_CODE (type1) != TYPE_CODE_INT
9670 || TYPE_CODE (type2) != TYPE_CODE_INT)
9671 return value_binop (arg1, arg2, op);
9680 return value_binop (arg1, arg2, op);
9683 v2 = value_as_long (arg2);
9685 error (_("second operand of %s must not be zero."), op_string (op));
9687 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9688 return value_binop (arg1, arg2, op);
9690 v1 = value_as_long (arg1);
9695 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9696 v += v > 0 ? -1 : 1;
9704 /* Should not reach this point. */
9708 val = allocate_value (type1);
9709 store_unsigned_integer (value_contents_raw (val),
9710 TYPE_LENGTH (value_type (val)),
9711 gdbarch_byte_order (get_type_arch (type1)), v);
9716 ada_value_equal (struct value *arg1, struct value *arg2)
9718 if (ada_is_direct_array_type (value_type (arg1))
9719 || ada_is_direct_array_type (value_type (arg2)))
9721 struct type *arg1_type, *arg2_type;
9723 /* Automatically dereference any array reference before
9724 we attempt to perform the comparison. */
9725 arg1 = ada_coerce_ref (arg1);
9726 arg2 = ada_coerce_ref (arg2);
9728 arg1 = ada_coerce_to_simple_array (arg1);
9729 arg2 = ada_coerce_to_simple_array (arg2);
9731 arg1_type = ada_check_typedef (value_type (arg1));
9732 arg2_type = ada_check_typedef (value_type (arg2));
9734 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9735 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9736 error (_("Attempt to compare array with non-array"));
9737 /* FIXME: The following works only for types whose
9738 representations use all bits (no padding or undefined bits)
9739 and do not have user-defined equality. */
9740 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9741 && memcmp (value_contents (arg1), value_contents (arg2),
9742 TYPE_LENGTH (arg1_type)) == 0);
9744 return value_equal (arg1, arg2);
9747 /* Total number of component associations in the aggregate starting at
9748 index PC in EXP. Assumes that index PC is the start of an
9752 num_component_specs (struct expression *exp, int pc)
9756 m = exp->elts[pc + 1].longconst;
9759 for (i = 0; i < m; i += 1)
9761 switch (exp->elts[pc].opcode)
9767 n += exp->elts[pc + 1].longconst;
9770 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9775 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9776 component of LHS (a simple array or a record), updating *POS past
9777 the expression, assuming that LHS is contained in CONTAINER. Does
9778 not modify the inferior's memory, nor does it modify LHS (unless
9779 LHS == CONTAINER). */
9782 assign_component (struct value *container, struct value *lhs, LONGEST index,
9783 struct expression *exp, int *pos)
9785 struct value *mark = value_mark ();
9787 struct type *lhs_type = check_typedef (value_type (lhs));
9789 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
9791 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9792 struct value *index_val = value_from_longest (index_type, index);
9794 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9798 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9799 elt = ada_to_fixed_value (elt);
9802 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9803 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9805 value_assign_to_component (container, elt,
9806 ada_evaluate_subexp (NULL, exp, pos,
9809 value_free_to_mark (mark);
9812 /* Assuming that LHS represents an lvalue having a record or array
9813 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9814 of that aggregate's value to LHS, advancing *POS past the
9815 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9816 lvalue containing LHS (possibly LHS itself). Does not modify
9817 the inferior's memory, nor does it modify the contents of
9818 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9820 static struct value *
9821 assign_aggregate (struct value *container,
9822 struct value *lhs, struct expression *exp,
9823 int *pos, enum noside noside)
9825 struct type *lhs_type;
9826 int n = exp->elts[*pos+1].longconst;
9827 LONGEST low_index, high_index;
9830 int max_indices, num_indices;
9834 if (noside != EVAL_NORMAL)
9836 for (i = 0; i < n; i += 1)
9837 ada_evaluate_subexp (NULL, exp, pos, noside);
9841 container = ada_coerce_ref (container);
9842 if (ada_is_direct_array_type (value_type (container)))
9843 container = ada_coerce_to_simple_array (container);
9844 lhs = ada_coerce_ref (lhs);
9845 if (!deprecated_value_modifiable (lhs))
9846 error (_("Left operand of assignment is not a modifiable lvalue."));
9848 lhs_type = check_typedef (value_type (lhs));
9849 if (ada_is_direct_array_type (lhs_type))
9851 lhs = ada_coerce_to_simple_array (lhs);
9852 lhs_type = check_typedef (value_type (lhs));
9853 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9854 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9856 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9859 high_index = num_visible_fields (lhs_type) - 1;
9862 error (_("Left-hand side must be array or record."));
9864 num_specs = num_component_specs (exp, *pos - 3);
9865 max_indices = 4 * num_specs + 4;
9866 indices = XALLOCAVEC (LONGEST, max_indices);
9867 indices[0] = indices[1] = low_index - 1;
9868 indices[2] = indices[3] = high_index + 1;
9871 for (i = 0; i < n; i += 1)
9873 switch (exp->elts[*pos].opcode)
9876 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9877 &num_indices, max_indices,
9878 low_index, high_index);
9881 aggregate_assign_positional (container, lhs, exp, pos, indices,
9882 &num_indices, max_indices,
9883 low_index, high_index);
9887 error (_("Misplaced 'others' clause"));
9888 aggregate_assign_others (container, lhs, exp, pos, indices,
9889 num_indices, low_index, high_index);
9892 error (_("Internal error: bad aggregate clause"));
9899 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9900 construct at *POS, updating *POS past the construct, given that
9901 the positions are relative to lower bound LOW, where HIGH is the
9902 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9903 updating *NUM_INDICES as needed. CONTAINER is as for
9904 assign_aggregate. */
9906 aggregate_assign_positional (struct value *container,
9907 struct value *lhs, struct expression *exp,
9908 int *pos, LONGEST *indices, int *num_indices,
9909 int max_indices, LONGEST low, LONGEST high)
9911 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9913 if (ind - 1 == high)
9914 warning (_("Extra components in aggregate ignored."));
9917 add_component_interval (ind, ind, indices, num_indices, max_indices);
9919 assign_component (container, lhs, ind, exp, pos);
9922 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9925 /* Assign into the components of LHS indexed by the OP_CHOICES
9926 construct at *POS, updating *POS past the construct, given that
9927 the allowable indices are LOW..HIGH. Record the indices assigned
9928 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9929 needed. CONTAINER is as for assign_aggregate. */
9931 aggregate_assign_from_choices (struct value *container,
9932 struct value *lhs, struct expression *exp,
9933 int *pos, LONGEST *indices, int *num_indices,
9934 int max_indices, LONGEST low, LONGEST high)
9937 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9938 int choice_pos, expr_pc;
9939 int is_array = ada_is_direct_array_type (value_type (lhs));
9941 choice_pos = *pos += 3;
9943 for (j = 0; j < n_choices; j += 1)
9944 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9946 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9948 for (j = 0; j < n_choices; j += 1)
9950 LONGEST lower, upper;
9951 enum exp_opcode op = exp->elts[choice_pos].opcode;
9953 if (op == OP_DISCRETE_RANGE)
9956 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9958 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9963 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9975 name = &exp->elts[choice_pos + 2].string;
9978 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9981 error (_("Invalid record component association."));
9983 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9985 if (! find_struct_field (name, value_type (lhs), 0,
9986 NULL, NULL, NULL, NULL, &ind))
9987 error (_("Unknown component name: %s."), name);
9988 lower = upper = ind;
9991 if (lower <= upper && (lower < low || upper > high))
9992 error (_("Index in component association out of bounds."));
9994 add_component_interval (lower, upper, indices, num_indices,
9996 while (lower <= upper)
10001 assign_component (container, lhs, lower, exp, &pos1);
10007 /* Assign the value of the expression in the OP_OTHERS construct in
10008 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10009 have not been previously assigned. The index intervals already assigned
10010 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10011 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10013 aggregate_assign_others (struct value *container,
10014 struct value *lhs, struct expression *exp,
10015 int *pos, LONGEST *indices, int num_indices,
10016 LONGEST low, LONGEST high)
10019 int expr_pc = *pos + 1;
10021 for (i = 0; i < num_indices - 2; i += 2)
10025 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10029 localpos = expr_pc;
10030 assign_component (container, lhs, ind, exp, &localpos);
10033 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10036 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10037 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10038 modifying *SIZE as needed. It is an error if *SIZE exceeds
10039 MAX_SIZE. The resulting intervals do not overlap. */
10041 add_component_interval (LONGEST low, LONGEST high,
10042 LONGEST* indices, int *size, int max_size)
10046 for (i = 0; i < *size; i += 2) {
10047 if (high >= indices[i] && low <= indices[i + 1])
10051 for (kh = i + 2; kh < *size; kh += 2)
10052 if (high < indices[kh])
10054 if (low < indices[i])
10056 indices[i + 1] = indices[kh - 1];
10057 if (high > indices[i + 1])
10058 indices[i + 1] = high;
10059 memcpy (indices + i + 2, indices + kh, *size - kh);
10060 *size -= kh - i - 2;
10063 else if (high < indices[i])
10067 if (*size == max_size)
10068 error (_("Internal error: miscounted aggregate components."));
10070 for (j = *size-1; j >= i+2; j -= 1)
10071 indices[j] = indices[j - 2];
10073 indices[i + 1] = high;
10076 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10079 static struct value *
10080 ada_value_cast (struct type *type, struct value *arg2)
10082 if (type == ada_check_typedef (value_type (arg2)))
10085 if (ada_is_fixed_point_type (type))
10086 return cast_to_fixed (type, arg2);
10088 if (ada_is_fixed_point_type (value_type (arg2)))
10089 return cast_from_fixed (type, arg2);
10091 return value_cast (type, arg2);
10094 /* Evaluating Ada expressions, and printing their result.
10095 ------------------------------------------------------
10100 We usually evaluate an Ada expression in order to print its value.
10101 We also evaluate an expression in order to print its type, which
10102 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10103 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10104 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10105 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10108 Evaluating expressions is a little more complicated for Ada entities
10109 than it is for entities in languages such as C. The main reason for
10110 this is that Ada provides types whose definition might be dynamic.
10111 One example of such types is variant records. Or another example
10112 would be an array whose bounds can only be known at run time.
10114 The following description is a general guide as to what should be
10115 done (and what should NOT be done) in order to evaluate an expression
10116 involving such types, and when. This does not cover how the semantic
10117 information is encoded by GNAT as this is covered separatly. For the
10118 document used as the reference for the GNAT encoding, see exp_dbug.ads
10119 in the GNAT sources.
10121 Ideally, we should embed each part of this description next to its
10122 associated code. Unfortunately, the amount of code is so vast right
10123 now that it's hard to see whether the code handling a particular
10124 situation might be duplicated or not. One day, when the code is
10125 cleaned up, this guide might become redundant with the comments
10126 inserted in the code, and we might want to remove it.
10128 2. ``Fixing'' an Entity, the Simple Case:
10129 -----------------------------------------
10131 When evaluating Ada expressions, the tricky issue is that they may
10132 reference entities whose type contents and size are not statically
10133 known. Consider for instance a variant record:
10135 type Rec (Empty : Boolean := True) is record
10138 when False => Value : Integer;
10141 Yes : Rec := (Empty => False, Value => 1);
10142 No : Rec := (empty => True);
10144 The size and contents of that record depends on the value of the
10145 descriminant (Rec.Empty). At this point, neither the debugging
10146 information nor the associated type structure in GDB are able to
10147 express such dynamic types. So what the debugger does is to create
10148 "fixed" versions of the type that applies to the specific object.
10149 We also informally refer to this opperation as "fixing" an object,
10150 which means creating its associated fixed type.
10152 Example: when printing the value of variable "Yes" above, its fixed
10153 type would look like this:
10160 On the other hand, if we printed the value of "No", its fixed type
10167 Things become a little more complicated when trying to fix an entity
10168 with a dynamic type that directly contains another dynamic type,
10169 such as an array of variant records, for instance. There are
10170 two possible cases: Arrays, and records.
10172 3. ``Fixing'' Arrays:
10173 ---------------------
10175 The type structure in GDB describes an array in terms of its bounds,
10176 and the type of its elements. By design, all elements in the array
10177 have the same type and we cannot represent an array of variant elements
10178 using the current type structure in GDB. When fixing an array,
10179 we cannot fix the array element, as we would potentially need one
10180 fixed type per element of the array. As a result, the best we can do
10181 when fixing an array is to produce an array whose bounds and size
10182 are correct (allowing us to read it from memory), but without having
10183 touched its element type. Fixing each element will be done later,
10184 when (if) necessary.
10186 Arrays are a little simpler to handle than records, because the same
10187 amount of memory is allocated for each element of the array, even if
10188 the amount of space actually used by each element differs from element
10189 to element. Consider for instance the following array of type Rec:
10191 type Rec_Array is array (1 .. 2) of Rec;
10193 The actual amount of memory occupied by each element might be different
10194 from element to element, depending on the value of their discriminant.
10195 But the amount of space reserved for each element in the array remains
10196 fixed regardless. So we simply need to compute that size using
10197 the debugging information available, from which we can then determine
10198 the array size (we multiply the number of elements of the array by
10199 the size of each element).
10201 The simplest case is when we have an array of a constrained element
10202 type. For instance, consider the following type declarations:
10204 type Bounded_String (Max_Size : Integer) is
10206 Buffer : String (1 .. Max_Size);
10208 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10210 In this case, the compiler describes the array as an array of
10211 variable-size elements (identified by its XVS suffix) for which
10212 the size can be read in the parallel XVZ variable.
10214 In the case of an array of an unconstrained element type, the compiler
10215 wraps the array element inside a private PAD type. This type should not
10216 be shown to the user, and must be "unwrap"'ed before printing. Note
10217 that we also use the adjective "aligner" in our code to designate
10218 these wrapper types.
10220 In some cases, the size allocated for each element is statically
10221 known. In that case, the PAD type already has the correct size,
10222 and the array element should remain unfixed.
10224 But there are cases when this size is not statically known.
10225 For instance, assuming that "Five" is an integer variable:
10227 type Dynamic is array (1 .. Five) of Integer;
10228 type Wrapper (Has_Length : Boolean := False) is record
10231 when True => Length : Integer;
10232 when False => null;
10235 type Wrapper_Array is array (1 .. 2) of Wrapper;
10237 Hello : Wrapper_Array := (others => (Has_Length => True,
10238 Data => (others => 17),
10242 The debugging info would describe variable Hello as being an
10243 array of a PAD type. The size of that PAD type is not statically
10244 known, but can be determined using a parallel XVZ variable.
10245 In that case, a copy of the PAD type with the correct size should
10246 be used for the fixed array.
10248 3. ``Fixing'' record type objects:
10249 ----------------------------------
10251 Things are slightly different from arrays in the case of dynamic
10252 record types. In this case, in order to compute the associated
10253 fixed type, we need to determine the size and offset of each of
10254 its components. This, in turn, requires us to compute the fixed
10255 type of each of these components.
10257 Consider for instance the example:
10259 type Bounded_String (Max_Size : Natural) is record
10260 Str : String (1 .. Max_Size);
10263 My_String : Bounded_String (Max_Size => 10);
10265 In that case, the position of field "Length" depends on the size
10266 of field Str, which itself depends on the value of the Max_Size
10267 discriminant. In order to fix the type of variable My_String,
10268 we need to fix the type of field Str. Therefore, fixing a variant
10269 record requires us to fix each of its components.
10271 However, if a component does not have a dynamic size, the component
10272 should not be fixed. In particular, fields that use a PAD type
10273 should not fixed. Here is an example where this might happen
10274 (assuming type Rec above):
10276 type Container (Big : Boolean) is record
10280 when True => Another : Integer;
10281 when False => null;
10284 My_Container : Container := (Big => False,
10285 First => (Empty => True),
10288 In that example, the compiler creates a PAD type for component First,
10289 whose size is constant, and then positions the component After just
10290 right after it. The offset of component After is therefore constant
10293 The debugger computes the position of each field based on an algorithm
10294 that uses, among other things, the actual position and size of the field
10295 preceding it. Let's now imagine that the user is trying to print
10296 the value of My_Container. If the type fixing was recursive, we would
10297 end up computing the offset of field After based on the size of the
10298 fixed version of field First. And since in our example First has
10299 only one actual field, the size of the fixed type is actually smaller
10300 than the amount of space allocated to that field, and thus we would
10301 compute the wrong offset of field After.
10303 To make things more complicated, we need to watch out for dynamic
10304 components of variant records (identified by the ___XVL suffix in
10305 the component name). Even if the target type is a PAD type, the size
10306 of that type might not be statically known. So the PAD type needs
10307 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10308 we might end up with the wrong size for our component. This can be
10309 observed with the following type declarations:
10311 type Octal is new Integer range 0 .. 7;
10312 type Octal_Array is array (Positive range <>) of Octal;
10313 pragma Pack (Octal_Array);
10315 type Octal_Buffer (Size : Positive) is record
10316 Buffer : Octal_Array (1 .. Size);
10320 In that case, Buffer is a PAD type whose size is unset and needs
10321 to be computed by fixing the unwrapped type.
10323 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10324 ----------------------------------------------------------
10326 Lastly, when should the sub-elements of an entity that remained unfixed
10327 thus far, be actually fixed?
10329 The answer is: Only when referencing that element. For instance
10330 when selecting one component of a record, this specific component
10331 should be fixed at that point in time. Or when printing the value
10332 of a record, each component should be fixed before its value gets
10333 printed. Similarly for arrays, the element of the array should be
10334 fixed when printing each element of the array, or when extracting
10335 one element out of that array. On the other hand, fixing should
10336 not be performed on the elements when taking a slice of an array!
10338 Note that one of the side effects of miscomputing the offset and
10339 size of each field is that we end up also miscomputing the size
10340 of the containing type. This can have adverse results when computing
10341 the value of an entity. GDB fetches the value of an entity based
10342 on the size of its type, and thus a wrong size causes GDB to fetch
10343 the wrong amount of memory. In the case where the computed size is
10344 too small, GDB fetches too little data to print the value of our
10345 entity. Results in this case are unpredictable, as we usually read
10346 past the buffer containing the data =:-o. */
10348 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10349 for that subexpression cast to TO_TYPE. Advance *POS over the
10353 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10354 enum noside noside, struct type *to_type)
10358 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10359 || exp->elts[pc].opcode == OP_VAR_VALUE)
10364 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10366 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10367 return value_zero (to_type, not_lval);
10369 val = evaluate_var_msym_value (noside,
10370 exp->elts[pc + 1].objfile,
10371 exp->elts[pc + 2].msymbol);
10374 val = evaluate_var_value (noside,
10375 exp->elts[pc + 1].block,
10376 exp->elts[pc + 2].symbol);
10378 if (noside == EVAL_SKIP)
10379 return eval_skip_value (exp);
10381 val = ada_value_cast (to_type, val);
10383 /* Follow the Ada language semantics that do not allow taking
10384 an address of the result of a cast (view conversion in Ada). */
10385 if (VALUE_LVAL (val) == lval_memory)
10387 if (value_lazy (val))
10388 value_fetch_lazy (val);
10389 VALUE_LVAL (val) = not_lval;
10394 value *val = evaluate_subexp (to_type, exp, pos, noside);
10395 if (noside == EVAL_SKIP)
10396 return eval_skip_value (exp);
10397 return ada_value_cast (to_type, val);
10400 /* Implement the evaluate_exp routine in the exp_descriptor structure
10401 for the Ada language. */
10403 static struct value *
10404 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10405 int *pos, enum noside noside)
10407 enum exp_opcode op;
10411 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10414 struct value **argvec;
10418 op = exp->elts[pc].opcode;
10424 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10426 if (noside == EVAL_NORMAL)
10427 arg1 = unwrap_value (arg1);
10429 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10430 then we need to perform the conversion manually, because
10431 evaluate_subexp_standard doesn't do it. This conversion is
10432 necessary in Ada because the different kinds of float/fixed
10433 types in Ada have different representations.
10435 Similarly, we need to perform the conversion from OP_LONG
10437 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10438 arg1 = ada_value_cast (expect_type, arg1);
10444 struct value *result;
10447 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10448 /* The result type will have code OP_STRING, bashed there from
10449 OP_ARRAY. Bash it back. */
10450 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10451 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10457 type = exp->elts[pc + 1].type;
10458 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10462 type = exp->elts[pc + 1].type;
10463 return ada_evaluate_subexp (type, exp, pos, noside);
10466 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10467 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10469 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10470 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10472 return ada_value_assign (arg1, arg1);
10474 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10475 except if the lhs of our assignment is a convenience variable.
10476 In the case of assigning to a convenience variable, the lhs
10477 should be exactly the result of the evaluation of the rhs. */
10478 type = value_type (arg1);
10479 if (VALUE_LVAL (arg1) == lval_internalvar)
10481 arg2 = evaluate_subexp (type, exp, pos, noside);
10482 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10484 if (VALUE_LVAL (arg1) == lval_internalvar)
10488 else if (ada_is_fixed_point_type (value_type (arg1)))
10489 arg2 = cast_to_fixed (value_type (arg1), arg2);
10490 else if (ada_is_fixed_point_type (value_type (arg2)))
10492 (_("Fixed-point values must be assigned to fixed-point variables"));
10494 arg2 = coerce_for_assign (value_type (arg1), arg2);
10495 return ada_value_assign (arg1, arg2);
10498 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10499 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10500 if (noside == EVAL_SKIP)
10502 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10503 return (value_from_longest
10504 (value_type (arg1),
10505 value_as_long (arg1) + value_as_long (arg2)));
10506 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10507 return (value_from_longest
10508 (value_type (arg2),
10509 value_as_long (arg1) + value_as_long (arg2)));
10510 if ((ada_is_fixed_point_type (value_type (arg1))
10511 || ada_is_fixed_point_type (value_type (arg2)))
10512 && value_type (arg1) != value_type (arg2))
10513 error (_("Operands of fixed-point addition must have the same type"));
10514 /* Do the addition, and cast the result to the type of the first
10515 argument. We cannot cast the result to a reference type, so if
10516 ARG1 is a reference type, find its underlying type. */
10517 type = value_type (arg1);
10518 while (TYPE_CODE (type) == TYPE_CODE_REF)
10519 type = TYPE_TARGET_TYPE (type);
10520 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10521 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10524 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10525 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10526 if (noside == EVAL_SKIP)
10528 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10529 return (value_from_longest
10530 (value_type (arg1),
10531 value_as_long (arg1) - value_as_long (arg2)));
10532 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10533 return (value_from_longest
10534 (value_type (arg2),
10535 value_as_long (arg1) - value_as_long (arg2)));
10536 if ((ada_is_fixed_point_type (value_type (arg1))
10537 || ada_is_fixed_point_type (value_type (arg2)))
10538 && value_type (arg1) != value_type (arg2))
10539 error (_("Operands of fixed-point subtraction "
10540 "must have the same type"));
10541 /* Do the substraction, and cast the result to the type of the first
10542 argument. We cannot cast the result to a reference type, so if
10543 ARG1 is a reference type, find its underlying type. */
10544 type = value_type (arg1);
10545 while (TYPE_CODE (type) == TYPE_CODE_REF)
10546 type = TYPE_TARGET_TYPE (type);
10547 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10548 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10554 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10555 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10556 if (noside == EVAL_SKIP)
10558 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10560 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10561 return value_zero (value_type (arg1), not_lval);
10565 type = builtin_type (exp->gdbarch)->builtin_double;
10566 if (ada_is_fixed_point_type (value_type (arg1)))
10567 arg1 = cast_from_fixed (type, arg1);
10568 if (ada_is_fixed_point_type (value_type (arg2)))
10569 arg2 = cast_from_fixed (type, arg2);
10570 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10571 return ada_value_binop (arg1, arg2, op);
10575 case BINOP_NOTEQUAL:
10576 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10577 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10578 if (noside == EVAL_SKIP)
10580 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10584 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10585 tem = ada_value_equal (arg1, arg2);
10587 if (op == BINOP_NOTEQUAL)
10589 type = language_bool_type (exp->language_defn, exp->gdbarch);
10590 return value_from_longest (type, (LONGEST) tem);
10593 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10594 if (noside == EVAL_SKIP)
10596 else if (ada_is_fixed_point_type (value_type (arg1)))
10597 return value_cast (value_type (arg1), value_neg (arg1));
10600 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10601 return value_neg (arg1);
10604 case BINOP_LOGICAL_AND:
10605 case BINOP_LOGICAL_OR:
10606 case UNOP_LOGICAL_NOT:
10611 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10612 type = language_bool_type (exp->language_defn, exp->gdbarch);
10613 return value_cast (type, val);
10616 case BINOP_BITWISE_AND:
10617 case BINOP_BITWISE_IOR:
10618 case BINOP_BITWISE_XOR:
10622 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10624 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10626 return value_cast (value_type (arg1), val);
10632 if (noside == EVAL_SKIP)
10638 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10639 /* Only encountered when an unresolved symbol occurs in a
10640 context other than a function call, in which case, it is
10642 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10643 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10645 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10647 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10648 /* Check to see if this is a tagged type. We also need to handle
10649 the case where the type is a reference to a tagged type, but
10650 we have to be careful to exclude pointers to tagged types.
10651 The latter should be shown as usual (as a pointer), whereas
10652 a reference should mostly be transparent to the user. */
10653 if (ada_is_tagged_type (type, 0)
10654 || (TYPE_CODE (type) == TYPE_CODE_REF
10655 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10657 /* Tagged types are a little special in the fact that the real
10658 type is dynamic and can only be determined by inspecting the
10659 object's tag. This means that we need to get the object's
10660 value first (EVAL_NORMAL) and then extract the actual object
10663 Note that we cannot skip the final step where we extract
10664 the object type from its tag, because the EVAL_NORMAL phase
10665 results in dynamic components being resolved into fixed ones.
10666 This can cause problems when trying to print the type
10667 description of tagged types whose parent has a dynamic size:
10668 We use the type name of the "_parent" component in order
10669 to print the name of the ancestor type in the type description.
10670 If that component had a dynamic size, the resolution into
10671 a fixed type would result in the loss of that type name,
10672 thus preventing us from printing the name of the ancestor
10673 type in the type description. */
10674 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10676 if (TYPE_CODE (type) != TYPE_CODE_REF)
10678 struct type *actual_type;
10680 actual_type = type_from_tag (ada_value_tag (arg1));
10681 if (actual_type == NULL)
10682 /* If, for some reason, we were unable to determine
10683 the actual type from the tag, then use the static
10684 approximation that we just computed as a fallback.
10685 This can happen if the debugging information is
10686 incomplete, for instance. */
10687 actual_type = type;
10688 return value_zero (actual_type, not_lval);
10692 /* In the case of a ref, ada_coerce_ref takes care
10693 of determining the actual type. But the evaluation
10694 should return a ref as it should be valid to ask
10695 for its address; so rebuild a ref after coerce. */
10696 arg1 = ada_coerce_ref (arg1);
10697 return value_ref (arg1, TYPE_CODE_REF);
10701 /* Records and unions for which GNAT encodings have been
10702 generated need to be statically fixed as well.
10703 Otherwise, non-static fixing produces a type where
10704 all dynamic properties are removed, which prevents "ptype"
10705 from being able to completely describe the type.
10706 For instance, a case statement in a variant record would be
10707 replaced by the relevant components based on the actual
10708 value of the discriminants. */
10709 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10710 && dynamic_template_type (type) != NULL)
10711 || (TYPE_CODE (type) == TYPE_CODE_UNION
10712 && ada_find_parallel_type (type, "___XVU") != NULL))
10715 return value_zero (to_static_fixed_type (type), not_lval);
10719 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10720 return ada_to_fixed_value (arg1);
10725 /* Allocate arg vector, including space for the function to be
10726 called in argvec[0] and a terminating NULL. */
10727 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10728 argvec = XALLOCAVEC (struct value *, nargs + 2);
10730 if (exp->elts[*pos].opcode == OP_VAR_VALUE
10731 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10732 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10733 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10736 for (tem = 0; tem <= nargs; tem += 1)
10737 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10740 if (noside == EVAL_SKIP)
10744 if (ada_is_constrained_packed_array_type
10745 (desc_base_type (value_type (argvec[0]))))
10746 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10747 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10748 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10749 /* This is a packed array that has already been fixed, and
10750 therefore already coerced to a simple array. Nothing further
10753 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10755 /* Make sure we dereference references so that all the code below
10756 feels like it's really handling the referenced value. Wrapping
10757 types (for alignment) may be there, so make sure we strip them as
10759 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10761 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10762 && VALUE_LVAL (argvec[0]) == lval_memory)
10763 argvec[0] = value_addr (argvec[0]);
10765 type = ada_check_typedef (value_type (argvec[0]));
10767 /* Ada allows us to implicitly dereference arrays when subscripting
10768 them. So, if this is an array typedef (encoding use for array
10769 access types encoded as fat pointers), strip it now. */
10770 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10771 type = ada_typedef_target_type (type);
10773 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10775 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10777 case TYPE_CODE_FUNC:
10778 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10780 case TYPE_CODE_ARRAY:
10782 case TYPE_CODE_STRUCT:
10783 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10784 argvec[0] = ada_value_ind (argvec[0]);
10785 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10788 error (_("cannot subscript or call something of type `%s'"),
10789 ada_type_name (value_type (argvec[0])));
10794 switch (TYPE_CODE (type))
10796 case TYPE_CODE_FUNC:
10797 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10799 if (TYPE_TARGET_TYPE (type) == NULL)
10800 error_call_unknown_return_type (NULL);
10801 return allocate_value (TYPE_TARGET_TYPE (type));
10803 return call_function_by_hand (argvec[0], NULL,
10804 gdb::make_array_view (argvec + 1,
10806 case TYPE_CODE_INTERNAL_FUNCTION:
10807 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10808 /* We don't know anything about what the internal
10809 function might return, but we have to return
10811 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10814 return call_internal_function (exp->gdbarch, exp->language_defn,
10815 argvec[0], nargs, argvec + 1);
10817 case TYPE_CODE_STRUCT:
10821 arity = ada_array_arity (type);
10822 type = ada_array_element_type (type, nargs);
10824 error (_("cannot subscript or call a record"));
10825 if (arity != nargs)
10826 error (_("wrong number of subscripts; expecting %d"), arity);
10827 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10828 return value_zero (ada_aligned_type (type), lval_memory);
10830 unwrap_value (ada_value_subscript
10831 (argvec[0], nargs, argvec + 1));
10833 case TYPE_CODE_ARRAY:
10834 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10836 type = ada_array_element_type (type, nargs);
10838 error (_("element type of array unknown"));
10840 return value_zero (ada_aligned_type (type), lval_memory);
10843 unwrap_value (ada_value_subscript
10844 (ada_coerce_to_simple_array (argvec[0]),
10845 nargs, argvec + 1));
10846 case TYPE_CODE_PTR: /* Pointer to array */
10847 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10849 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10850 type = ada_array_element_type (type, nargs);
10852 error (_("element type of array unknown"));
10854 return value_zero (ada_aligned_type (type), lval_memory);
10857 unwrap_value (ada_value_ptr_subscript (argvec[0],
10858 nargs, argvec + 1));
10861 error (_("Attempt to index or call something other than an "
10862 "array or function"));
10867 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10868 struct value *low_bound_val =
10869 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10870 struct value *high_bound_val =
10871 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10873 LONGEST high_bound;
10875 low_bound_val = coerce_ref (low_bound_val);
10876 high_bound_val = coerce_ref (high_bound_val);
10877 low_bound = value_as_long (low_bound_val);
10878 high_bound = value_as_long (high_bound_val);
10880 if (noside == EVAL_SKIP)
10883 /* If this is a reference to an aligner type, then remove all
10885 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10886 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10887 TYPE_TARGET_TYPE (value_type (array)) =
10888 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10890 if (ada_is_constrained_packed_array_type (value_type (array)))
10891 error (_("cannot slice a packed array"));
10893 /* If this is a reference to an array or an array lvalue,
10894 convert to a pointer. */
10895 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10896 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10897 && VALUE_LVAL (array) == lval_memory))
10898 array = value_addr (array);
10900 if (noside == EVAL_AVOID_SIDE_EFFECTS
10901 && ada_is_array_descriptor_type (ada_check_typedef
10902 (value_type (array))))
10903 return empty_array (ada_type_of_array (array, 0), low_bound,
10906 array = ada_coerce_to_simple_array_ptr (array);
10908 /* If we have more than one level of pointer indirection,
10909 dereference the value until we get only one level. */
10910 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10911 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10913 array = value_ind (array);
10915 /* Make sure we really do have an array type before going further,
10916 to avoid a SEGV when trying to get the index type or the target
10917 type later down the road if the debug info generated by
10918 the compiler is incorrect or incomplete. */
10919 if (!ada_is_simple_array_type (value_type (array)))
10920 error (_("cannot take slice of non-array"));
10922 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10925 struct type *type0 = ada_check_typedef (value_type (array));
10927 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10928 return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10931 struct type *arr_type0 =
10932 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10934 return ada_value_slice_from_ptr (array, arr_type0,
10935 longest_to_int (low_bound),
10936 longest_to_int (high_bound));
10939 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10941 else if (high_bound < low_bound)
10942 return empty_array (value_type (array), low_bound, high_bound);
10944 return ada_value_slice (array, longest_to_int (low_bound),
10945 longest_to_int (high_bound));
10948 case UNOP_IN_RANGE:
10950 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10951 type = check_typedef (exp->elts[pc + 1].type);
10953 if (noside == EVAL_SKIP)
10956 switch (TYPE_CODE (type))
10959 lim_warning (_("Membership test incompletely implemented; "
10960 "always returns true"));
10961 type = language_bool_type (exp->language_defn, exp->gdbarch);
10962 return value_from_longest (type, (LONGEST) 1);
10964 case TYPE_CODE_RANGE:
10965 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10966 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10967 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10968 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10969 type = language_bool_type (exp->language_defn, exp->gdbarch);
10971 value_from_longest (type,
10972 (value_less (arg1, arg3)
10973 || value_equal (arg1, arg3))
10974 && (value_less (arg2, arg1)
10975 || value_equal (arg2, arg1)));
10978 case BINOP_IN_BOUNDS:
10980 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10981 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10983 if (noside == EVAL_SKIP)
10986 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10988 type = language_bool_type (exp->language_defn, exp->gdbarch);
10989 return value_zero (type, not_lval);
10992 tem = longest_to_int (exp->elts[pc + 1].longconst);
10994 type = ada_index_type (value_type (arg2), tem, "range");
10996 type = value_type (arg1);
10998 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10999 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
11001 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11002 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11003 type = language_bool_type (exp->language_defn, exp->gdbarch);
11005 value_from_longest (type,
11006 (value_less (arg1, arg3)
11007 || value_equal (arg1, arg3))
11008 && (value_less (arg2, arg1)
11009 || value_equal (arg2, arg1)));
11011 case TERNOP_IN_RANGE:
11012 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11013 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11014 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11016 if (noside == EVAL_SKIP)
11019 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11020 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11021 type = language_bool_type (exp->language_defn, exp->gdbarch);
11023 value_from_longest (type,
11024 (value_less (arg1, arg3)
11025 || value_equal (arg1, arg3))
11026 && (value_less (arg2, arg1)
11027 || value_equal (arg2, arg1)));
11031 case OP_ATR_LENGTH:
11033 struct type *type_arg;
11035 if (exp->elts[*pos].opcode == OP_TYPE)
11037 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11039 type_arg = check_typedef (exp->elts[pc + 2].type);
11043 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11047 if (exp->elts[*pos].opcode != OP_LONG)
11048 error (_("Invalid operand to '%s"), ada_attribute_name (op));
11049 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11052 if (noside == EVAL_SKIP)
11054 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11056 if (type_arg == NULL)
11057 type_arg = value_type (arg1);
11059 if (ada_is_constrained_packed_array_type (type_arg))
11060 type_arg = decode_constrained_packed_array_type (type_arg);
11062 if (!discrete_type_p (type_arg))
11066 default: /* Should never happen. */
11067 error (_("unexpected attribute encountered"));
11070 type_arg = ada_index_type (type_arg, tem,
11071 ada_attribute_name (op));
11073 case OP_ATR_LENGTH:
11074 type_arg = builtin_type (exp->gdbarch)->builtin_int;
11079 return value_zero (type_arg, not_lval);
11081 else if (type_arg == NULL)
11083 arg1 = ada_coerce_ref (arg1);
11085 if (ada_is_constrained_packed_array_type (value_type (arg1)))
11086 arg1 = ada_coerce_to_simple_array (arg1);
11088 if (op == OP_ATR_LENGTH)
11089 type = builtin_type (exp->gdbarch)->builtin_int;
11092 type = ada_index_type (value_type (arg1), tem,
11093 ada_attribute_name (op));
11095 type = builtin_type (exp->gdbarch)->builtin_int;
11100 default: /* Should never happen. */
11101 error (_("unexpected attribute encountered"));
11103 return value_from_longest
11104 (type, ada_array_bound (arg1, tem, 0));
11106 return value_from_longest
11107 (type, ada_array_bound (arg1, tem, 1));
11108 case OP_ATR_LENGTH:
11109 return value_from_longest
11110 (type, ada_array_length (arg1, tem));
11113 else if (discrete_type_p (type_arg))
11115 struct type *range_type;
11116 const char *name = ada_type_name (type_arg);
11119 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11120 range_type = to_fixed_range_type (type_arg, NULL);
11121 if (range_type == NULL)
11122 range_type = type_arg;
11126 error (_("unexpected attribute encountered"));
11128 return value_from_longest
11129 (range_type, ada_discrete_type_low_bound (range_type));
11131 return value_from_longest
11132 (range_type, ada_discrete_type_high_bound (range_type));
11133 case OP_ATR_LENGTH:
11134 error (_("the 'length attribute applies only to array types"));
11137 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11138 error (_("unimplemented type attribute"));
11143 if (ada_is_constrained_packed_array_type (type_arg))
11144 type_arg = decode_constrained_packed_array_type (type_arg);
11146 if (op == OP_ATR_LENGTH)
11147 type = builtin_type (exp->gdbarch)->builtin_int;
11150 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11152 type = builtin_type (exp->gdbarch)->builtin_int;
11158 error (_("unexpected attribute encountered"));
11160 low = ada_array_bound_from_type (type_arg, tem, 0);
11161 return value_from_longest (type, low);
11163 high = ada_array_bound_from_type (type_arg, tem, 1);
11164 return value_from_longest (type, high);
11165 case OP_ATR_LENGTH:
11166 low = ada_array_bound_from_type (type_arg, tem, 0);
11167 high = ada_array_bound_from_type (type_arg, tem, 1);
11168 return value_from_longest (type, high - low + 1);
11174 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11175 if (noside == EVAL_SKIP)
11178 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11179 return value_zero (ada_tag_type (arg1), not_lval);
11181 return ada_value_tag (arg1);
11185 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11186 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11187 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11188 if (noside == EVAL_SKIP)
11190 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11191 return value_zero (value_type (arg1), not_lval);
11194 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11195 return value_binop (arg1, arg2,
11196 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11199 case OP_ATR_MODULUS:
11201 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11203 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11204 if (noside == EVAL_SKIP)
11207 if (!ada_is_modular_type (type_arg))
11208 error (_("'modulus must be applied to modular type"));
11210 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11211 ada_modulus (type_arg));
11216 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11217 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11218 if (noside == EVAL_SKIP)
11220 type = builtin_type (exp->gdbarch)->builtin_int;
11221 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11222 return value_zero (type, not_lval);
11224 return value_pos_atr (type, arg1);
11227 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11228 type = value_type (arg1);
11230 /* If the argument is a reference, then dereference its type, since
11231 the user is really asking for the size of the actual object,
11232 not the size of the pointer. */
11233 if (TYPE_CODE (type) == TYPE_CODE_REF)
11234 type = TYPE_TARGET_TYPE (type);
11236 if (noside == EVAL_SKIP)
11238 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11239 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11241 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11242 TARGET_CHAR_BIT * TYPE_LENGTH (type));
11245 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11246 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11247 type = exp->elts[pc + 2].type;
11248 if (noside == EVAL_SKIP)
11250 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11251 return value_zero (type, not_lval);
11253 return value_val_atr (type, arg1);
11256 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11257 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11258 if (noside == EVAL_SKIP)
11260 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11261 return value_zero (value_type (arg1), not_lval);
11264 /* For integer exponentiation operations,
11265 only promote the first argument. */
11266 if (is_integral_type (value_type (arg2)))
11267 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11269 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11271 return value_binop (arg1, arg2, op);
11275 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11276 if (noside == EVAL_SKIP)
11282 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11283 if (noside == EVAL_SKIP)
11285 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11286 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11287 return value_neg (arg1);
11292 preeval_pos = *pos;
11293 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11294 if (noside == EVAL_SKIP)
11296 type = ada_check_typedef (value_type (arg1));
11297 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11299 if (ada_is_array_descriptor_type (type))
11300 /* GDB allows dereferencing GNAT array descriptors. */
11302 struct type *arrType = ada_type_of_array (arg1, 0);
11304 if (arrType == NULL)
11305 error (_("Attempt to dereference null array pointer."));
11306 return value_at_lazy (arrType, 0);
11308 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11309 || TYPE_CODE (type) == TYPE_CODE_REF
11310 /* In C you can dereference an array to get the 1st elt. */
11311 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11313 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11314 only be determined by inspecting the object's tag.
11315 This means that we need to evaluate completely the
11316 expression in order to get its type. */
11318 if ((TYPE_CODE (type) == TYPE_CODE_REF
11319 || TYPE_CODE (type) == TYPE_CODE_PTR)
11320 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11322 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11324 type = value_type (ada_value_ind (arg1));
11328 type = to_static_fixed_type
11330 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11332 ada_ensure_varsize_limit (type);
11333 return value_zero (type, lval_memory);
11335 else if (TYPE_CODE (type) == TYPE_CODE_INT)
11337 /* GDB allows dereferencing an int. */
11338 if (expect_type == NULL)
11339 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11344 to_static_fixed_type (ada_aligned_type (expect_type));
11345 return value_zero (expect_type, lval_memory);
11349 error (_("Attempt to take contents of a non-pointer value."));
11351 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11352 type = ada_check_typedef (value_type (arg1));
11354 if (TYPE_CODE (type) == TYPE_CODE_INT)
11355 /* GDB allows dereferencing an int. If we were given
11356 the expect_type, then use that as the target type.
11357 Otherwise, assume that the target type is an int. */
11359 if (expect_type != NULL)
11360 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11363 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11364 (CORE_ADDR) value_as_address (arg1));
11367 if (ada_is_array_descriptor_type (type))
11368 /* GDB allows dereferencing GNAT array descriptors. */
11369 return ada_coerce_to_simple_array (arg1);
11371 return ada_value_ind (arg1);
11373 case STRUCTOP_STRUCT:
11374 tem = longest_to_int (exp->elts[pc + 1].longconst);
11375 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11376 preeval_pos = *pos;
11377 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11378 if (noside == EVAL_SKIP)
11380 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11382 struct type *type1 = value_type (arg1);
11384 if (ada_is_tagged_type (type1, 1))
11386 type = ada_lookup_struct_elt_type (type1,
11387 &exp->elts[pc + 2].string,
11390 /* If the field is not found, check if it exists in the
11391 extension of this object's type. This means that we
11392 need to evaluate completely the expression. */
11396 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11398 arg1 = ada_value_struct_elt (arg1,
11399 &exp->elts[pc + 2].string,
11401 arg1 = unwrap_value (arg1);
11402 type = value_type (ada_to_fixed_value (arg1));
11407 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11410 return value_zero (ada_aligned_type (type), lval_memory);
11414 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11415 arg1 = unwrap_value (arg1);
11416 return ada_to_fixed_value (arg1);
11420 /* The value is not supposed to be used. This is here to make it
11421 easier to accommodate expressions that contain types. */
11423 if (noside == EVAL_SKIP)
11425 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11426 return allocate_value (exp->elts[pc + 1].type);
11428 error (_("Attempt to use a type name as an expression"));
11433 case OP_DISCRETE_RANGE:
11434 case OP_POSITIONAL:
11436 if (noside == EVAL_NORMAL)
11440 error (_("Undefined name, ambiguous name, or renaming used in "
11441 "component association: %s."), &exp->elts[pc+2].string);
11443 error (_("Aggregates only allowed on the right of an assignment"));
11445 internal_error (__FILE__, __LINE__,
11446 _("aggregate apparently mangled"));
11449 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11451 for (tem = 0; tem < nargs; tem += 1)
11452 ada_evaluate_subexp (NULL, exp, pos, noside);
11457 return eval_skip_value (exp);
11463 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11464 type name that encodes the 'small and 'delta information.
11465 Otherwise, return NULL. */
11467 static const char *
11468 fixed_type_info (struct type *type)
11470 const char *name = ada_type_name (type);
11471 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11473 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11475 const char *tail = strstr (name, "___XF_");
11482 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11483 return fixed_type_info (TYPE_TARGET_TYPE (type));
11488 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11491 ada_is_fixed_point_type (struct type *type)
11493 return fixed_type_info (type) != NULL;
11496 /* Return non-zero iff TYPE represents a System.Address type. */
11499 ada_is_system_address_type (struct type *type)
11501 return (TYPE_NAME (type)
11502 && strcmp (TYPE_NAME (type), "system__address") == 0);
11505 /* Assuming that TYPE is the representation of an Ada fixed-point
11506 type, return the target floating-point type to be used to represent
11507 of this type during internal computation. */
11509 static struct type *
11510 ada_scaling_type (struct type *type)
11512 return builtin_type (get_type_arch (type))->builtin_long_double;
11515 /* Assuming that TYPE is the representation of an Ada fixed-point
11516 type, return its delta, or NULL if the type is malformed and the
11517 delta cannot be determined. */
11520 ada_delta (struct type *type)
11522 const char *encoding = fixed_type_info (type);
11523 struct type *scale_type = ada_scaling_type (type);
11525 long long num, den;
11527 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11530 return value_binop (value_from_longest (scale_type, num),
11531 value_from_longest (scale_type, den), BINOP_DIV);
11534 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11535 factor ('SMALL value) associated with the type. */
11538 ada_scaling_factor (struct type *type)
11540 const char *encoding = fixed_type_info (type);
11541 struct type *scale_type = ada_scaling_type (type);
11543 long long num0, den0, num1, den1;
11546 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11547 &num0, &den0, &num1, &den1);
11550 return value_from_longest (scale_type, 1);
11552 return value_binop (value_from_longest (scale_type, num1),
11553 value_from_longest (scale_type, den1), BINOP_DIV);
11555 return value_binop (value_from_longest (scale_type, num0),
11556 value_from_longest (scale_type, den0), BINOP_DIV);
11563 /* Scan STR beginning at position K for a discriminant name, and
11564 return the value of that discriminant field of DVAL in *PX. If
11565 PNEW_K is not null, put the position of the character beyond the
11566 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11567 not alter *PX and *PNEW_K if unsuccessful. */
11570 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11573 static char *bound_buffer = NULL;
11574 static size_t bound_buffer_len = 0;
11575 const char *pstart, *pend, *bound;
11576 struct value *bound_val;
11578 if (dval == NULL || str == NULL || str[k] == '\0')
11582 pend = strstr (pstart, "__");
11586 k += strlen (bound);
11590 int len = pend - pstart;
11592 /* Strip __ and beyond. */
11593 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11594 strncpy (bound_buffer, pstart, len);
11595 bound_buffer[len] = '\0';
11597 bound = bound_buffer;
11601 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11602 if (bound_val == NULL)
11605 *px = value_as_long (bound_val);
11606 if (pnew_k != NULL)
11611 /* Value of variable named NAME in the current environment. If
11612 no such variable found, then if ERR_MSG is null, returns 0, and
11613 otherwise causes an error with message ERR_MSG. */
11615 static struct value *
11616 get_var_value (const char *name, const char *err_msg)
11618 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11620 std::vector<struct block_symbol> syms;
11621 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11622 get_selected_block (0),
11623 VAR_DOMAIN, &syms, 1);
11627 if (err_msg == NULL)
11630 error (("%s"), err_msg);
11633 return value_of_variable (syms[0].symbol, syms[0].block);
11636 /* Value of integer variable named NAME in the current environment.
11637 If no such variable is found, returns false. Otherwise, sets VALUE
11638 to the variable's value and returns true. */
11641 get_int_var_value (const char *name, LONGEST &value)
11643 struct value *var_val = get_var_value (name, 0);
11648 value = value_as_long (var_val);
11653 /* Return a range type whose base type is that of the range type named
11654 NAME in the current environment, and whose bounds are calculated
11655 from NAME according to the GNAT range encoding conventions.
11656 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11657 corresponding range type from debug information; fall back to using it
11658 if symbol lookup fails. If a new type must be created, allocate it
11659 like ORIG_TYPE was. The bounds information, in general, is encoded
11660 in NAME, the base type given in the named range type. */
11662 static struct type *
11663 to_fixed_range_type (struct type *raw_type, struct value *dval)
11666 struct type *base_type;
11667 const char *subtype_info;
11669 gdb_assert (raw_type != NULL);
11670 gdb_assert (TYPE_NAME (raw_type) != NULL);
11672 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11673 base_type = TYPE_TARGET_TYPE (raw_type);
11675 base_type = raw_type;
11677 name = TYPE_NAME (raw_type);
11678 subtype_info = strstr (name, "___XD");
11679 if (subtype_info == NULL)
11681 LONGEST L = ada_discrete_type_low_bound (raw_type);
11682 LONGEST U = ada_discrete_type_high_bound (raw_type);
11684 if (L < INT_MIN || U > INT_MAX)
11687 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11692 static char *name_buf = NULL;
11693 static size_t name_len = 0;
11694 int prefix_len = subtype_info - name;
11697 const char *bounds_str;
11700 GROW_VECT (name_buf, name_len, prefix_len + 5);
11701 strncpy (name_buf, name, prefix_len);
11702 name_buf[prefix_len] = '\0';
11705 bounds_str = strchr (subtype_info, '_');
11708 if (*subtype_info == 'L')
11710 if (!ada_scan_number (bounds_str, n, &L, &n)
11711 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11713 if (bounds_str[n] == '_')
11715 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11721 strcpy (name_buf + prefix_len, "___L");
11722 if (!get_int_var_value (name_buf, L))
11724 lim_warning (_("Unknown lower bound, using 1."));
11729 if (*subtype_info == 'U')
11731 if (!ada_scan_number (bounds_str, n, &U, &n)
11732 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11737 strcpy (name_buf + prefix_len, "___U");
11738 if (!get_int_var_value (name_buf, U))
11740 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11745 type = create_static_range_type (alloc_type_copy (raw_type),
11747 /* create_static_range_type alters the resulting type's length
11748 to match the size of the base_type, which is not what we want.
11749 Set it back to the original range type's length. */
11750 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11751 TYPE_NAME (type) = name;
11756 /* True iff NAME is the name of a range type. */
11759 ada_is_range_type_name (const char *name)
11761 return (name != NULL && strstr (name, "___XD"));
11765 /* Modular types */
11767 /* True iff TYPE is an Ada modular type. */
11770 ada_is_modular_type (struct type *type)
11772 struct type *subranged_type = get_base_type (type);
11774 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11775 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11776 && TYPE_UNSIGNED (subranged_type));
11779 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11782 ada_modulus (struct type *type)
11784 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11788 /* Ada exception catchpoint support:
11789 ---------------------------------
11791 We support 3 kinds of exception catchpoints:
11792 . catchpoints on Ada exceptions
11793 . catchpoints on unhandled Ada exceptions
11794 . catchpoints on failed assertions
11796 Exceptions raised during failed assertions, or unhandled exceptions
11797 could perfectly be caught with the general catchpoint on Ada exceptions.
11798 However, we can easily differentiate these two special cases, and having
11799 the option to distinguish these two cases from the rest can be useful
11800 to zero-in on certain situations.
11802 Exception catchpoints are a specialized form of breakpoint,
11803 since they rely on inserting breakpoints inside known routines
11804 of the GNAT runtime. The implementation therefore uses a standard
11805 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11808 Support in the runtime for exception catchpoints have been changed
11809 a few times already, and these changes affect the implementation
11810 of these catchpoints. In order to be able to support several
11811 variants of the runtime, we use a sniffer that will determine
11812 the runtime variant used by the program being debugged. */
11814 /* Ada's standard exceptions.
11816 The Ada 83 standard also defined Numeric_Error. But there so many
11817 situations where it was unclear from the Ada 83 Reference Manual
11818 (RM) whether Constraint_Error or Numeric_Error should be raised,
11819 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11820 Interpretation saying that anytime the RM says that Numeric_Error
11821 should be raised, the implementation may raise Constraint_Error.
11822 Ada 95 went one step further and pretty much removed Numeric_Error
11823 from the list of standard exceptions (it made it a renaming of
11824 Constraint_Error, to help preserve compatibility when compiling
11825 an Ada83 compiler). As such, we do not include Numeric_Error from
11826 this list of standard exceptions. */
11828 static const char *standard_exc[] = {
11829 "constraint_error",
11835 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11837 /* A structure that describes how to support exception catchpoints
11838 for a given executable. */
11840 struct exception_support_info
11842 /* The name of the symbol to break on in order to insert
11843 a catchpoint on exceptions. */
11844 const char *catch_exception_sym;
11846 /* The name of the symbol to break on in order to insert
11847 a catchpoint on unhandled exceptions. */
11848 const char *catch_exception_unhandled_sym;
11850 /* The name of the symbol to break on in order to insert
11851 a catchpoint on failed assertions. */
11852 const char *catch_assert_sym;
11854 /* The name of the symbol to break on in order to insert
11855 a catchpoint on exception handling. */
11856 const char *catch_handlers_sym;
11858 /* Assuming that the inferior just triggered an unhandled exception
11859 catchpoint, this function is responsible for returning the address
11860 in inferior memory where the name of that exception is stored.
11861 Return zero if the address could not be computed. */
11862 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11865 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11866 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11868 /* The following exception support info structure describes how to
11869 implement exception catchpoints with the latest version of the
11870 Ada runtime (as of 2007-03-06). */
11872 static const struct exception_support_info default_exception_support_info =
11874 "__gnat_debug_raise_exception", /* catch_exception_sym */
11875 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11876 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11877 "__gnat_begin_handler", /* catch_handlers_sym */
11878 ada_unhandled_exception_name_addr
11881 /* The following exception support info structure describes how to
11882 implement exception catchpoints with a slightly older version
11883 of the Ada runtime. */
11885 static const struct exception_support_info exception_support_info_fallback =
11887 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11888 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11889 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11890 "__gnat_begin_handler", /* catch_handlers_sym */
11891 ada_unhandled_exception_name_addr_from_raise
11894 /* Return nonzero if we can detect the exception support routines
11895 described in EINFO.
11897 This function errors out if an abnormal situation is detected
11898 (for instance, if we find the exception support routines, but
11899 that support is found to be incomplete). */
11902 ada_has_this_exception_support (const struct exception_support_info *einfo)
11904 struct symbol *sym;
11906 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11907 that should be compiled with debugging information. As a result, we
11908 expect to find that symbol in the symtabs. */
11910 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11913 /* Perhaps we did not find our symbol because the Ada runtime was
11914 compiled without debugging info, or simply stripped of it.
11915 It happens on some GNU/Linux distributions for instance, where
11916 users have to install a separate debug package in order to get
11917 the runtime's debugging info. In that situation, let the user
11918 know why we cannot insert an Ada exception catchpoint.
11920 Note: Just for the purpose of inserting our Ada exception
11921 catchpoint, we could rely purely on the associated minimal symbol.
11922 But we would be operating in degraded mode anyway, since we are
11923 still lacking the debugging info needed later on to extract
11924 the name of the exception being raised (this name is printed in
11925 the catchpoint message, and is also used when trying to catch
11926 a specific exception). We do not handle this case for now. */
11927 struct bound_minimal_symbol msym
11928 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11930 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11931 error (_("Your Ada runtime appears to be missing some debugging "
11932 "information.\nCannot insert Ada exception catchpoint "
11933 "in this configuration."));
11938 /* Make sure that the symbol we found corresponds to a function. */
11940 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11941 error (_("Symbol \"%s\" is not a function (class = %d)"),
11942 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11947 /* Inspect the Ada runtime and determine which exception info structure
11948 should be used to provide support for exception catchpoints.
11950 This function will always set the per-inferior exception_info,
11951 or raise an error. */
11954 ada_exception_support_info_sniffer (void)
11956 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11958 /* If the exception info is already known, then no need to recompute it. */
11959 if (data->exception_info != NULL)
11962 /* Check the latest (default) exception support info. */
11963 if (ada_has_this_exception_support (&default_exception_support_info))
11965 data->exception_info = &default_exception_support_info;
11969 /* Try our fallback exception suport info. */
11970 if (ada_has_this_exception_support (&exception_support_info_fallback))
11972 data->exception_info = &exception_support_info_fallback;
11976 /* Sometimes, it is normal for us to not be able to find the routine
11977 we are looking for. This happens when the program is linked with
11978 the shared version of the GNAT runtime, and the program has not been
11979 started yet. Inform the user of these two possible causes if
11982 if (ada_update_initial_language (language_unknown) != language_ada)
11983 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11985 /* If the symbol does not exist, then check that the program is
11986 already started, to make sure that shared libraries have been
11987 loaded. If it is not started, this may mean that the symbol is
11988 in a shared library. */
11990 if (inferior_ptid.pid () == 0)
11991 error (_("Unable to insert catchpoint. Try to start the program first."));
11993 /* At this point, we know that we are debugging an Ada program and
11994 that the inferior has been started, but we still are not able to
11995 find the run-time symbols. That can mean that we are in
11996 configurable run time mode, or that a-except as been optimized
11997 out by the linker... In any case, at this point it is not worth
11998 supporting this feature. */
12000 error (_("Cannot insert Ada exception catchpoints in this configuration."));
12003 /* True iff FRAME is very likely to be that of a function that is
12004 part of the runtime system. This is all very heuristic, but is
12005 intended to be used as advice as to what frames are uninteresting
12009 is_known_support_routine (struct frame_info *frame)
12011 enum language func_lang;
12013 const char *fullname;
12015 /* If this code does not have any debugging information (no symtab),
12016 This cannot be any user code. */
12018 symtab_and_line sal = find_frame_sal (frame);
12019 if (sal.symtab == NULL)
12022 /* If there is a symtab, but the associated source file cannot be
12023 located, then assume this is not user code: Selecting a frame
12024 for which we cannot display the code would not be very helpful
12025 for the user. This should also take care of case such as VxWorks
12026 where the kernel has some debugging info provided for a few units. */
12028 fullname = symtab_to_fullname (sal.symtab);
12029 if (access (fullname, R_OK) != 0)
12032 /* Check the unit filename againt the Ada runtime file naming.
12033 We also check the name of the objfile against the name of some
12034 known system libraries that sometimes come with debugging info
12037 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12039 re_comp (known_runtime_file_name_patterns[i]);
12040 if (re_exec (lbasename (sal.symtab->filename)))
12042 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12043 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12047 /* Check whether the function is a GNAT-generated entity. */
12049 gdb::unique_xmalloc_ptr<char> func_name
12050 = find_frame_funname (frame, &func_lang, NULL);
12051 if (func_name == NULL)
12054 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12056 re_comp (known_auxiliary_function_name_patterns[i]);
12057 if (re_exec (func_name.get ()))
12064 /* Find the first frame that contains debugging information and that is not
12065 part of the Ada run-time, starting from FI and moving upward. */
12068 ada_find_printable_frame (struct frame_info *fi)
12070 for (; fi != NULL; fi = get_prev_frame (fi))
12072 if (!is_known_support_routine (fi))
12081 /* Assuming that the inferior just triggered an unhandled exception
12082 catchpoint, return the address in inferior memory where the name
12083 of the exception is stored.
12085 Return zero if the address could not be computed. */
12088 ada_unhandled_exception_name_addr (void)
12090 return parse_and_eval_address ("e.full_name");
12093 /* Same as ada_unhandled_exception_name_addr, except that this function
12094 should be used when the inferior uses an older version of the runtime,
12095 where the exception name needs to be extracted from a specific frame
12096 several frames up in the callstack. */
12099 ada_unhandled_exception_name_addr_from_raise (void)
12102 struct frame_info *fi;
12103 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12105 /* To determine the name of this exception, we need to select
12106 the frame corresponding to RAISE_SYM_NAME. This frame is
12107 at least 3 levels up, so we simply skip the first 3 frames
12108 without checking the name of their associated function. */
12109 fi = get_current_frame ();
12110 for (frame_level = 0; frame_level < 3; frame_level += 1)
12112 fi = get_prev_frame (fi);
12116 enum language func_lang;
12118 gdb::unique_xmalloc_ptr<char> func_name
12119 = find_frame_funname (fi, &func_lang, NULL);
12120 if (func_name != NULL)
12122 if (strcmp (func_name.get (),
12123 data->exception_info->catch_exception_sym) == 0)
12124 break; /* We found the frame we were looking for... */
12126 fi = get_prev_frame (fi);
12133 return parse_and_eval_address ("id.full_name");
12136 /* Assuming the inferior just triggered an Ada exception catchpoint
12137 (of any type), return the address in inferior memory where the name
12138 of the exception is stored, if applicable.
12140 Assumes the selected frame is the current frame.
12142 Return zero if the address could not be computed, or if not relevant. */
12145 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12146 struct breakpoint *b)
12148 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12152 case ada_catch_exception:
12153 return (parse_and_eval_address ("e.full_name"));
12156 case ada_catch_exception_unhandled:
12157 return data->exception_info->unhandled_exception_name_addr ();
12160 case ada_catch_handlers:
12161 return 0; /* The runtimes does not provide access to the exception
12165 case ada_catch_assert:
12166 return 0; /* Exception name is not relevant in this case. */
12170 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12174 return 0; /* Should never be reached. */
12177 /* Assuming the inferior is stopped at an exception catchpoint,
12178 return the message which was associated to the exception, if
12179 available. Return NULL if the message could not be retrieved.
12181 Note: The exception message can be associated to an exception
12182 either through the use of the Raise_Exception function, or
12183 more simply (Ada 2005 and later), via:
12185 raise Exception_Name with "exception message";
12189 static gdb::unique_xmalloc_ptr<char>
12190 ada_exception_message_1 (void)
12192 struct value *e_msg_val;
12195 /* For runtimes that support this feature, the exception message
12196 is passed as an unbounded string argument called "message". */
12197 e_msg_val = parse_and_eval ("message");
12198 if (e_msg_val == NULL)
12199 return NULL; /* Exception message not supported. */
12201 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12202 gdb_assert (e_msg_val != NULL);
12203 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12205 /* If the message string is empty, then treat it as if there was
12206 no exception message. */
12207 if (e_msg_len <= 0)
12210 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12211 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12212 e_msg.get ()[e_msg_len] = '\0';
12217 /* Same as ada_exception_message_1, except that all exceptions are
12218 contained here (returning NULL instead). */
12220 static gdb::unique_xmalloc_ptr<char>
12221 ada_exception_message (void)
12223 gdb::unique_xmalloc_ptr<char> e_msg;
12227 e_msg = ada_exception_message_1 ();
12229 catch (const gdb_exception_error &e)
12231 e_msg.reset (nullptr);
12237 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12238 any error that ada_exception_name_addr_1 might cause to be thrown.
12239 When an error is intercepted, a warning with the error message is printed,
12240 and zero is returned. */
12243 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12244 struct breakpoint *b)
12246 CORE_ADDR result = 0;
12250 result = ada_exception_name_addr_1 (ex, b);
12253 catch (const gdb_exception_error &e)
12255 warning (_("failed to get exception name: %s"), e.what ());
12262 static std::string ada_exception_catchpoint_cond_string
12263 (const char *excep_string,
12264 enum ada_exception_catchpoint_kind ex);
12266 /* Ada catchpoints.
12268 In the case of catchpoints on Ada exceptions, the catchpoint will
12269 stop the target on every exception the program throws. When a user
12270 specifies the name of a specific exception, we translate this
12271 request into a condition expression (in text form), and then parse
12272 it into an expression stored in each of the catchpoint's locations.
12273 We then use this condition to check whether the exception that was
12274 raised is the one the user is interested in. If not, then the
12275 target is resumed again. We store the name of the requested
12276 exception, in order to be able to re-set the condition expression
12277 when symbols change. */
12279 /* An instance of this type is used to represent an Ada catchpoint
12280 breakpoint location. */
12282 class ada_catchpoint_location : public bp_location
12285 ada_catchpoint_location (breakpoint *owner)
12286 : bp_location (owner)
12289 /* The condition that checks whether the exception that was raised
12290 is the specific exception the user specified on catchpoint
12292 expression_up excep_cond_expr;
12295 /* An instance of this type is used to represent an Ada catchpoint. */
12297 struct ada_catchpoint : public breakpoint
12299 /* The name of the specific exception the user specified. */
12300 std::string excep_string;
12303 /* Parse the exception condition string in the context of each of the
12304 catchpoint's locations, and store them for later evaluation. */
12307 create_excep_cond_exprs (struct ada_catchpoint *c,
12308 enum ada_exception_catchpoint_kind ex)
12310 /* Nothing to do if there's no specific exception to catch. */
12311 if (c->excep_string.empty ())
12314 /* Same if there are no locations... */
12315 if (c->loc == NULL)
12318 /* We have to compute the expression once for each program space,
12319 because the expression may hold the addresses of multiple symbols
12321 std::multimap<program_space *, struct bp_location *> loc_map;
12322 for (bp_location *bl = c->loc; bl != NULL; bl = bl->next)
12323 loc_map.emplace (bl->pspace, bl);
12325 scoped_restore_current_program_space save_pspace;
12327 std::string cond_string;
12328 program_space *last_ps = nullptr;
12329 for (auto iter : loc_map)
12331 struct ada_catchpoint_location *ada_loc
12332 = (struct ada_catchpoint_location *) iter.second;
12334 if (ada_loc->pspace != last_ps)
12336 last_ps = ada_loc->pspace;
12337 set_current_program_space (last_ps);
12339 /* Compute the condition expression in text form, from the
12340 specific expection we want to catch. */
12342 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (),
12348 if (!ada_loc->shlib_disabled)
12352 s = cond_string.c_str ();
12355 exp = parse_exp_1 (&s, ada_loc->address,
12356 block_for_pc (ada_loc->address),
12359 catch (const gdb_exception_error &e)
12361 warning (_("failed to reevaluate internal exception condition "
12362 "for catchpoint %d: %s"),
12363 c->number, e.what ());
12367 ada_loc->excep_cond_expr = std::move (exp);
12371 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12372 structure for all exception catchpoint kinds. */
12374 static struct bp_location *
12375 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12376 struct breakpoint *self)
12378 return new ada_catchpoint_location (self);
12381 /* Implement the RE_SET method in the breakpoint_ops structure for all
12382 exception catchpoint kinds. */
12385 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12387 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12389 /* Call the base class's method. This updates the catchpoint's
12391 bkpt_breakpoint_ops.re_set (b);
12393 /* Reparse the exception conditional expressions. One for each
12395 create_excep_cond_exprs (c, ex);
12398 /* Returns true if we should stop for this breakpoint hit. If the
12399 user specified a specific exception, we only want to cause a stop
12400 if the program thrown that exception. */
12403 should_stop_exception (const struct bp_location *bl)
12405 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12406 const struct ada_catchpoint_location *ada_loc
12407 = (const struct ada_catchpoint_location *) bl;
12410 /* With no specific exception, should always stop. */
12411 if (c->excep_string.empty ())
12414 if (ada_loc->excep_cond_expr == NULL)
12416 /* We will have a NULL expression if back when we were creating
12417 the expressions, this location's had failed to parse. */
12424 struct value *mark;
12426 mark = value_mark ();
12427 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12428 value_free_to_mark (mark);
12430 catch (const gdb_exception &ex)
12432 exception_fprintf (gdb_stderr, ex,
12433 _("Error in testing exception condition:\n"));
12439 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12440 for all exception catchpoint kinds. */
12443 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12445 bs->stop = should_stop_exception (bs->bp_location_at);
12448 /* Implement the PRINT_IT method in the breakpoint_ops structure
12449 for all exception catchpoint kinds. */
12451 static enum print_stop_action
12452 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12454 struct ui_out *uiout = current_uiout;
12455 struct breakpoint *b = bs->breakpoint_at;
12457 annotate_catchpoint (b->number);
12459 if (uiout->is_mi_like_p ())
12461 uiout->field_string ("reason",
12462 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12463 uiout->field_string ("disp", bpdisp_text (b->disposition));
12466 uiout->text (b->disposition == disp_del
12467 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12468 uiout->field_int ("bkptno", b->number);
12469 uiout->text (", ");
12471 /* ada_exception_name_addr relies on the selected frame being the
12472 current frame. Need to do this here because this function may be
12473 called more than once when printing a stop, and below, we'll
12474 select the first frame past the Ada run-time (see
12475 ada_find_printable_frame). */
12476 select_frame (get_current_frame ());
12480 case ada_catch_exception:
12481 case ada_catch_exception_unhandled:
12482 case ada_catch_handlers:
12484 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12485 char exception_name[256];
12489 read_memory (addr, (gdb_byte *) exception_name,
12490 sizeof (exception_name) - 1);
12491 exception_name [sizeof (exception_name) - 1] = '\0';
12495 /* For some reason, we were unable to read the exception
12496 name. This could happen if the Runtime was compiled
12497 without debugging info, for instance. In that case,
12498 just replace the exception name by the generic string
12499 "exception" - it will read as "an exception" in the
12500 notification we are about to print. */
12501 memcpy (exception_name, "exception", sizeof ("exception"));
12503 /* In the case of unhandled exception breakpoints, we print
12504 the exception name as "unhandled EXCEPTION_NAME", to make
12505 it clearer to the user which kind of catchpoint just got
12506 hit. We used ui_out_text to make sure that this extra
12507 info does not pollute the exception name in the MI case. */
12508 if (ex == ada_catch_exception_unhandled)
12509 uiout->text ("unhandled ");
12510 uiout->field_string ("exception-name", exception_name);
12513 case ada_catch_assert:
12514 /* In this case, the name of the exception is not really
12515 important. Just print "failed assertion" to make it clearer
12516 that his program just hit an assertion-failure catchpoint.
12517 We used ui_out_text because this info does not belong in
12519 uiout->text ("failed assertion");
12523 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12524 if (exception_message != NULL)
12526 uiout->text (" (");
12527 uiout->field_string ("exception-message", exception_message.get ());
12531 uiout->text (" at ");
12532 ada_find_printable_frame (get_current_frame ());
12534 return PRINT_SRC_AND_LOC;
12537 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12538 for all exception catchpoint kinds. */
12541 print_one_exception (enum ada_exception_catchpoint_kind ex,
12542 struct breakpoint *b, struct bp_location **last_loc)
12544 struct ui_out *uiout = current_uiout;
12545 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12546 struct value_print_options opts;
12548 get_user_print_options (&opts);
12549 if (opts.addressprint)
12551 annotate_field (4);
12552 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12555 annotate_field (5);
12556 *last_loc = b->loc;
12559 case ada_catch_exception:
12560 if (!c->excep_string.empty ())
12562 std::string msg = string_printf (_("`%s' Ada exception"),
12563 c->excep_string.c_str ());
12565 uiout->field_string ("what", msg);
12568 uiout->field_string ("what", "all Ada exceptions");
12572 case ada_catch_exception_unhandled:
12573 uiout->field_string ("what", "unhandled Ada exceptions");
12576 case ada_catch_handlers:
12577 if (!c->excep_string.empty ())
12579 uiout->field_fmt ("what",
12580 _("`%s' Ada exception handlers"),
12581 c->excep_string.c_str ());
12584 uiout->field_string ("what", "all Ada exceptions handlers");
12587 case ada_catch_assert:
12588 uiout->field_string ("what", "failed Ada assertions");
12592 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12597 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12598 for all exception catchpoint kinds. */
12601 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12602 struct breakpoint *b)
12604 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12605 struct ui_out *uiout = current_uiout;
12607 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12608 : _("Catchpoint "));
12609 uiout->field_int ("bkptno", b->number);
12610 uiout->text (": ");
12614 case ada_catch_exception:
12615 if (!c->excep_string.empty ())
12617 std::string info = string_printf (_("`%s' Ada exception"),
12618 c->excep_string.c_str ());
12619 uiout->text (info.c_str ());
12622 uiout->text (_("all Ada exceptions"));
12625 case ada_catch_exception_unhandled:
12626 uiout->text (_("unhandled Ada exceptions"));
12629 case ada_catch_handlers:
12630 if (!c->excep_string.empty ())
12633 = string_printf (_("`%s' Ada exception handlers"),
12634 c->excep_string.c_str ());
12635 uiout->text (info.c_str ());
12638 uiout->text (_("all Ada exceptions handlers"));
12641 case ada_catch_assert:
12642 uiout->text (_("failed Ada assertions"));
12646 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12651 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12652 for all exception catchpoint kinds. */
12655 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12656 struct breakpoint *b, struct ui_file *fp)
12658 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12662 case ada_catch_exception:
12663 fprintf_filtered (fp, "catch exception");
12664 if (!c->excep_string.empty ())
12665 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12668 case ada_catch_exception_unhandled:
12669 fprintf_filtered (fp, "catch exception unhandled");
12672 case ada_catch_handlers:
12673 fprintf_filtered (fp, "catch handlers");
12676 case ada_catch_assert:
12677 fprintf_filtered (fp, "catch assert");
12681 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12683 print_recreate_thread (b, fp);
12686 /* Virtual table for "catch exception" breakpoints. */
12688 static struct bp_location *
12689 allocate_location_catch_exception (struct breakpoint *self)
12691 return allocate_location_exception (ada_catch_exception, self);
12695 re_set_catch_exception (struct breakpoint *b)
12697 re_set_exception (ada_catch_exception, b);
12701 check_status_catch_exception (bpstat bs)
12703 check_status_exception (ada_catch_exception, bs);
12706 static enum print_stop_action
12707 print_it_catch_exception (bpstat bs)
12709 return print_it_exception (ada_catch_exception, bs);
12713 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12715 print_one_exception (ada_catch_exception, b, last_loc);
12719 print_mention_catch_exception (struct breakpoint *b)
12721 print_mention_exception (ada_catch_exception, b);
12725 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12727 print_recreate_exception (ada_catch_exception, b, fp);
12730 static struct breakpoint_ops catch_exception_breakpoint_ops;
12732 /* Virtual table for "catch exception unhandled" breakpoints. */
12734 static struct bp_location *
12735 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12737 return allocate_location_exception (ada_catch_exception_unhandled, self);
12741 re_set_catch_exception_unhandled (struct breakpoint *b)
12743 re_set_exception (ada_catch_exception_unhandled, b);
12747 check_status_catch_exception_unhandled (bpstat bs)
12749 check_status_exception (ada_catch_exception_unhandled, bs);
12752 static enum print_stop_action
12753 print_it_catch_exception_unhandled (bpstat bs)
12755 return print_it_exception (ada_catch_exception_unhandled, bs);
12759 print_one_catch_exception_unhandled (struct breakpoint *b,
12760 struct bp_location **last_loc)
12762 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12766 print_mention_catch_exception_unhandled (struct breakpoint *b)
12768 print_mention_exception (ada_catch_exception_unhandled, b);
12772 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12773 struct ui_file *fp)
12775 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12778 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12780 /* Virtual table for "catch assert" breakpoints. */
12782 static struct bp_location *
12783 allocate_location_catch_assert (struct breakpoint *self)
12785 return allocate_location_exception (ada_catch_assert, self);
12789 re_set_catch_assert (struct breakpoint *b)
12791 re_set_exception (ada_catch_assert, b);
12795 check_status_catch_assert (bpstat bs)
12797 check_status_exception (ada_catch_assert, bs);
12800 static enum print_stop_action
12801 print_it_catch_assert (bpstat bs)
12803 return print_it_exception (ada_catch_assert, bs);
12807 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
12809 print_one_exception (ada_catch_assert, b, last_loc);
12813 print_mention_catch_assert (struct breakpoint *b)
12815 print_mention_exception (ada_catch_assert, b);
12819 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12821 print_recreate_exception (ada_catch_assert, b, fp);
12824 static struct breakpoint_ops catch_assert_breakpoint_ops;
12826 /* Virtual table for "catch handlers" breakpoints. */
12828 static struct bp_location *
12829 allocate_location_catch_handlers (struct breakpoint *self)
12831 return allocate_location_exception (ada_catch_handlers, self);
12835 re_set_catch_handlers (struct breakpoint *b)
12837 re_set_exception (ada_catch_handlers, b);
12841 check_status_catch_handlers (bpstat bs)
12843 check_status_exception (ada_catch_handlers, bs);
12846 static enum print_stop_action
12847 print_it_catch_handlers (bpstat bs)
12849 return print_it_exception (ada_catch_handlers, bs);
12853 print_one_catch_handlers (struct breakpoint *b,
12854 struct bp_location **last_loc)
12856 print_one_exception (ada_catch_handlers, b, last_loc);
12860 print_mention_catch_handlers (struct breakpoint *b)
12862 print_mention_exception (ada_catch_handlers, b);
12866 print_recreate_catch_handlers (struct breakpoint *b,
12867 struct ui_file *fp)
12869 print_recreate_exception (ada_catch_handlers, b, fp);
12872 static struct breakpoint_ops catch_handlers_breakpoint_ops;
12874 /* Split the arguments specified in a "catch exception" command.
12875 Set EX to the appropriate catchpoint type.
12876 Set EXCEP_STRING to the name of the specific exception if
12877 specified by the user.
12878 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12879 "catch handlers" command. False otherwise.
12880 If a condition is found at the end of the arguments, the condition
12881 expression is stored in COND_STRING (memory must be deallocated
12882 after use). Otherwise COND_STRING is set to NULL. */
12885 catch_ada_exception_command_split (const char *args,
12886 bool is_catch_handlers_cmd,
12887 enum ada_exception_catchpoint_kind *ex,
12888 std::string *excep_string,
12889 std::string *cond_string)
12891 std::string exception_name;
12893 exception_name = extract_arg (&args);
12894 if (exception_name == "if")
12896 /* This is not an exception name; this is the start of a condition
12897 expression for a catchpoint on all exceptions. So, "un-get"
12898 this token, and set exception_name to NULL. */
12899 exception_name.clear ();
12903 /* Check to see if we have a condition. */
12905 args = skip_spaces (args);
12906 if (startswith (args, "if")
12907 && (isspace (args[2]) || args[2] == '\0'))
12910 args = skip_spaces (args);
12912 if (args[0] == '\0')
12913 error (_("Condition missing after `if' keyword"));
12914 *cond_string = args;
12916 args += strlen (args);
12919 /* Check that we do not have any more arguments. Anything else
12922 if (args[0] != '\0')
12923 error (_("Junk at end of expression"));
12925 if (is_catch_handlers_cmd)
12927 /* Catch handling of exceptions. */
12928 *ex = ada_catch_handlers;
12929 *excep_string = exception_name;
12931 else if (exception_name.empty ())
12933 /* Catch all exceptions. */
12934 *ex = ada_catch_exception;
12935 excep_string->clear ();
12937 else if (exception_name == "unhandled")
12939 /* Catch unhandled exceptions. */
12940 *ex = ada_catch_exception_unhandled;
12941 excep_string->clear ();
12945 /* Catch a specific exception. */
12946 *ex = ada_catch_exception;
12947 *excep_string = exception_name;
12951 /* Return the name of the symbol on which we should break in order to
12952 implement a catchpoint of the EX kind. */
12954 static const char *
12955 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12957 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12959 gdb_assert (data->exception_info != NULL);
12963 case ada_catch_exception:
12964 return (data->exception_info->catch_exception_sym);
12966 case ada_catch_exception_unhandled:
12967 return (data->exception_info->catch_exception_unhandled_sym);
12969 case ada_catch_assert:
12970 return (data->exception_info->catch_assert_sym);
12972 case ada_catch_handlers:
12973 return (data->exception_info->catch_handlers_sym);
12976 internal_error (__FILE__, __LINE__,
12977 _("unexpected catchpoint kind (%d)"), ex);
12981 /* Return the breakpoint ops "virtual table" used for catchpoints
12984 static const struct breakpoint_ops *
12985 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12989 case ada_catch_exception:
12990 return (&catch_exception_breakpoint_ops);
12992 case ada_catch_exception_unhandled:
12993 return (&catch_exception_unhandled_breakpoint_ops);
12995 case ada_catch_assert:
12996 return (&catch_assert_breakpoint_ops);
12998 case ada_catch_handlers:
12999 return (&catch_handlers_breakpoint_ops);
13002 internal_error (__FILE__, __LINE__,
13003 _("unexpected catchpoint kind (%d)"), ex);
13007 /* Return the condition that will be used to match the current exception
13008 being raised with the exception that the user wants to catch. This
13009 assumes that this condition is used when the inferior just triggered
13010 an exception catchpoint.
13011 EX: the type of catchpoints used for catching Ada exceptions. */
13014 ada_exception_catchpoint_cond_string (const char *excep_string,
13015 enum ada_exception_catchpoint_kind ex)
13018 std::string result;
13021 if (ex == ada_catch_handlers)
13023 /* For exception handlers catchpoints, the condition string does
13024 not use the same parameter as for the other exceptions. */
13025 name = ("long_integer (GNAT_GCC_exception_Access"
13026 "(gcc_exception).all.occurrence.id)");
13029 name = "long_integer (e)";
13031 /* The standard exceptions are a special case. They are defined in
13032 runtime units that have been compiled without debugging info; if
13033 EXCEP_STRING is the not-fully-qualified name of a standard
13034 exception (e.g. "constraint_error") then, during the evaluation
13035 of the condition expression, the symbol lookup on this name would
13036 *not* return this standard exception. The catchpoint condition
13037 may then be set only on user-defined exceptions which have the
13038 same not-fully-qualified name (e.g. my_package.constraint_error).
13040 To avoid this unexcepted behavior, these standard exceptions are
13041 systematically prefixed by "standard". This means that "catch
13042 exception constraint_error" is rewritten into "catch exception
13043 standard.constraint_error".
13045 If an exception named contraint_error is defined in another package of
13046 the inferior program, then the only way to specify this exception as a
13047 breakpoint condition is to use its fully-qualified named:
13048 e.g. my_package.constraint_error.
13050 Furthermore, in some situations a standard exception's symbol may
13051 be present in more than one objfile, because the compiler may
13052 choose to emit copy relocations for them. So, we have to compare
13053 against all the possible addresses. */
13055 /* Storage for a rewritten symbol name. */
13056 std::string std_name;
13057 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13059 if (strcmp (standard_exc [i], excep_string) == 0)
13061 std_name = std::string ("standard.") + excep_string;
13062 excep_string = std_name.c_str ();
13067 excep_string = ada_encode (excep_string);
13068 std::vector<struct bound_minimal_symbol> symbols
13069 = ada_lookup_simple_minsyms (excep_string);
13070 for (const bound_minimal_symbol &msym : symbols)
13072 if (!result.empty ())
13074 string_appendf (result, "%s = %s", name,
13075 pulongest (BMSYMBOL_VALUE_ADDRESS (msym)));
13081 /* Return the symtab_and_line that should be used to insert an exception
13082 catchpoint of the TYPE kind.
13084 ADDR_STRING returns the name of the function where the real
13085 breakpoint that implements the catchpoints is set, depending on the
13086 type of catchpoint we need to create. */
13088 static struct symtab_and_line
13089 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
13090 std::string *addr_string, const struct breakpoint_ops **ops)
13092 const char *sym_name;
13093 struct symbol *sym;
13095 /* First, find out which exception support info to use. */
13096 ada_exception_support_info_sniffer ();
13098 /* Then lookup the function on which we will break in order to catch
13099 the Ada exceptions requested by the user. */
13100 sym_name = ada_exception_sym_name (ex);
13101 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13104 error (_("Catchpoint symbol not found: %s"), sym_name);
13106 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13107 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
13109 /* Set ADDR_STRING. */
13110 *addr_string = sym_name;
13113 *ops = ada_exception_breakpoint_ops (ex);
13115 return find_function_start_sal (sym, 1);
13118 /* Create an Ada exception catchpoint.
13120 EX_KIND is the kind of exception catchpoint to be created.
13122 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
13123 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13124 of the exception to which this catchpoint applies.
13126 COND_STRING, if not empty, is the catchpoint condition.
13128 TEMPFLAG, if nonzero, means that the underlying breakpoint
13129 should be temporary.
13131 FROM_TTY is the usual argument passed to all commands implementations. */
13134 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
13135 enum ada_exception_catchpoint_kind ex_kind,
13136 const std::string &excep_string,
13137 const std::string &cond_string,
13142 std::string addr_string;
13143 const struct breakpoint_ops *ops = NULL;
13144 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
13146 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13147 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
13148 ops, tempflag, disabled, from_tty);
13149 c->excep_string = excep_string;
13150 create_excep_cond_exprs (c.get (), ex_kind);
13151 if (!cond_string.empty ())
13152 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
13153 install_breakpoint (0, std::move (c), 1);
13156 /* Implement the "catch exception" command. */
13159 catch_ada_exception_command (const char *arg_entry, int from_tty,
13160 struct cmd_list_element *command)
13162 const char *arg = arg_entry;
13163 struct gdbarch *gdbarch = get_current_arch ();
13165 enum ada_exception_catchpoint_kind ex_kind;
13166 std::string excep_string;
13167 std::string cond_string;
13169 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13173 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13175 create_ada_exception_catchpoint (gdbarch, ex_kind,
13176 excep_string, cond_string,
13177 tempflag, 1 /* enabled */,
13181 /* Implement the "catch handlers" command. */
13184 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13185 struct cmd_list_element *command)
13187 const char *arg = arg_entry;
13188 struct gdbarch *gdbarch = get_current_arch ();
13190 enum ada_exception_catchpoint_kind ex_kind;
13191 std::string excep_string;
13192 std::string cond_string;
13194 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13198 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13200 create_ada_exception_catchpoint (gdbarch, ex_kind,
13201 excep_string, cond_string,
13202 tempflag, 1 /* enabled */,
13206 /* Completion function for the Ada "catch" commands. */
13209 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
13210 const char *text, const char *word)
13212 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
13214 for (const ada_exc_info &info : exceptions)
13216 if (startswith (info.name, word))
13217 tracker.add_completion (make_unique_xstrdup (info.name));
13221 /* Split the arguments specified in a "catch assert" command.
13223 ARGS contains the command's arguments (or the empty string if
13224 no arguments were passed).
13226 If ARGS contains a condition, set COND_STRING to that condition
13227 (the memory needs to be deallocated after use). */
13230 catch_ada_assert_command_split (const char *args, std::string &cond_string)
13232 args = skip_spaces (args);
13234 /* Check whether a condition was provided. */
13235 if (startswith (args, "if")
13236 && (isspace (args[2]) || args[2] == '\0'))
13239 args = skip_spaces (args);
13240 if (args[0] == '\0')
13241 error (_("condition missing after `if' keyword"));
13242 cond_string.assign (args);
13245 /* Otherwise, there should be no other argument at the end of
13247 else if (args[0] != '\0')
13248 error (_("Junk at end of arguments."));
13251 /* Implement the "catch assert" command. */
13254 catch_assert_command (const char *arg_entry, int from_tty,
13255 struct cmd_list_element *command)
13257 const char *arg = arg_entry;
13258 struct gdbarch *gdbarch = get_current_arch ();
13260 std::string cond_string;
13262 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13266 catch_ada_assert_command_split (arg, cond_string);
13267 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13269 tempflag, 1 /* enabled */,
13273 /* Return non-zero if the symbol SYM is an Ada exception object. */
13276 ada_is_exception_sym (struct symbol *sym)
13278 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
13280 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13281 && SYMBOL_CLASS (sym) != LOC_BLOCK
13282 && SYMBOL_CLASS (sym) != LOC_CONST
13283 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13284 && type_name != NULL && strcmp (type_name, "exception") == 0);
13287 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13288 Ada exception object. This matches all exceptions except the ones
13289 defined by the Ada language. */
13292 ada_is_non_standard_exception_sym (struct symbol *sym)
13296 if (!ada_is_exception_sym (sym))
13299 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13300 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13301 return 0; /* A standard exception. */
13303 /* Numeric_Error is also a standard exception, so exclude it.
13304 See the STANDARD_EXC description for more details as to why
13305 this exception is not listed in that array. */
13306 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13312 /* A helper function for std::sort, comparing two struct ada_exc_info
13315 The comparison is determined first by exception name, and then
13316 by exception address. */
13319 ada_exc_info::operator< (const ada_exc_info &other) const
13323 result = strcmp (name, other.name);
13326 if (result == 0 && addr < other.addr)
13332 ada_exc_info::operator== (const ada_exc_info &other) const
13334 return addr == other.addr && strcmp (name, other.name) == 0;
13337 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13338 routine, but keeping the first SKIP elements untouched.
13340 All duplicates are also removed. */
13343 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13346 std::sort (exceptions->begin () + skip, exceptions->end ());
13347 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13348 exceptions->end ());
13351 /* Add all exceptions defined by the Ada standard whose name match
13352 a regular expression.
13354 If PREG is not NULL, then this regexp_t object is used to
13355 perform the symbol name matching. Otherwise, no name-based
13356 filtering is performed.
13358 EXCEPTIONS is a vector of exceptions to which matching exceptions
13362 ada_add_standard_exceptions (compiled_regex *preg,
13363 std::vector<ada_exc_info> *exceptions)
13367 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13370 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13372 struct bound_minimal_symbol msymbol
13373 = ada_lookup_simple_minsym (standard_exc[i]);
13375 if (msymbol.minsym != NULL)
13377 struct ada_exc_info info
13378 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13380 exceptions->push_back (info);
13386 /* Add all Ada exceptions defined locally and accessible from the given
13389 If PREG is not NULL, then this regexp_t object is used to
13390 perform the symbol name matching. Otherwise, no name-based
13391 filtering is performed.
13393 EXCEPTIONS is a vector of exceptions to which matching exceptions
13397 ada_add_exceptions_from_frame (compiled_regex *preg,
13398 struct frame_info *frame,
13399 std::vector<ada_exc_info> *exceptions)
13401 const struct block *block = get_frame_block (frame, 0);
13405 struct block_iterator iter;
13406 struct symbol *sym;
13408 ALL_BLOCK_SYMBOLS (block, iter, sym)
13410 switch (SYMBOL_CLASS (sym))
13417 if (ada_is_exception_sym (sym))
13419 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13420 SYMBOL_VALUE_ADDRESS (sym)};
13422 exceptions->push_back (info);
13426 if (BLOCK_FUNCTION (block) != NULL)
13428 block = BLOCK_SUPERBLOCK (block);
13432 /* Return true if NAME matches PREG or if PREG is NULL. */
13435 name_matches_regex (const char *name, compiled_regex *preg)
13437 return (preg == NULL
13438 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13441 /* Add all exceptions defined globally whose name name match
13442 a regular expression, excluding standard exceptions.
13444 The reason we exclude standard exceptions is that they need
13445 to be handled separately: Standard exceptions are defined inside
13446 a runtime unit which is normally not compiled with debugging info,
13447 and thus usually do not show up in our symbol search. However,
13448 if the unit was in fact built with debugging info, we need to
13449 exclude them because they would duplicate the entry we found
13450 during the special loop that specifically searches for those
13451 standard exceptions.
13453 If PREG is not NULL, then this regexp_t object is used to
13454 perform the symbol name matching. Otherwise, no name-based
13455 filtering is performed.
13457 EXCEPTIONS is a vector of exceptions to which matching exceptions
13461 ada_add_global_exceptions (compiled_regex *preg,
13462 std::vector<ada_exc_info> *exceptions)
13464 /* In Ada, the symbol "search name" is a linkage name, whereas the
13465 regular expression used to do the matching refers to the natural
13466 name. So match against the decoded name. */
13467 expand_symtabs_matching (NULL,
13468 lookup_name_info::match_any (),
13469 [&] (const char *search_name)
13471 const char *decoded = ada_decode (search_name);
13472 return name_matches_regex (decoded, preg);
13477 for (objfile *objfile : current_program_space->objfiles ())
13479 for (compunit_symtab *s : objfile->compunits ())
13481 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13484 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13486 const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13487 struct block_iterator iter;
13488 struct symbol *sym;
13490 ALL_BLOCK_SYMBOLS (b, iter, sym)
13491 if (ada_is_non_standard_exception_sym (sym)
13492 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13494 struct ada_exc_info info
13495 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13497 exceptions->push_back (info);
13504 /* Implements ada_exceptions_list with the regular expression passed
13505 as a regex_t, rather than a string.
13507 If not NULL, PREG is used to filter out exceptions whose names
13508 do not match. Otherwise, all exceptions are listed. */
13510 static std::vector<ada_exc_info>
13511 ada_exceptions_list_1 (compiled_regex *preg)
13513 std::vector<ada_exc_info> result;
13516 /* First, list the known standard exceptions. These exceptions
13517 need to be handled separately, as they are usually defined in
13518 runtime units that have been compiled without debugging info. */
13520 ada_add_standard_exceptions (preg, &result);
13522 /* Next, find all exceptions whose scope is local and accessible
13523 from the currently selected frame. */
13525 if (has_stack_frames ())
13527 prev_len = result.size ();
13528 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13530 if (result.size () > prev_len)
13531 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13534 /* Add all exceptions whose scope is global. */
13536 prev_len = result.size ();
13537 ada_add_global_exceptions (preg, &result);
13538 if (result.size () > prev_len)
13539 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13544 /* Return a vector of ada_exc_info.
13546 If REGEXP is NULL, all exceptions are included in the result.
13547 Otherwise, it should contain a valid regular expression,
13548 and only the exceptions whose names match that regular expression
13549 are included in the result.
13551 The exceptions are sorted in the following order:
13552 - Standard exceptions (defined by the Ada language), in
13553 alphabetical order;
13554 - Exceptions only visible from the current frame, in
13555 alphabetical order;
13556 - Exceptions whose scope is global, in alphabetical order. */
13558 std::vector<ada_exc_info>
13559 ada_exceptions_list (const char *regexp)
13561 if (regexp == NULL)
13562 return ada_exceptions_list_1 (NULL);
13564 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13565 return ada_exceptions_list_1 (®);
13568 /* Implement the "info exceptions" command. */
13571 info_exceptions_command (const char *regexp, int from_tty)
13573 struct gdbarch *gdbarch = get_current_arch ();
13575 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13577 if (regexp != NULL)
13579 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13581 printf_filtered (_("All defined Ada exceptions:\n"));
13583 for (const ada_exc_info &info : exceptions)
13584 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13588 /* Information about operators given special treatment in functions
13590 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13592 #define ADA_OPERATORS \
13593 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13594 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13595 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13596 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13597 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13598 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13599 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13600 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13601 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13602 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13603 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13604 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13605 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13606 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13607 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13608 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13609 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13610 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13611 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13614 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13617 switch (exp->elts[pc - 1].opcode)
13620 operator_length_standard (exp, pc, oplenp, argsp);
13623 #define OP_DEFN(op, len, args, binop) \
13624 case op: *oplenp = len; *argsp = args; break;
13630 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13635 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13640 /* Implementation of the exp_descriptor method operator_check. */
13643 ada_operator_check (struct expression *exp, int pos,
13644 int (*objfile_func) (struct objfile *objfile, void *data),
13647 const union exp_element *const elts = exp->elts;
13648 struct type *type = NULL;
13650 switch (elts[pos].opcode)
13652 case UNOP_IN_RANGE:
13654 type = elts[pos + 1].type;
13658 return operator_check_standard (exp, pos, objfile_func, data);
13661 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13663 if (type && TYPE_OBJFILE (type)
13664 && (*objfile_func) (TYPE_OBJFILE (type), data))
13670 static const char *
13671 ada_op_name (enum exp_opcode opcode)
13676 return op_name_standard (opcode);
13678 #define OP_DEFN(op, len, args, binop) case op: return #op;
13683 return "OP_AGGREGATE";
13685 return "OP_CHOICES";
13691 /* As for operator_length, but assumes PC is pointing at the first
13692 element of the operator, and gives meaningful results only for the
13693 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13696 ada_forward_operator_length (struct expression *exp, int pc,
13697 int *oplenp, int *argsp)
13699 switch (exp->elts[pc].opcode)
13702 *oplenp = *argsp = 0;
13705 #define OP_DEFN(op, len, args, binop) \
13706 case op: *oplenp = len; *argsp = args; break;
13712 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13717 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13723 int len = longest_to_int (exp->elts[pc + 1].longconst);
13725 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13733 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13735 enum exp_opcode op = exp->elts[elt].opcode;
13740 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13744 /* Ada attributes ('Foo). */
13747 case OP_ATR_LENGTH:
13751 case OP_ATR_MODULUS:
13758 case UNOP_IN_RANGE:
13760 /* XXX: gdb_sprint_host_address, type_sprint */
13761 fprintf_filtered (stream, _("Type @"));
13762 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13763 fprintf_filtered (stream, " (");
13764 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13765 fprintf_filtered (stream, ")");
13767 case BINOP_IN_BOUNDS:
13768 fprintf_filtered (stream, " (%d)",
13769 longest_to_int (exp->elts[pc + 2].longconst));
13771 case TERNOP_IN_RANGE:
13776 case OP_DISCRETE_RANGE:
13777 case OP_POSITIONAL:
13784 char *name = &exp->elts[elt + 2].string;
13785 int len = longest_to_int (exp->elts[elt + 1].longconst);
13787 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13792 return dump_subexp_body_standard (exp, stream, elt);
13796 for (i = 0; i < nargs; i += 1)
13797 elt = dump_subexp (exp, stream, elt);
13802 /* The Ada extension of print_subexp (q.v.). */
13805 ada_print_subexp (struct expression *exp, int *pos,
13806 struct ui_file *stream, enum precedence prec)
13808 int oplen, nargs, i;
13810 enum exp_opcode op = exp->elts[pc].opcode;
13812 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13819 print_subexp_standard (exp, pos, stream, prec);
13823 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13826 case BINOP_IN_BOUNDS:
13827 /* XXX: sprint_subexp */
13828 print_subexp (exp, pos, stream, PREC_SUFFIX);
13829 fputs_filtered (" in ", stream);
13830 print_subexp (exp, pos, stream, PREC_SUFFIX);
13831 fputs_filtered ("'range", stream);
13832 if (exp->elts[pc + 1].longconst > 1)
13833 fprintf_filtered (stream, "(%ld)",
13834 (long) exp->elts[pc + 1].longconst);
13837 case TERNOP_IN_RANGE:
13838 if (prec >= PREC_EQUAL)
13839 fputs_filtered ("(", stream);
13840 /* XXX: sprint_subexp */
13841 print_subexp (exp, pos, stream, PREC_SUFFIX);
13842 fputs_filtered (" in ", stream);
13843 print_subexp (exp, pos, stream, PREC_EQUAL);
13844 fputs_filtered (" .. ", stream);
13845 print_subexp (exp, pos, stream, PREC_EQUAL);
13846 if (prec >= PREC_EQUAL)
13847 fputs_filtered (")", stream);
13852 case OP_ATR_LENGTH:
13856 case OP_ATR_MODULUS:
13861 if (exp->elts[*pos].opcode == OP_TYPE)
13863 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
13864 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13865 &type_print_raw_options);
13869 print_subexp (exp, pos, stream, PREC_SUFFIX);
13870 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13875 for (tem = 1; tem < nargs; tem += 1)
13877 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13878 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13880 fputs_filtered (")", stream);
13885 type_print (exp->elts[pc + 1].type, "", stream, 0);
13886 fputs_filtered ("'(", stream);
13887 print_subexp (exp, pos, stream, PREC_PREFIX);
13888 fputs_filtered (")", stream);
13891 case UNOP_IN_RANGE:
13892 /* XXX: sprint_subexp */
13893 print_subexp (exp, pos, stream, PREC_SUFFIX);
13894 fputs_filtered (" in ", stream);
13895 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13896 &type_print_raw_options);
13899 case OP_DISCRETE_RANGE:
13900 print_subexp (exp, pos, stream, PREC_SUFFIX);
13901 fputs_filtered ("..", stream);
13902 print_subexp (exp, pos, stream, PREC_SUFFIX);
13906 fputs_filtered ("others => ", stream);
13907 print_subexp (exp, pos, stream, PREC_SUFFIX);
13911 for (i = 0; i < nargs-1; i += 1)
13914 fputs_filtered ("|", stream);
13915 print_subexp (exp, pos, stream, PREC_SUFFIX);
13917 fputs_filtered (" => ", stream);
13918 print_subexp (exp, pos, stream, PREC_SUFFIX);
13921 case OP_POSITIONAL:
13922 print_subexp (exp, pos, stream, PREC_SUFFIX);
13926 fputs_filtered ("(", stream);
13927 for (i = 0; i < nargs; i += 1)
13930 fputs_filtered (", ", stream);
13931 print_subexp (exp, pos, stream, PREC_SUFFIX);
13933 fputs_filtered (")", stream);
13938 /* Table mapping opcodes into strings for printing operators
13939 and precedences of the operators. */
13941 static const struct op_print ada_op_print_tab[] = {
13942 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13943 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13944 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13945 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13946 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13947 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13948 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13949 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13950 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13951 {">=", BINOP_GEQ, PREC_ORDER, 0},
13952 {">", BINOP_GTR, PREC_ORDER, 0},
13953 {"<", BINOP_LESS, PREC_ORDER, 0},
13954 {">>", BINOP_RSH, PREC_SHIFT, 0},
13955 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13956 {"+", BINOP_ADD, PREC_ADD, 0},
13957 {"-", BINOP_SUB, PREC_ADD, 0},
13958 {"&", BINOP_CONCAT, PREC_ADD, 0},
13959 {"*", BINOP_MUL, PREC_MUL, 0},
13960 {"/", BINOP_DIV, PREC_MUL, 0},
13961 {"rem", BINOP_REM, PREC_MUL, 0},
13962 {"mod", BINOP_MOD, PREC_MUL, 0},
13963 {"**", BINOP_EXP, PREC_REPEAT, 0},
13964 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13965 {"-", UNOP_NEG, PREC_PREFIX, 0},
13966 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13967 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13968 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13969 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13970 {".all", UNOP_IND, PREC_SUFFIX, 1},
13971 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13972 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13973 {NULL, OP_NULL, PREC_SUFFIX, 0}
13976 enum ada_primitive_types {
13977 ada_primitive_type_int,
13978 ada_primitive_type_long,
13979 ada_primitive_type_short,
13980 ada_primitive_type_char,
13981 ada_primitive_type_float,
13982 ada_primitive_type_double,
13983 ada_primitive_type_void,
13984 ada_primitive_type_long_long,
13985 ada_primitive_type_long_double,
13986 ada_primitive_type_natural,
13987 ada_primitive_type_positive,
13988 ada_primitive_type_system_address,
13989 ada_primitive_type_storage_offset,
13990 nr_ada_primitive_types
13994 ada_language_arch_info (struct gdbarch *gdbarch,
13995 struct language_arch_info *lai)
13997 const struct builtin_type *builtin = builtin_type (gdbarch);
13999 lai->primitive_type_vector
14000 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
14003 lai->primitive_type_vector [ada_primitive_type_int]
14004 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14006 lai->primitive_type_vector [ada_primitive_type_long]
14007 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14008 0, "long_integer");
14009 lai->primitive_type_vector [ada_primitive_type_short]
14010 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14011 0, "short_integer");
14012 lai->string_char_type
14013 = lai->primitive_type_vector [ada_primitive_type_char]
14014 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
14015 lai->primitive_type_vector [ada_primitive_type_float]
14016 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
14017 "float", gdbarch_float_format (gdbarch));
14018 lai->primitive_type_vector [ada_primitive_type_double]
14019 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
14020 "long_float", gdbarch_double_format (gdbarch));
14021 lai->primitive_type_vector [ada_primitive_type_long_long]
14022 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14023 0, "long_long_integer");
14024 lai->primitive_type_vector [ada_primitive_type_long_double]
14025 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
14026 "long_long_float", gdbarch_long_double_format (gdbarch));
14027 lai->primitive_type_vector [ada_primitive_type_natural]
14028 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14030 lai->primitive_type_vector [ada_primitive_type_positive]
14031 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14033 lai->primitive_type_vector [ada_primitive_type_void]
14034 = builtin->builtin_void;
14036 lai->primitive_type_vector [ada_primitive_type_system_address]
14037 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14039 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14040 = "system__address";
14042 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14043 type. This is a signed integral type whose size is the same as
14044 the size of addresses. */
14046 unsigned int addr_length = TYPE_LENGTH
14047 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14049 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14050 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14054 lai->bool_type_symbol = NULL;
14055 lai->bool_type_default = builtin->builtin_bool;
14058 /* Language vector */
14060 /* Not really used, but needed in the ada_language_defn. */
14063 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
14065 ada_emit_char (c, type, stream, quoter, 1);
14069 parse (struct parser_state *ps)
14071 warnings_issued = 0;
14072 return ada_parse (ps);
14075 static const struct exp_descriptor ada_exp_descriptor = {
14077 ada_operator_length,
14078 ada_operator_check,
14080 ada_dump_subexp_body,
14081 ada_evaluate_subexp
14084 /* symbol_name_matcher_ftype adapter for wild_match. */
14087 do_wild_match (const char *symbol_search_name,
14088 const lookup_name_info &lookup_name,
14089 completion_match_result *comp_match_res)
14091 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14094 /* symbol_name_matcher_ftype adapter for full_match. */
14097 do_full_match (const char *symbol_search_name,
14098 const lookup_name_info &lookup_name,
14099 completion_match_result *comp_match_res)
14101 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14104 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
14107 do_exact_match (const char *symbol_search_name,
14108 const lookup_name_info &lookup_name,
14109 completion_match_result *comp_match_res)
14111 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
14114 /* Build the Ada lookup name for LOOKUP_NAME. */
14116 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14118 const std::string &user_name = lookup_name.name ();
14120 if (user_name[0] == '<')
14122 if (user_name.back () == '>')
14123 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14125 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14126 m_encoded_p = true;
14127 m_verbatim_p = true;
14128 m_wild_match_p = false;
14129 m_standard_p = false;
14133 m_verbatim_p = false;
14135 m_encoded_p = user_name.find ("__") != std::string::npos;
14139 const char *folded = ada_fold_name (user_name.c_str ());
14140 const char *encoded = ada_encode_1 (folded, false);
14141 if (encoded != NULL)
14142 m_encoded_name = encoded;
14144 m_encoded_name = user_name;
14147 m_encoded_name = user_name;
14149 /* Handle the 'package Standard' special case. See description
14150 of m_standard_p. */
14151 if (startswith (m_encoded_name.c_str (), "standard__"))
14153 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14154 m_standard_p = true;
14157 m_standard_p = false;
14159 /* If the name contains a ".", then the user is entering a fully
14160 qualified entity name, and the match must not be done in wild
14161 mode. Similarly, if the user wants to complete what looks
14162 like an encoded name, the match must not be done in wild
14163 mode. Also, in the standard__ special case always do
14164 non-wild matching. */
14166 = (lookup_name.match_type () != symbol_name_match_type::FULL
14169 && user_name.find ('.') == std::string::npos);
14173 /* symbol_name_matcher_ftype method for Ada. This only handles
14174 completion mode. */
14177 ada_symbol_name_matches (const char *symbol_search_name,
14178 const lookup_name_info &lookup_name,
14179 completion_match_result *comp_match_res)
14181 return lookup_name.ada ().matches (symbol_search_name,
14182 lookup_name.match_type (),
14186 /* A name matcher that matches the symbol name exactly, with
14190 literal_symbol_name_matcher (const char *symbol_search_name,
14191 const lookup_name_info &lookup_name,
14192 completion_match_result *comp_match_res)
14194 const std::string &name = lookup_name.name ();
14196 int cmp = (lookup_name.completion_mode ()
14197 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14198 : strcmp (symbol_search_name, name.c_str ()));
14201 if (comp_match_res != NULL)
14202 comp_match_res->set_match (symbol_search_name);
14209 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14212 static symbol_name_matcher_ftype *
14213 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14215 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14216 return literal_symbol_name_matcher;
14218 if (lookup_name.completion_mode ())
14219 return ada_symbol_name_matches;
14222 if (lookup_name.ada ().wild_match_p ())
14223 return do_wild_match;
14224 else if (lookup_name.ada ().verbatim_p ())
14225 return do_exact_match;
14227 return do_full_match;
14231 /* Implement the "la_read_var_value" language_defn method for Ada. */
14233 static struct value *
14234 ada_read_var_value (struct symbol *var, const struct block *var_block,
14235 struct frame_info *frame)
14237 /* The only case where default_read_var_value is not sufficient
14238 is when VAR is a renaming... */
14239 if (frame != nullptr)
14241 const struct block *frame_block = get_frame_block (frame, NULL);
14242 if (frame_block != nullptr && ada_is_renaming_symbol (var))
14243 return ada_read_renaming_var_value (var, frame_block);
14246 /* This is a typical case where we expect the default_read_var_value
14247 function to work. */
14248 return default_read_var_value (var, var_block, frame);
14251 static const char *ada_extensions[] =
14253 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14256 extern const struct language_defn ada_language_defn = {
14257 "ada", /* Language name */
14261 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14262 that's not quite what this means. */
14264 macro_expansion_no,
14266 &ada_exp_descriptor,
14269 ada_printchar, /* Print a character constant */
14270 ada_printstr, /* Function to print string constant */
14271 emit_char, /* Function to print single char (not used) */
14272 ada_print_type, /* Print a type using appropriate syntax */
14273 ada_print_typedef, /* Print a typedef using appropriate syntax */
14274 ada_val_print, /* Print a value using appropriate syntax */
14275 ada_value_print, /* Print a top-level value */
14276 ada_read_var_value, /* la_read_var_value */
14277 NULL, /* Language specific skip_trampoline */
14278 NULL, /* name_of_this */
14279 true, /* la_store_sym_names_in_linkage_form_p */
14280 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14281 basic_lookup_transparent_type, /* lookup_transparent_type */
14282 ada_la_decode, /* Language specific symbol demangler */
14283 ada_sniff_from_mangled_name,
14284 NULL, /* Language specific
14285 class_name_from_physname */
14286 ada_op_print_tab, /* expression operators for printing */
14287 0, /* c-style arrays */
14288 1, /* String lower bound */
14289 ada_get_gdb_completer_word_break_characters,
14290 ada_collect_symbol_completion_matches,
14291 ada_language_arch_info,
14292 ada_print_array_index,
14293 default_pass_by_reference,
14295 ada_watch_location_expression,
14296 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
14297 ada_iterate_over_symbols,
14298 default_search_name_hash,
14302 ada_is_string_type,
14303 "(...)" /* la_struct_too_deep_ellipsis */
14306 /* Command-list for the "set/show ada" prefix command. */
14307 static struct cmd_list_element *set_ada_list;
14308 static struct cmd_list_element *show_ada_list;
14310 /* Implement the "set ada" prefix command. */
14313 set_ada_command (const char *arg, int from_tty)
14315 printf_unfiltered (_(\
14316 "\"set ada\" must be followed by the name of a setting.\n"));
14317 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14320 /* Implement the "show ada" prefix command. */
14323 show_ada_command (const char *args, int from_tty)
14325 cmd_show_list (show_ada_list, from_tty, "");
14329 initialize_ada_catchpoint_ops (void)
14331 struct breakpoint_ops *ops;
14333 initialize_breakpoint_ops ();
14335 ops = &catch_exception_breakpoint_ops;
14336 *ops = bkpt_breakpoint_ops;
14337 ops->allocate_location = allocate_location_catch_exception;
14338 ops->re_set = re_set_catch_exception;
14339 ops->check_status = check_status_catch_exception;
14340 ops->print_it = print_it_catch_exception;
14341 ops->print_one = print_one_catch_exception;
14342 ops->print_mention = print_mention_catch_exception;
14343 ops->print_recreate = print_recreate_catch_exception;
14345 ops = &catch_exception_unhandled_breakpoint_ops;
14346 *ops = bkpt_breakpoint_ops;
14347 ops->allocate_location = allocate_location_catch_exception_unhandled;
14348 ops->re_set = re_set_catch_exception_unhandled;
14349 ops->check_status = check_status_catch_exception_unhandled;
14350 ops->print_it = print_it_catch_exception_unhandled;
14351 ops->print_one = print_one_catch_exception_unhandled;
14352 ops->print_mention = print_mention_catch_exception_unhandled;
14353 ops->print_recreate = print_recreate_catch_exception_unhandled;
14355 ops = &catch_assert_breakpoint_ops;
14356 *ops = bkpt_breakpoint_ops;
14357 ops->allocate_location = allocate_location_catch_assert;
14358 ops->re_set = re_set_catch_assert;
14359 ops->check_status = check_status_catch_assert;
14360 ops->print_it = print_it_catch_assert;
14361 ops->print_one = print_one_catch_assert;
14362 ops->print_mention = print_mention_catch_assert;
14363 ops->print_recreate = print_recreate_catch_assert;
14365 ops = &catch_handlers_breakpoint_ops;
14366 *ops = bkpt_breakpoint_ops;
14367 ops->allocate_location = allocate_location_catch_handlers;
14368 ops->re_set = re_set_catch_handlers;
14369 ops->check_status = check_status_catch_handlers;
14370 ops->print_it = print_it_catch_handlers;
14371 ops->print_one = print_one_catch_handlers;
14372 ops->print_mention = print_mention_catch_handlers;
14373 ops->print_recreate = print_recreate_catch_handlers;
14376 /* This module's 'new_objfile' observer. */
14379 ada_new_objfile_observer (struct objfile *objfile)
14381 ada_clear_symbol_cache ();
14384 /* This module's 'free_objfile' observer. */
14387 ada_free_objfile_observer (struct objfile *objfile)
14389 ada_clear_symbol_cache ();
14393 _initialize_ada_language (void)
14395 initialize_ada_catchpoint_ops ();
14397 add_prefix_cmd ("ada", no_class, set_ada_command,
14398 _("Prefix command for changing Ada-specific settings"),
14399 &set_ada_list, "set ada ", 0, &setlist);
14401 add_prefix_cmd ("ada", no_class, show_ada_command,
14402 _("Generic command for showing Ada-specific settings."),
14403 &show_ada_list, "show ada ", 0, &showlist);
14405 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14406 &trust_pad_over_xvs, _("\
14407 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14408 Show whether an optimization trusting PAD types over XVS types is activated"),
14410 This is related to the encoding used by the GNAT compiler. The debugger\n\
14411 should normally trust the contents of PAD types, but certain older versions\n\
14412 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14413 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14414 work around this bug. It is always safe to turn this option \"off\", but\n\
14415 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14416 this option to \"off\" unless necessary."),
14417 NULL, NULL, &set_ada_list, &show_ada_list);
14419 add_setshow_boolean_cmd ("print-signatures", class_vars,
14420 &print_signatures, _("\
14421 Enable or disable the output of formal and return types for functions in the \
14422 overloads selection menu"), _("\
14423 Show whether the output of formal and return types for functions in the \
14424 overloads selection menu is activated"),
14425 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14427 add_catch_command ("exception", _("\
14428 Catch Ada exceptions, when raised.\n\
14429 Usage: catch exception [ARG] [if CONDITION]\n\
14430 Without any argument, stop when any Ada exception is raised.\n\
14431 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14432 being raised does not have a handler (and will therefore lead to the task's\n\
14434 Otherwise, the catchpoint only stops when the name of the exception being\n\
14435 raised is the same as ARG.\n\
14436 CONDITION is a boolean expression that is evaluated to see whether the\n\
14437 exception should cause a stop."),
14438 catch_ada_exception_command,
14439 catch_ada_completer,
14443 add_catch_command ("handlers", _("\
14444 Catch Ada exceptions, when handled.\n\
14445 Usage: catch handlers [ARG] [if CONDITION]\n\
14446 Without any argument, stop when any Ada exception is handled.\n\
14447 With an argument, catch only exceptions with the given name.\n\
14448 CONDITION is a boolean expression that is evaluated to see whether the\n\
14449 exception should cause a stop."),
14450 catch_ada_handlers_command,
14451 catch_ada_completer,
14454 add_catch_command ("assert", _("\
14455 Catch failed Ada assertions, when raised.\n\
14456 Usage: catch assert [if CONDITION]\n\
14457 CONDITION is a boolean expression that is evaluated to see whether the\n\
14458 exception should cause a stop."),
14459 catch_assert_command,
14464 varsize_limit = 65536;
14465 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14466 &varsize_limit, _("\
14467 Set the maximum number of bytes allowed in a variable-size object."), _("\
14468 Show the maximum number of bytes allowed in a variable-size object."), _("\
14469 Attempts to access an object whose size is not a compile-time constant\n\
14470 and exceeds this limit will cause an error."),
14471 NULL, NULL, &setlist, &showlist);
14473 add_info ("exceptions", info_exceptions_command,
14475 List all Ada exception names.\n\
14476 Usage: info exceptions [REGEXP]\n\
14477 If a regular expression is passed as an argument, only those matching\n\
14478 the regular expression are listed."));
14480 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14481 _("Set Ada maintenance-related variables."),
14482 &maint_set_ada_cmdlist, "maintenance set ada ",
14483 0/*allow-unknown*/, &maintenance_set_cmdlist);
14485 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14486 _("Show Ada maintenance-related variables"),
14487 &maint_show_ada_cmdlist, "maintenance show ada ",
14488 0/*allow-unknown*/, &maintenance_show_cmdlist);
14490 add_setshow_boolean_cmd
14491 ("ignore-descriptive-types", class_maintenance,
14492 &ada_ignore_descriptive_types_p,
14493 _("Set whether descriptive types generated by GNAT should be ignored."),
14494 _("Show whether descriptive types generated by GNAT should be ignored."),
14496 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14497 DWARF attribute."),
14498 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14500 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14501 NULL, xcalloc, xfree);
14503 /* The ada-lang observers. */
14504 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14505 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14506 gdb::observers::inferior_exit.attach (ada_inferior_exit);