1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2021 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 #include "gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdb_obstack.h"
40 #include "completer.h"
47 #include "observable.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 static struct type
*desc_base_type (struct type
*);
71 static struct type
*desc_bounds_type (struct type
*);
73 static struct value
*desc_bounds (struct value
*);
75 static int fat_pntr_bounds_bitpos (struct type
*);
77 static int fat_pntr_bounds_bitsize (struct type
*);
79 static struct type
*desc_data_target_type (struct type
*);
81 static struct value
*desc_data (struct value
*);
83 static int fat_pntr_data_bitpos (struct type
*);
85 static int fat_pntr_data_bitsize (struct type
*);
87 static struct value
*desc_one_bound (struct value
*, int, int);
89 static int desc_bound_bitpos (struct type
*, int, int);
91 static int desc_bound_bitsize (struct type
*, int, int);
93 static struct type
*desc_index_type (struct type
*, int);
95 static int desc_arity (struct type
*);
97 static int ada_type_match (struct type
*, struct type
*, int);
99 static int ada_args_match (struct symbol
*, struct value
**, int);
101 static struct value
*make_array_descriptor (struct type
*, struct value
*);
103 static void ada_add_block_symbols (std::vector
<struct block_symbol
> &,
104 const struct block
*,
105 const lookup_name_info
&lookup_name
,
106 domain_enum
, struct objfile
*);
108 static void ada_add_all_symbols (std::vector
<struct block_symbol
> &,
109 const struct block
*,
110 const lookup_name_info
&lookup_name
,
111 domain_enum
, int, int *);
113 static int is_nonfunction (const std::vector
<struct block_symbol
> &);
115 static void add_defn_to_vec (std::vector
<struct block_symbol
> &,
117 const struct block
*);
119 static struct value
*resolve_subexp (expression_up
*, int *, int,
121 innermost_block_tracker
*);
123 static void replace_operator_with_call (expression_up
*, int, int, int,
124 struct symbol
*, const struct block
*);
126 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
128 static const char *ada_decoded_op_name (enum exp_opcode
);
130 static int numeric_type_p (struct type
*);
132 static int integer_type_p (struct type
*);
134 static int scalar_type_p (struct type
*);
136 static int discrete_type_p (struct type
*);
138 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
141 static struct value
*evaluate_subexp_type (struct expression
*, int *);
143 static struct type
*ada_find_parallel_type_with_name (struct type
*,
146 static int is_dynamic_field (struct type
*, int);
148 static struct type
*to_fixed_variant_branch_type (struct type
*,
150 CORE_ADDR
, struct value
*);
152 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
154 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
156 static struct type
*to_static_fixed_type (struct type
*);
157 static struct type
*static_unwrap_type (struct type
*type
);
159 static struct value
*unwrap_value (struct value
*);
161 static struct type
*constrained_packed_array_type (struct type
*, long *);
163 static struct type
*decode_constrained_packed_array_type (struct type
*);
165 static long decode_packed_array_bitsize (struct type
*);
167 static struct value
*decode_constrained_packed_array (struct value
*);
169 static int ada_is_unconstrained_packed_array_type (struct type
*);
171 static struct value
*value_subscript_packed (struct value
*, int,
174 static struct value
*coerce_unspec_val_to_type (struct value
*,
177 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
179 static int equiv_types (struct type
*, struct type
*);
181 static int is_name_suffix (const char *);
183 static int advance_wild_match (const char **, const char *, char);
185 static bool wild_match (const char *name
, const char *patn
);
187 static struct value
*ada_coerce_ref (struct value
*);
189 static LONGEST
pos_atr (struct value
*);
191 static struct value
*value_pos_atr (struct type
*, struct value
*);
193 static struct value
*val_atr (struct type
*, LONGEST
);
195 static struct value
*value_val_atr (struct type
*, struct value
*);
197 static struct symbol
*standard_lookup (const char *, const struct block
*,
200 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
203 static int find_struct_field (const char *, struct type
*, int,
204 struct type
**, int *, int *, int *, int *);
206 static int ada_resolve_function (std::vector
<struct block_symbol
> &,
207 struct value
**, int, const char *,
210 static int ada_is_direct_array_type (struct type
*);
212 static struct value
*ada_index_struct_field (int, struct value
*, int,
215 static struct value
*assign_aggregate (struct value
*, struct value
*,
219 static void aggregate_assign_from_choices (struct value
*, struct value
*,
221 int *, std::vector
<LONGEST
> &,
224 static void aggregate_assign_positional (struct value
*, struct value
*,
226 int *, std::vector
<LONGEST
> &,
230 static void aggregate_assign_others (struct value
*, struct value
*,
232 int *, std::vector
<LONGEST
> &,
236 static void add_component_interval (LONGEST
, LONGEST
, std::vector
<LONGEST
> &);
239 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
242 static void ada_forward_operator_length (struct expression
*, int, int *,
245 static struct type
*ada_find_any_type (const char *name
);
247 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
248 (const lookup_name_info
&lookup_name
);
252 /* The result of a symbol lookup to be stored in our symbol cache. */
256 /* The name used to perform the lookup. */
258 /* The namespace used during the lookup. */
260 /* The symbol returned by the lookup, or NULL if no matching symbol
263 /* The block where the symbol was found, or NULL if no matching
265 const struct block
*block
;
266 /* A pointer to the next entry with the same hash. */
267 struct cache_entry
*next
;
270 /* The Ada symbol cache, used to store the result of Ada-mode symbol
271 lookups in the course of executing the user's commands.
273 The cache is implemented using a simple, fixed-sized hash.
274 The size is fixed on the grounds that there are not likely to be
275 all that many symbols looked up during any given session, regardless
276 of the size of the symbol table. If we decide to go to a resizable
277 table, let's just use the stuff from libiberty instead. */
279 #define HASH_SIZE 1009
281 struct ada_symbol_cache
283 /* An obstack used to store the entries in our cache. */
284 struct auto_obstack cache_space
;
286 /* The root of the hash table used to implement our symbol cache. */
287 struct cache_entry
*root
[HASH_SIZE
] {};
290 /* Maximum-sized dynamic type. */
291 static unsigned int varsize_limit
;
293 static const char ada_completer_word_break_characters
[] =
295 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
297 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
300 /* The name of the symbol to use to get the name of the main subprogram. */
301 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
302 = "__gnat_ada_main_program_name";
304 /* Limit on the number of warnings to raise per expression evaluation. */
305 static int warning_limit
= 2;
307 /* Number of warning messages issued; reset to 0 by cleanups after
308 expression evaluation. */
309 static int warnings_issued
= 0;
311 static const char * const known_runtime_file_name_patterns
[] = {
312 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
315 static const char * const known_auxiliary_function_name_patterns
[] = {
316 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
319 /* Maintenance-related settings for this module. */
321 static struct cmd_list_element
*maint_set_ada_cmdlist
;
322 static struct cmd_list_element
*maint_show_ada_cmdlist
;
324 /* The "maintenance ada set/show ignore-descriptive-type" value. */
326 static bool ada_ignore_descriptive_types_p
= false;
328 /* Inferior-specific data. */
330 /* Per-inferior data for this module. */
332 struct ada_inferior_data
334 /* The ada__tags__type_specific_data type, which is used when decoding
335 tagged types. With older versions of GNAT, this type was directly
336 accessible through a component ("tsd") in the object tag. But this
337 is no longer the case, so we cache it for each inferior. */
338 struct type
*tsd_type
= nullptr;
340 /* The exception_support_info data. This data is used to determine
341 how to implement support for Ada exception catchpoints in a given
343 const struct exception_support_info
*exception_info
= nullptr;
346 /* Our key to this module's inferior data. */
347 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
349 /* Return our inferior data for the given inferior (INF).
351 This function always returns a valid pointer to an allocated
352 ada_inferior_data structure. If INF's inferior data has not
353 been previously set, this functions creates a new one with all
354 fields set to zero, sets INF's inferior to it, and then returns
355 a pointer to that newly allocated ada_inferior_data. */
357 static struct ada_inferior_data
*
358 get_ada_inferior_data (struct inferior
*inf
)
360 struct ada_inferior_data
*data
;
362 data
= ada_inferior_data
.get (inf
);
364 data
= ada_inferior_data
.emplace (inf
);
369 /* Perform all necessary cleanups regarding our module's inferior data
370 that is required after the inferior INF just exited. */
373 ada_inferior_exit (struct inferior
*inf
)
375 ada_inferior_data
.clear (inf
);
379 /* program-space-specific data. */
381 /* This module's per-program-space data. */
382 struct ada_pspace_data
384 /* The Ada symbol cache. */
385 std::unique_ptr
<ada_symbol_cache
> sym_cache
;
388 /* Key to our per-program-space data. */
389 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
391 /* Return this module's data for the given program space (PSPACE).
392 If not is found, add a zero'ed one now.
394 This function always returns a valid object. */
396 static struct ada_pspace_data
*
397 get_ada_pspace_data (struct program_space
*pspace
)
399 struct ada_pspace_data
*data
;
401 data
= ada_pspace_data_handle
.get (pspace
);
403 data
= ada_pspace_data_handle
.emplace (pspace
);
410 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
411 all typedef layers have been peeled. Otherwise, return TYPE.
413 Normally, we really expect a typedef type to only have 1 typedef layer.
414 In other words, we really expect the target type of a typedef type to be
415 a non-typedef type. This is particularly true for Ada units, because
416 the language does not have a typedef vs not-typedef distinction.
417 In that respect, the Ada compiler has been trying to eliminate as many
418 typedef definitions in the debugging information, since they generally
419 do not bring any extra information (we still use typedef under certain
420 circumstances related mostly to the GNAT encoding).
422 Unfortunately, we have seen situations where the debugging information
423 generated by the compiler leads to such multiple typedef layers. For
424 instance, consider the following example with stabs:
426 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
427 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
429 This is an error in the debugging information which causes type
430 pck__float_array___XUP to be defined twice, and the second time,
431 it is defined as a typedef of a typedef.
433 This is on the fringe of legality as far as debugging information is
434 concerned, and certainly unexpected. But it is easy to handle these
435 situations correctly, so we can afford to be lenient in this case. */
438 ada_typedef_target_type (struct type
*type
)
440 while (type
->code () == TYPE_CODE_TYPEDEF
)
441 type
= TYPE_TARGET_TYPE (type
);
445 /* Given DECODED_NAME a string holding a symbol name in its
446 decoded form (ie using the Ada dotted notation), returns
447 its unqualified name. */
450 ada_unqualified_name (const char *decoded_name
)
454 /* If the decoded name starts with '<', it means that the encoded
455 name does not follow standard naming conventions, and thus that
456 it is not your typical Ada symbol name. Trying to unqualify it
457 is therefore pointless and possibly erroneous. */
458 if (decoded_name
[0] == '<')
461 result
= strrchr (decoded_name
, '.');
463 result
++; /* Skip the dot... */
465 result
= decoded_name
;
470 /* Return a string starting with '<', followed by STR, and '>'. */
473 add_angle_brackets (const char *str
)
475 return string_printf ("<%s>", str
);
478 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
479 suffix of FIELD_NAME beginning "___". */
482 field_name_match (const char *field_name
, const char *target
)
484 int len
= strlen (target
);
487 (strncmp (field_name
, target
, len
) == 0
488 && (field_name
[len
] == '\0'
489 || (startswith (field_name
+ len
, "___")
490 && strcmp (field_name
+ strlen (field_name
) - 6,
495 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
496 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
497 and return its index. This function also handles fields whose name
498 have ___ suffixes because the compiler sometimes alters their name
499 by adding such a suffix to represent fields with certain constraints.
500 If the field could not be found, return a negative number if
501 MAYBE_MISSING is set. Otherwise raise an error. */
504 ada_get_field_index (const struct type
*type
, const char *field_name
,
508 struct type
*struct_type
= check_typedef ((struct type
*) type
);
510 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
511 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
515 error (_("Unable to find field %s in struct %s. Aborting"),
516 field_name
, struct_type
->name ());
521 /* The length of the prefix of NAME prior to any "___" suffix. */
524 ada_name_prefix_len (const char *name
)
530 const char *p
= strstr (name
, "___");
533 return strlen (name
);
539 /* Return non-zero if SUFFIX is a suffix of STR.
540 Return zero if STR is null. */
543 is_suffix (const char *str
, const char *suffix
)
550 len2
= strlen (suffix
);
551 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
554 /* The contents of value VAL, treated as a value of type TYPE. The
555 result is an lval in memory if VAL is. */
557 static struct value
*
558 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
560 type
= ada_check_typedef (type
);
561 if (value_type (val
) == type
)
565 struct value
*result
;
567 /* Make sure that the object size is not unreasonable before
568 trying to allocate some memory for it. */
569 ada_ensure_varsize_limit (type
);
571 if (value_optimized_out (val
))
572 result
= allocate_optimized_out_value (type
);
573 else if (value_lazy (val
)
574 /* Be careful not to make a lazy not_lval value. */
575 || (VALUE_LVAL (val
) != not_lval
576 && TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
))))
577 result
= allocate_value_lazy (type
);
580 result
= allocate_value (type
);
581 value_contents_copy (result
, 0, val
, 0, TYPE_LENGTH (type
));
583 set_value_component_location (result
, val
);
584 set_value_bitsize (result
, value_bitsize (val
));
585 set_value_bitpos (result
, value_bitpos (val
));
586 if (VALUE_LVAL (result
) == lval_memory
)
587 set_value_address (result
, value_address (val
));
592 static const gdb_byte
*
593 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
598 return valaddr
+ offset
;
602 cond_offset_target (CORE_ADDR address
, long offset
)
607 return address
+ offset
;
610 /* Issue a warning (as for the definition of warning in utils.c, but
611 with exactly one argument rather than ...), unless the limit on the
612 number of warnings has passed during the evaluation of the current
615 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
616 provided by "complaint". */
617 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
620 lim_warning (const char *format
, ...)
624 va_start (args
, format
);
625 warnings_issued
+= 1;
626 if (warnings_issued
<= warning_limit
)
627 vwarning (format
, args
);
632 /* Issue an error if the size of an object of type T is unreasonable,
633 i.e. if it would be a bad idea to allocate a value of this type in
637 ada_ensure_varsize_limit (const struct type
*type
)
639 if (TYPE_LENGTH (type
) > varsize_limit
)
640 error (_("object size is larger than varsize-limit"));
643 /* Maximum value of a SIZE-byte signed integer type. */
645 max_of_size (int size
)
647 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
649 return top_bit
| (top_bit
- 1);
652 /* Minimum value of a SIZE-byte signed integer type. */
654 min_of_size (int size
)
656 return -max_of_size (size
) - 1;
659 /* Maximum value of a SIZE-byte unsigned integer type. */
661 umax_of_size (int size
)
663 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
665 return top_bit
| (top_bit
- 1);
668 /* Maximum value of integral type T, as a signed quantity. */
670 max_of_type (struct type
*t
)
672 if (t
->is_unsigned ())
673 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
675 return max_of_size (TYPE_LENGTH (t
));
678 /* Minimum value of integral type T, as a signed quantity. */
680 min_of_type (struct type
*t
)
682 if (t
->is_unsigned ())
685 return min_of_size (TYPE_LENGTH (t
));
688 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
690 ada_discrete_type_high_bound (struct type
*type
)
692 type
= resolve_dynamic_type (type
, {}, 0);
693 switch (type
->code ())
695 case TYPE_CODE_RANGE
:
697 const dynamic_prop
&high
= type
->bounds ()->high
;
699 if (high
.kind () == PROP_CONST
)
700 return high
.const_val ();
703 gdb_assert (high
.kind () == PROP_UNDEFINED
);
705 /* This happens when trying to evaluate a type's dynamic bound
706 without a live target. There is nothing relevant for us to
707 return here, so return 0. */
712 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
717 return max_of_type (type
);
719 error (_("Unexpected type in ada_discrete_type_high_bound."));
723 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
725 ada_discrete_type_low_bound (struct type
*type
)
727 type
= resolve_dynamic_type (type
, {}, 0);
728 switch (type
->code ())
730 case TYPE_CODE_RANGE
:
732 const dynamic_prop
&low
= type
->bounds ()->low
;
734 if (low
.kind () == PROP_CONST
)
735 return low
.const_val ();
738 gdb_assert (low
.kind () == PROP_UNDEFINED
);
740 /* This happens when trying to evaluate a type's dynamic bound
741 without a live target. There is nothing relevant for us to
742 return here, so return 0. */
747 return TYPE_FIELD_ENUMVAL (type
, 0);
752 return min_of_type (type
);
754 error (_("Unexpected type in ada_discrete_type_low_bound."));
758 /* The identity on non-range types. For range types, the underlying
759 non-range scalar type. */
762 get_base_type (struct type
*type
)
764 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
766 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
768 type
= TYPE_TARGET_TYPE (type
);
773 /* Return a decoded version of the given VALUE. This means returning
774 a value whose type is obtained by applying all the GNAT-specific
775 encodings, making the resulting type a static but standard description
776 of the initial type. */
779 ada_get_decoded_value (struct value
*value
)
781 struct type
*type
= ada_check_typedef (value_type (value
));
783 if (ada_is_array_descriptor_type (type
)
784 || (ada_is_constrained_packed_array_type (type
)
785 && type
->code () != TYPE_CODE_PTR
))
787 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
788 value
= ada_coerce_to_simple_array_ptr (value
);
790 value
= ada_coerce_to_simple_array (value
);
793 value
= ada_to_fixed_value (value
);
798 /* Same as ada_get_decoded_value, but with the given TYPE.
799 Because there is no associated actual value for this type,
800 the resulting type might be a best-effort approximation in
801 the case of dynamic types. */
804 ada_get_decoded_type (struct type
*type
)
806 type
= to_static_fixed_type (type
);
807 if (ada_is_constrained_packed_array_type (type
))
808 type
= ada_coerce_to_simple_array_type (type
);
814 /* Language Selection */
816 /* If the main program is in Ada, return language_ada, otherwise return LANG
817 (the main program is in Ada iif the adainit symbol is found). */
820 ada_update_initial_language (enum language lang
)
822 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
828 /* If the main procedure is written in Ada, then return its name.
829 The result is good until the next call. Return NULL if the main
830 procedure doesn't appear to be in Ada. */
835 struct bound_minimal_symbol msym
;
836 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
838 /* For Ada, the name of the main procedure is stored in a specific
839 string constant, generated by the binder. Look for that symbol,
840 extract its address, and then read that string. If we didn't find
841 that string, then most probably the main procedure is not written
843 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
845 if (msym
.minsym
!= NULL
)
847 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
848 if (main_program_name_addr
== 0)
849 error (_("Invalid address for Ada main program name."));
851 main_program_name
= target_read_string (main_program_name_addr
, 1024);
852 return main_program_name
.get ();
855 /* The main procedure doesn't seem to be in Ada. */
861 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
864 const struct ada_opname_map ada_opname_table
[] = {
865 {"Oadd", "\"+\"", BINOP_ADD
},
866 {"Osubtract", "\"-\"", BINOP_SUB
},
867 {"Omultiply", "\"*\"", BINOP_MUL
},
868 {"Odivide", "\"/\"", BINOP_DIV
},
869 {"Omod", "\"mod\"", BINOP_MOD
},
870 {"Orem", "\"rem\"", BINOP_REM
},
871 {"Oexpon", "\"**\"", BINOP_EXP
},
872 {"Olt", "\"<\"", BINOP_LESS
},
873 {"Ole", "\"<=\"", BINOP_LEQ
},
874 {"Ogt", "\">\"", BINOP_GTR
},
875 {"Oge", "\">=\"", BINOP_GEQ
},
876 {"Oeq", "\"=\"", BINOP_EQUAL
},
877 {"One", "\"/=\"", BINOP_NOTEQUAL
},
878 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
879 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
880 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
881 {"Oconcat", "\"&\"", BINOP_CONCAT
},
882 {"Oabs", "\"abs\"", UNOP_ABS
},
883 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
884 {"Oadd", "\"+\"", UNOP_PLUS
},
885 {"Osubtract", "\"-\"", UNOP_NEG
},
889 /* The "encoded" form of DECODED, according to GNAT conventions. If
890 THROW_ERRORS, throw an error if invalid operator name is found.
891 Otherwise, return the empty string in that case. */
894 ada_encode_1 (const char *decoded
, bool throw_errors
)
899 std::string encoding_buffer
;
900 for (const char *p
= decoded
; *p
!= '\0'; p
+= 1)
903 encoding_buffer
.append ("__");
906 const struct ada_opname_map
*mapping
;
908 for (mapping
= ada_opname_table
;
909 mapping
->encoded
!= NULL
910 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
912 if (mapping
->encoded
== NULL
)
915 error (_("invalid Ada operator name: %s"), p
);
919 encoding_buffer
.append (mapping
->encoded
);
923 encoding_buffer
.push_back (*p
);
926 return encoding_buffer
;
929 /* The "encoded" form of DECODED, according to GNAT conventions. */
932 ada_encode (const char *decoded
)
934 return ada_encode_1 (decoded
, true);
937 /* Return NAME folded to lower case, or, if surrounded by single
938 quotes, unfolded, but with the quotes stripped away. Result good
942 ada_fold_name (gdb::string_view name
)
944 static std::string fold_storage
;
946 if (!name
.empty () && name
[0] == '\'')
947 fold_storage
= gdb::to_string (name
.substr (1, name
.size () - 2));
950 fold_storage
= gdb::to_string (name
);
951 for (int i
= 0; i
< name
.size (); i
+= 1)
952 fold_storage
[i
] = tolower (fold_storage
[i
]);
955 return fold_storage
.c_str ();
958 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
961 is_lower_alphanum (const char c
)
963 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
966 /* ENCODED is the linkage name of a symbol and LEN contains its length.
967 This function saves in LEN the length of that same symbol name but
968 without either of these suffixes:
974 These are suffixes introduced by the compiler for entities such as
975 nested subprogram for instance, in order to avoid name clashes.
976 They do not serve any purpose for the debugger. */
979 ada_remove_trailing_digits (const char *encoded
, int *len
)
981 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
985 while (i
> 0 && isdigit (encoded
[i
]))
987 if (i
>= 0 && encoded
[i
] == '.')
989 else if (i
>= 0 && encoded
[i
] == '$')
991 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
993 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
998 /* Remove the suffix introduced by the compiler for protected object
1002 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1004 /* Remove trailing N. */
1006 /* Protected entry subprograms are broken into two
1007 separate subprograms: The first one is unprotected, and has
1008 a 'N' suffix; the second is the protected version, and has
1009 the 'P' suffix. The second calls the first one after handling
1010 the protection. Since the P subprograms are internally generated,
1011 we leave these names undecoded, giving the user a clue that this
1012 entity is internal. */
1015 && encoded
[*len
- 1] == 'N'
1016 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1020 /* If ENCODED follows the GNAT entity encoding conventions, then return
1021 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1022 replaced by ENCODED. */
1025 ada_decode (const char *encoded
)
1031 std::string decoded
;
1033 /* With function descriptors on PPC64, the value of a symbol named
1034 ".FN", if it exists, is the entry point of the function "FN". */
1035 if (encoded
[0] == '.')
1038 /* The name of the Ada main procedure starts with "_ada_".
1039 This prefix is not part of the decoded name, so skip this part
1040 if we see this prefix. */
1041 if (startswith (encoded
, "_ada_"))
1044 /* If the name starts with '_', then it is not a properly encoded
1045 name, so do not attempt to decode it. Similarly, if the name
1046 starts with '<', the name should not be decoded. */
1047 if (encoded
[0] == '_' || encoded
[0] == '<')
1050 len0
= strlen (encoded
);
1052 ada_remove_trailing_digits (encoded
, &len0
);
1053 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1055 /* Remove the ___X.* suffix if present. Do not forget to verify that
1056 the suffix is located before the current "end" of ENCODED. We want
1057 to avoid re-matching parts of ENCODED that have previously been
1058 marked as discarded (by decrementing LEN0). */
1059 p
= strstr (encoded
, "___");
1060 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1068 /* Remove any trailing TKB suffix. It tells us that this symbol
1069 is for the body of a task, but that information does not actually
1070 appear in the decoded name. */
1072 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1075 /* Remove any trailing TB suffix. The TB suffix is slightly different
1076 from the TKB suffix because it is used for non-anonymous task
1079 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1082 /* Remove trailing "B" suffixes. */
1083 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1085 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1088 /* Make decoded big enough for possible expansion by operator name. */
1090 decoded
.resize (2 * len0
+ 1, 'X');
1092 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1094 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1097 while ((i
>= 0 && isdigit (encoded
[i
]))
1098 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1100 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1102 else if (encoded
[i
] == '$')
1106 /* The first few characters that are not alphabetic are not part
1107 of any encoding we use, so we can copy them over verbatim. */
1109 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1110 decoded
[j
] = encoded
[i
];
1115 /* Is this a symbol function? */
1116 if (at_start_name
&& encoded
[i
] == 'O')
1120 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1122 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1123 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1125 && !isalnum (encoded
[i
+ op_len
]))
1127 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1130 j
+= strlen (ada_opname_table
[k
].decoded
);
1134 if (ada_opname_table
[k
].encoded
!= NULL
)
1139 /* Replace "TK__" with "__", which will eventually be translated
1140 into "." (just below). */
1142 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1145 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1146 be translated into "." (just below). These are internal names
1147 generated for anonymous blocks inside which our symbol is nested. */
1149 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1150 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1151 && isdigit (encoded
[i
+4]))
1155 while (k
< len0
&& isdigit (encoded
[k
]))
1156 k
++; /* Skip any extra digit. */
1158 /* Double-check that the "__B_{DIGITS}+" sequence we found
1159 is indeed followed by "__". */
1160 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1164 /* Remove _E{DIGITS}+[sb] */
1166 /* Just as for protected object subprograms, there are 2 categories
1167 of subprograms created by the compiler for each entry. The first
1168 one implements the actual entry code, and has a suffix following
1169 the convention above; the second one implements the barrier and
1170 uses the same convention as above, except that the 'E' is replaced
1173 Just as above, we do not decode the name of barrier functions
1174 to give the user a clue that the code he is debugging has been
1175 internally generated. */
1177 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1178 && isdigit (encoded
[i
+2]))
1182 while (k
< len0
&& isdigit (encoded
[k
]))
1186 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1189 /* Just as an extra precaution, make sure that if this
1190 suffix is followed by anything else, it is a '_'.
1191 Otherwise, we matched this sequence by accident. */
1193 || (k
< len0
&& encoded
[k
] == '_'))
1198 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1199 the GNAT front-end in protected object subprograms. */
1202 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1204 /* Backtrack a bit up until we reach either the begining of
1205 the encoded name, or "__". Make sure that we only find
1206 digits or lowercase characters. */
1207 const char *ptr
= encoded
+ i
- 1;
1209 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1212 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1216 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1218 /* This is a X[bn]* sequence not separated from the previous
1219 part of the name with a non-alpha-numeric character (in other
1220 words, immediately following an alpha-numeric character), then
1221 verify that it is placed at the end of the encoded name. If
1222 not, then the encoding is not valid and we should abort the
1223 decoding. Otherwise, just skip it, it is used in body-nested
1227 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1231 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1233 /* Replace '__' by '.'. */
1241 /* It's a character part of the decoded name, so just copy it
1243 decoded
[j
] = encoded
[i
];
1250 /* Decoded names should never contain any uppercase character.
1251 Double-check this, and abort the decoding if we find one. */
1253 for (i
= 0; i
< decoded
.length(); ++i
)
1254 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1260 if (encoded
[0] == '<')
1263 decoded
= '<' + std::string(encoded
) + '>';
1268 /* Table for keeping permanent unique copies of decoded names. Once
1269 allocated, names in this table are never released. While this is a
1270 storage leak, it should not be significant unless there are massive
1271 changes in the set of decoded names in successive versions of a
1272 symbol table loaded during a single session. */
1273 static struct htab
*decoded_names_store
;
1275 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1276 in the language-specific part of GSYMBOL, if it has not been
1277 previously computed. Tries to save the decoded name in the same
1278 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1279 in any case, the decoded symbol has a lifetime at least that of
1281 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1282 const, but nevertheless modified to a semantically equivalent form
1283 when a decoded name is cached in it. */
1286 ada_decode_symbol (const struct general_symbol_info
*arg
)
1288 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1289 const char **resultp
=
1290 &gsymbol
->language_specific
.demangled_name
;
1292 if (!gsymbol
->ada_mangled
)
1294 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1295 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1297 gsymbol
->ada_mangled
= 1;
1299 if (obstack
!= NULL
)
1300 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1303 /* Sometimes, we can't find a corresponding objfile, in
1304 which case, we put the result on the heap. Since we only
1305 decode when needed, we hope this usually does not cause a
1306 significant memory leak (FIXME). */
1308 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1309 decoded
.c_str (), INSERT
);
1312 *slot
= xstrdup (decoded
.c_str ());
1321 ada_la_decode (const char *encoded
, int options
)
1323 return xstrdup (ada_decode (encoded
).c_str ());
1330 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1331 generated by the GNAT compiler to describe the index type used
1332 for each dimension of an array, check whether it follows the latest
1333 known encoding. If not, fix it up to conform to the latest encoding.
1334 Otherwise, do nothing. This function also does nothing if
1335 INDEX_DESC_TYPE is NULL.
1337 The GNAT encoding used to describe the array index type evolved a bit.
1338 Initially, the information would be provided through the name of each
1339 field of the structure type only, while the type of these fields was
1340 described as unspecified and irrelevant. The debugger was then expected
1341 to perform a global type lookup using the name of that field in order
1342 to get access to the full index type description. Because these global
1343 lookups can be very expensive, the encoding was later enhanced to make
1344 the global lookup unnecessary by defining the field type as being
1345 the full index type description.
1347 The purpose of this routine is to allow us to support older versions
1348 of the compiler by detecting the use of the older encoding, and by
1349 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1350 we essentially replace each field's meaningless type by the associated
1354 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1358 if (index_desc_type
== NULL
)
1360 gdb_assert (index_desc_type
->num_fields () > 0);
1362 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1363 to check one field only, no need to check them all). If not, return
1366 If our INDEX_DESC_TYPE was generated using the older encoding,
1367 the field type should be a meaningless integer type whose name
1368 is not equal to the field name. */
1369 if (index_desc_type
->field (0).type ()->name () != NULL
1370 && strcmp (index_desc_type
->field (0).type ()->name (),
1371 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1374 /* Fixup each field of INDEX_DESC_TYPE. */
1375 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1377 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1378 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1381 index_desc_type
->field (i
).set_type (raw_type
);
1385 /* The desc_* routines return primitive portions of array descriptors
1388 /* The descriptor or array type, if any, indicated by TYPE; removes
1389 level of indirection, if needed. */
1391 static struct type
*
1392 desc_base_type (struct type
*type
)
1396 type
= ada_check_typedef (type
);
1397 if (type
->code () == TYPE_CODE_TYPEDEF
)
1398 type
= ada_typedef_target_type (type
);
1401 && (type
->code () == TYPE_CODE_PTR
1402 || type
->code () == TYPE_CODE_REF
))
1403 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1408 /* True iff TYPE indicates a "thin" array pointer type. */
1411 is_thin_pntr (struct type
*type
)
1414 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1415 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1418 /* The descriptor type for thin pointer type TYPE. */
1420 static struct type
*
1421 thin_descriptor_type (struct type
*type
)
1423 struct type
*base_type
= desc_base_type (type
);
1425 if (base_type
== NULL
)
1427 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1431 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1433 if (alt_type
== NULL
)
1440 /* A pointer to the array data for thin-pointer value VAL. */
1442 static struct value
*
1443 thin_data_pntr (struct value
*val
)
1445 struct type
*type
= ada_check_typedef (value_type (val
));
1446 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1448 data_type
= lookup_pointer_type (data_type
);
1450 if (type
->code () == TYPE_CODE_PTR
)
1451 return value_cast (data_type
, value_copy (val
));
1453 return value_from_longest (data_type
, value_address (val
));
1456 /* True iff TYPE indicates a "thick" array pointer type. */
1459 is_thick_pntr (struct type
*type
)
1461 type
= desc_base_type (type
);
1462 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1463 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1466 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1467 pointer to one, the type of its bounds data; otherwise, NULL. */
1469 static struct type
*
1470 desc_bounds_type (struct type
*type
)
1474 type
= desc_base_type (type
);
1478 else if (is_thin_pntr (type
))
1480 type
= thin_descriptor_type (type
);
1483 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1485 return ada_check_typedef (r
);
1487 else if (type
->code () == TYPE_CODE_STRUCT
)
1489 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1491 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1496 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1497 one, a pointer to its bounds data. Otherwise NULL. */
1499 static struct value
*
1500 desc_bounds (struct value
*arr
)
1502 struct type
*type
= ada_check_typedef (value_type (arr
));
1504 if (is_thin_pntr (type
))
1506 struct type
*bounds_type
=
1507 desc_bounds_type (thin_descriptor_type (type
));
1510 if (bounds_type
== NULL
)
1511 error (_("Bad GNAT array descriptor"));
1513 /* NOTE: The following calculation is not really kosher, but
1514 since desc_type is an XVE-encoded type (and shouldn't be),
1515 the correct calculation is a real pain. FIXME (and fix GCC). */
1516 if (type
->code () == TYPE_CODE_PTR
)
1517 addr
= value_as_long (arr
);
1519 addr
= value_address (arr
);
1522 value_from_longest (lookup_pointer_type (bounds_type
),
1523 addr
- TYPE_LENGTH (bounds_type
));
1526 else if (is_thick_pntr (type
))
1528 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1529 _("Bad GNAT array descriptor"));
1530 struct type
*p_bounds_type
= value_type (p_bounds
);
1533 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1535 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1537 if (target_type
->is_stub ())
1538 p_bounds
= value_cast (lookup_pointer_type
1539 (ada_check_typedef (target_type
)),
1543 error (_("Bad GNAT array descriptor"));
1551 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1552 position of the field containing the address of the bounds data. */
1555 fat_pntr_bounds_bitpos (struct type
*type
)
1557 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1560 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1561 size of the field containing the address of the bounds data. */
1564 fat_pntr_bounds_bitsize (struct type
*type
)
1566 type
= desc_base_type (type
);
1568 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1569 return TYPE_FIELD_BITSIZE (type
, 1);
1571 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1574 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1575 pointer to one, the type of its array data (a array-with-no-bounds type);
1576 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1579 static struct type
*
1580 desc_data_target_type (struct type
*type
)
1582 type
= desc_base_type (type
);
1584 /* NOTE: The following is bogus; see comment in desc_bounds. */
1585 if (is_thin_pntr (type
))
1586 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1587 else if (is_thick_pntr (type
))
1589 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1592 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1593 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1599 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1602 static struct value
*
1603 desc_data (struct value
*arr
)
1605 struct type
*type
= value_type (arr
);
1607 if (is_thin_pntr (type
))
1608 return thin_data_pntr (arr
);
1609 else if (is_thick_pntr (type
))
1610 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1611 _("Bad GNAT array descriptor"));
1617 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1618 position of the field containing the address of the data. */
1621 fat_pntr_data_bitpos (struct type
*type
)
1623 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1626 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1627 size of the field containing the address of the data. */
1630 fat_pntr_data_bitsize (struct type
*type
)
1632 type
= desc_base_type (type
);
1634 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1635 return TYPE_FIELD_BITSIZE (type
, 0);
1637 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1640 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1641 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1642 bound, if WHICH is 1. The first bound is I=1. */
1644 static struct value
*
1645 desc_one_bound (struct value
*bounds
, int i
, int which
)
1647 char bound_name
[20];
1648 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1649 which
? 'U' : 'L', i
- 1);
1650 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1651 _("Bad GNAT array descriptor bounds"));
1654 /* If BOUNDS is an array-bounds structure type, return the bit position
1655 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1656 bound, if WHICH is 1. The first bound is I=1. */
1659 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1661 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1664 /* If BOUNDS is an array-bounds structure type, return the bit field size
1665 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1666 bound, if WHICH is 1. The first bound is I=1. */
1669 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1671 type
= desc_base_type (type
);
1673 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1674 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1676 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1679 /* If TYPE is the type of an array-bounds structure, the type of its
1680 Ith bound (numbering from 1). Otherwise, NULL. */
1682 static struct type
*
1683 desc_index_type (struct type
*type
, int i
)
1685 type
= desc_base_type (type
);
1687 if (type
->code () == TYPE_CODE_STRUCT
)
1689 char bound_name
[20];
1690 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1691 return lookup_struct_elt_type (type
, bound_name
, 1);
1697 /* The number of index positions in the array-bounds type TYPE.
1698 Return 0 if TYPE is NULL. */
1701 desc_arity (struct type
*type
)
1703 type
= desc_base_type (type
);
1706 return type
->num_fields () / 2;
1710 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1711 an array descriptor type (representing an unconstrained array
1715 ada_is_direct_array_type (struct type
*type
)
1719 type
= ada_check_typedef (type
);
1720 return (type
->code () == TYPE_CODE_ARRAY
1721 || ada_is_array_descriptor_type (type
));
1724 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1728 ada_is_array_type (struct type
*type
)
1731 && (type
->code () == TYPE_CODE_PTR
1732 || type
->code () == TYPE_CODE_REF
))
1733 type
= TYPE_TARGET_TYPE (type
);
1734 return ada_is_direct_array_type (type
);
1737 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1740 ada_is_simple_array_type (struct type
*type
)
1744 type
= ada_check_typedef (type
);
1745 return (type
->code () == TYPE_CODE_ARRAY
1746 || (type
->code () == TYPE_CODE_PTR
1747 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1748 == TYPE_CODE_ARRAY
)));
1751 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1754 ada_is_array_descriptor_type (struct type
*type
)
1756 struct type
*data_type
= desc_data_target_type (type
);
1760 type
= ada_check_typedef (type
);
1761 return (data_type
!= NULL
1762 && data_type
->code () == TYPE_CODE_ARRAY
1763 && desc_arity (desc_bounds_type (type
)) > 0);
1766 /* Non-zero iff type is a partially mal-formed GNAT array
1767 descriptor. FIXME: This is to compensate for some problems with
1768 debugging output from GNAT. Re-examine periodically to see if it
1772 ada_is_bogus_array_descriptor (struct type
*type
)
1776 && type
->code () == TYPE_CODE_STRUCT
1777 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1778 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1779 && !ada_is_array_descriptor_type (type
);
1783 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1784 (fat pointer) returns the type of the array data described---specifically,
1785 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1786 in from the descriptor; otherwise, they are left unspecified. If
1787 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1788 returns NULL. The result is simply the type of ARR if ARR is not
1791 static struct type
*
1792 ada_type_of_array (struct value
*arr
, int bounds
)
1794 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1795 return decode_constrained_packed_array_type (value_type (arr
));
1797 if (!ada_is_array_descriptor_type (value_type (arr
)))
1798 return value_type (arr
);
1802 struct type
*array_type
=
1803 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1805 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1806 TYPE_FIELD_BITSIZE (array_type
, 0) =
1807 decode_packed_array_bitsize (value_type (arr
));
1813 struct type
*elt_type
;
1815 struct value
*descriptor
;
1817 elt_type
= ada_array_element_type (value_type (arr
), -1);
1818 arity
= ada_array_arity (value_type (arr
));
1820 if (elt_type
== NULL
|| arity
== 0)
1821 return ada_check_typedef (value_type (arr
));
1823 descriptor
= desc_bounds (arr
);
1824 if (value_as_long (descriptor
) == 0)
1828 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1829 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1830 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1831 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1834 create_static_range_type (range_type
, value_type (low
),
1835 longest_to_int (value_as_long (low
)),
1836 longest_to_int (value_as_long (high
)));
1837 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1839 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1841 /* We need to store the element packed bitsize, as well as
1842 recompute the array size, because it was previously
1843 computed based on the unpacked element size. */
1844 LONGEST lo
= value_as_long (low
);
1845 LONGEST hi
= value_as_long (high
);
1847 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1848 decode_packed_array_bitsize (value_type (arr
));
1849 /* If the array has no element, then the size is already
1850 zero, and does not need to be recomputed. */
1854 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1856 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1861 return lookup_pointer_type (elt_type
);
1865 /* If ARR does not represent an array, returns ARR unchanged.
1866 Otherwise, returns either a standard GDB array with bounds set
1867 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1868 GDB array. Returns NULL if ARR is a null fat pointer. */
1871 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1873 if (ada_is_array_descriptor_type (value_type (arr
)))
1875 struct type
*arrType
= ada_type_of_array (arr
, 1);
1877 if (arrType
== NULL
)
1879 return value_cast (arrType
, value_copy (desc_data (arr
)));
1881 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1882 return decode_constrained_packed_array (arr
);
1887 /* If ARR does not represent an array, returns ARR unchanged.
1888 Otherwise, returns a standard GDB array describing ARR (which may
1889 be ARR itself if it already is in the proper form). */
1892 ada_coerce_to_simple_array (struct value
*arr
)
1894 if (ada_is_array_descriptor_type (value_type (arr
)))
1896 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1899 error (_("Bounds unavailable for null array pointer."));
1900 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1901 return value_ind (arrVal
);
1903 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1904 return decode_constrained_packed_array (arr
);
1909 /* If TYPE represents a GNAT array type, return it translated to an
1910 ordinary GDB array type (possibly with BITSIZE fields indicating
1911 packing). For other types, is the identity. */
1914 ada_coerce_to_simple_array_type (struct type
*type
)
1916 if (ada_is_constrained_packed_array_type (type
))
1917 return decode_constrained_packed_array_type (type
);
1919 if (ada_is_array_descriptor_type (type
))
1920 return ada_check_typedef (desc_data_target_type (type
));
1925 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1928 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
1932 type
= desc_base_type (type
);
1933 type
= ada_check_typedef (type
);
1935 ada_type_name (type
) != NULL
1936 && strstr (ada_type_name (type
), "___XP") != NULL
;
1939 /* Non-zero iff TYPE represents a standard GNAT constrained
1940 packed-array type. */
1943 ada_is_constrained_packed_array_type (struct type
*type
)
1945 return ada_is_gnat_encoded_packed_array_type (type
)
1946 && !ada_is_array_descriptor_type (type
);
1949 /* Non-zero iff TYPE represents an array descriptor for a
1950 unconstrained packed-array type. */
1953 ada_is_unconstrained_packed_array_type (struct type
*type
)
1955 if (!ada_is_array_descriptor_type (type
))
1958 if (ada_is_gnat_encoded_packed_array_type (type
))
1961 /* If we saw GNAT encodings, then the above code is sufficient.
1962 However, with minimal encodings, we will just have a thick
1964 if (is_thick_pntr (type
))
1966 type
= desc_base_type (type
);
1967 /* The structure's first field is a pointer to an array, so this
1968 fetches the array type. */
1969 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
1970 /* Now we can see if the array elements are packed. */
1971 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
1977 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1978 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
1981 ada_is_any_packed_array_type (struct type
*type
)
1983 return (ada_is_constrained_packed_array_type (type
)
1984 || (type
->code () == TYPE_CODE_ARRAY
1985 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
1988 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1989 return the size of its elements in bits. */
1992 decode_packed_array_bitsize (struct type
*type
)
1994 const char *raw_name
;
1998 /* Access to arrays implemented as fat pointers are encoded as a typedef
1999 of the fat pointer type. We need the name of the fat pointer type
2000 to do the decoding, so strip the typedef layer. */
2001 if (type
->code () == TYPE_CODE_TYPEDEF
)
2002 type
= ada_typedef_target_type (type
);
2004 raw_name
= ada_type_name (ada_check_typedef (type
));
2006 raw_name
= ada_type_name (desc_base_type (type
));
2011 tail
= strstr (raw_name
, "___XP");
2012 if (tail
== nullptr)
2014 gdb_assert (is_thick_pntr (type
));
2015 /* The structure's first field is a pointer to an array, so this
2016 fetches the array type. */
2017 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2018 /* Now we can see if the array elements are packed. */
2019 return TYPE_FIELD_BITSIZE (type
, 0);
2022 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2025 (_("could not understand bit size information on packed array"));
2032 /* Given that TYPE is a standard GDB array type with all bounds filled
2033 in, and that the element size of its ultimate scalar constituents
2034 (that is, either its elements, or, if it is an array of arrays, its
2035 elements' elements, etc.) is *ELT_BITS, return an identical type,
2036 but with the bit sizes of its elements (and those of any
2037 constituent arrays) recorded in the BITSIZE components of its
2038 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2041 Note that, for arrays whose index type has an XA encoding where
2042 a bound references a record discriminant, getting that discriminant,
2043 and therefore the actual value of that bound, is not possible
2044 because none of the given parameters gives us access to the record.
2045 This function assumes that it is OK in the context where it is being
2046 used to return an array whose bounds are still dynamic and where
2047 the length is arbitrary. */
2049 static struct type
*
2050 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2052 struct type
*new_elt_type
;
2053 struct type
*new_type
;
2054 struct type
*index_type_desc
;
2055 struct type
*index_type
;
2056 LONGEST low_bound
, high_bound
;
2058 type
= ada_check_typedef (type
);
2059 if (type
->code () != TYPE_CODE_ARRAY
)
2062 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2063 if (index_type_desc
)
2064 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2067 index_type
= type
->index_type ();
2069 new_type
= alloc_type_copy (type
);
2071 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2073 create_array_type (new_type
, new_elt_type
, index_type
);
2074 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2075 new_type
->set_name (ada_type_name (type
));
2077 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2078 && is_dynamic_type (check_typedef (index_type
)))
2079 || !get_discrete_bounds (index_type
, &low_bound
, &high_bound
))
2080 low_bound
= high_bound
= 0;
2081 if (high_bound
< low_bound
)
2082 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2085 *elt_bits
*= (high_bound
- low_bound
+ 1);
2086 TYPE_LENGTH (new_type
) =
2087 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2090 new_type
->set_is_fixed_instance (true);
2094 /* The array type encoded by TYPE, where
2095 ada_is_constrained_packed_array_type (TYPE). */
2097 static struct type
*
2098 decode_constrained_packed_array_type (struct type
*type
)
2100 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2103 struct type
*shadow_type
;
2107 raw_name
= ada_type_name (desc_base_type (type
));
2112 name
= (char *) alloca (strlen (raw_name
) + 1);
2113 tail
= strstr (raw_name
, "___XP");
2114 type
= desc_base_type (type
);
2116 memcpy (name
, raw_name
, tail
- raw_name
);
2117 name
[tail
- raw_name
] = '\000';
2119 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2121 if (shadow_type
== NULL
)
2123 lim_warning (_("could not find bounds information on packed array"));
2126 shadow_type
= check_typedef (shadow_type
);
2128 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2130 lim_warning (_("could not understand bounds "
2131 "information on packed array"));
2135 bits
= decode_packed_array_bitsize (type
);
2136 return constrained_packed_array_type (shadow_type
, &bits
);
2139 /* Helper function for decode_constrained_packed_array. Set the field
2140 bitsize on a series of packed arrays. Returns the number of
2141 elements in TYPE. */
2144 recursively_update_array_bitsize (struct type
*type
)
2146 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2149 if (!get_discrete_bounds (type
->index_type (), &low
, &high
)
2152 LONGEST our_len
= high
- low
+ 1;
2154 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
2155 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2157 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2158 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2159 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2161 TYPE_LENGTH (type
) = ((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2168 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2169 array, returns a simple array that denotes that array. Its type is a
2170 standard GDB array type except that the BITSIZEs of the array
2171 target types are set to the number of bits in each element, and the
2172 type length is set appropriately. */
2174 static struct value
*
2175 decode_constrained_packed_array (struct value
*arr
)
2179 /* If our value is a pointer, then dereference it. Likewise if
2180 the value is a reference. Make sure that this operation does not
2181 cause the target type to be fixed, as this would indirectly cause
2182 this array to be decoded. The rest of the routine assumes that
2183 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2184 and "value_ind" routines to perform the dereferencing, as opposed
2185 to using "ada_coerce_ref" or "ada_value_ind". */
2186 arr
= coerce_ref (arr
);
2187 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2188 arr
= value_ind (arr
);
2190 type
= decode_constrained_packed_array_type (value_type (arr
));
2193 error (_("can't unpack array"));
2197 /* Decoding the packed array type could not correctly set the field
2198 bitsizes for any dimension except the innermost, because the
2199 bounds may be variable and were not passed to that function. So,
2200 we further resolve the array bounds here and then update the
2202 const gdb_byte
*valaddr
= value_contents_for_printing (arr
);
2203 CORE_ADDR address
= value_address (arr
);
2204 gdb::array_view
<const gdb_byte
> view
2205 = gdb::make_array_view (valaddr
, TYPE_LENGTH (type
));
2206 type
= resolve_dynamic_type (type
, view
, address
);
2207 recursively_update_array_bitsize (type
);
2209 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2210 && ada_is_modular_type (value_type (arr
)))
2212 /* This is a (right-justified) modular type representing a packed
2213 array with no wrapper. In order to interpret the value through
2214 the (left-justified) packed array type we just built, we must
2215 first left-justify it. */
2216 int bit_size
, bit_pos
;
2219 mod
= ada_modulus (value_type (arr
)) - 1;
2226 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2227 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2228 bit_pos
/ HOST_CHAR_BIT
,
2229 bit_pos
% HOST_CHAR_BIT
,
2234 return coerce_unspec_val_to_type (arr
, type
);
2238 /* The value of the element of packed array ARR at the ARITY indices
2239 given in IND. ARR must be a simple array. */
2241 static struct value
*
2242 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2245 int bits
, elt_off
, bit_off
;
2246 long elt_total_bit_offset
;
2247 struct type
*elt_type
;
2251 elt_total_bit_offset
= 0;
2252 elt_type
= ada_check_typedef (value_type (arr
));
2253 for (i
= 0; i
< arity
; i
+= 1)
2255 if (elt_type
->code () != TYPE_CODE_ARRAY
2256 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2258 (_("attempt to do packed indexing of "
2259 "something other than a packed array"));
2262 struct type
*range_type
= elt_type
->index_type ();
2263 LONGEST lowerbound
, upperbound
;
2266 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2268 lim_warning (_("don't know bounds of array"));
2269 lowerbound
= upperbound
= 0;
2272 idx
= pos_atr (ind
[i
]);
2273 if (idx
< lowerbound
|| idx
> upperbound
)
2274 lim_warning (_("packed array index %ld out of bounds"),
2276 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2277 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2278 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2281 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2282 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2284 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2289 /* Non-zero iff TYPE includes negative integer values. */
2292 has_negatives (struct type
*type
)
2294 switch (type
->code ())
2299 return !type
->is_unsigned ();
2300 case TYPE_CODE_RANGE
:
2301 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2305 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2306 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2307 the unpacked buffer.
2309 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2310 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2312 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2315 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2317 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2320 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2321 gdb_byte
*unpacked
, int unpacked_len
,
2322 int is_big_endian
, int is_signed_type
,
2325 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2326 int src_idx
; /* Index into the source area */
2327 int src_bytes_left
; /* Number of source bytes left to process. */
2328 int srcBitsLeft
; /* Number of source bits left to move */
2329 int unusedLS
; /* Number of bits in next significant
2330 byte of source that are unused */
2332 int unpacked_idx
; /* Index into the unpacked buffer */
2333 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2335 unsigned long accum
; /* Staging area for bits being transferred */
2336 int accumSize
; /* Number of meaningful bits in accum */
2339 /* Transmit bytes from least to most significant; delta is the direction
2340 the indices move. */
2341 int delta
= is_big_endian
? -1 : 1;
2343 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2345 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2346 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2347 bit_size
, unpacked_len
);
2349 srcBitsLeft
= bit_size
;
2350 src_bytes_left
= src_len
;
2351 unpacked_bytes_left
= unpacked_len
;
2356 src_idx
= src_len
- 1;
2358 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2362 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2368 unpacked_idx
= unpacked_len
- 1;
2372 /* Non-scalar values must be aligned at a byte boundary... */
2374 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2375 /* ... And are placed at the beginning (most-significant) bytes
2377 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2378 unpacked_bytes_left
= unpacked_idx
+ 1;
2383 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2385 src_idx
= unpacked_idx
= 0;
2386 unusedLS
= bit_offset
;
2389 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2394 while (src_bytes_left
> 0)
2396 /* Mask for removing bits of the next source byte that are not
2397 part of the value. */
2398 unsigned int unusedMSMask
=
2399 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2401 /* Sign-extend bits for this byte. */
2402 unsigned int signMask
= sign
& ~unusedMSMask
;
2405 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2406 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2407 if (accumSize
>= HOST_CHAR_BIT
)
2409 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2410 accumSize
-= HOST_CHAR_BIT
;
2411 accum
>>= HOST_CHAR_BIT
;
2412 unpacked_bytes_left
-= 1;
2413 unpacked_idx
+= delta
;
2415 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2417 src_bytes_left
-= 1;
2420 while (unpacked_bytes_left
> 0)
2422 accum
|= sign
<< accumSize
;
2423 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2424 accumSize
-= HOST_CHAR_BIT
;
2427 accum
>>= HOST_CHAR_BIT
;
2428 unpacked_bytes_left
-= 1;
2429 unpacked_idx
+= delta
;
2433 /* Create a new value of type TYPE from the contents of OBJ starting
2434 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2435 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2436 assigning through the result will set the field fetched from.
2437 VALADDR is ignored unless OBJ is NULL, in which case,
2438 VALADDR+OFFSET must address the start of storage containing the
2439 packed value. The value returned in this case is never an lval.
2440 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2443 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2444 long offset
, int bit_offset
, int bit_size
,
2448 const gdb_byte
*src
; /* First byte containing data to unpack */
2450 const int is_scalar
= is_scalar_type (type
);
2451 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2452 gdb::byte_vector staging
;
2454 type
= ada_check_typedef (type
);
2457 src
= valaddr
+ offset
;
2459 src
= value_contents (obj
) + offset
;
2461 if (is_dynamic_type (type
))
2463 /* The length of TYPE might by dynamic, so we need to resolve
2464 TYPE in order to know its actual size, which we then use
2465 to create the contents buffer of the value we return.
2466 The difficulty is that the data containing our object is
2467 packed, and therefore maybe not at a byte boundary. So, what
2468 we do, is unpack the data into a byte-aligned buffer, and then
2469 use that buffer as our object's value for resolving the type. */
2470 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2471 staging
.resize (staging_len
);
2473 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2474 staging
.data (), staging
.size (),
2475 is_big_endian
, has_negatives (type
),
2477 type
= resolve_dynamic_type (type
, staging
, 0);
2478 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2480 /* This happens when the length of the object is dynamic,
2481 and is actually smaller than the space reserved for it.
2482 For instance, in an array of variant records, the bit_size
2483 we're given is the array stride, which is constant and
2484 normally equal to the maximum size of its element.
2485 But, in reality, each element only actually spans a portion
2487 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2493 v
= allocate_value (type
);
2494 src
= valaddr
+ offset
;
2496 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2498 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2501 v
= value_at (type
, value_address (obj
) + offset
);
2502 buf
= (gdb_byte
*) alloca (src_len
);
2503 read_memory (value_address (v
), buf
, src_len
);
2508 v
= allocate_value (type
);
2509 src
= value_contents (obj
) + offset
;
2514 long new_offset
= offset
;
2516 set_value_component_location (v
, obj
);
2517 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2518 set_value_bitsize (v
, bit_size
);
2519 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2522 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2524 set_value_offset (v
, new_offset
);
2526 /* Also set the parent value. This is needed when trying to
2527 assign a new value (in inferior memory). */
2528 set_value_parent (v
, obj
);
2531 set_value_bitsize (v
, bit_size
);
2532 unpacked
= value_contents_writeable (v
);
2536 memset (unpacked
, 0, TYPE_LENGTH (type
));
2540 if (staging
.size () == TYPE_LENGTH (type
))
2542 /* Small short-cut: If we've unpacked the data into a buffer
2543 of the same size as TYPE's length, then we can reuse that,
2544 instead of doing the unpacking again. */
2545 memcpy (unpacked
, staging
.data (), staging
.size ());
2548 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2549 unpacked
, TYPE_LENGTH (type
),
2550 is_big_endian
, has_negatives (type
), is_scalar
);
2555 /* Store the contents of FROMVAL into the location of TOVAL.
2556 Return a new value with the location of TOVAL and contents of
2557 FROMVAL. Handles assignment into packed fields that have
2558 floating-point or non-scalar types. */
2560 static struct value
*
2561 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2563 struct type
*type
= value_type (toval
);
2564 int bits
= value_bitsize (toval
);
2566 toval
= ada_coerce_ref (toval
);
2567 fromval
= ada_coerce_ref (fromval
);
2569 if (ada_is_direct_array_type (value_type (toval
)))
2570 toval
= ada_coerce_to_simple_array (toval
);
2571 if (ada_is_direct_array_type (value_type (fromval
)))
2572 fromval
= ada_coerce_to_simple_array (fromval
);
2574 if (!deprecated_value_modifiable (toval
))
2575 error (_("Left operand of assignment is not a modifiable lvalue."));
2577 if (VALUE_LVAL (toval
) == lval_memory
2579 && (type
->code () == TYPE_CODE_FLT
2580 || type
->code () == TYPE_CODE_STRUCT
))
2582 int len
= (value_bitpos (toval
)
2583 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2585 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2587 CORE_ADDR to_addr
= value_address (toval
);
2589 if (type
->code () == TYPE_CODE_FLT
)
2590 fromval
= value_cast (type
, fromval
);
2592 read_memory (to_addr
, buffer
, len
);
2593 from_size
= value_bitsize (fromval
);
2595 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2597 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2598 ULONGEST from_offset
= 0;
2599 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2600 from_offset
= from_size
- bits
;
2601 copy_bitwise (buffer
, value_bitpos (toval
),
2602 value_contents (fromval
), from_offset
,
2603 bits
, is_big_endian
);
2604 write_memory_with_notification (to_addr
, buffer
, len
);
2606 val
= value_copy (toval
);
2607 memcpy (value_contents_raw (val
), value_contents (fromval
),
2608 TYPE_LENGTH (type
));
2609 deprecated_set_value_type (val
, type
);
2614 return value_assign (toval
, fromval
);
2618 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2619 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2620 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2621 COMPONENT, and not the inferior's memory. The current contents
2622 of COMPONENT are ignored.
2624 Although not part of the initial design, this function also works
2625 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2626 had a null address, and COMPONENT had an address which is equal to
2627 its offset inside CONTAINER. */
2630 value_assign_to_component (struct value
*container
, struct value
*component
,
2633 LONGEST offset_in_container
=
2634 (LONGEST
) (value_address (component
) - value_address (container
));
2635 int bit_offset_in_container
=
2636 value_bitpos (component
) - value_bitpos (container
);
2639 val
= value_cast (value_type (component
), val
);
2641 if (value_bitsize (component
) == 0)
2642 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2644 bits
= value_bitsize (component
);
2646 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2650 if (is_scalar_type (check_typedef (value_type (component
))))
2652 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2655 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2656 value_bitpos (container
) + bit_offset_in_container
,
2657 value_contents (val
), src_offset
, bits
, 1);
2660 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2661 value_bitpos (container
) + bit_offset_in_container
,
2662 value_contents (val
), 0, bits
, 0);
2665 /* Determine if TYPE is an access to an unconstrained array. */
2668 ada_is_access_to_unconstrained_array (struct type
*type
)
2670 return (type
->code () == TYPE_CODE_TYPEDEF
2671 && is_thick_pntr (ada_typedef_target_type (type
)));
2674 /* The value of the element of array ARR at the ARITY indices given in IND.
2675 ARR may be either a simple array, GNAT array descriptor, or pointer
2679 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2683 struct type
*elt_type
;
2685 elt
= ada_coerce_to_simple_array (arr
);
2687 elt_type
= ada_check_typedef (value_type (elt
));
2688 if (elt_type
->code () == TYPE_CODE_ARRAY
2689 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2690 return value_subscript_packed (elt
, arity
, ind
);
2692 for (k
= 0; k
< arity
; k
+= 1)
2694 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2696 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2697 error (_("too many subscripts (%d expected)"), k
);
2699 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2701 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2702 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2704 /* The element is a typedef to an unconstrained array,
2705 except that the value_subscript call stripped the
2706 typedef layer. The typedef layer is GNAT's way to
2707 specify that the element is, at the source level, an
2708 access to the unconstrained array, rather than the
2709 unconstrained array. So, we need to restore that
2710 typedef layer, which we can do by forcing the element's
2711 type back to its original type. Otherwise, the returned
2712 value is going to be printed as the array, rather
2713 than as an access. Another symptom of the same issue
2714 would be that an expression trying to dereference the
2715 element would also be improperly rejected. */
2716 deprecated_set_value_type (elt
, saved_elt_type
);
2719 elt_type
= ada_check_typedef (value_type (elt
));
2725 /* Assuming ARR is a pointer to a GDB array, the value of the element
2726 of *ARR at the ARITY indices given in IND.
2727 Does not read the entire array into memory.
2729 Note: Unlike what one would expect, this function is used instead of
2730 ada_value_subscript for basically all non-packed array types. The reason
2731 for this is that a side effect of doing our own pointer arithmetics instead
2732 of relying on value_subscript is that there is no implicit typedef peeling.
2733 This is important for arrays of array accesses, where it allows us to
2734 preserve the fact that the array's element is an array access, where the
2735 access part os encoded in a typedef layer. */
2737 static struct value
*
2738 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2741 struct value
*array_ind
= ada_value_ind (arr
);
2743 = check_typedef (value_enclosing_type (array_ind
));
2745 if (type
->code () == TYPE_CODE_ARRAY
2746 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2747 return value_subscript_packed (array_ind
, arity
, ind
);
2749 for (k
= 0; k
< arity
; k
+= 1)
2753 if (type
->code () != TYPE_CODE_ARRAY
)
2754 error (_("too many subscripts (%d expected)"), k
);
2755 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2757 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2758 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2759 type
= TYPE_TARGET_TYPE (type
);
2762 return value_ind (arr
);
2765 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2766 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2767 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2768 this array is LOW, as per Ada rules. */
2769 static struct value
*
2770 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2773 struct type
*type0
= ada_check_typedef (type
);
2774 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2775 struct type
*index_type
2776 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2777 struct type
*slice_type
= create_array_type_with_stride
2778 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2779 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2780 TYPE_FIELD_BITSIZE (type0
, 0));
2781 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2782 gdb::optional
<LONGEST
> base_low_pos
, low_pos
;
2785 low_pos
= discrete_position (base_index_type
, low
);
2786 base_low_pos
= discrete_position (base_index_type
, base_low
);
2788 if (!low_pos
.has_value () || !base_low_pos
.has_value ())
2790 warning (_("unable to get positions in slice, use bounds instead"));
2792 base_low_pos
= base_low
;
2795 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
2797 stride
= TYPE_LENGTH (TYPE_TARGET_TYPE (type0
));
2799 base
= value_as_address (array_ptr
) + (*low_pos
- *base_low_pos
) * stride
;
2800 return value_at_lazy (slice_type
, base
);
2804 static struct value
*
2805 ada_value_slice (struct value
*array
, int low
, int high
)
2807 struct type
*type
= ada_check_typedef (value_type (array
));
2808 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2809 struct type
*index_type
2810 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2811 struct type
*slice_type
= create_array_type_with_stride
2812 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2813 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2814 TYPE_FIELD_BITSIZE (type
, 0));
2815 gdb::optional
<LONGEST
> low_pos
, high_pos
;
2818 low_pos
= discrete_position (base_index_type
, low
);
2819 high_pos
= discrete_position (base_index_type
, high
);
2821 if (!low_pos
.has_value () || !high_pos
.has_value ())
2823 warning (_("unable to get positions in slice, use bounds instead"));
2828 return value_cast (slice_type
,
2829 value_slice (array
, low
, *high_pos
- *low_pos
+ 1));
2832 /* If type is a record type in the form of a standard GNAT array
2833 descriptor, returns the number of dimensions for type. If arr is a
2834 simple array, returns the number of "array of"s that prefix its
2835 type designation. Otherwise, returns 0. */
2838 ada_array_arity (struct type
*type
)
2845 type
= desc_base_type (type
);
2848 if (type
->code () == TYPE_CODE_STRUCT
)
2849 return desc_arity (desc_bounds_type (type
));
2851 while (type
->code () == TYPE_CODE_ARRAY
)
2854 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2860 /* If TYPE is a record type in the form of a standard GNAT array
2861 descriptor or a simple array type, returns the element type for
2862 TYPE after indexing by NINDICES indices, or by all indices if
2863 NINDICES is -1. Otherwise, returns NULL. */
2866 ada_array_element_type (struct type
*type
, int nindices
)
2868 type
= desc_base_type (type
);
2870 if (type
->code () == TYPE_CODE_STRUCT
)
2873 struct type
*p_array_type
;
2875 p_array_type
= desc_data_target_type (type
);
2877 k
= ada_array_arity (type
);
2881 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2882 if (nindices
>= 0 && k
> nindices
)
2884 while (k
> 0 && p_array_type
!= NULL
)
2886 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2889 return p_array_type
;
2891 else if (type
->code () == TYPE_CODE_ARRAY
)
2893 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2895 type
= TYPE_TARGET_TYPE (type
);
2904 /* The type of nth index in arrays of given type (n numbering from 1).
2905 Does not examine memory. Throws an error if N is invalid or TYPE
2906 is not an array type. NAME is the name of the Ada attribute being
2907 evaluated ('range, 'first, 'last, or 'length); it is used in building
2908 the error message. */
2910 static struct type
*
2911 ada_index_type (struct type
*type
, int n
, const char *name
)
2913 struct type
*result_type
;
2915 type
= desc_base_type (type
);
2917 if (n
< 0 || n
> ada_array_arity (type
))
2918 error (_("invalid dimension number to '%s"), name
);
2920 if (ada_is_simple_array_type (type
))
2924 for (i
= 1; i
< n
; i
+= 1)
2925 type
= TYPE_TARGET_TYPE (type
);
2926 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2927 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2928 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2929 perhaps stabsread.c would make more sense. */
2930 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2935 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2936 if (result_type
== NULL
)
2937 error (_("attempt to take bound of something that is not an array"));
2943 /* Given that arr is an array type, returns the lower bound of the
2944 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2945 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2946 array-descriptor type. It works for other arrays with bounds supplied
2947 by run-time quantities other than discriminants. */
2950 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2952 struct type
*type
, *index_type_desc
, *index_type
;
2955 gdb_assert (which
== 0 || which
== 1);
2957 if (ada_is_constrained_packed_array_type (arr_type
))
2958 arr_type
= decode_constrained_packed_array_type (arr_type
);
2960 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2961 return (LONGEST
) - which
;
2963 if (arr_type
->code () == TYPE_CODE_PTR
)
2964 type
= TYPE_TARGET_TYPE (arr_type
);
2968 if (type
->is_fixed_instance ())
2970 /* The array has already been fixed, so we do not need to
2971 check the parallel ___XA type again. That encoding has
2972 already been applied, so ignore it now. */
2973 index_type_desc
= NULL
;
2977 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2978 ada_fixup_array_indexes_type (index_type_desc
);
2981 if (index_type_desc
!= NULL
)
2982 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
2986 struct type
*elt_type
= check_typedef (type
);
2988 for (i
= 1; i
< n
; i
++)
2989 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2991 index_type
= elt_type
->index_type ();
2995 (LONGEST
) (which
== 0
2996 ? ada_discrete_type_low_bound (index_type
)
2997 : ada_discrete_type_high_bound (index_type
));
3000 /* Given that arr is an array value, returns the lower bound of the
3001 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3002 WHICH is 1. This routine will also work for arrays with bounds
3003 supplied by run-time quantities other than discriminants. */
3006 ada_array_bound (struct value
*arr
, int n
, int which
)
3008 struct type
*arr_type
;
3010 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3011 arr
= value_ind (arr
);
3012 arr_type
= value_enclosing_type (arr
);
3014 if (ada_is_constrained_packed_array_type (arr_type
))
3015 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3016 else if (ada_is_simple_array_type (arr_type
))
3017 return ada_array_bound_from_type (arr_type
, n
, which
);
3019 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3022 /* Given that arr is an array value, returns the length of the
3023 nth index. This routine will also work for arrays with bounds
3024 supplied by run-time quantities other than discriminants.
3025 Does not work for arrays indexed by enumeration types with representation
3026 clauses at the moment. */
3029 ada_array_length (struct value
*arr
, int n
)
3031 struct type
*arr_type
, *index_type
;
3034 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3035 arr
= value_ind (arr
);
3036 arr_type
= value_enclosing_type (arr
);
3038 if (ada_is_constrained_packed_array_type (arr_type
))
3039 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3041 if (ada_is_simple_array_type (arr_type
))
3043 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3044 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3048 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3049 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3052 arr_type
= check_typedef (arr_type
);
3053 index_type
= ada_index_type (arr_type
, n
, "length");
3054 if (index_type
!= NULL
)
3056 struct type
*base_type
;
3057 if (index_type
->code () == TYPE_CODE_RANGE
)
3058 base_type
= TYPE_TARGET_TYPE (index_type
);
3060 base_type
= index_type
;
3062 low
= pos_atr (value_from_longest (base_type
, low
));
3063 high
= pos_atr (value_from_longest (base_type
, high
));
3065 return high
- low
+ 1;
3068 /* An array whose type is that of ARR_TYPE (an array type), with
3069 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3070 less than LOW, then LOW-1 is used. */
3072 static struct value
*
3073 empty_array (struct type
*arr_type
, int low
, int high
)
3075 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3076 struct type
*index_type
3077 = create_static_range_type
3078 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3079 high
< low
? low
- 1 : high
);
3080 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3082 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3086 /* Name resolution */
3088 /* The "decoded" name for the user-definable Ada operator corresponding
3092 ada_decoded_op_name (enum exp_opcode op
)
3096 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3098 if (ada_opname_table
[i
].op
== op
)
3099 return ada_opname_table
[i
].decoded
;
3101 error (_("Could not find operator name for opcode"));
3104 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3105 in a listing of choices during disambiguation (see sort_choices, below).
3106 The idea is that overloadings of a subprogram name from the
3107 same package should sort in their source order. We settle for ordering
3108 such symbols by their trailing number (__N or $N). */
3111 encoded_ordered_before (const char *N0
, const char *N1
)
3115 else if (N0
== NULL
)
3121 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3123 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3125 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3126 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3131 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3134 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3136 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3137 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3139 return (strcmp (N0
, N1
) < 0);
3143 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3147 sort_choices (struct block_symbol syms
[], int nsyms
)
3151 for (i
= 1; i
< nsyms
; i
+= 1)
3153 struct block_symbol sym
= syms
[i
];
3156 for (j
= i
- 1; j
>= 0; j
-= 1)
3158 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3159 sym
.symbol
->linkage_name ()))
3161 syms
[j
+ 1] = syms
[j
];
3167 /* Whether GDB should display formals and return types for functions in the
3168 overloads selection menu. */
3169 static bool print_signatures
= true;
3171 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3172 all but functions, the signature is just the name of the symbol. For
3173 functions, this is the name of the function, the list of types for formals
3174 and the return type (if any). */
3177 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3178 const struct type_print_options
*flags
)
3180 struct type
*type
= SYMBOL_TYPE (sym
);
3182 fprintf_filtered (stream
, "%s", sym
->print_name ());
3183 if (!print_signatures
3185 || type
->code () != TYPE_CODE_FUNC
)
3188 if (type
->num_fields () > 0)
3192 fprintf_filtered (stream
, " (");
3193 for (i
= 0; i
< type
->num_fields (); ++i
)
3196 fprintf_filtered (stream
, "; ");
3197 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3200 fprintf_filtered (stream
, ")");
3202 if (TYPE_TARGET_TYPE (type
) != NULL
3203 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3205 fprintf_filtered (stream
, " return ");
3206 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3210 /* Read and validate a set of numeric choices from the user in the
3211 range 0 .. N_CHOICES-1. Place the results in increasing
3212 order in CHOICES[0 .. N-1], and return N.
3214 The user types choices as a sequence of numbers on one line
3215 separated by blanks, encoding them as follows:
3217 + A choice of 0 means to cancel the selection, throwing an error.
3218 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3219 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3221 The user is not allowed to choose more than MAX_RESULTS values.
3223 ANNOTATION_SUFFIX, if present, is used to annotate the input
3224 prompts (for use with the -f switch). */
3227 get_selections (int *choices
, int n_choices
, int max_results
,
3228 int is_all_choice
, const char *annotation_suffix
)
3233 int first_choice
= is_all_choice
? 2 : 1;
3235 prompt
= getenv ("PS2");
3239 args
= command_line_input (prompt
, annotation_suffix
);
3242 error_no_arg (_("one or more choice numbers"));
3246 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3247 order, as given in args. Choices are validated. */
3253 args
= skip_spaces (args
);
3254 if (*args
== '\0' && n_chosen
== 0)
3255 error_no_arg (_("one or more choice numbers"));
3256 else if (*args
== '\0')
3259 choice
= strtol (args
, &args2
, 10);
3260 if (args
== args2
|| choice
< 0
3261 || choice
> n_choices
+ first_choice
- 1)
3262 error (_("Argument must be choice number"));
3266 error (_("cancelled"));
3268 if (choice
< first_choice
)
3270 n_chosen
= n_choices
;
3271 for (j
= 0; j
< n_choices
; j
+= 1)
3275 choice
-= first_choice
;
3277 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3281 if (j
< 0 || choice
!= choices
[j
])
3285 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3286 choices
[k
+ 1] = choices
[k
];
3287 choices
[j
+ 1] = choice
;
3292 if (n_chosen
> max_results
)
3293 error (_("Select no more than %d of the above"), max_results
);
3298 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3299 by asking the user (if necessary), returning the number selected,
3300 and setting the first elements of SYMS items. Error if no symbols
3303 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3304 to be re-integrated one of these days. */
3307 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3310 int *chosen
= XALLOCAVEC (int , nsyms
);
3312 int first_choice
= (max_results
== 1) ? 1 : 2;
3313 const char *select_mode
= multiple_symbols_select_mode ();
3315 if (max_results
< 1)
3316 error (_("Request to select 0 symbols!"));
3320 if (select_mode
== multiple_symbols_cancel
)
3322 canceled because the command is ambiguous\n\
3323 See set/show multiple-symbol."));
3325 /* If select_mode is "all", then return all possible symbols.
3326 Only do that if more than one symbol can be selected, of course.
3327 Otherwise, display the menu as usual. */
3328 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3331 printf_filtered (_("[0] cancel\n"));
3332 if (max_results
> 1)
3333 printf_filtered (_("[1] all\n"));
3335 sort_choices (syms
, nsyms
);
3337 for (i
= 0; i
< nsyms
; i
+= 1)
3339 if (syms
[i
].symbol
== NULL
)
3342 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3344 struct symtab_and_line sal
=
3345 find_function_start_sal (syms
[i
].symbol
, 1);
3347 printf_filtered ("[%d] ", i
+ first_choice
);
3348 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3349 &type_print_raw_options
);
3350 if (sal
.symtab
== NULL
)
3351 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3352 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3356 styled_string (file_name_style
.style (),
3357 symtab_to_filename_for_display (sal
.symtab
)),
3364 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3365 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3366 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3367 struct symtab
*symtab
= NULL
;
3369 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3370 symtab
= symbol_symtab (syms
[i
].symbol
);
3372 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3374 printf_filtered ("[%d] ", i
+ first_choice
);
3375 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3376 &type_print_raw_options
);
3377 printf_filtered (_(" at %s:%d\n"),
3378 symtab_to_filename_for_display (symtab
),
3379 SYMBOL_LINE (syms
[i
].symbol
));
3381 else if (is_enumeral
3382 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3384 printf_filtered (("[%d] "), i
+ first_choice
);
3385 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3386 gdb_stdout
, -1, 0, &type_print_raw_options
);
3387 printf_filtered (_("'(%s) (enumeral)\n"),
3388 syms
[i
].symbol
->print_name ());
3392 printf_filtered ("[%d] ", i
+ first_choice
);
3393 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3394 &type_print_raw_options
);
3397 printf_filtered (is_enumeral
3398 ? _(" in %s (enumeral)\n")
3400 symtab_to_filename_for_display (symtab
));
3402 printf_filtered (is_enumeral
3403 ? _(" (enumeral)\n")
3409 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3412 for (i
= 0; i
< n_chosen
; i
+= 1)
3413 syms
[i
] = syms
[chosen
[i
]];
3418 /* Resolve the operator of the subexpression beginning at
3419 position *POS of *EXPP. "Resolving" consists of replacing
3420 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3421 with their resolutions, replacing built-in operators with
3422 function calls to user-defined operators, where appropriate, and,
3423 when DEPROCEDURE_P is non-zero, converting function-valued variables
3424 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3425 are as in ada_resolve, above. */
3427 static struct value
*
3428 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3429 struct type
*context_type
, int parse_completion
,
3430 innermost_block_tracker
*tracker
)
3434 struct expression
*exp
; /* Convenience: == *expp. */
3435 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3436 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3437 int nargs
; /* Number of operands. */
3439 /* If we're resolving an expression like ARRAY(ARG...), then we set
3440 this to the type of the array, so we can use the index types as
3441 the expected types for resolution. */
3442 struct type
*array_type
= nullptr;
3443 /* The arity of ARRAY_TYPE. */
3444 int array_arity
= 0;
3450 /* Pass one: resolve operands, saving their types and updating *pos,
3455 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3456 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3461 struct value
*lhs
= resolve_subexp (expp
, pos
, 0, NULL
,
3462 parse_completion
, tracker
);
3463 struct type
*lhstype
= ada_check_typedef (value_type (lhs
));
3464 array_arity
= ada_array_arity (lhstype
);
3465 if (array_arity
> 0)
3466 array_type
= lhstype
;
3468 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3473 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3478 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3479 parse_completion
, tracker
);
3482 case OP_ATR_MODULUS
:
3492 case TERNOP_IN_RANGE
:
3493 case BINOP_IN_BOUNDS
:
3499 case OP_DISCRETE_RANGE
:
3501 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3510 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3512 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3514 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3532 case BINOP_LOGICAL_AND
:
3533 case BINOP_LOGICAL_OR
:
3534 case BINOP_BITWISE_AND
:
3535 case BINOP_BITWISE_IOR
:
3536 case BINOP_BITWISE_XOR
:
3539 case BINOP_NOTEQUAL
:
3546 case BINOP_SUBSCRIPT
:
3554 case UNOP_LOGICAL_NOT
:
3564 case OP_VAR_MSYM_VALUE
:
3571 case OP_INTERNALVAR
:
3581 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3584 case STRUCTOP_STRUCT
:
3585 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3598 error (_("Unexpected operator during name resolution"));
3601 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3602 for (i
= 0; i
< nargs
; i
+= 1)
3604 struct type
*subtype
= nullptr;
3605 if (i
< array_arity
)
3606 subtype
= ada_index_type (array_type
, i
+ 1, "array type");
3607 argvec
[i
] = resolve_subexp (expp
, pos
, 1, subtype
, parse_completion
,
3613 /* Pass two: perform any resolution on principal operator. */
3620 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3622 std::vector
<struct block_symbol
> candidates
3623 = ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3624 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
);
3626 if (std::any_of (candidates
.begin (),
3628 [] (block_symbol
&sym
)
3630 switch (SYMBOL_CLASS (sym
.symbol
))
3635 case LOC_REGPARM_ADDR
:
3644 /* Types tend to get re-introduced locally, so if there
3645 are any local symbols that are not types, first filter
3649 (candidates
.begin (),
3651 [] (block_symbol
&sym
)
3653 return SYMBOL_CLASS (sym
.symbol
) == LOC_TYPEDEF
;
3658 if (candidates
.empty ())
3659 error (_("No definition found for %s"),
3660 exp
->elts
[pc
+ 2].symbol
->print_name ());
3661 else if (candidates
.size () == 1)
3663 else if (deprocedure_p
&& !is_nonfunction (candidates
))
3665 i
= ada_resolve_function
3666 (candidates
, NULL
, 0,
3667 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3668 context_type
, parse_completion
);
3670 error (_("Could not find a match for %s"),
3671 exp
->elts
[pc
+ 2].symbol
->print_name ());
3675 printf_filtered (_("Multiple matches for %s\n"),
3676 exp
->elts
[pc
+ 2].symbol
->print_name ());
3677 user_select_syms (candidates
.data (), candidates
.size (), 1);
3681 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3682 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3683 tracker
->update (candidates
[i
]);
3687 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3690 replace_operator_with_call (expp
, pc
, 0, 4,
3691 exp
->elts
[pc
+ 2].symbol
,
3692 exp
->elts
[pc
+ 1].block
);
3699 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3700 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3702 std::vector
<struct block_symbol
> candidates
3703 = ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3704 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
);
3706 if (candidates
.size () == 1)
3710 i
= ada_resolve_function
3713 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3714 context_type
, parse_completion
);
3716 error (_("Could not find a match for %s"),
3717 exp
->elts
[pc
+ 5].symbol
->print_name ());
3720 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3721 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3722 tracker
->update (candidates
[i
]);
3733 case BINOP_BITWISE_AND
:
3734 case BINOP_BITWISE_IOR
:
3735 case BINOP_BITWISE_XOR
:
3737 case BINOP_NOTEQUAL
:
3745 case UNOP_LOGICAL_NOT
:
3747 if (possible_user_operator_p (op
, argvec
))
3749 std::vector
<struct block_symbol
> candidates
3750 = ada_lookup_symbol_list (ada_decoded_op_name (op
),
3753 i
= ada_resolve_function (candidates
, argvec
,
3754 nargs
, ada_decoded_op_name (op
), NULL
,
3759 replace_operator_with_call (expp
, pc
, nargs
, 1,
3760 candidates
[i
].symbol
,
3761 candidates
[i
].block
);
3772 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3773 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3774 exp
->elts
[pc
+ 1].objfile
,
3775 exp
->elts
[pc
+ 2].msymbol
);
3777 return evaluate_subexp_type (exp
, pos
);
3780 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3781 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3783 /* The term "match" here is rather loose. The match is heuristic and
3787 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3789 ftype
= ada_check_typedef (ftype
);
3790 atype
= ada_check_typedef (atype
);
3792 if (ftype
->code () == TYPE_CODE_REF
)
3793 ftype
= TYPE_TARGET_TYPE (ftype
);
3794 if (atype
->code () == TYPE_CODE_REF
)
3795 atype
= TYPE_TARGET_TYPE (atype
);
3797 switch (ftype
->code ())
3800 return ftype
->code () == atype
->code ();
3802 if (atype
->code () == TYPE_CODE_PTR
)
3803 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3804 TYPE_TARGET_TYPE (atype
), 0);
3807 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3809 case TYPE_CODE_ENUM
:
3810 case TYPE_CODE_RANGE
:
3811 switch (atype
->code ())
3814 case TYPE_CODE_ENUM
:
3815 case TYPE_CODE_RANGE
:
3821 case TYPE_CODE_ARRAY
:
3822 return (atype
->code () == TYPE_CODE_ARRAY
3823 || ada_is_array_descriptor_type (atype
));
3825 case TYPE_CODE_STRUCT
:
3826 if (ada_is_array_descriptor_type (ftype
))
3827 return (atype
->code () == TYPE_CODE_ARRAY
3828 || ada_is_array_descriptor_type (atype
));
3830 return (atype
->code () == TYPE_CODE_STRUCT
3831 && !ada_is_array_descriptor_type (atype
));
3833 case TYPE_CODE_UNION
:
3835 return (atype
->code () == ftype
->code ());
3839 /* Return non-zero if the formals of FUNC "sufficiently match" the
3840 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3841 may also be an enumeral, in which case it is treated as a 0-
3842 argument function. */
3845 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3848 struct type
*func_type
= SYMBOL_TYPE (func
);
3850 if (SYMBOL_CLASS (func
) == LOC_CONST
3851 && func_type
->code () == TYPE_CODE_ENUM
)
3852 return (n_actuals
== 0);
3853 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3856 if (func_type
->num_fields () != n_actuals
)
3859 for (i
= 0; i
< n_actuals
; i
+= 1)
3861 if (actuals
[i
] == NULL
)
3865 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3866 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3868 if (!ada_type_match (ftype
, atype
, 1))
3875 /* False iff function type FUNC_TYPE definitely does not produce a value
3876 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3877 FUNC_TYPE is not a valid function type with a non-null return type
3878 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3881 return_match (struct type
*func_type
, struct type
*context_type
)
3883 struct type
*return_type
;
3885 if (func_type
== NULL
)
3888 if (func_type
->code () == TYPE_CODE_FUNC
)
3889 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3891 return_type
= get_base_type (func_type
);
3892 if (return_type
== NULL
)
3895 context_type
= get_base_type (context_type
);
3897 if (return_type
->code () == TYPE_CODE_ENUM
)
3898 return context_type
== NULL
|| return_type
== context_type
;
3899 else if (context_type
== NULL
)
3900 return return_type
->code () != TYPE_CODE_VOID
;
3902 return return_type
->code () == context_type
->code ();
3906 /* Returns the index in SYMS that contains the symbol for the
3907 function (if any) that matches the types of the NARGS arguments in
3908 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3909 that returns that type, then eliminate matches that don't. If
3910 CONTEXT_TYPE is void and there is at least one match that does not
3911 return void, eliminate all matches that do.
3913 Asks the user if there is more than one match remaining. Returns -1
3914 if there is no such symbol or none is selected. NAME is used
3915 solely for messages. May re-arrange and modify SYMS in
3916 the process; the index returned is for the modified vector. */
3919 ada_resolve_function (std::vector
<struct block_symbol
> &syms
,
3920 struct value
**args
, int nargs
,
3921 const char *name
, struct type
*context_type
,
3922 int parse_completion
)
3926 int m
; /* Number of hits */
3929 /* In the first pass of the loop, we only accept functions matching
3930 context_type. If none are found, we add a second pass of the loop
3931 where every function is accepted. */
3932 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3934 for (k
= 0; k
< syms
.size (); k
+= 1)
3936 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3938 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3939 && (fallback
|| return_match (type
, context_type
)))
3947 /* If we got multiple matches, ask the user which one to use. Don't do this
3948 interactive thing during completion, though, as the purpose of the
3949 completion is providing a list of all possible matches. Prompting the
3950 user to filter it down would be completely unexpected in this case. */
3953 else if (m
> 1 && !parse_completion
)
3955 printf_filtered (_("Multiple matches for %s\n"), name
);
3956 user_select_syms (syms
.data (), m
, 1);
3962 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3963 on the function identified by SYM and BLOCK, and taking NARGS
3964 arguments. Update *EXPP as needed to hold more space. */
3967 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
3968 int oplen
, struct symbol
*sym
,
3969 const struct block
*block
)
3971 /* We want to add 6 more elements (3 for funcall, 4 for function
3972 symbol, -OPLEN for operator being replaced) to the
3974 struct expression
*exp
= expp
->get ();
3975 int save_nelts
= exp
->nelts
;
3976 int extra_elts
= 7 - oplen
;
3977 exp
->nelts
+= extra_elts
;
3980 exp
->resize (exp
->nelts
);
3981 memmove (exp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3982 EXP_ELEM_TO_BYTES (save_nelts
- pc
- oplen
));
3984 exp
->resize (exp
->nelts
);
3986 exp
->elts
[pc
].opcode
= exp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3987 exp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3989 exp
->elts
[pc
+ 3].opcode
= exp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3990 exp
->elts
[pc
+ 4].block
= block
;
3991 exp
->elts
[pc
+ 5].symbol
= sym
;
3994 /* Type-class predicates */
3996 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4000 numeric_type_p (struct type
*type
)
4006 switch (type
->code ())
4011 case TYPE_CODE_RANGE
:
4012 return (type
== TYPE_TARGET_TYPE (type
)
4013 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4020 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4023 integer_type_p (struct type
*type
)
4029 switch (type
->code ())
4033 case TYPE_CODE_RANGE
:
4034 return (type
== TYPE_TARGET_TYPE (type
)
4035 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4042 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4045 scalar_type_p (struct type
*type
)
4051 switch (type
->code ())
4054 case TYPE_CODE_RANGE
:
4055 case TYPE_CODE_ENUM
:
4064 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4067 discrete_type_p (struct type
*type
)
4073 switch (type
->code ())
4076 case TYPE_CODE_RANGE
:
4077 case TYPE_CODE_ENUM
:
4078 case TYPE_CODE_BOOL
:
4086 /* Returns non-zero if OP with operands in the vector ARGS could be
4087 a user-defined function. Errs on the side of pre-defined operators
4088 (i.e., result 0). */
4091 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4093 struct type
*type0
=
4094 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4095 struct type
*type1
=
4096 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4110 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4114 case BINOP_BITWISE_AND
:
4115 case BINOP_BITWISE_IOR
:
4116 case BINOP_BITWISE_XOR
:
4117 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4120 case BINOP_NOTEQUAL
:
4125 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4128 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4131 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4135 case UNOP_LOGICAL_NOT
:
4137 return (!numeric_type_p (type0
));
4146 1. In the following, we assume that a renaming type's name may
4147 have an ___XD suffix. It would be nice if this went away at some
4149 2. We handle both the (old) purely type-based representation of
4150 renamings and the (new) variable-based encoding. At some point,
4151 it is devoutly to be hoped that the former goes away
4152 (FIXME: hilfinger-2007-07-09).
4153 3. Subprogram renamings are not implemented, although the XRS
4154 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4156 /* If SYM encodes a renaming,
4158 <renaming> renames <renamed entity>,
4160 sets *LEN to the length of the renamed entity's name,
4161 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4162 the string describing the subcomponent selected from the renamed
4163 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4164 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4165 are undefined). Otherwise, returns a value indicating the category
4166 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4167 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4168 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4169 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4170 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4171 may be NULL, in which case they are not assigned.
4173 [Currently, however, GCC does not generate subprogram renamings.] */
4175 enum ada_renaming_category
4176 ada_parse_renaming (struct symbol
*sym
,
4177 const char **renamed_entity
, int *len
,
4178 const char **renaming_expr
)
4180 enum ada_renaming_category kind
;
4185 return ADA_NOT_RENAMING
;
4186 switch (SYMBOL_CLASS (sym
))
4189 return ADA_NOT_RENAMING
;
4193 case LOC_OPTIMIZED_OUT
:
4194 info
= strstr (sym
->linkage_name (), "___XR");
4196 return ADA_NOT_RENAMING
;
4200 kind
= ADA_OBJECT_RENAMING
;
4204 kind
= ADA_EXCEPTION_RENAMING
;
4208 kind
= ADA_PACKAGE_RENAMING
;
4212 kind
= ADA_SUBPROGRAM_RENAMING
;
4216 return ADA_NOT_RENAMING
;
4220 if (renamed_entity
!= NULL
)
4221 *renamed_entity
= info
;
4222 suffix
= strstr (info
, "___XE");
4223 if (suffix
== NULL
|| suffix
== info
)
4224 return ADA_NOT_RENAMING
;
4226 *len
= strlen (info
) - strlen (suffix
);
4228 if (renaming_expr
!= NULL
)
4229 *renaming_expr
= suffix
;
4233 /* Compute the value of the given RENAMING_SYM, which is expected to
4234 be a symbol encoding a renaming expression. BLOCK is the block
4235 used to evaluate the renaming. */
4237 static struct value
*
4238 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4239 const struct block
*block
)
4241 const char *sym_name
;
4243 sym_name
= renaming_sym
->linkage_name ();
4244 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4245 return evaluate_expression (expr
.get ());
4249 /* Evaluation: Function Calls */
4251 /* Return an lvalue containing the value VAL. This is the identity on
4252 lvalues, and otherwise has the side-effect of allocating memory
4253 in the inferior where a copy of the value contents is copied. */
4255 static struct value
*
4256 ensure_lval (struct value
*val
)
4258 if (VALUE_LVAL (val
) == not_lval
4259 || VALUE_LVAL (val
) == lval_internalvar
)
4261 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4262 const CORE_ADDR addr
=
4263 value_as_long (value_allocate_space_in_inferior (len
));
4265 VALUE_LVAL (val
) = lval_memory
;
4266 set_value_address (val
, addr
);
4267 write_memory (addr
, value_contents (val
), len
);
4273 /* Given ARG, a value of type (pointer or reference to a)*
4274 structure/union, extract the component named NAME from the ultimate
4275 target structure/union and return it as a value with its
4278 The routine searches for NAME among all members of the structure itself
4279 and (recursively) among all members of any wrapper members
4282 If NO_ERR, then simply return NULL in case of error, rather than
4285 static struct value
*
4286 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4288 struct type
*t
, *t1
;
4293 t1
= t
= ada_check_typedef (value_type (arg
));
4294 if (t
->code () == TYPE_CODE_REF
)
4296 t1
= TYPE_TARGET_TYPE (t
);
4299 t1
= ada_check_typedef (t1
);
4300 if (t1
->code () == TYPE_CODE_PTR
)
4302 arg
= coerce_ref (arg
);
4307 while (t
->code () == TYPE_CODE_PTR
)
4309 t1
= TYPE_TARGET_TYPE (t
);
4312 t1
= ada_check_typedef (t1
);
4313 if (t1
->code () == TYPE_CODE_PTR
)
4315 arg
= value_ind (arg
);
4322 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4326 v
= ada_search_struct_field (name
, arg
, 0, t
);
4329 int bit_offset
, bit_size
, byte_offset
;
4330 struct type
*field_type
;
4333 if (t
->code () == TYPE_CODE_PTR
)
4334 address
= value_address (ada_value_ind (arg
));
4336 address
= value_address (ada_coerce_ref (arg
));
4338 /* Check to see if this is a tagged type. We also need to handle
4339 the case where the type is a reference to a tagged type, but
4340 we have to be careful to exclude pointers to tagged types.
4341 The latter should be shown as usual (as a pointer), whereas
4342 a reference should mostly be transparent to the user. */
4344 if (ada_is_tagged_type (t1
, 0)
4345 || (t1
->code () == TYPE_CODE_REF
4346 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4348 /* We first try to find the searched field in the current type.
4349 If not found then let's look in the fixed type. */
4351 if (!find_struct_field (name
, t1
, 0,
4352 &field_type
, &byte_offset
, &bit_offset
,
4361 /* Convert to fixed type in all cases, so that we have proper
4362 offsets to each field in unconstrained record types. */
4363 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4364 address
, NULL
, check_tag
);
4366 /* Resolve the dynamic type as well. */
4367 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4368 t1
= value_type (arg
);
4370 if (find_struct_field (name
, t1
, 0,
4371 &field_type
, &byte_offset
, &bit_offset
,
4376 if (t
->code () == TYPE_CODE_REF
)
4377 arg
= ada_coerce_ref (arg
);
4379 arg
= ada_value_ind (arg
);
4380 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4381 bit_offset
, bit_size
,
4385 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4389 if (v
!= NULL
|| no_err
)
4392 error (_("There is no member named %s."), name
);
4398 error (_("Attempt to extract a component of "
4399 "a value that is not a record."));
4402 /* Return the value ACTUAL, converted to be an appropriate value for a
4403 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4404 allocating any necessary descriptors (fat pointers), or copies of
4405 values not residing in memory, updating it as needed. */
4408 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4410 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4411 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4412 struct type
*formal_target
=
4413 formal_type
->code () == TYPE_CODE_PTR
4414 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4415 struct type
*actual_target
=
4416 actual_type
->code () == TYPE_CODE_PTR
4417 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4419 if (ada_is_array_descriptor_type (formal_target
)
4420 && actual_target
->code () == TYPE_CODE_ARRAY
)
4421 return make_array_descriptor (formal_type
, actual
);
4422 else if (formal_type
->code () == TYPE_CODE_PTR
4423 || formal_type
->code () == TYPE_CODE_REF
)
4425 struct value
*result
;
4427 if (formal_target
->code () == TYPE_CODE_ARRAY
4428 && ada_is_array_descriptor_type (actual_target
))
4429 result
= desc_data (actual
);
4430 else if (formal_type
->code () != TYPE_CODE_PTR
)
4432 if (VALUE_LVAL (actual
) != lval_memory
)
4436 actual_type
= ada_check_typedef (value_type (actual
));
4437 val
= allocate_value (actual_type
);
4438 memcpy ((char *) value_contents_raw (val
),
4439 (char *) value_contents (actual
),
4440 TYPE_LENGTH (actual_type
));
4441 actual
= ensure_lval (val
);
4443 result
= value_addr (actual
);
4447 return value_cast_pointers (formal_type
, result
, 0);
4449 else if (actual_type
->code () == TYPE_CODE_PTR
)
4450 return ada_value_ind (actual
);
4451 else if (ada_is_aligner_type (formal_type
))
4453 /* We need to turn this parameter into an aligner type
4455 struct value
*aligner
= allocate_value (formal_type
);
4456 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4458 value_assign_to_component (aligner
, component
, actual
);
4465 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4466 type TYPE. This is usually an inefficient no-op except on some targets
4467 (such as AVR) where the representation of a pointer and an address
4471 value_pointer (struct value
*value
, struct type
*type
)
4473 unsigned len
= TYPE_LENGTH (type
);
4474 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4477 addr
= value_address (value
);
4478 gdbarch_address_to_pointer (type
->arch (), type
, buf
, addr
);
4479 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4484 /* Push a descriptor of type TYPE for array value ARR on the stack at
4485 *SP, updating *SP to reflect the new descriptor. Return either
4486 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4487 to-descriptor type rather than a descriptor type), a struct value *
4488 representing a pointer to this descriptor. */
4490 static struct value
*
4491 make_array_descriptor (struct type
*type
, struct value
*arr
)
4493 struct type
*bounds_type
= desc_bounds_type (type
);
4494 struct type
*desc_type
= desc_base_type (type
);
4495 struct value
*descriptor
= allocate_value (desc_type
);
4496 struct value
*bounds
= allocate_value (bounds_type
);
4499 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4502 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4503 ada_array_bound (arr
, i
, 0),
4504 desc_bound_bitpos (bounds_type
, i
, 0),
4505 desc_bound_bitsize (bounds_type
, i
, 0));
4506 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4507 ada_array_bound (arr
, i
, 1),
4508 desc_bound_bitpos (bounds_type
, i
, 1),
4509 desc_bound_bitsize (bounds_type
, i
, 1));
4512 bounds
= ensure_lval (bounds
);
4514 modify_field (value_type (descriptor
),
4515 value_contents_writeable (descriptor
),
4516 value_pointer (ensure_lval (arr
),
4517 desc_type
->field (0).type ()),
4518 fat_pntr_data_bitpos (desc_type
),
4519 fat_pntr_data_bitsize (desc_type
));
4521 modify_field (value_type (descriptor
),
4522 value_contents_writeable (descriptor
),
4523 value_pointer (bounds
,
4524 desc_type
->field (1).type ()),
4525 fat_pntr_bounds_bitpos (desc_type
),
4526 fat_pntr_bounds_bitsize (desc_type
));
4528 descriptor
= ensure_lval (descriptor
);
4530 if (type
->code () == TYPE_CODE_PTR
)
4531 return value_addr (descriptor
);
4536 /* Symbol Cache Module */
4538 /* Performance measurements made as of 2010-01-15 indicate that
4539 this cache does bring some noticeable improvements. Depending
4540 on the type of entity being printed, the cache can make it as much
4541 as an order of magnitude faster than without it.
4543 The descriptive type DWARF extension has significantly reduced
4544 the need for this cache, at least when DWARF is being used. However,
4545 even in this case, some expensive name-based symbol searches are still
4546 sometimes necessary - to find an XVZ variable, mostly. */
4548 /* Return the symbol cache associated to the given program space PSPACE.
4549 If not allocated for this PSPACE yet, allocate and initialize one. */
4551 static struct ada_symbol_cache
*
4552 ada_get_symbol_cache (struct program_space
*pspace
)
4554 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4556 if (pspace_data
->sym_cache
== nullptr)
4557 pspace_data
->sym_cache
.reset (new ada_symbol_cache
);
4559 return pspace_data
->sym_cache
.get ();
4562 /* Clear all entries from the symbol cache. */
4565 ada_clear_symbol_cache ()
4567 struct ada_pspace_data
*pspace_data
4568 = get_ada_pspace_data (current_program_space
);
4570 if (pspace_data
->sym_cache
!= nullptr)
4571 pspace_data
->sym_cache
.reset ();
4574 /* Search our cache for an entry matching NAME and DOMAIN.
4575 Return it if found, or NULL otherwise. */
4577 static struct cache_entry
**
4578 find_entry (const char *name
, domain_enum domain
)
4580 struct ada_symbol_cache
*sym_cache
4581 = ada_get_symbol_cache (current_program_space
);
4582 int h
= msymbol_hash (name
) % HASH_SIZE
;
4583 struct cache_entry
**e
;
4585 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4587 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4593 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4594 Return 1 if found, 0 otherwise.
4596 If an entry was found and SYM is not NULL, set *SYM to the entry's
4597 SYM. Same principle for BLOCK if not NULL. */
4600 lookup_cached_symbol (const char *name
, domain_enum domain
,
4601 struct symbol
**sym
, const struct block
**block
)
4603 struct cache_entry
**e
= find_entry (name
, domain
);
4610 *block
= (*e
)->block
;
4614 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4615 in domain DOMAIN, save this result in our symbol cache. */
4618 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4619 const struct block
*block
)
4621 struct ada_symbol_cache
*sym_cache
4622 = ada_get_symbol_cache (current_program_space
);
4624 struct cache_entry
*e
;
4626 /* Symbols for builtin types don't have a block.
4627 For now don't cache such symbols. */
4628 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4631 /* If the symbol is a local symbol, then do not cache it, as a search
4632 for that symbol depends on the context. To determine whether
4633 the symbol is local or not, we check the block where we found it
4634 against the global and static blocks of its associated symtab. */
4636 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4637 GLOBAL_BLOCK
) != block
4638 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4639 STATIC_BLOCK
) != block
)
4642 h
= msymbol_hash (name
) % HASH_SIZE
;
4643 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4644 e
->next
= sym_cache
->root
[h
];
4645 sym_cache
->root
[h
] = e
;
4646 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4654 /* Return the symbol name match type that should be used used when
4655 searching for all symbols matching LOOKUP_NAME.
4657 LOOKUP_NAME is expected to be a symbol name after transformation
4660 static symbol_name_match_type
4661 name_match_type_from_name (const char *lookup_name
)
4663 return (strstr (lookup_name
, "__") == NULL
4664 ? symbol_name_match_type::WILD
4665 : symbol_name_match_type::FULL
);
4668 /* Return the result of a standard (literal, C-like) lookup of NAME in
4669 given DOMAIN, visible from lexical block BLOCK. */
4671 static struct symbol
*
4672 standard_lookup (const char *name
, const struct block
*block
,
4675 /* Initialize it just to avoid a GCC false warning. */
4676 struct block_symbol sym
= {};
4678 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4680 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4681 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4686 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4687 in the symbol fields of SYMS. We treat enumerals as functions,
4688 since they contend in overloading in the same way. */
4690 is_nonfunction (const std::vector
<struct block_symbol
> &syms
)
4692 for (const block_symbol
&sym
: syms
)
4693 if (SYMBOL_TYPE (sym
.symbol
)->code () != TYPE_CODE_FUNC
4694 && (SYMBOL_TYPE (sym
.symbol
)->code () != TYPE_CODE_ENUM
4695 || SYMBOL_CLASS (sym
.symbol
) != LOC_CONST
))
4701 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4702 struct types. Otherwise, they may not. */
4705 equiv_types (struct type
*type0
, struct type
*type1
)
4709 if (type0
== NULL
|| type1
== NULL
4710 || type0
->code () != type1
->code ())
4712 if ((type0
->code () == TYPE_CODE_STRUCT
4713 || type0
->code () == TYPE_CODE_ENUM
)
4714 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4715 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4721 /* True iff SYM0 represents the same entity as SYM1, or one that is
4722 no more defined than that of SYM1. */
4725 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4729 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4730 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4733 switch (SYMBOL_CLASS (sym0
))
4739 struct type
*type0
= SYMBOL_TYPE (sym0
);
4740 struct type
*type1
= SYMBOL_TYPE (sym1
);
4741 const char *name0
= sym0
->linkage_name ();
4742 const char *name1
= sym1
->linkage_name ();
4743 int len0
= strlen (name0
);
4746 type0
->code () == type1
->code ()
4747 && (equiv_types (type0
, type1
)
4748 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4749 && startswith (name1
+ len0
, "___XV")));
4752 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4753 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4757 const char *name0
= sym0
->linkage_name ();
4758 const char *name1
= sym1
->linkage_name ();
4759 return (strcmp (name0
, name1
) == 0
4760 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4768 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4769 records in RESULT. Do nothing if SYM is a duplicate. */
4772 add_defn_to_vec (std::vector
<struct block_symbol
> &result
,
4774 const struct block
*block
)
4776 /* Do not try to complete stub types, as the debugger is probably
4777 already scanning all symbols matching a certain name at the
4778 time when this function is called. Trying to replace the stub
4779 type by its associated full type will cause us to restart a scan
4780 which may lead to an infinite recursion. Instead, the client
4781 collecting the matching symbols will end up collecting several
4782 matches, with at least one of them complete. It can then filter
4783 out the stub ones if needed. */
4785 for (int i
= result
.size () - 1; i
>= 0; i
-= 1)
4787 if (lesseq_defined_than (sym
, result
[i
].symbol
))
4789 else if (lesseq_defined_than (result
[i
].symbol
, sym
))
4791 result
[i
].symbol
= sym
;
4792 result
[i
].block
= block
;
4797 struct block_symbol info
;
4800 result
.push_back (info
);
4803 /* Return a bound minimal symbol matching NAME according to Ada
4804 decoding rules. Returns an invalid symbol if there is no such
4805 minimal symbol. Names prefixed with "standard__" are handled
4806 specially: "standard__" is first stripped off, and only static and
4807 global symbols are searched. */
4809 struct bound_minimal_symbol
4810 ada_lookup_simple_minsym (const char *name
)
4812 struct bound_minimal_symbol result
;
4814 memset (&result
, 0, sizeof (result
));
4816 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4817 lookup_name_info
lookup_name (name
, match_type
);
4819 symbol_name_matcher_ftype
*match_name
4820 = ada_get_symbol_name_matcher (lookup_name
);
4822 for (objfile
*objfile
: current_program_space
->objfiles ())
4824 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4826 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4827 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4829 result
.minsym
= msymbol
;
4830 result
.objfile
= objfile
;
4839 /* For all subprograms that statically enclose the subprogram of the
4840 selected frame, add symbols matching identifier NAME in DOMAIN
4841 and their blocks to the list of data in RESULT, as for
4842 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4843 with a wildcard prefix. */
4846 add_symbols_from_enclosing_procs (std::vector
<struct block_symbol
> &result
,
4847 const lookup_name_info
&lookup_name
,
4852 /* True if TYPE is definitely an artificial type supplied to a symbol
4853 for which no debugging information was given in the symbol file. */
4856 is_nondebugging_type (struct type
*type
)
4858 const char *name
= ada_type_name (type
);
4860 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4863 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4864 that are deemed "identical" for practical purposes.
4866 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4867 types and that their number of enumerals is identical (in other
4868 words, type1->num_fields () == type2->num_fields ()). */
4871 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4875 /* The heuristic we use here is fairly conservative. We consider
4876 that 2 enumerate types are identical if they have the same
4877 number of enumerals and that all enumerals have the same
4878 underlying value and name. */
4880 /* All enums in the type should have an identical underlying value. */
4881 for (i
= 0; i
< type1
->num_fields (); i
++)
4882 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4885 /* All enumerals should also have the same name (modulo any numerical
4887 for (i
= 0; i
< type1
->num_fields (); i
++)
4889 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4890 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4891 int len_1
= strlen (name_1
);
4892 int len_2
= strlen (name_2
);
4894 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4895 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4897 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4898 TYPE_FIELD_NAME (type2
, i
),
4906 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4907 that are deemed "identical" for practical purposes. Sometimes,
4908 enumerals are not strictly identical, but their types are so similar
4909 that they can be considered identical.
4911 For instance, consider the following code:
4913 type Color is (Black, Red, Green, Blue, White);
4914 type RGB_Color is new Color range Red .. Blue;
4916 Type RGB_Color is a subrange of an implicit type which is a copy
4917 of type Color. If we call that implicit type RGB_ColorB ("B" is
4918 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4919 As a result, when an expression references any of the enumeral
4920 by name (Eg. "print green"), the expression is technically
4921 ambiguous and the user should be asked to disambiguate. But
4922 doing so would only hinder the user, since it wouldn't matter
4923 what choice he makes, the outcome would always be the same.
4924 So, for practical purposes, we consider them as the same. */
4927 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
4931 /* Before performing a thorough comparison check of each type,
4932 we perform a series of inexpensive checks. We expect that these
4933 checks will quickly fail in the vast majority of cases, and thus
4934 help prevent the unnecessary use of a more expensive comparison.
4935 Said comparison also expects us to make some of these checks
4936 (see ada_identical_enum_types_p). */
4938 /* Quick check: All symbols should have an enum type. */
4939 for (i
= 0; i
< syms
.size (); i
++)
4940 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
4943 /* Quick check: They should all have the same value. */
4944 for (i
= 1; i
< syms
.size (); i
++)
4945 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
4948 /* Quick check: They should all have the same number of enumerals. */
4949 for (i
= 1; i
< syms
.size (); i
++)
4950 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
4951 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
4954 /* All the sanity checks passed, so we might have a set of
4955 identical enumeration types. Perform a more complete
4956 comparison of the type of each symbol. */
4957 for (i
= 1; i
< syms
.size (); i
++)
4958 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
4959 SYMBOL_TYPE (syms
[0].symbol
)))
4965 /* Remove any non-debugging symbols in SYMS that definitely
4966 duplicate other symbols in the list (The only case I know of where
4967 this happens is when object files containing stabs-in-ecoff are
4968 linked with files containing ordinary ecoff debugging symbols (or no
4969 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
4972 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
4976 /* We should never be called with less than 2 symbols, as there
4977 cannot be any extra symbol in that case. But it's easy to
4978 handle, since we have nothing to do in that case. */
4979 if (syms
->size () < 2)
4983 while (i
< syms
->size ())
4987 /* If two symbols have the same name and one of them is a stub type,
4988 the get rid of the stub. */
4990 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
4991 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
4993 for (j
= 0; j
< syms
->size (); j
++)
4996 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
4997 && (*syms
)[j
].symbol
->linkage_name () != NULL
4998 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
4999 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5004 /* Two symbols with the same name, same class and same address
5005 should be identical. */
5007 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5008 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5009 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5011 for (j
= 0; j
< syms
->size (); j
+= 1)
5014 && (*syms
)[j
].symbol
->linkage_name () != NULL
5015 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5016 (*syms
)[j
].symbol
->linkage_name ()) == 0
5017 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5018 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5019 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5020 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5026 syms
->erase (syms
->begin () + i
);
5031 /* If all the remaining symbols are identical enumerals, then
5032 just keep the first one and discard the rest.
5034 Unlike what we did previously, we do not discard any entry
5035 unless they are ALL identical. This is because the symbol
5036 comparison is not a strict comparison, but rather a practical
5037 comparison. If all symbols are considered identical, then
5038 we can just go ahead and use the first one and discard the rest.
5039 But if we cannot reduce the list to a single element, we have
5040 to ask the user to disambiguate anyways. And if we have to
5041 present a multiple-choice menu, it's less confusing if the list
5042 isn't missing some choices that were identical and yet distinct. */
5043 if (symbols_are_identical_enums (*syms
))
5047 /* Given a type that corresponds to a renaming entity, use the type name
5048 to extract the scope (package name or function name, fully qualified,
5049 and following the GNAT encoding convention) where this renaming has been
5053 xget_renaming_scope (struct type
*renaming_type
)
5055 /* The renaming types adhere to the following convention:
5056 <scope>__<rename>___<XR extension>.
5057 So, to extract the scope, we search for the "___XR" extension,
5058 and then backtrack until we find the first "__". */
5060 const char *name
= renaming_type
->name ();
5061 const char *suffix
= strstr (name
, "___XR");
5064 /* Now, backtrack a bit until we find the first "__". Start looking
5065 at suffix - 3, as the <rename> part is at least one character long. */
5067 for (last
= suffix
- 3; last
> name
; last
--)
5068 if (last
[0] == '_' && last
[1] == '_')
5071 /* Make a copy of scope and return it. */
5072 return std::string (name
, last
);
5075 /* Return nonzero if NAME corresponds to a package name. */
5078 is_package_name (const char *name
)
5080 /* Here, We take advantage of the fact that no symbols are generated
5081 for packages, while symbols are generated for each function.
5082 So the condition for NAME represent a package becomes equivalent
5083 to NAME not existing in our list of symbols. There is only one
5084 small complication with library-level functions (see below). */
5086 /* If it is a function that has not been defined at library level,
5087 then we should be able to look it up in the symbols. */
5088 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5091 /* Library-level function names start with "_ada_". See if function
5092 "_ada_" followed by NAME can be found. */
5094 /* Do a quick check that NAME does not contain "__", since library-level
5095 functions names cannot contain "__" in them. */
5096 if (strstr (name
, "__") != NULL
)
5099 std::string fun_name
= string_printf ("_ada_%s", name
);
5101 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5104 /* Return nonzero if SYM corresponds to a renaming entity that is
5105 not visible from FUNCTION_NAME. */
5108 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5110 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5113 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5115 /* If the rename has been defined in a package, then it is visible. */
5116 if (is_package_name (scope
.c_str ()))
5119 /* Check that the rename is in the current function scope by checking
5120 that its name starts with SCOPE. */
5122 /* If the function name starts with "_ada_", it means that it is
5123 a library-level function. Strip this prefix before doing the
5124 comparison, as the encoding for the renaming does not contain
5126 if (startswith (function_name
, "_ada_"))
5129 return !startswith (function_name
, scope
.c_str ());
5132 /* Remove entries from SYMS that corresponds to a renaming entity that
5133 is not visible from the function associated with CURRENT_BLOCK or
5134 that is superfluous due to the presence of more specific renaming
5135 information. Places surviving symbols in the initial entries of
5139 First, in cases where an object renaming is implemented as a
5140 reference variable, GNAT may produce both the actual reference
5141 variable and the renaming encoding. In this case, we discard the
5144 Second, GNAT emits a type following a specified encoding for each renaming
5145 entity. Unfortunately, STABS currently does not support the definition
5146 of types that are local to a given lexical block, so all renamings types
5147 are emitted at library level. As a consequence, if an application
5148 contains two renaming entities using the same name, and a user tries to
5149 print the value of one of these entities, the result of the ada symbol
5150 lookup will also contain the wrong renaming type.
5152 This function partially covers for this limitation by attempting to
5153 remove from the SYMS list renaming symbols that should be visible
5154 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5155 method with the current information available. The implementation
5156 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5158 - When the user tries to print a rename in a function while there
5159 is another rename entity defined in a package: Normally, the
5160 rename in the function has precedence over the rename in the
5161 package, so the latter should be removed from the list. This is
5162 currently not the case.
5164 - This function will incorrectly remove valid renames if
5165 the CURRENT_BLOCK corresponds to a function which symbol name
5166 has been changed by an "Export" pragma. As a consequence,
5167 the user will be unable to print such rename entities. */
5170 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5171 const struct block
*current_block
)
5173 struct symbol
*current_function
;
5174 const char *current_function_name
;
5176 int is_new_style_renaming
;
5178 /* If there is both a renaming foo___XR... encoded as a variable and
5179 a simple variable foo in the same block, discard the latter.
5180 First, zero out such symbols, then compress. */
5181 is_new_style_renaming
= 0;
5182 for (i
= 0; i
< syms
->size (); i
+= 1)
5184 struct symbol
*sym
= (*syms
)[i
].symbol
;
5185 const struct block
*block
= (*syms
)[i
].block
;
5189 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5191 name
= sym
->linkage_name ();
5192 suffix
= strstr (name
, "___XR");
5196 int name_len
= suffix
- name
;
5199 is_new_style_renaming
= 1;
5200 for (j
= 0; j
< syms
->size (); j
+= 1)
5201 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5202 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5204 && block
== (*syms
)[j
].block
)
5205 (*syms
)[j
].symbol
= NULL
;
5208 if (is_new_style_renaming
)
5212 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5213 if ((*syms
)[j
].symbol
!= NULL
)
5215 (*syms
)[k
] = (*syms
)[j
];
5222 /* Extract the function name associated to CURRENT_BLOCK.
5223 Abort if unable to do so. */
5225 if (current_block
== NULL
)
5228 current_function
= block_linkage_function (current_block
);
5229 if (current_function
== NULL
)
5232 current_function_name
= current_function
->linkage_name ();
5233 if (current_function_name
== NULL
)
5236 /* Check each of the symbols, and remove it from the list if it is
5237 a type corresponding to a renaming that is out of the scope of
5238 the current block. */
5241 while (i
< syms
->size ())
5243 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5244 == ADA_OBJECT_RENAMING
5245 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5246 current_function_name
))
5247 syms
->erase (syms
->begin () + i
);
5253 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5254 whose name and domain match NAME and DOMAIN respectively.
5255 If no match was found, then extend the search to "enclosing"
5256 routines (in other words, if we're inside a nested function,
5257 search the symbols defined inside the enclosing functions).
5258 If WILD_MATCH_P is nonzero, perform the naming matching in
5259 "wild" mode (see function "wild_match" for more info).
5261 Note: This function assumes that RESULT has 0 (zero) element in it. */
5264 ada_add_local_symbols (std::vector
<struct block_symbol
> &result
,
5265 const lookup_name_info
&lookup_name
,
5266 const struct block
*block
, domain_enum domain
)
5268 int block_depth
= 0;
5270 while (block
!= NULL
)
5273 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5275 /* If we found a non-function match, assume that's the one. */
5276 if (is_nonfunction (result
))
5279 block
= BLOCK_SUPERBLOCK (block
);
5282 /* If no luck so far, try to find NAME as a local symbol in some lexically
5283 enclosing subprogram. */
5284 if (result
.empty () && block_depth
> 2)
5285 add_symbols_from_enclosing_procs (result
, lookup_name
, domain
);
5288 /* An object of this type is used as the user_data argument when
5289 calling the map_matching_symbols method. */
5293 explicit match_data (std::vector
<struct block_symbol
> *rp
)
5297 DISABLE_COPY_AND_ASSIGN (match_data
);
5299 struct objfile
*objfile
= nullptr;
5300 std::vector
<struct block_symbol
> *resultp
;
5301 struct symbol
*arg_sym
= nullptr;
5302 bool found_sym
= false;
5305 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5306 to a list of symbols. DATA is a pointer to a struct match_data *
5307 containing the vector that collects the symbol list, the file that SYM
5308 must come from, a flag indicating whether a non-argument symbol has
5309 been found in the current block, and the last argument symbol
5310 passed in SYM within the current block (if any). When SYM is null,
5311 marking the end of a block, the argument symbol is added if no
5312 other has been found. */
5315 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5316 struct match_data
*data
)
5318 const struct block
*block
= bsym
->block
;
5319 struct symbol
*sym
= bsym
->symbol
;
5323 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5324 add_defn_to_vec (*data
->resultp
,
5325 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5327 data
->found_sym
= false;
5328 data
->arg_sym
= NULL
;
5332 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5334 else if (SYMBOL_IS_ARGUMENT (sym
))
5335 data
->arg_sym
= sym
;
5338 data
->found_sym
= true;
5339 add_defn_to_vec (*data
->resultp
,
5340 fixup_symbol_section (sym
, data
->objfile
),
5347 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5348 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5349 symbols to RESULT. Return whether we found such symbols. */
5352 ada_add_block_renamings (std::vector
<struct block_symbol
> &result
,
5353 const struct block
*block
,
5354 const lookup_name_info
&lookup_name
,
5357 struct using_direct
*renaming
;
5358 int defns_mark
= result
.size ();
5360 symbol_name_matcher_ftype
*name_match
5361 = ada_get_symbol_name_matcher (lookup_name
);
5363 for (renaming
= block_using (block
);
5365 renaming
= renaming
->next
)
5369 /* Avoid infinite recursions: skip this renaming if we are actually
5370 already traversing it.
5372 Currently, symbol lookup in Ada don't use the namespace machinery from
5373 C++/Fortran support: skip namespace imports that use them. */
5374 if (renaming
->searched
5375 || (renaming
->import_src
!= NULL
5376 && renaming
->import_src
[0] != '\0')
5377 || (renaming
->import_dest
!= NULL
5378 && renaming
->import_dest
[0] != '\0'))
5380 renaming
->searched
= 1;
5382 /* TODO: here, we perform another name-based symbol lookup, which can
5383 pull its own multiple overloads. In theory, we should be able to do
5384 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5385 not a simple name. But in order to do this, we would need to enhance
5386 the DWARF reader to associate a symbol to this renaming, instead of a
5387 name. So, for now, we do something simpler: re-use the C++/Fortran
5388 namespace machinery. */
5389 r_name
= (renaming
->alias
!= NULL
5391 : renaming
->declaration
);
5392 if (name_match (r_name
, lookup_name
, NULL
))
5394 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5395 lookup_name
.match_type ());
5396 ada_add_all_symbols (result
, block
, decl_lookup_name
, domain
,
5399 renaming
->searched
= 0;
5401 return result
.size () != defns_mark
;
5404 /* Implements compare_names, but only applying the comparision using
5405 the given CASING. */
5408 compare_names_with_case (const char *string1
, const char *string2
,
5409 enum case_sensitivity casing
)
5411 while (*string1
!= '\0' && *string2
!= '\0')
5415 if (isspace (*string1
) || isspace (*string2
))
5416 return strcmp_iw_ordered (string1
, string2
);
5418 if (casing
== case_sensitive_off
)
5420 c1
= tolower (*string1
);
5421 c2
= tolower (*string2
);
5438 return strcmp_iw_ordered (string1
, string2
);
5440 if (*string2
== '\0')
5442 if (is_name_suffix (string1
))
5449 if (*string2
== '(')
5450 return strcmp_iw_ordered (string1
, string2
);
5453 if (casing
== case_sensitive_off
)
5454 return tolower (*string1
) - tolower (*string2
);
5456 return *string1
- *string2
;
5461 /* Compare STRING1 to STRING2, with results as for strcmp.
5462 Compatible with strcmp_iw_ordered in that...
5464 strcmp_iw_ordered (STRING1, STRING2) <= 0
5468 compare_names (STRING1, STRING2) <= 0
5470 (they may differ as to what symbols compare equal). */
5473 compare_names (const char *string1
, const char *string2
)
5477 /* Similar to what strcmp_iw_ordered does, we need to perform
5478 a case-insensitive comparison first, and only resort to
5479 a second, case-sensitive, comparison if the first one was
5480 not sufficient to differentiate the two strings. */
5482 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5484 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5489 /* Convenience function to get at the Ada encoded lookup name for
5490 LOOKUP_NAME, as a C string. */
5493 ada_lookup_name (const lookup_name_info
&lookup_name
)
5495 return lookup_name
.ada ().lookup_name ().c_str ();
5498 /* Add to RESULT all non-local symbols whose name and domain match
5499 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5500 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5501 symbols otherwise. */
5504 add_nonlocal_symbols (std::vector
<struct block_symbol
> &result
,
5505 const lookup_name_info
&lookup_name
,
5506 domain_enum domain
, int global
)
5508 struct match_data
data (&result
);
5510 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5512 auto callback
= [&] (struct block_symbol
*bsym
)
5514 return aux_add_nonlocal_symbols (bsym
, &data
);
5517 for (objfile
*objfile
: current_program_space
->objfiles ())
5519 data
.objfile
= objfile
;
5521 if (objfile
->sf
!= nullptr)
5522 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5523 domain
, global
, callback
,
5525 ? NULL
: compare_names
));
5527 for (compunit_symtab
*cu
: objfile
->compunits ())
5529 const struct block
*global_block
5530 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5532 if (ada_add_block_renamings (result
, global_block
, lookup_name
,
5534 data
.found_sym
= true;
5538 if (result
.empty () && global
&& !is_wild_match
)
5540 const char *name
= ada_lookup_name (lookup_name
);
5541 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5542 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5544 for (objfile
*objfile
: current_program_space
->objfiles ())
5546 data
.objfile
= objfile
;
5547 if (objfile
->sf
!= nullptr)
5548 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5549 domain
, global
, callback
,
5555 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5556 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5557 returning the number of matches. Add these to RESULT.
5559 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5560 symbol match within the nest of blocks whose innermost member is BLOCK,
5561 is the one match returned (no other matches in that or
5562 enclosing blocks is returned). If there are any matches in or
5563 surrounding BLOCK, then these alone are returned.
5565 Names prefixed with "standard__" are handled specially:
5566 "standard__" is first stripped off (by the lookup_name
5567 constructor), and only static and global symbols are searched.
5569 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5570 to lookup global symbols. */
5573 ada_add_all_symbols (std::vector
<struct block_symbol
> &result
,
5574 const struct block
*block
,
5575 const lookup_name_info
&lookup_name
,
5578 int *made_global_lookup_p
)
5582 if (made_global_lookup_p
)
5583 *made_global_lookup_p
= 0;
5585 /* Special case: If the user specifies a symbol name inside package
5586 Standard, do a non-wild matching of the symbol name without
5587 the "standard__" prefix. This was primarily introduced in order
5588 to allow the user to specifically access the standard exceptions
5589 using, for instance, Standard.Constraint_Error when Constraint_Error
5590 is ambiguous (due to the user defining its own Constraint_Error
5591 entity inside its program). */
5592 if (lookup_name
.ada ().standard_p ())
5595 /* Check the non-global symbols. If we have ANY match, then we're done. */
5600 ada_add_local_symbols (result
, lookup_name
, block
, domain
);
5603 /* In the !full_search case we're are being called by
5604 iterate_over_symbols, and we don't want to search
5606 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5608 if (!result
.empty () || !full_search
)
5612 /* No non-global symbols found. Check our cache to see if we have
5613 already performed this search before. If we have, then return
5616 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5617 domain
, &sym
, &block
))
5620 add_defn_to_vec (result
, sym
, block
);
5624 if (made_global_lookup_p
)
5625 *made_global_lookup_p
= 1;
5627 /* Search symbols from all global blocks. */
5629 add_nonlocal_symbols (result
, lookup_name
, domain
, 1);
5631 /* Now add symbols from all per-file blocks if we've gotten no hits
5632 (not strictly correct, but perhaps better than an error). */
5634 if (result
.empty ())
5635 add_nonlocal_symbols (result
, lookup_name
, domain
, 0);
5638 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5639 is non-zero, enclosing scope and in global scopes.
5641 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5642 blocks and symbol tables (if any) in which they were found.
5644 When full_search is non-zero, any non-function/non-enumeral
5645 symbol match within the nest of blocks whose innermost member is BLOCK,
5646 is the one match returned (no other matches in that or
5647 enclosing blocks is returned). If there are any matches in or
5648 surrounding BLOCK, then these alone are returned.
5650 Names prefixed with "standard__" are handled specially: "standard__"
5651 is first stripped off, and only static and global symbols are searched. */
5653 static std::vector
<struct block_symbol
>
5654 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5655 const struct block
*block
,
5659 int syms_from_global_search
;
5660 std::vector
<struct block_symbol
> results
;
5662 ada_add_all_symbols (results
, block
, lookup_name
,
5663 domain
, full_search
, &syms_from_global_search
);
5665 remove_extra_symbols (&results
);
5667 if (results
.empty () && full_search
&& syms_from_global_search
)
5668 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5670 if (results
.size () == 1 && full_search
&& syms_from_global_search
)
5671 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5672 results
[0].symbol
, results
[0].block
);
5674 remove_irrelevant_renamings (&results
, block
);
5678 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5679 in global scopes, returning (SYM,BLOCK) tuples.
5681 See ada_lookup_symbol_list_worker for further details. */
5683 std::vector
<struct block_symbol
>
5684 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5687 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5688 lookup_name_info
lookup_name (name
, name_match_type
);
5690 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, 1);
5693 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5694 to 1, but choosing the first symbol found if there are multiple
5697 The result is stored in *INFO, which must be non-NULL.
5698 If no match is found, INFO->SYM is set to NULL. */
5701 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5703 struct block_symbol
*info
)
5705 /* Since we already have an encoded name, wrap it in '<>' to force a
5706 verbatim match. Otherwise, if the name happens to not look like
5707 an encoded name (because it doesn't include a "__"),
5708 ada_lookup_name_info would re-encode/fold it again, and that
5709 would e.g., incorrectly lowercase object renaming names like
5710 "R28b" -> "r28b". */
5711 std::string verbatim
= add_angle_brackets (name
);
5713 gdb_assert (info
!= NULL
);
5714 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5717 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5718 scope and in global scopes, or NULL if none. NAME is folded and
5719 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5720 choosing the first symbol if there are multiple choices. */
5723 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5726 std::vector
<struct block_symbol
> candidates
5727 = ada_lookup_symbol_list (name
, block0
, domain
);
5729 if (candidates
.empty ())
5732 block_symbol info
= candidates
[0];
5733 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5738 /* True iff STR is a possible encoded suffix of a normal Ada name
5739 that is to be ignored for matching purposes. Suffixes of parallel
5740 names (e.g., XVE) are not included here. Currently, the possible suffixes
5741 are given by any of the regular expressions:
5743 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5744 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5745 TKB [subprogram suffix for task bodies]
5746 _E[0-9]+[bs]$ [protected object entry suffixes]
5747 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5749 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5750 match is performed. This sequence is used to differentiate homonyms,
5751 is an optional part of a valid name suffix. */
5754 is_name_suffix (const char *str
)
5757 const char *matching
;
5758 const int len
= strlen (str
);
5760 /* Skip optional leading __[0-9]+. */
5762 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5765 while (isdigit (str
[0]))
5771 if (str
[0] == '.' || str
[0] == '$')
5774 while (isdigit (matching
[0]))
5776 if (matching
[0] == '\0')
5782 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5785 while (isdigit (matching
[0]))
5787 if (matching
[0] == '\0')
5791 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5793 if (strcmp (str
, "TKB") == 0)
5797 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5798 with a N at the end. Unfortunately, the compiler uses the same
5799 convention for other internal types it creates. So treating
5800 all entity names that end with an "N" as a name suffix causes
5801 some regressions. For instance, consider the case of an enumerated
5802 type. To support the 'Image attribute, it creates an array whose
5804 Having a single character like this as a suffix carrying some
5805 information is a bit risky. Perhaps we should change the encoding
5806 to be something like "_N" instead. In the meantime, do not do
5807 the following check. */
5808 /* Protected Object Subprograms */
5809 if (len
== 1 && str
[0] == 'N')
5814 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5817 while (isdigit (matching
[0]))
5819 if ((matching
[0] == 'b' || matching
[0] == 's')
5820 && matching
[1] == '\0')
5824 /* ??? We should not modify STR directly, as we are doing below. This
5825 is fine in this case, but may become problematic later if we find
5826 that this alternative did not work, and want to try matching
5827 another one from the begining of STR. Since we modified it, we
5828 won't be able to find the begining of the string anymore! */
5832 while (str
[0] != '_' && str
[0] != '\0')
5834 if (str
[0] != 'n' && str
[0] != 'b')
5840 if (str
[0] == '\000')
5845 if (str
[1] != '_' || str
[2] == '\000')
5849 if (strcmp (str
+ 3, "JM") == 0)
5851 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5852 the LJM suffix in favor of the JM one. But we will
5853 still accept LJM as a valid suffix for a reasonable
5854 amount of time, just to allow ourselves to debug programs
5855 compiled using an older version of GNAT. */
5856 if (strcmp (str
+ 3, "LJM") == 0)
5860 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5861 || str
[4] == 'U' || str
[4] == 'P')
5863 if (str
[4] == 'R' && str
[5] != 'T')
5867 if (!isdigit (str
[2]))
5869 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5870 if (!isdigit (str
[k
]) && str
[k
] != '_')
5874 if (str
[0] == '$' && isdigit (str
[1]))
5876 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5877 if (!isdigit (str
[k
]) && str
[k
] != '_')
5884 /* Return non-zero if the string starting at NAME and ending before
5885 NAME_END contains no capital letters. */
5888 is_valid_name_for_wild_match (const char *name0
)
5890 std::string decoded_name
= ada_decode (name0
);
5893 /* If the decoded name starts with an angle bracket, it means that
5894 NAME0 does not follow the GNAT encoding format. It should then
5895 not be allowed as a possible wild match. */
5896 if (decoded_name
[0] == '<')
5899 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5900 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5906 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5907 character which could start a simple name. Assumes that *NAMEP points
5908 somewhere inside the string beginning at NAME0. */
5911 advance_wild_match (const char **namep
, const char *name0
, char target0
)
5913 const char *name
= *namep
;
5923 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5926 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
5931 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
5932 || name
[2] == target0
))
5937 else if (t1
== '_' && name
[2] == 'B' && name
[3] == '_')
5939 /* Names like "pkg__B_N__name", where N is a number, are
5940 block-local. We can handle these by simply skipping
5947 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5957 /* Return true iff NAME encodes a name of the form prefix.PATN.
5958 Ignores any informational suffixes of NAME (i.e., for which
5959 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
5963 wild_match (const char *name
, const char *patn
)
5966 const char *name0
= name
;
5970 const char *match
= name
;
5974 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5977 if (*p
== '\0' && is_name_suffix (name
))
5978 return match
== name0
|| is_valid_name_for_wild_match (name0
);
5980 if (name
[-1] == '_')
5983 if (!advance_wild_match (&name
, name0
, *patn
))
5988 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5989 necessary). OBJFILE is the section containing BLOCK. */
5992 ada_add_block_symbols (std::vector
<struct block_symbol
> &result
,
5993 const struct block
*block
,
5994 const lookup_name_info
&lookup_name
,
5995 domain_enum domain
, struct objfile
*objfile
)
5997 struct block_iterator iter
;
5998 /* A matching argument symbol, if any. */
5999 struct symbol
*arg_sym
;
6000 /* Set true when we find a matching non-argument symbol. */
6006 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6008 sym
= block_iter_match_next (lookup_name
, &iter
))
6010 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6012 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6014 if (SYMBOL_IS_ARGUMENT (sym
))
6019 add_defn_to_vec (result
,
6020 fixup_symbol_section (sym
, objfile
),
6027 /* Handle renamings. */
6029 if (ada_add_block_renamings (result
, block
, lookup_name
, domain
))
6032 if (!found_sym
&& arg_sym
!= NULL
)
6034 add_defn_to_vec (result
,
6035 fixup_symbol_section (arg_sym
, objfile
),
6039 if (!lookup_name
.ada ().wild_match_p ())
6043 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6044 const char *name
= ada_lookup_name
.c_str ();
6045 size_t name_len
= ada_lookup_name
.size ();
6047 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6049 if (symbol_matches_domain (sym
->language (),
6050 SYMBOL_DOMAIN (sym
), domain
))
6054 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6057 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6059 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6064 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6066 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6068 if (SYMBOL_IS_ARGUMENT (sym
))
6073 add_defn_to_vec (result
,
6074 fixup_symbol_section (sym
, objfile
),
6082 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6083 They aren't parameters, right? */
6084 if (!found_sym
&& arg_sym
!= NULL
)
6086 add_defn_to_vec (result
,
6087 fixup_symbol_section (arg_sym
, objfile
),
6094 /* Symbol Completion */
6099 ada_lookup_name_info::matches
6100 (const char *sym_name
,
6101 symbol_name_match_type match_type
,
6102 completion_match_result
*comp_match_res
) const
6105 const char *text
= m_encoded_name
.c_str ();
6106 size_t text_len
= m_encoded_name
.size ();
6108 /* First, test against the fully qualified name of the symbol. */
6110 if (strncmp (sym_name
, text
, text_len
) == 0)
6113 std::string decoded_name
= ada_decode (sym_name
);
6114 if (match
&& !m_encoded_p
)
6116 /* One needed check before declaring a positive match is to verify
6117 that iff we are doing a verbatim match, the decoded version
6118 of the symbol name starts with '<'. Otherwise, this symbol name
6119 is not a suitable completion. */
6121 bool has_angle_bracket
= (decoded_name
[0] == '<');
6122 match
= (has_angle_bracket
== m_verbatim_p
);
6125 if (match
&& !m_verbatim_p
)
6127 /* When doing non-verbatim match, another check that needs to
6128 be done is to verify that the potentially matching symbol name
6129 does not include capital letters, because the ada-mode would
6130 not be able to understand these symbol names without the
6131 angle bracket notation. */
6134 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6139 /* Second: Try wild matching... */
6141 if (!match
&& m_wild_match_p
)
6143 /* Since we are doing wild matching, this means that TEXT
6144 may represent an unqualified symbol name. We therefore must
6145 also compare TEXT against the unqualified name of the symbol. */
6146 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6148 if (strncmp (sym_name
, text
, text_len
) == 0)
6152 /* Finally: If we found a match, prepare the result to return. */
6157 if (comp_match_res
!= NULL
)
6159 std::string
&match_str
= comp_match_res
->match
.storage ();
6162 match_str
= ada_decode (sym_name
);
6166 match_str
= add_angle_brackets (sym_name
);
6168 match_str
= sym_name
;
6172 comp_match_res
->set_match (match_str
.c_str ());
6180 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6181 for tagged types. */
6184 ada_is_dispatch_table_ptr_type (struct type
*type
)
6188 if (type
->code () != TYPE_CODE_PTR
)
6191 name
= TYPE_TARGET_TYPE (type
)->name ();
6195 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6198 /* Return non-zero if TYPE is an interface tag. */
6201 ada_is_interface_tag (struct type
*type
)
6203 const char *name
= type
->name ();
6208 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6211 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6212 to be invisible to users. */
6215 ada_is_ignored_field (struct type
*type
, int field_num
)
6217 if (field_num
< 0 || field_num
> type
->num_fields ())
6220 /* Check the name of that field. */
6222 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6224 /* Anonymous field names should not be printed.
6225 brobecker/2007-02-20: I don't think this can actually happen
6226 but we don't want to print the value of anonymous fields anyway. */
6230 /* Normally, fields whose name start with an underscore ("_")
6231 are fields that have been internally generated by the compiler,
6232 and thus should not be printed. The "_parent" field is special,
6233 however: This is a field internally generated by the compiler
6234 for tagged types, and it contains the components inherited from
6235 the parent type. This field should not be printed as is, but
6236 should not be ignored either. */
6237 if (name
[0] == '_' && !startswith (name
, "_parent"))
6241 /* If this is the dispatch table of a tagged type or an interface tag,
6243 if (ada_is_tagged_type (type
, 1)
6244 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6245 || ada_is_interface_tag (type
->field (field_num
).type ())))
6248 /* Not a special field, so it should not be ignored. */
6252 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6253 pointer or reference type whose ultimate target has a tag field. */
6256 ada_is_tagged_type (struct type
*type
, int refok
)
6258 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6261 /* True iff TYPE represents the type of X'Tag */
6264 ada_is_tag_type (struct type
*type
)
6266 type
= ada_check_typedef (type
);
6268 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6272 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6274 return (name
!= NULL
6275 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6279 /* The type of the tag on VAL. */
6281 static struct type
*
6282 ada_tag_type (struct value
*val
)
6284 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6287 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6288 retired at Ada 05). */
6291 is_ada95_tag (struct value
*tag
)
6293 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6296 /* The value of the tag on VAL. */
6298 static struct value
*
6299 ada_value_tag (struct value
*val
)
6301 return ada_value_struct_elt (val
, "_tag", 0);
6304 /* The value of the tag on the object of type TYPE whose contents are
6305 saved at VALADDR, if it is non-null, or is at memory address
6308 static struct value
*
6309 value_tag_from_contents_and_address (struct type
*type
,
6310 const gdb_byte
*valaddr
,
6313 int tag_byte_offset
;
6314 struct type
*tag_type
;
6316 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6319 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6321 : valaddr
+ tag_byte_offset
);
6322 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6324 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6329 static struct type
*
6330 type_from_tag (struct value
*tag
)
6332 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6334 if (type_name
!= NULL
)
6335 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6339 /* Given a value OBJ of a tagged type, return a value of this
6340 type at the base address of the object. The base address, as
6341 defined in Ada.Tags, it is the address of the primary tag of
6342 the object, and therefore where the field values of its full
6343 view can be fetched. */
6346 ada_tag_value_at_base_address (struct value
*obj
)
6349 LONGEST offset_to_top
= 0;
6350 struct type
*ptr_type
, *obj_type
;
6352 CORE_ADDR base_address
;
6354 obj_type
= value_type (obj
);
6356 /* It is the responsability of the caller to deref pointers. */
6358 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6361 tag
= ada_value_tag (obj
);
6365 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6367 if (is_ada95_tag (tag
))
6370 ptr_type
= language_lookup_primitive_type
6371 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6372 ptr_type
= lookup_pointer_type (ptr_type
);
6373 val
= value_cast (ptr_type
, tag
);
6377 /* It is perfectly possible that an exception be raised while
6378 trying to determine the base address, just like for the tag;
6379 see ada_tag_name for more details. We do not print the error
6380 message for the same reason. */
6384 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6387 catch (const gdb_exception_error
&e
)
6392 /* If offset is null, nothing to do. */
6394 if (offset_to_top
== 0)
6397 /* -1 is a special case in Ada.Tags; however, what should be done
6398 is not quite clear from the documentation. So do nothing for
6401 if (offset_to_top
== -1)
6404 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6405 from the base address. This was however incompatible with
6406 C++ dispatch table: C++ uses a *negative* value to *add*
6407 to the base address. Ada's convention has therefore been
6408 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6409 use the same convention. Here, we support both cases by
6410 checking the sign of OFFSET_TO_TOP. */
6412 if (offset_to_top
> 0)
6413 offset_to_top
= -offset_to_top
;
6415 base_address
= value_address (obj
) + offset_to_top
;
6416 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6418 /* Make sure that we have a proper tag at the new address.
6419 Otherwise, offset_to_top is bogus (which can happen when
6420 the object is not initialized yet). */
6425 obj_type
= type_from_tag (tag
);
6430 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6433 /* Return the "ada__tags__type_specific_data" type. */
6435 static struct type
*
6436 ada_get_tsd_type (struct inferior
*inf
)
6438 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6440 if (data
->tsd_type
== 0)
6441 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6442 return data
->tsd_type
;
6445 /* Return the TSD (type-specific data) associated to the given TAG.
6446 TAG is assumed to be the tag of a tagged-type entity.
6448 May return NULL if we are unable to get the TSD. */
6450 static struct value
*
6451 ada_get_tsd_from_tag (struct value
*tag
)
6456 /* First option: The TSD is simply stored as a field of our TAG.
6457 Only older versions of GNAT would use this format, but we have
6458 to test it first, because there are no visible markers for
6459 the current approach except the absence of that field. */
6461 val
= ada_value_struct_elt (tag
, "tsd", 1);
6465 /* Try the second representation for the dispatch table (in which
6466 there is no explicit 'tsd' field in the referent of the tag pointer,
6467 and instead the tsd pointer is stored just before the dispatch
6470 type
= ada_get_tsd_type (current_inferior());
6473 type
= lookup_pointer_type (lookup_pointer_type (type
));
6474 val
= value_cast (type
, tag
);
6477 return value_ind (value_ptradd (val
, -1));
6480 /* Given the TSD of a tag (type-specific data), return a string
6481 containing the name of the associated type.
6483 May return NULL if we are unable to determine the tag name. */
6485 static gdb::unique_xmalloc_ptr
<char>
6486 ada_tag_name_from_tsd (struct value
*tsd
)
6491 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6494 gdb::unique_xmalloc_ptr
<char> buffer
6495 = target_read_string (value_as_address (val
), INT_MAX
);
6496 if (buffer
== nullptr)
6499 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6508 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6511 Return NULL if the TAG is not an Ada tag, or if we were unable to
6512 determine the name of that tag. */
6514 gdb::unique_xmalloc_ptr
<char>
6515 ada_tag_name (struct value
*tag
)
6517 gdb::unique_xmalloc_ptr
<char> name
;
6519 if (!ada_is_tag_type (value_type (tag
)))
6522 /* It is perfectly possible that an exception be raised while trying
6523 to determine the TAG's name, even under normal circumstances:
6524 The associated variable may be uninitialized or corrupted, for
6525 instance. We do not let any exception propagate past this point.
6526 instead we return NULL.
6528 We also do not print the error message either (which often is very
6529 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6530 the caller print a more meaningful message if necessary. */
6533 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6536 name
= ada_tag_name_from_tsd (tsd
);
6538 catch (const gdb_exception_error
&e
)
6545 /* The parent type of TYPE, or NULL if none. */
6548 ada_parent_type (struct type
*type
)
6552 type
= ada_check_typedef (type
);
6554 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6557 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6558 if (ada_is_parent_field (type
, i
))
6560 struct type
*parent_type
= type
->field (i
).type ();
6562 /* If the _parent field is a pointer, then dereference it. */
6563 if (parent_type
->code () == TYPE_CODE_PTR
)
6564 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6565 /* If there is a parallel XVS type, get the actual base type. */
6566 parent_type
= ada_get_base_type (parent_type
);
6568 return ada_check_typedef (parent_type
);
6574 /* True iff field number FIELD_NUM of structure type TYPE contains the
6575 parent-type (inherited) fields of a derived type. Assumes TYPE is
6576 a structure type with at least FIELD_NUM+1 fields. */
6579 ada_is_parent_field (struct type
*type
, int field_num
)
6581 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6583 return (name
!= NULL
6584 && (startswith (name
, "PARENT")
6585 || startswith (name
, "_parent")));
6588 /* True iff field number FIELD_NUM of structure type TYPE is a
6589 transparent wrapper field (which should be silently traversed when doing
6590 field selection and flattened when printing). Assumes TYPE is a
6591 structure type with at least FIELD_NUM+1 fields. Such fields are always
6595 ada_is_wrapper_field (struct type
*type
, int field_num
)
6597 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6599 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6601 /* This happens in functions with "out" or "in out" parameters
6602 which are passed by copy. For such functions, GNAT describes
6603 the function's return type as being a struct where the return
6604 value is in a field called RETVAL, and where the other "out"
6605 or "in out" parameters are fields of that struct. This is not
6610 return (name
!= NULL
6611 && (startswith (name
, "PARENT")
6612 || strcmp (name
, "REP") == 0
6613 || startswith (name
, "_parent")
6614 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6617 /* True iff field number FIELD_NUM of structure or union type TYPE
6618 is a variant wrapper. Assumes TYPE is a structure type with at least
6619 FIELD_NUM+1 fields. */
6622 ada_is_variant_part (struct type
*type
, int field_num
)
6624 /* Only Ada types are eligible. */
6625 if (!ADA_TYPE_P (type
))
6628 struct type
*field_type
= type
->field (field_num
).type ();
6630 return (field_type
->code () == TYPE_CODE_UNION
6631 || (is_dynamic_field (type
, field_num
)
6632 && (TYPE_TARGET_TYPE (field_type
)->code ()
6633 == TYPE_CODE_UNION
)));
6636 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6637 whose discriminants are contained in the record type OUTER_TYPE,
6638 returns the type of the controlling discriminant for the variant.
6639 May return NULL if the type could not be found. */
6642 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6644 const char *name
= ada_variant_discrim_name (var_type
);
6646 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6649 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6650 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6651 represents a 'when others' clause; otherwise 0. */
6654 ada_is_others_clause (struct type
*type
, int field_num
)
6656 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6658 return (name
!= NULL
&& name
[0] == 'O');
6661 /* Assuming that TYPE0 is the type of the variant part of a record,
6662 returns the name of the discriminant controlling the variant.
6663 The value is valid until the next call to ada_variant_discrim_name. */
6666 ada_variant_discrim_name (struct type
*type0
)
6668 static std::string result
;
6671 const char *discrim_end
;
6672 const char *discrim_start
;
6674 if (type0
->code () == TYPE_CODE_PTR
)
6675 type
= TYPE_TARGET_TYPE (type0
);
6679 name
= ada_type_name (type
);
6681 if (name
== NULL
|| name
[0] == '\000')
6684 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6687 if (startswith (discrim_end
, "___XVN"))
6690 if (discrim_end
== name
)
6693 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6696 if (discrim_start
== name
+ 1)
6698 if ((discrim_start
> name
+ 3
6699 && startswith (discrim_start
- 3, "___"))
6700 || discrim_start
[-1] == '.')
6704 result
= std::string (discrim_start
, discrim_end
- discrim_start
);
6705 return result
.c_str ();
6708 /* Scan STR for a subtype-encoded number, beginning at position K.
6709 Put the position of the character just past the number scanned in
6710 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6711 Return 1 if there was a valid number at the given position, and 0
6712 otherwise. A "subtype-encoded" number consists of the absolute value
6713 in decimal, followed by the letter 'm' to indicate a negative number.
6714 Assumes 0m does not occur. */
6717 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6721 if (!isdigit (str
[k
]))
6724 /* Do it the hard way so as not to make any assumption about
6725 the relationship of unsigned long (%lu scan format code) and
6728 while (isdigit (str
[k
]))
6730 RU
= RU
* 10 + (str
[k
] - '0');
6737 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6743 /* NOTE on the above: Technically, C does not say what the results of
6744 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6745 number representable as a LONGEST (although either would probably work
6746 in most implementations). When RU>0, the locution in the then branch
6747 above is always equivalent to the negative of RU. */
6754 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6755 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6756 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6759 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6761 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6775 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6785 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6786 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6788 if (val
>= L
&& val
<= U
)
6800 /* FIXME: Lots of redundancy below. Try to consolidate. */
6802 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6803 ARG_TYPE, extract and return the value of one of its (non-static)
6804 fields. FIELDNO says which field. Differs from value_primitive_field
6805 only in that it can handle packed values of arbitrary type. */
6808 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6809 struct type
*arg_type
)
6813 arg_type
= ada_check_typedef (arg_type
);
6814 type
= arg_type
->field (fieldno
).type ();
6816 /* Handle packed fields. It might be that the field is not packed
6817 relative to its containing structure, but the structure itself is
6818 packed; in this case we must take the bit-field path. */
6819 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6821 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6822 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6824 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6825 offset
+ bit_pos
/ 8,
6826 bit_pos
% 8, bit_size
, type
);
6829 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6832 /* Find field with name NAME in object of type TYPE. If found,
6833 set the following for each argument that is non-null:
6834 - *FIELD_TYPE_P to the field's type;
6835 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6836 an object of that type;
6837 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6838 - *BIT_SIZE_P to its size in bits if the field is packed, and
6840 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6841 fields up to but not including the desired field, or by the total
6842 number of fields if not found. A NULL value of NAME never
6843 matches; the function just counts visible fields in this case.
6845 Notice that we need to handle when a tagged record hierarchy
6846 has some components with the same name, like in this scenario:
6848 type Top_T is tagged record
6854 type Middle_T is new Top.Top_T with record
6855 N : Character := 'a';
6859 type Bottom_T is new Middle.Middle_T with record
6861 C : Character := '5';
6863 A : Character := 'J';
6866 Let's say we now have a variable declared and initialized as follow:
6868 TC : Top_A := new Bottom_T;
6870 And then we use this variable to call this function
6872 procedure Assign (Obj: in out Top_T; TV : Integer);
6876 Assign (Top_T (B), 12);
6878 Now, we're in the debugger, and we're inside that procedure
6879 then and we want to print the value of obj.c:
6881 Usually, the tagged record or one of the parent type owns the
6882 component to print and there's no issue but in this particular
6883 case, what does it mean to ask for Obj.C? Since the actual
6884 type for object is type Bottom_T, it could mean two things: type
6885 component C from the Middle_T view, but also component C from
6886 Bottom_T. So in that "undefined" case, when the component is
6887 not found in the non-resolved type (which includes all the
6888 components of the parent type), then resolve it and see if we
6889 get better luck once expanded.
6891 In the case of homonyms in the derived tagged type, we don't
6892 guaranty anything, and pick the one that's easiest for us
6895 Returns 1 if found, 0 otherwise. */
6898 find_struct_field (const char *name
, struct type
*type
, int offset
,
6899 struct type
**field_type_p
,
6900 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6904 int parent_offset
= -1;
6906 type
= ada_check_typedef (type
);
6908 if (field_type_p
!= NULL
)
6909 *field_type_p
= NULL
;
6910 if (byte_offset_p
!= NULL
)
6912 if (bit_offset_p
!= NULL
)
6914 if (bit_size_p
!= NULL
)
6917 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6919 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6920 int fld_offset
= offset
+ bit_pos
/ 8;
6921 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6923 if (t_field_name
== NULL
)
6926 else if (ada_is_parent_field (type
, i
))
6928 /* This is a field pointing us to the parent type of a tagged
6929 type. As hinted in this function's documentation, we give
6930 preference to fields in the current record first, so what
6931 we do here is just record the index of this field before
6932 we skip it. If it turns out we couldn't find our field
6933 in the current record, then we'll get back to it and search
6934 inside it whether the field might exist in the parent. */
6940 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6942 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6944 if (field_type_p
!= NULL
)
6945 *field_type_p
= type
->field (i
).type ();
6946 if (byte_offset_p
!= NULL
)
6947 *byte_offset_p
= fld_offset
;
6948 if (bit_offset_p
!= NULL
)
6949 *bit_offset_p
= bit_pos
% 8;
6950 if (bit_size_p
!= NULL
)
6951 *bit_size_p
= bit_size
;
6954 else if (ada_is_wrapper_field (type
, i
))
6956 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
6957 field_type_p
, byte_offset_p
, bit_offset_p
,
6958 bit_size_p
, index_p
))
6961 else if (ada_is_variant_part (type
, i
))
6963 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6966 struct type
*field_type
6967 = ada_check_typedef (type
->field (i
).type ());
6969 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
6971 if (find_struct_field (name
, field_type
->field (j
).type (),
6973 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6974 field_type_p
, byte_offset_p
,
6975 bit_offset_p
, bit_size_p
, index_p
))
6979 else if (index_p
!= NULL
)
6983 /* Field not found so far. If this is a tagged type which
6984 has a parent, try finding that field in the parent now. */
6986 if (parent_offset
!= -1)
6988 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
6989 int fld_offset
= offset
+ bit_pos
/ 8;
6991 if (find_struct_field (name
, type
->field (parent_offset
).type (),
6992 fld_offset
, field_type_p
, byte_offset_p
,
6993 bit_offset_p
, bit_size_p
, index_p
))
7000 /* Number of user-visible fields in record type TYPE. */
7003 num_visible_fields (struct type
*type
)
7008 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7012 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7013 and search in it assuming it has (class) type TYPE.
7014 If found, return value, else return NULL.
7016 Searches recursively through wrapper fields (e.g., '_parent').
7018 In the case of homonyms in the tagged types, please refer to the
7019 long explanation in find_struct_field's function documentation. */
7021 static struct value
*
7022 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7026 int parent_offset
= -1;
7028 type
= ada_check_typedef (type
);
7029 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7031 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7033 if (t_field_name
== NULL
)
7036 else if (ada_is_parent_field (type
, i
))
7038 /* This is a field pointing us to the parent type of a tagged
7039 type. As hinted in this function's documentation, we give
7040 preference to fields in the current record first, so what
7041 we do here is just record the index of this field before
7042 we skip it. If it turns out we couldn't find our field
7043 in the current record, then we'll get back to it and search
7044 inside it whether the field might exist in the parent. */
7050 else if (field_name_match (t_field_name
, name
))
7051 return ada_value_primitive_field (arg
, offset
, i
, type
);
7053 else if (ada_is_wrapper_field (type
, i
))
7055 struct value
*v
= /* Do not let indent join lines here. */
7056 ada_search_struct_field (name
, arg
,
7057 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7058 type
->field (i
).type ());
7064 else if (ada_is_variant_part (type
, i
))
7066 /* PNH: Do we ever get here? See find_struct_field. */
7068 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7069 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7071 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7073 struct value
*v
= ada_search_struct_field
/* Force line
7076 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7077 field_type
->field (j
).type ());
7085 /* Field not found so far. If this is a tagged type which
7086 has a parent, try finding that field in the parent now. */
7088 if (parent_offset
!= -1)
7090 struct value
*v
= ada_search_struct_field (
7091 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7092 type
->field (parent_offset
).type ());
7101 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7102 int, struct type
*);
7105 /* Return field #INDEX in ARG, where the index is that returned by
7106 * find_struct_field through its INDEX_P argument. Adjust the address
7107 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7108 * If found, return value, else return NULL. */
7110 static struct value
*
7111 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7114 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7118 /* Auxiliary function for ada_index_struct_field. Like
7119 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7122 static struct value
*
7123 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7127 type
= ada_check_typedef (type
);
7129 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7131 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7133 else if (ada_is_wrapper_field (type
, i
))
7135 struct value
*v
= /* Do not let indent join lines here. */
7136 ada_index_struct_field_1 (index_p
, arg
,
7137 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7138 type
->field (i
).type ());
7144 else if (ada_is_variant_part (type
, i
))
7146 /* PNH: Do we ever get here? See ada_search_struct_field,
7147 find_struct_field. */
7148 error (_("Cannot assign this kind of variant record"));
7150 else if (*index_p
== 0)
7151 return ada_value_primitive_field (arg
, offset
, i
, type
);
7158 /* Return a string representation of type TYPE. */
7161 type_as_string (struct type
*type
)
7163 string_file tmp_stream
;
7165 type_print (type
, "", &tmp_stream
, -1);
7167 return std::move (tmp_stream
.string ());
7170 /* Given a type TYPE, look up the type of the component of type named NAME.
7171 If DISPP is non-null, add its byte displacement from the beginning of a
7172 structure (pointed to by a value) of type TYPE to *DISPP (does not
7173 work for packed fields).
7175 Matches any field whose name has NAME as a prefix, possibly
7178 TYPE can be either a struct or union. If REFOK, TYPE may also
7179 be a (pointer or reference)+ to a struct or union, and the
7180 ultimate target type will be searched.
7182 Looks recursively into variant clauses and parent types.
7184 In the case of homonyms in the tagged types, please refer to the
7185 long explanation in find_struct_field's function documentation.
7187 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7188 TYPE is not a type of the right kind. */
7190 static struct type
*
7191 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7195 int parent_offset
= -1;
7200 if (refok
&& type
!= NULL
)
7203 type
= ada_check_typedef (type
);
7204 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7206 type
= TYPE_TARGET_TYPE (type
);
7210 || (type
->code () != TYPE_CODE_STRUCT
7211 && type
->code () != TYPE_CODE_UNION
))
7216 error (_("Type %s is not a structure or union type"),
7217 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7220 type
= to_static_fixed_type (type
);
7222 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7224 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7227 if (t_field_name
== NULL
)
7230 else if (ada_is_parent_field (type
, i
))
7232 /* This is a field pointing us to the parent type of a tagged
7233 type. As hinted in this function's documentation, we give
7234 preference to fields in the current record first, so what
7235 we do here is just record the index of this field before
7236 we skip it. If it turns out we couldn't find our field
7237 in the current record, then we'll get back to it and search
7238 inside it whether the field might exist in the parent. */
7244 else if (field_name_match (t_field_name
, name
))
7245 return type
->field (i
).type ();
7247 else if (ada_is_wrapper_field (type
, i
))
7249 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7255 else if (ada_is_variant_part (type
, i
))
7258 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7260 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7262 /* FIXME pnh 2008/01/26: We check for a field that is
7263 NOT wrapped in a struct, since the compiler sometimes
7264 generates these for unchecked variant types. Revisit
7265 if the compiler changes this practice. */
7266 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7268 if (v_field_name
!= NULL
7269 && field_name_match (v_field_name
, name
))
7270 t
= field_type
->field (j
).type ();
7272 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7282 /* Field not found so far. If this is a tagged type which
7283 has a parent, try finding that field in the parent now. */
7285 if (parent_offset
!= -1)
7289 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7298 const char *name_str
= name
!= NULL
? name
: _("<null>");
7300 error (_("Type %s has no component named %s"),
7301 type_as_string (type
).c_str (), name_str
);
7307 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7308 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7309 represents an unchecked union (that is, the variant part of a
7310 record that is named in an Unchecked_Union pragma). */
7313 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7315 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7317 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7321 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7322 within OUTER, determine which variant clause (field number in VAR_TYPE,
7323 numbering from 0) is applicable. Returns -1 if none are. */
7326 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7330 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7331 struct value
*discrim
;
7332 LONGEST discrim_val
;
7334 /* Using plain value_from_contents_and_address here causes problems
7335 because we will end up trying to resolve a type that is currently
7336 being constructed. */
7337 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7338 if (discrim
== NULL
)
7340 discrim_val
= value_as_long (discrim
);
7343 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7345 if (ada_is_others_clause (var_type
, i
))
7347 else if (ada_in_variant (discrim_val
, var_type
, i
))
7351 return others_clause
;
7356 /* Dynamic-Sized Records */
7358 /* Strategy: The type ostensibly attached to a value with dynamic size
7359 (i.e., a size that is not statically recorded in the debugging
7360 data) does not accurately reflect the size or layout of the value.
7361 Our strategy is to convert these values to values with accurate,
7362 conventional types that are constructed on the fly. */
7364 /* There is a subtle and tricky problem here. In general, we cannot
7365 determine the size of dynamic records without its data. However,
7366 the 'struct value' data structure, which GDB uses to represent
7367 quantities in the inferior process (the target), requires the size
7368 of the type at the time of its allocation in order to reserve space
7369 for GDB's internal copy of the data. That's why the
7370 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7371 rather than struct value*s.
7373 However, GDB's internal history variables ($1, $2, etc.) are
7374 struct value*s containing internal copies of the data that are not, in
7375 general, the same as the data at their corresponding addresses in
7376 the target. Fortunately, the types we give to these values are all
7377 conventional, fixed-size types (as per the strategy described
7378 above), so that we don't usually have to perform the
7379 'to_fixed_xxx_type' conversions to look at their values.
7380 Unfortunately, there is one exception: if one of the internal
7381 history variables is an array whose elements are unconstrained
7382 records, then we will need to create distinct fixed types for each
7383 element selected. */
7385 /* The upshot of all of this is that many routines take a (type, host
7386 address, target address) triple as arguments to represent a value.
7387 The host address, if non-null, is supposed to contain an internal
7388 copy of the relevant data; otherwise, the program is to consult the
7389 target at the target address. */
7391 /* Assuming that VAL0 represents a pointer value, the result of
7392 dereferencing it. Differs from value_ind in its treatment of
7393 dynamic-sized types. */
7396 ada_value_ind (struct value
*val0
)
7398 struct value
*val
= value_ind (val0
);
7400 if (ada_is_tagged_type (value_type (val
), 0))
7401 val
= ada_tag_value_at_base_address (val
);
7403 return ada_to_fixed_value (val
);
7406 /* The value resulting from dereferencing any "reference to"
7407 qualifiers on VAL0. */
7409 static struct value
*
7410 ada_coerce_ref (struct value
*val0
)
7412 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7414 struct value
*val
= val0
;
7416 val
= coerce_ref (val
);
7418 if (ada_is_tagged_type (value_type (val
), 0))
7419 val
= ada_tag_value_at_base_address (val
);
7421 return ada_to_fixed_value (val
);
7427 /* Return the bit alignment required for field #F of template type TYPE. */
7430 field_alignment (struct type
*type
, int f
)
7432 const char *name
= TYPE_FIELD_NAME (type
, f
);
7436 /* The field name should never be null, unless the debugging information
7437 is somehow malformed. In this case, we assume the field does not
7438 require any alignment. */
7442 len
= strlen (name
);
7444 if (!isdigit (name
[len
- 1]))
7447 if (isdigit (name
[len
- 2]))
7448 align_offset
= len
- 2;
7450 align_offset
= len
- 1;
7452 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7453 return TARGET_CHAR_BIT
;
7455 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7458 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7460 static struct symbol
*
7461 ada_find_any_type_symbol (const char *name
)
7465 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7466 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7469 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7473 /* Find a type named NAME. Ignores ambiguity. This routine will look
7474 solely for types defined by debug info, it will not search the GDB
7477 static struct type
*
7478 ada_find_any_type (const char *name
)
7480 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7483 return SYMBOL_TYPE (sym
);
7488 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7489 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7490 symbol, in which case it is returned. Otherwise, this looks for
7491 symbols whose name is that of NAME_SYM suffixed with "___XR".
7492 Return symbol if found, and NULL otherwise. */
7495 ada_is_renaming_symbol (struct symbol
*name_sym
)
7497 const char *name
= name_sym
->linkage_name ();
7498 return strstr (name
, "___XR") != NULL
;
7501 /* Because of GNAT encoding conventions, several GDB symbols may match a
7502 given type name. If the type denoted by TYPE0 is to be preferred to
7503 that of TYPE1 for purposes of type printing, return non-zero;
7504 otherwise return 0. */
7507 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7511 else if (type0
== NULL
)
7513 else if (type1
->code () == TYPE_CODE_VOID
)
7515 else if (type0
->code () == TYPE_CODE_VOID
)
7517 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7519 else if (ada_is_constrained_packed_array_type (type0
))
7521 else if (ada_is_array_descriptor_type (type0
)
7522 && !ada_is_array_descriptor_type (type1
))
7526 const char *type0_name
= type0
->name ();
7527 const char *type1_name
= type1
->name ();
7529 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7530 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7536 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7540 ada_type_name (struct type
*type
)
7544 return type
->name ();
7547 /* Search the list of "descriptive" types associated to TYPE for a type
7548 whose name is NAME. */
7550 static struct type
*
7551 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7553 struct type
*result
, *tmp
;
7555 if (ada_ignore_descriptive_types_p
)
7558 /* If there no descriptive-type info, then there is no parallel type
7560 if (!HAVE_GNAT_AUX_INFO (type
))
7563 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7564 while (result
!= NULL
)
7566 const char *result_name
= ada_type_name (result
);
7568 if (result_name
== NULL
)
7570 warning (_("unexpected null name on descriptive type"));
7574 /* If the names match, stop. */
7575 if (strcmp (result_name
, name
) == 0)
7578 /* Otherwise, look at the next item on the list, if any. */
7579 if (HAVE_GNAT_AUX_INFO (result
))
7580 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7584 /* If not found either, try after having resolved the typedef. */
7589 result
= check_typedef (result
);
7590 if (HAVE_GNAT_AUX_INFO (result
))
7591 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7597 /* If we didn't find a match, see whether this is a packed array. With
7598 older compilers, the descriptive type information is either absent or
7599 irrelevant when it comes to packed arrays so the above lookup fails.
7600 Fall back to using a parallel lookup by name in this case. */
7601 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7602 return ada_find_any_type (name
);
7607 /* Find a parallel type to TYPE with the specified NAME, using the
7608 descriptive type taken from the debugging information, if available,
7609 and otherwise using the (slower) name-based method. */
7611 static struct type
*
7612 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7614 struct type
*result
= NULL
;
7616 if (HAVE_GNAT_AUX_INFO (type
))
7617 result
= find_parallel_type_by_descriptive_type (type
, name
);
7619 result
= ada_find_any_type (name
);
7624 /* Same as above, but specify the name of the parallel type by appending
7625 SUFFIX to the name of TYPE. */
7628 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7631 const char *type_name
= ada_type_name (type
);
7634 if (type_name
== NULL
)
7637 len
= strlen (type_name
);
7639 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7641 strcpy (name
, type_name
);
7642 strcpy (name
+ len
, suffix
);
7644 return ada_find_parallel_type_with_name (type
, name
);
7647 /* If TYPE is a variable-size record type, return the corresponding template
7648 type describing its fields. Otherwise, return NULL. */
7650 static struct type
*
7651 dynamic_template_type (struct type
*type
)
7653 type
= ada_check_typedef (type
);
7655 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7656 || ada_type_name (type
) == NULL
)
7660 int len
= strlen (ada_type_name (type
));
7662 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7665 return ada_find_parallel_type (type
, "___XVE");
7669 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7670 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7673 is_dynamic_field (struct type
*templ_type
, int field_num
)
7675 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7678 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7679 && strstr (name
, "___XVL") != NULL
;
7682 /* The index of the variant field of TYPE, or -1 if TYPE does not
7683 represent a variant record type. */
7686 variant_field_index (struct type
*type
)
7690 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7693 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7695 if (ada_is_variant_part (type
, f
))
7701 /* A record type with no fields. */
7703 static struct type
*
7704 empty_record (struct type
*templ
)
7706 struct type
*type
= alloc_type_copy (templ
);
7708 type
->set_code (TYPE_CODE_STRUCT
);
7709 INIT_NONE_SPECIFIC (type
);
7710 type
->set_name ("<empty>");
7711 TYPE_LENGTH (type
) = 0;
7715 /* An ordinary record type (with fixed-length fields) that describes
7716 the value of type TYPE at VALADDR or ADDRESS (see comments at
7717 the beginning of this section) VAL according to GNAT conventions.
7718 DVAL0 should describe the (portion of a) record that contains any
7719 necessary discriminants. It should be NULL if value_type (VAL) is
7720 an outer-level type (i.e., as opposed to a branch of a variant.) A
7721 variant field (unless unchecked) is replaced by a particular branch
7724 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7725 length are not statically known are discarded. As a consequence,
7726 VALADDR, ADDRESS and DVAL0 are ignored.
7728 NOTE: Limitations: For now, we assume that dynamic fields and
7729 variants occupy whole numbers of bytes. However, they need not be
7733 ada_template_to_fixed_record_type_1 (struct type
*type
,
7734 const gdb_byte
*valaddr
,
7735 CORE_ADDR address
, struct value
*dval0
,
7736 int keep_dynamic_fields
)
7738 struct value
*mark
= value_mark ();
7741 int nfields
, bit_len
;
7747 /* Compute the number of fields in this record type that are going
7748 to be processed: unless keep_dynamic_fields, this includes only
7749 fields whose position and length are static will be processed. */
7750 if (keep_dynamic_fields
)
7751 nfields
= type
->num_fields ();
7755 while (nfields
< type
->num_fields ()
7756 && !ada_is_variant_part (type
, nfields
)
7757 && !is_dynamic_field (type
, nfields
))
7761 rtype
= alloc_type_copy (type
);
7762 rtype
->set_code (TYPE_CODE_STRUCT
);
7763 INIT_NONE_SPECIFIC (rtype
);
7764 rtype
->set_num_fields (nfields
);
7766 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7767 rtype
->set_name (ada_type_name (type
));
7768 rtype
->set_is_fixed_instance (true);
7774 for (f
= 0; f
< nfields
; f
+= 1)
7776 off
= align_up (off
, field_alignment (type
, f
))
7777 + TYPE_FIELD_BITPOS (type
, f
);
7778 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7779 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7781 if (ada_is_variant_part (type
, f
))
7786 else if (is_dynamic_field (type
, f
))
7788 const gdb_byte
*field_valaddr
= valaddr
;
7789 CORE_ADDR field_address
= address
;
7790 struct type
*field_type
=
7791 TYPE_TARGET_TYPE (type
->field (f
).type ());
7795 /* rtype's length is computed based on the run-time
7796 value of discriminants. If the discriminants are not
7797 initialized, the type size may be completely bogus and
7798 GDB may fail to allocate a value for it. So check the
7799 size first before creating the value. */
7800 ada_ensure_varsize_limit (rtype
);
7801 /* Using plain value_from_contents_and_address here
7802 causes problems because we will end up trying to
7803 resolve a type that is currently being
7805 dval
= value_from_contents_and_address_unresolved (rtype
,
7808 rtype
= value_type (dval
);
7813 /* If the type referenced by this field is an aligner type, we need
7814 to unwrap that aligner type, because its size might not be set.
7815 Keeping the aligner type would cause us to compute the wrong
7816 size for this field, impacting the offset of the all the fields
7817 that follow this one. */
7818 if (ada_is_aligner_type (field_type
))
7820 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7822 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7823 field_address
= cond_offset_target (field_address
, field_offset
);
7824 field_type
= ada_aligned_type (field_type
);
7827 field_valaddr
= cond_offset_host (field_valaddr
,
7828 off
/ TARGET_CHAR_BIT
);
7829 field_address
= cond_offset_target (field_address
,
7830 off
/ TARGET_CHAR_BIT
);
7832 /* Get the fixed type of the field. Note that, in this case,
7833 we do not want to get the real type out of the tag: if
7834 the current field is the parent part of a tagged record,
7835 we will get the tag of the object. Clearly wrong: the real
7836 type of the parent is not the real type of the child. We
7837 would end up in an infinite loop. */
7838 field_type
= ada_get_base_type (field_type
);
7839 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7840 field_address
, dval
, 0);
7841 /* If the field size is already larger than the maximum
7842 object size, then the record itself will necessarily
7843 be larger than the maximum object size. We need to make
7844 this check now, because the size might be so ridiculously
7845 large (due to an uninitialized variable in the inferior)
7846 that it would cause an overflow when adding it to the
7848 ada_ensure_varsize_limit (field_type
);
7850 rtype
->field (f
).set_type (field_type
);
7851 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7852 /* The multiplication can potentially overflow. But because
7853 the field length has been size-checked just above, and
7854 assuming that the maximum size is a reasonable value,
7855 an overflow should not happen in practice. So rather than
7856 adding overflow recovery code to this already complex code,
7857 we just assume that it's not going to happen. */
7859 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7863 /* Note: If this field's type is a typedef, it is important
7864 to preserve the typedef layer.
7866 Otherwise, we might be transforming a typedef to a fat
7867 pointer (encoding a pointer to an unconstrained array),
7868 into a basic fat pointer (encoding an unconstrained
7869 array). As both types are implemented using the same
7870 structure, the typedef is the only clue which allows us
7871 to distinguish between the two options. Stripping it
7872 would prevent us from printing this field appropriately. */
7873 rtype
->field (f
).set_type (type
->field (f
).type ());
7874 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7875 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7877 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7880 struct type
*field_type
= type
->field (f
).type ();
7882 /* We need to be careful of typedefs when computing
7883 the length of our field. If this is a typedef,
7884 get the length of the target type, not the length
7886 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7887 field_type
= ada_typedef_target_type (field_type
);
7890 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7893 if (off
+ fld_bit_len
> bit_len
)
7894 bit_len
= off
+ fld_bit_len
;
7896 TYPE_LENGTH (rtype
) =
7897 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7900 /* We handle the variant part, if any, at the end because of certain
7901 odd cases in which it is re-ordered so as NOT to be the last field of
7902 the record. This can happen in the presence of representation
7904 if (variant_field
>= 0)
7906 struct type
*branch_type
;
7908 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7912 /* Using plain value_from_contents_and_address here causes
7913 problems because we will end up trying to resolve a type
7914 that is currently being constructed. */
7915 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
7917 rtype
= value_type (dval
);
7923 to_fixed_variant_branch_type
7924 (type
->field (variant_field
).type (),
7925 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7926 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7927 if (branch_type
== NULL
)
7929 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
7930 rtype
->field (f
- 1) = rtype
->field (f
);
7931 rtype
->set_num_fields (rtype
->num_fields () - 1);
7935 rtype
->field (variant_field
).set_type (branch_type
);
7936 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7938 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
7940 if (off
+ fld_bit_len
> bit_len
)
7941 bit_len
= off
+ fld_bit_len
;
7942 TYPE_LENGTH (rtype
) =
7943 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7947 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7948 should contain the alignment of that record, which should be a strictly
7949 positive value. If null or negative, then something is wrong, most
7950 probably in the debug info. In that case, we don't round up the size
7951 of the resulting type. If this record is not part of another structure,
7952 the current RTYPE length might be good enough for our purposes. */
7953 if (TYPE_LENGTH (type
) <= 0)
7956 warning (_("Invalid type size for `%s' detected: %s."),
7957 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
7959 warning (_("Invalid type size for <unnamed> detected: %s."),
7960 pulongest (TYPE_LENGTH (type
)));
7964 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
7965 TYPE_LENGTH (type
));
7968 value_free_to_mark (mark
);
7969 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7970 error (_("record type with dynamic size is larger than varsize-limit"));
7974 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7977 static struct type
*
7978 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7979 CORE_ADDR address
, struct value
*dval0
)
7981 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7985 /* An ordinary record type in which ___XVL-convention fields and
7986 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7987 static approximations, containing all possible fields. Uses
7988 no runtime values. Useless for use in values, but that's OK,
7989 since the results are used only for type determinations. Works on both
7990 structs and unions. Representation note: to save space, we memorize
7991 the result of this function in the TYPE_TARGET_TYPE of the
7994 static struct type
*
7995 template_to_static_fixed_type (struct type
*type0
)
8001 /* No need no do anything if the input type is already fixed. */
8002 if (type0
->is_fixed_instance ())
8005 /* Likewise if we already have computed the static approximation. */
8006 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8007 return TYPE_TARGET_TYPE (type0
);
8009 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8011 nfields
= type0
->num_fields ();
8013 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8014 recompute all over next time. */
8015 TYPE_TARGET_TYPE (type0
) = type
;
8017 for (f
= 0; f
< nfields
; f
+= 1)
8019 struct type
*field_type
= type0
->field (f
).type ();
8020 struct type
*new_type
;
8022 if (is_dynamic_field (type0
, f
))
8024 field_type
= ada_check_typedef (field_type
);
8025 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8028 new_type
= static_unwrap_type (field_type
);
8030 if (new_type
!= field_type
)
8032 /* Clone TYPE0 only the first time we get a new field type. */
8035 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8036 type
->set_code (type0
->code ());
8037 INIT_NONE_SPECIFIC (type
);
8038 type
->set_num_fields (nfields
);
8042 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8043 memcpy (fields
, type0
->fields (),
8044 sizeof (struct field
) * nfields
);
8045 type
->set_fields (fields
);
8047 type
->set_name (ada_type_name (type0
));
8048 type
->set_is_fixed_instance (true);
8049 TYPE_LENGTH (type
) = 0;
8051 type
->field (f
).set_type (new_type
);
8052 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8059 /* Given an object of type TYPE whose contents are at VALADDR and
8060 whose address in memory is ADDRESS, returns a revision of TYPE,
8061 which should be a non-dynamic-sized record, in which the variant
8062 part, if any, is replaced with the appropriate branch. Looks
8063 for discriminant values in DVAL0, which can be NULL if the record
8064 contains the necessary discriminant values. */
8066 static struct type
*
8067 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8068 CORE_ADDR address
, struct value
*dval0
)
8070 struct value
*mark
= value_mark ();
8073 struct type
*branch_type
;
8074 int nfields
= type
->num_fields ();
8075 int variant_field
= variant_field_index (type
);
8077 if (variant_field
== -1)
8082 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8083 type
= value_type (dval
);
8088 rtype
= alloc_type_copy (type
);
8089 rtype
->set_code (TYPE_CODE_STRUCT
);
8090 INIT_NONE_SPECIFIC (rtype
);
8091 rtype
->set_num_fields (nfields
);
8094 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8095 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8096 rtype
->set_fields (fields
);
8098 rtype
->set_name (ada_type_name (type
));
8099 rtype
->set_is_fixed_instance (true);
8100 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8102 branch_type
= to_fixed_variant_branch_type
8103 (type
->field (variant_field
).type (),
8104 cond_offset_host (valaddr
,
8105 TYPE_FIELD_BITPOS (type
, variant_field
)
8107 cond_offset_target (address
,
8108 TYPE_FIELD_BITPOS (type
, variant_field
)
8109 / TARGET_CHAR_BIT
), dval
);
8110 if (branch_type
== NULL
)
8114 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8115 rtype
->field (f
- 1) = rtype
->field (f
);
8116 rtype
->set_num_fields (rtype
->num_fields () - 1);
8120 rtype
->field (variant_field
).set_type (branch_type
);
8121 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8122 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8123 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8125 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8127 value_free_to_mark (mark
);
8131 /* An ordinary record type (with fixed-length fields) that describes
8132 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8133 beginning of this section]. Any necessary discriminants' values
8134 should be in DVAL, a record value; it may be NULL if the object
8135 at ADDR itself contains any necessary discriminant values.
8136 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8137 values from the record are needed. Except in the case that DVAL,
8138 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8139 unchecked) is replaced by a particular branch of the variant.
8141 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8142 is questionable and may be removed. It can arise during the
8143 processing of an unconstrained-array-of-record type where all the
8144 variant branches have exactly the same size. This is because in
8145 such cases, the compiler does not bother to use the XVS convention
8146 when encoding the record. I am currently dubious of this
8147 shortcut and suspect the compiler should be altered. FIXME. */
8149 static struct type
*
8150 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8151 CORE_ADDR address
, struct value
*dval
)
8153 struct type
*templ_type
;
8155 if (type0
->is_fixed_instance ())
8158 templ_type
= dynamic_template_type (type0
);
8160 if (templ_type
!= NULL
)
8161 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8162 else if (variant_field_index (type0
) >= 0)
8164 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8166 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8171 type0
->set_is_fixed_instance (true);
8177 /* An ordinary record type (with fixed-length fields) that describes
8178 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8179 union type. Any necessary discriminants' values should be in DVAL,
8180 a record value. That is, this routine selects the appropriate
8181 branch of the union at ADDR according to the discriminant value
8182 indicated in the union's type name. Returns VAR_TYPE0 itself if
8183 it represents a variant subject to a pragma Unchecked_Union. */
8185 static struct type
*
8186 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8187 CORE_ADDR address
, struct value
*dval
)
8190 struct type
*templ_type
;
8191 struct type
*var_type
;
8193 if (var_type0
->code () == TYPE_CODE_PTR
)
8194 var_type
= TYPE_TARGET_TYPE (var_type0
);
8196 var_type
= var_type0
;
8198 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8200 if (templ_type
!= NULL
)
8201 var_type
= templ_type
;
8203 if (is_unchecked_variant (var_type
, value_type (dval
)))
8205 which
= ada_which_variant_applies (var_type
, dval
);
8208 return empty_record (var_type
);
8209 else if (is_dynamic_field (var_type
, which
))
8210 return to_fixed_record_type
8211 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8212 valaddr
, address
, dval
);
8213 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8215 to_fixed_record_type
8216 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8218 return var_type
->field (which
).type ();
8221 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8222 ENCODING_TYPE, a type following the GNAT conventions for discrete
8223 type encodings, only carries redundant information. */
8226 ada_is_redundant_range_encoding (struct type
*range_type
,
8227 struct type
*encoding_type
)
8229 const char *bounds_str
;
8233 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8235 if (get_base_type (range_type
)->code ()
8236 != get_base_type (encoding_type
)->code ())
8238 /* The compiler probably used a simple base type to describe
8239 the range type instead of the range's actual base type,
8240 expecting us to get the real base type from the encoding
8241 anyway. In this situation, the encoding cannot be ignored
8246 if (is_dynamic_type (range_type
))
8249 if (encoding_type
->name () == NULL
)
8252 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8253 if (bounds_str
== NULL
)
8256 n
= 8; /* Skip "___XDLU_". */
8257 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8259 if (range_type
->bounds ()->low
.const_val () != lo
)
8262 n
+= 2; /* Skip the "__" separator between the two bounds. */
8263 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8265 if (range_type
->bounds ()->high
.const_val () != hi
)
8271 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8272 a type following the GNAT encoding for describing array type
8273 indices, only carries redundant information. */
8276 ada_is_redundant_index_type_desc (struct type
*array_type
,
8277 struct type
*desc_type
)
8279 struct type
*this_layer
= check_typedef (array_type
);
8282 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8284 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8285 desc_type
->field (i
).type ()))
8287 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8293 /* Assuming that TYPE0 is an array type describing the type of a value
8294 at ADDR, and that DVAL describes a record containing any
8295 discriminants used in TYPE0, returns a type for the value that
8296 contains no dynamic components (that is, no components whose sizes
8297 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8298 true, gives an error message if the resulting type's size is over
8301 static struct type
*
8302 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8305 struct type
*index_type_desc
;
8306 struct type
*result
;
8307 int constrained_packed_array_p
;
8308 static const char *xa_suffix
= "___XA";
8310 type0
= ada_check_typedef (type0
);
8311 if (type0
->is_fixed_instance ())
8314 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8315 if (constrained_packed_array_p
)
8317 type0
= decode_constrained_packed_array_type (type0
);
8318 if (type0
== nullptr)
8319 error (_("could not decode constrained packed array type"));
8322 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8324 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8325 encoding suffixed with 'P' may still be generated. If so,
8326 it should be used to find the XA type. */
8328 if (index_type_desc
== NULL
)
8330 const char *type_name
= ada_type_name (type0
);
8332 if (type_name
!= NULL
)
8334 const int len
= strlen (type_name
);
8335 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8337 if (type_name
[len
- 1] == 'P')
8339 strcpy (name
, type_name
);
8340 strcpy (name
+ len
- 1, xa_suffix
);
8341 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8346 ada_fixup_array_indexes_type (index_type_desc
);
8347 if (index_type_desc
!= NULL
8348 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8350 /* Ignore this ___XA parallel type, as it does not bring any
8351 useful information. This allows us to avoid creating fixed
8352 versions of the array's index types, which would be identical
8353 to the original ones. This, in turn, can also help avoid
8354 the creation of fixed versions of the array itself. */
8355 index_type_desc
= NULL
;
8358 if (index_type_desc
== NULL
)
8360 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8362 /* NOTE: elt_type---the fixed version of elt_type0---should never
8363 depend on the contents of the array in properly constructed
8365 /* Create a fixed version of the array element type.
8366 We're not providing the address of an element here,
8367 and thus the actual object value cannot be inspected to do
8368 the conversion. This should not be a problem, since arrays of
8369 unconstrained objects are not allowed. In particular, all
8370 the elements of an array of a tagged type should all be of
8371 the same type specified in the debugging info. No need to
8372 consult the object tag. */
8373 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8375 /* Make sure we always create a new array type when dealing with
8376 packed array types, since we're going to fix-up the array
8377 type length and element bitsize a little further down. */
8378 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8381 result
= create_array_type (alloc_type_copy (type0
),
8382 elt_type
, type0
->index_type ());
8387 struct type
*elt_type0
;
8390 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8391 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8393 /* NOTE: result---the fixed version of elt_type0---should never
8394 depend on the contents of the array in properly constructed
8396 /* Create a fixed version of the array element type.
8397 We're not providing the address of an element here,
8398 and thus the actual object value cannot be inspected to do
8399 the conversion. This should not be a problem, since arrays of
8400 unconstrained objects are not allowed. In particular, all
8401 the elements of an array of a tagged type should all be of
8402 the same type specified in the debugging info. No need to
8403 consult the object tag. */
8405 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8408 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8410 struct type
*range_type
=
8411 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8413 result
= create_array_type (alloc_type_copy (elt_type0
),
8414 result
, range_type
);
8415 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8417 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8418 error (_("array type with dynamic size is larger than varsize-limit"));
8421 /* We want to preserve the type name. This can be useful when
8422 trying to get the type name of a value that has already been
8423 printed (for instance, if the user did "print VAR; whatis $". */
8424 result
->set_name (type0
->name ());
8426 if (constrained_packed_array_p
)
8428 /* So far, the resulting type has been created as if the original
8429 type was a regular (non-packed) array type. As a result, the
8430 bitsize of the array elements needs to be set again, and the array
8431 length needs to be recomputed based on that bitsize. */
8432 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8433 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8435 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8436 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8437 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8438 TYPE_LENGTH (result
)++;
8441 result
->set_is_fixed_instance (true);
8446 /* A standard type (containing no dynamically sized components)
8447 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8448 DVAL describes a record containing any discriminants used in TYPE0,
8449 and may be NULL if there are none, or if the object of type TYPE at
8450 ADDRESS or in VALADDR contains these discriminants.
8452 If CHECK_TAG is not null, in the case of tagged types, this function
8453 attempts to locate the object's tag and use it to compute the actual
8454 type. However, when ADDRESS is null, we cannot use it to determine the
8455 location of the tag, and therefore compute the tagged type's actual type.
8456 So we return the tagged type without consulting the tag. */
8458 static struct type
*
8459 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8460 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8462 type
= ada_check_typedef (type
);
8464 /* Only un-fixed types need to be handled here. */
8465 if (!HAVE_GNAT_AUX_INFO (type
))
8468 switch (type
->code ())
8472 case TYPE_CODE_STRUCT
:
8474 struct type
*static_type
= to_static_fixed_type (type
);
8475 struct type
*fixed_record_type
=
8476 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8478 /* If STATIC_TYPE is a tagged type and we know the object's address,
8479 then we can determine its tag, and compute the object's actual
8480 type from there. Note that we have to use the fixed record
8481 type (the parent part of the record may have dynamic fields
8482 and the way the location of _tag is expressed may depend on
8485 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8488 value_tag_from_contents_and_address
8492 struct type
*real_type
= type_from_tag (tag
);
8494 value_from_contents_and_address (fixed_record_type
,
8497 fixed_record_type
= value_type (obj
);
8498 if (real_type
!= NULL
)
8499 return to_fixed_record_type
8501 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8504 /* Check to see if there is a parallel ___XVZ variable.
8505 If there is, then it provides the actual size of our type. */
8506 else if (ada_type_name (fixed_record_type
) != NULL
)
8508 const char *name
= ada_type_name (fixed_record_type
);
8510 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8511 bool xvz_found
= false;
8514 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8517 xvz_found
= get_int_var_value (xvz_name
, size
);
8519 catch (const gdb_exception_error
&except
)
8521 /* We found the variable, but somehow failed to read
8522 its value. Rethrow the same error, but with a little
8523 bit more information, to help the user understand
8524 what went wrong (Eg: the variable might have been
8526 throw_error (except
.error
,
8527 _("unable to read value of %s (%s)"),
8528 xvz_name
, except
.what ());
8531 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8533 fixed_record_type
= copy_type (fixed_record_type
);
8534 TYPE_LENGTH (fixed_record_type
) = size
;
8536 /* The FIXED_RECORD_TYPE may have be a stub. We have
8537 observed this when the debugging info is STABS, and
8538 apparently it is something that is hard to fix.
8540 In practice, we don't need the actual type definition
8541 at all, because the presence of the XVZ variable allows us
8542 to assume that there must be a XVS type as well, which we
8543 should be able to use later, when we need the actual type
8546 In the meantime, pretend that the "fixed" type we are
8547 returning is NOT a stub, because this can cause trouble
8548 when using this type to create new types targeting it.
8549 Indeed, the associated creation routines often check
8550 whether the target type is a stub and will try to replace
8551 it, thus using a type with the wrong size. This, in turn,
8552 might cause the new type to have the wrong size too.
8553 Consider the case of an array, for instance, where the size
8554 of the array is computed from the number of elements in
8555 our array multiplied by the size of its element. */
8556 fixed_record_type
->set_is_stub (false);
8559 return fixed_record_type
;
8561 case TYPE_CODE_ARRAY
:
8562 return to_fixed_array_type (type
, dval
, 1);
8563 case TYPE_CODE_UNION
:
8567 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8571 /* The same as ada_to_fixed_type_1, except that it preserves the type
8572 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8574 The typedef layer needs be preserved in order to differentiate between
8575 arrays and array pointers when both types are implemented using the same
8576 fat pointer. In the array pointer case, the pointer is encoded as
8577 a typedef of the pointer type. For instance, considering:
8579 type String_Access is access String;
8580 S1 : String_Access := null;
8582 To the debugger, S1 is defined as a typedef of type String. But
8583 to the user, it is a pointer. So if the user tries to print S1,
8584 we should not dereference the array, but print the array address
8587 If we didn't preserve the typedef layer, we would lose the fact that
8588 the type is to be presented as a pointer (needs de-reference before
8589 being printed). And we would also use the source-level type name. */
8592 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8593 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8596 struct type
*fixed_type
=
8597 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8599 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8600 then preserve the typedef layer.
8602 Implementation note: We can only check the main-type portion of
8603 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8604 from TYPE now returns a type that has the same instance flags
8605 as TYPE. For instance, if TYPE is a "typedef const", and its
8606 target type is a "struct", then the typedef elimination will return
8607 a "const" version of the target type. See check_typedef for more
8608 details about how the typedef layer elimination is done.
8610 brobecker/2010-11-19: It seems to me that the only case where it is
8611 useful to preserve the typedef layer is when dealing with fat pointers.
8612 Perhaps, we could add a check for that and preserve the typedef layer
8613 only in that situation. But this seems unnecessary so far, probably
8614 because we call check_typedef/ada_check_typedef pretty much everywhere.
8616 if (type
->code () == TYPE_CODE_TYPEDEF
8617 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8618 == TYPE_MAIN_TYPE (fixed_type
)))
8624 /* A standard (static-sized) type corresponding as well as possible to
8625 TYPE0, but based on no runtime data. */
8627 static struct type
*
8628 to_static_fixed_type (struct type
*type0
)
8635 if (type0
->is_fixed_instance ())
8638 type0
= ada_check_typedef (type0
);
8640 switch (type0
->code ())
8644 case TYPE_CODE_STRUCT
:
8645 type
= dynamic_template_type (type0
);
8647 return template_to_static_fixed_type (type
);
8649 return template_to_static_fixed_type (type0
);
8650 case TYPE_CODE_UNION
:
8651 type
= ada_find_parallel_type (type0
, "___XVU");
8653 return template_to_static_fixed_type (type
);
8655 return template_to_static_fixed_type (type0
);
8659 /* A static approximation of TYPE with all type wrappers removed. */
8661 static struct type
*
8662 static_unwrap_type (struct type
*type
)
8664 if (ada_is_aligner_type (type
))
8666 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8667 if (ada_type_name (type1
) == NULL
)
8668 type1
->set_name (ada_type_name (type
));
8670 return static_unwrap_type (type1
);
8674 struct type
*raw_real_type
= ada_get_base_type (type
);
8676 if (raw_real_type
== type
)
8679 return to_static_fixed_type (raw_real_type
);
8683 /* In some cases, incomplete and private types require
8684 cross-references that are not resolved as records (for example,
8686 type FooP is access Foo;
8688 type Foo is array ...;
8689 ). In these cases, since there is no mechanism for producing
8690 cross-references to such types, we instead substitute for FooP a
8691 stub enumeration type that is nowhere resolved, and whose tag is
8692 the name of the actual type. Call these types "non-record stubs". */
8694 /* A type equivalent to TYPE that is not a non-record stub, if one
8695 exists, otherwise TYPE. */
8698 ada_check_typedef (struct type
*type
)
8703 /* If our type is an access to an unconstrained array, which is encoded
8704 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8705 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8706 what allows us to distinguish between fat pointers that represent
8707 array types, and fat pointers that represent array access types
8708 (in both cases, the compiler implements them as fat pointers). */
8709 if (ada_is_access_to_unconstrained_array (type
))
8712 type
= check_typedef (type
);
8713 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8714 || !type
->is_stub ()
8715 || type
->name () == NULL
)
8719 const char *name
= type
->name ();
8720 struct type
*type1
= ada_find_any_type (name
);
8725 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8726 stubs pointing to arrays, as we don't create symbols for array
8727 types, only for the typedef-to-array types). If that's the case,
8728 strip the typedef layer. */
8729 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8730 type1
= ada_check_typedef (type1
);
8736 /* A value representing the data at VALADDR/ADDRESS as described by
8737 type TYPE0, but with a standard (static-sized) type that correctly
8738 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8739 type, then return VAL0 [this feature is simply to avoid redundant
8740 creation of struct values]. */
8742 static struct value
*
8743 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8746 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8748 if (type
== type0
&& val0
!= NULL
)
8751 if (VALUE_LVAL (val0
) != lval_memory
)
8753 /* Our value does not live in memory; it could be a convenience
8754 variable, for instance. Create a not_lval value using val0's
8756 return value_from_contents (type
, value_contents (val0
));
8759 return value_from_contents_and_address (type
, 0, address
);
8762 /* A value representing VAL, but with a standard (static-sized) type
8763 that correctly describes it. Does not necessarily create a new
8767 ada_to_fixed_value (struct value
*val
)
8769 val
= unwrap_value (val
);
8770 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8777 /* Table mapping attribute numbers to names.
8778 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8780 static const char * const attribute_names
[] = {
8798 ada_attribute_name (enum exp_opcode n
)
8800 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8801 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8803 return attribute_names
[0];
8806 /* Evaluate the 'POS attribute applied to ARG. */
8809 pos_atr (struct value
*arg
)
8811 struct value
*val
= coerce_ref (arg
);
8812 struct type
*type
= value_type (val
);
8814 if (!discrete_type_p (type
))
8815 error (_("'POS only defined on discrete types"));
8817 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8818 if (!result
.has_value ())
8819 error (_("enumeration value is invalid: can't find 'POS"));
8824 static struct value
*
8825 value_pos_atr (struct type
*type
, struct value
*arg
)
8827 return value_from_longest (type
, pos_atr (arg
));
8830 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8832 static struct value
*
8833 val_atr (struct type
*type
, LONGEST val
)
8835 gdb_assert (discrete_type_p (type
));
8836 if (type
->code () == TYPE_CODE_RANGE
)
8837 type
= TYPE_TARGET_TYPE (type
);
8838 if (type
->code () == TYPE_CODE_ENUM
)
8840 if (val
< 0 || val
>= type
->num_fields ())
8841 error (_("argument to 'VAL out of range"));
8842 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8844 return value_from_longest (type
, val
);
8847 static struct value
*
8848 value_val_atr (struct type
*type
, struct value
*arg
)
8850 if (!discrete_type_p (type
))
8851 error (_("'VAL only defined on discrete types"));
8852 if (!integer_type_p (value_type (arg
)))
8853 error (_("'VAL requires integral argument"));
8855 return val_atr (type
, value_as_long (arg
));
8861 /* True if TYPE appears to be an Ada character type.
8862 [At the moment, this is true only for Character and Wide_Character;
8863 It is a heuristic test that could stand improvement]. */
8866 ada_is_character_type (struct type
*type
)
8870 /* If the type code says it's a character, then assume it really is,
8871 and don't check any further. */
8872 if (type
->code () == TYPE_CODE_CHAR
)
8875 /* Otherwise, assume it's a character type iff it is a discrete type
8876 with a known character type name. */
8877 name
= ada_type_name (type
);
8878 return (name
!= NULL
8879 && (type
->code () == TYPE_CODE_INT
8880 || type
->code () == TYPE_CODE_RANGE
)
8881 && (strcmp (name
, "character") == 0
8882 || strcmp (name
, "wide_character") == 0
8883 || strcmp (name
, "wide_wide_character") == 0
8884 || strcmp (name
, "unsigned char") == 0));
8887 /* True if TYPE appears to be an Ada string type. */
8890 ada_is_string_type (struct type
*type
)
8892 type
= ada_check_typedef (type
);
8894 && type
->code () != TYPE_CODE_PTR
8895 && (ada_is_simple_array_type (type
)
8896 || ada_is_array_descriptor_type (type
))
8897 && ada_array_arity (type
) == 1)
8899 struct type
*elttype
= ada_array_element_type (type
, 1);
8901 return ada_is_character_type (elttype
);
8907 /* The compiler sometimes provides a parallel XVS type for a given
8908 PAD type. Normally, it is safe to follow the PAD type directly,
8909 but older versions of the compiler have a bug that causes the offset
8910 of its "F" field to be wrong. Following that field in that case
8911 would lead to incorrect results, but this can be worked around
8912 by ignoring the PAD type and using the associated XVS type instead.
8914 Set to True if the debugger should trust the contents of PAD types.
8915 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8916 static bool trust_pad_over_xvs
= true;
8918 /* True if TYPE is a struct type introduced by the compiler to force the
8919 alignment of a value. Such types have a single field with a
8920 distinctive name. */
8923 ada_is_aligner_type (struct type
*type
)
8925 type
= ada_check_typedef (type
);
8927 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
8930 return (type
->code () == TYPE_CODE_STRUCT
8931 && type
->num_fields () == 1
8932 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8935 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8936 the parallel type. */
8939 ada_get_base_type (struct type
*raw_type
)
8941 struct type
*real_type_namer
;
8942 struct type
*raw_real_type
;
8944 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
8947 if (ada_is_aligner_type (raw_type
))
8948 /* The encoding specifies that we should always use the aligner type.
8949 So, even if this aligner type has an associated XVS type, we should
8952 According to the compiler gurus, an XVS type parallel to an aligner
8953 type may exist because of a stabs limitation. In stabs, aligner
8954 types are empty because the field has a variable-sized type, and
8955 thus cannot actually be used as an aligner type. As a result,
8956 we need the associated parallel XVS type to decode the type.
8957 Since the policy in the compiler is to not change the internal
8958 representation based on the debugging info format, we sometimes
8959 end up having a redundant XVS type parallel to the aligner type. */
8962 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8963 if (real_type_namer
== NULL
8964 || real_type_namer
->code () != TYPE_CODE_STRUCT
8965 || real_type_namer
->num_fields () != 1)
8968 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
8970 /* This is an older encoding form where the base type needs to be
8971 looked up by name. We prefer the newer encoding because it is
8973 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8974 if (raw_real_type
== NULL
)
8977 return raw_real_type
;
8980 /* The field in our XVS type is a reference to the base type. */
8981 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
8984 /* The type of value designated by TYPE, with all aligners removed. */
8987 ada_aligned_type (struct type
*type
)
8989 if (ada_is_aligner_type (type
))
8990 return ada_aligned_type (type
->field (0).type ());
8992 return ada_get_base_type (type
);
8996 /* The address of the aligned value in an object at address VALADDR
8997 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9000 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9002 if (ada_is_aligner_type (type
))
9003 return ada_aligned_value_addr (type
->field (0).type (),
9005 TYPE_FIELD_BITPOS (type
,
9006 0) / TARGET_CHAR_BIT
);
9013 /* The printed representation of an enumeration literal with encoded
9014 name NAME. The value is good to the next call of ada_enum_name. */
9016 ada_enum_name (const char *name
)
9018 static std::string storage
;
9021 /* First, unqualify the enumeration name:
9022 1. Search for the last '.' character. If we find one, then skip
9023 all the preceding characters, the unqualified name starts
9024 right after that dot.
9025 2. Otherwise, we may be debugging on a target where the compiler
9026 translates dots into "__". Search forward for double underscores,
9027 but stop searching when we hit an overloading suffix, which is
9028 of the form "__" followed by digits. */
9030 tmp
= strrchr (name
, '.');
9035 while ((tmp
= strstr (name
, "__")) != NULL
)
9037 if (isdigit (tmp
[2]))
9048 if (name
[1] == 'U' || name
[1] == 'W')
9050 if (sscanf (name
+ 2, "%x", &v
) != 1)
9053 else if (((name
[1] >= '0' && name
[1] <= '9')
9054 || (name
[1] >= 'a' && name
[1] <= 'z'))
9057 storage
= string_printf ("'%c'", name
[1]);
9058 return storage
.c_str ();
9063 if (isascii (v
) && isprint (v
))
9064 storage
= string_printf ("'%c'", v
);
9065 else if (name
[1] == 'U')
9066 storage
= string_printf ("[\"%02x\"]", v
);
9068 storage
= string_printf ("[\"%04x\"]", v
);
9070 return storage
.c_str ();
9074 tmp
= strstr (name
, "__");
9076 tmp
= strstr (name
, "$");
9079 storage
= std::string (name
, tmp
- name
);
9080 return storage
.c_str ();
9087 /* Evaluate the subexpression of EXP starting at *POS as for
9088 evaluate_type, updating *POS to point just past the evaluated
9091 static struct value
*
9092 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9094 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9097 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9100 static struct value
*
9101 unwrap_value (struct value
*val
)
9103 struct type
*type
= ada_check_typedef (value_type (val
));
9105 if (ada_is_aligner_type (type
))
9107 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9108 struct type
*val_type
= ada_check_typedef (value_type (v
));
9110 if (ada_type_name (val_type
) == NULL
)
9111 val_type
->set_name (ada_type_name (type
));
9113 return unwrap_value (v
);
9117 struct type
*raw_real_type
=
9118 ada_check_typedef (ada_get_base_type (type
));
9120 /* If there is no parallel XVS or XVE type, then the value is
9121 already unwrapped. Return it without further modification. */
9122 if ((type
== raw_real_type
)
9123 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9127 coerce_unspec_val_to_type
9128 (val
, ada_to_fixed_type (raw_real_type
, 0,
9129 value_address (val
),
9134 /* Given two array types T1 and T2, return nonzero iff both arrays
9135 contain the same number of elements. */
9138 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9140 LONGEST lo1
, hi1
, lo2
, hi2
;
9142 /* Get the array bounds in order to verify that the size of
9143 the two arrays match. */
9144 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9145 || !get_array_bounds (t2
, &lo2
, &hi2
))
9146 error (_("unable to determine array bounds"));
9148 /* To make things easier for size comparison, normalize a bit
9149 the case of empty arrays by making sure that the difference
9150 between upper bound and lower bound is always -1. */
9156 return (hi1
- lo1
== hi2
- lo2
);
9159 /* Assuming that VAL is an array of integrals, and TYPE represents
9160 an array with the same number of elements, but with wider integral
9161 elements, return an array "casted" to TYPE. In practice, this
9162 means that the returned array is built by casting each element
9163 of the original array into TYPE's (wider) element type. */
9165 static struct value
*
9166 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9168 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9173 /* Verify that both val and type are arrays of scalars, and
9174 that the size of val's elements is smaller than the size
9175 of type's element. */
9176 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9177 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9178 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9179 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9180 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9181 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9183 if (!get_array_bounds (type
, &lo
, &hi
))
9184 error (_("unable to determine array bounds"));
9186 res
= allocate_value (type
);
9188 /* Promote each array element. */
9189 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9191 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9193 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9194 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9200 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9201 return the converted value. */
9203 static struct value
*
9204 coerce_for_assign (struct type
*type
, struct value
*val
)
9206 struct type
*type2
= value_type (val
);
9211 type2
= ada_check_typedef (type2
);
9212 type
= ada_check_typedef (type
);
9214 if (type2
->code () == TYPE_CODE_PTR
9215 && type
->code () == TYPE_CODE_ARRAY
)
9217 val
= ada_value_ind (val
);
9218 type2
= value_type (val
);
9221 if (type2
->code () == TYPE_CODE_ARRAY
9222 && type
->code () == TYPE_CODE_ARRAY
)
9224 if (!ada_same_array_size_p (type
, type2
))
9225 error (_("cannot assign arrays of different length"));
9227 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9228 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9229 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9230 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9232 /* Allow implicit promotion of the array elements to
9234 return ada_promote_array_of_integrals (type
, val
);
9237 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9238 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9239 error (_("Incompatible types in assignment"));
9240 deprecated_set_value_type (val
, type
);
9245 static struct value
*
9246 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9249 struct type
*type1
, *type2
;
9252 arg1
= coerce_ref (arg1
);
9253 arg2
= coerce_ref (arg2
);
9254 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9255 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9257 if (type1
->code () != TYPE_CODE_INT
9258 || type2
->code () != TYPE_CODE_INT
)
9259 return value_binop (arg1
, arg2
, op
);
9268 return value_binop (arg1
, arg2
, op
);
9271 v2
= value_as_long (arg2
);
9273 error (_("second operand of %s must not be zero."), op_string (op
));
9275 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9276 return value_binop (arg1
, arg2
, op
);
9278 v1
= value_as_long (arg1
);
9283 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9284 v
+= v
> 0 ? -1 : 1;
9292 /* Should not reach this point. */
9296 val
= allocate_value (type1
);
9297 store_unsigned_integer (value_contents_raw (val
),
9298 TYPE_LENGTH (value_type (val
)),
9299 type_byte_order (type1
), v
);
9304 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9306 if (ada_is_direct_array_type (value_type (arg1
))
9307 || ada_is_direct_array_type (value_type (arg2
)))
9309 struct type
*arg1_type
, *arg2_type
;
9311 /* Automatically dereference any array reference before
9312 we attempt to perform the comparison. */
9313 arg1
= ada_coerce_ref (arg1
);
9314 arg2
= ada_coerce_ref (arg2
);
9316 arg1
= ada_coerce_to_simple_array (arg1
);
9317 arg2
= ada_coerce_to_simple_array (arg2
);
9319 arg1_type
= ada_check_typedef (value_type (arg1
));
9320 arg2_type
= ada_check_typedef (value_type (arg2
));
9322 if (arg1_type
->code () != TYPE_CODE_ARRAY
9323 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9324 error (_("Attempt to compare array with non-array"));
9325 /* FIXME: The following works only for types whose
9326 representations use all bits (no padding or undefined bits)
9327 and do not have user-defined equality. */
9328 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9329 && memcmp (value_contents (arg1
), value_contents (arg2
),
9330 TYPE_LENGTH (arg1_type
)) == 0);
9332 return value_equal (arg1
, arg2
);
9335 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9336 component of LHS (a simple array or a record), updating *POS past
9337 the expression, assuming that LHS is contained in CONTAINER. Does
9338 not modify the inferior's memory, nor does it modify LHS (unless
9339 LHS == CONTAINER). */
9342 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9343 struct expression
*exp
, int *pos
)
9345 struct value
*mark
= value_mark ();
9347 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9349 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9351 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9352 struct value
*index_val
= value_from_longest (index_type
, index
);
9354 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9358 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9359 elt
= ada_to_fixed_value (elt
);
9362 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9363 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9365 value_assign_to_component (container
, elt
,
9366 ada_evaluate_subexp (NULL
, exp
, pos
,
9369 value_free_to_mark (mark
);
9372 /* Assuming that LHS represents an lvalue having a record or array
9373 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9374 of that aggregate's value to LHS, advancing *POS past the
9375 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9376 lvalue containing LHS (possibly LHS itself). Does not modify
9377 the inferior's memory, nor does it modify the contents of
9378 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9380 static struct value
*
9381 assign_aggregate (struct value
*container
,
9382 struct value
*lhs
, struct expression
*exp
,
9383 int *pos
, enum noside noside
)
9385 struct type
*lhs_type
;
9386 int n
= exp
->elts
[*pos
+1].longconst
;
9387 LONGEST low_index
, high_index
;
9391 if (noside
!= EVAL_NORMAL
)
9393 for (i
= 0; i
< n
; i
+= 1)
9394 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9398 container
= ada_coerce_ref (container
);
9399 if (ada_is_direct_array_type (value_type (container
)))
9400 container
= ada_coerce_to_simple_array (container
);
9401 lhs
= ada_coerce_ref (lhs
);
9402 if (!deprecated_value_modifiable (lhs
))
9403 error (_("Left operand of assignment is not a modifiable lvalue."));
9405 lhs_type
= check_typedef (value_type (lhs
));
9406 if (ada_is_direct_array_type (lhs_type
))
9408 lhs
= ada_coerce_to_simple_array (lhs
);
9409 lhs_type
= check_typedef (value_type (lhs
));
9410 low_index
= lhs_type
->bounds ()->low
.const_val ();
9411 high_index
= lhs_type
->bounds ()->high
.const_val ();
9413 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9416 high_index
= num_visible_fields (lhs_type
) - 1;
9419 error (_("Left-hand side must be array or record."));
9421 std::vector
<LONGEST
> indices (4);
9422 indices
[0] = indices
[1] = low_index
- 1;
9423 indices
[2] = indices
[3] = high_index
+ 1;
9425 for (i
= 0; i
< n
; i
+= 1)
9427 switch (exp
->elts
[*pos
].opcode
)
9430 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9431 low_index
, high_index
);
9434 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9435 low_index
, high_index
);
9439 error (_("Misplaced 'others' clause"));
9440 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9441 low_index
, high_index
);
9444 error (_("Internal error: bad aggregate clause"));
9451 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9452 construct at *POS, updating *POS past the construct, given that
9453 the positions are relative to lower bound LOW, where HIGH is the
9454 upper bound. Record the position in INDICES. CONTAINER is as for
9455 assign_aggregate. */
9457 aggregate_assign_positional (struct value
*container
,
9458 struct value
*lhs
, struct expression
*exp
,
9459 int *pos
, std::vector
<LONGEST
> &indices
,
9460 LONGEST low
, LONGEST high
)
9462 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9464 if (ind
- 1 == high
)
9465 warning (_("Extra components in aggregate ignored."));
9468 add_component_interval (ind
, ind
, indices
);
9470 assign_component (container
, lhs
, ind
, exp
, pos
);
9473 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9476 /* Assign into the components of LHS indexed by the OP_CHOICES
9477 construct at *POS, updating *POS past the construct, given that
9478 the allowable indices are LOW..HIGH. Record the indices assigned
9479 to in INDICES. CONTAINER is as for assign_aggregate. */
9481 aggregate_assign_from_choices (struct value
*container
,
9482 struct value
*lhs
, struct expression
*exp
,
9483 int *pos
, std::vector
<LONGEST
> &indices
,
9484 LONGEST low
, LONGEST high
)
9487 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9488 int choice_pos
, expr_pc
;
9489 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9491 choice_pos
= *pos
+= 3;
9493 for (j
= 0; j
< n_choices
; j
+= 1)
9494 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9496 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9498 for (j
= 0; j
< n_choices
; j
+= 1)
9500 LONGEST lower
, upper
;
9501 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9503 if (op
== OP_DISCRETE_RANGE
)
9506 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9508 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9513 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9525 name
= &exp
->elts
[choice_pos
+ 2].string
;
9528 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9531 error (_("Invalid record component association."));
9533 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9535 if (! find_struct_field (name
, value_type (lhs
), 0,
9536 NULL
, NULL
, NULL
, NULL
, &ind
))
9537 error (_("Unknown component name: %s."), name
);
9538 lower
= upper
= ind
;
9541 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9542 error (_("Index in component association out of bounds."));
9544 add_component_interval (lower
, upper
, indices
);
9545 while (lower
<= upper
)
9550 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9556 /* Assign the value of the expression in the OP_OTHERS construct in
9557 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9558 have not been previously assigned. The index intervals already assigned
9559 are in INDICES. Updates *POS to after the OP_OTHERS clause.
9560 CONTAINER is as for assign_aggregate. */
9562 aggregate_assign_others (struct value
*container
,
9563 struct value
*lhs
, struct expression
*exp
,
9564 int *pos
, std::vector
<LONGEST
> &indices
,
9565 LONGEST low
, LONGEST high
)
9568 int expr_pc
= *pos
+ 1;
9570 int num_indices
= indices
.size ();
9571 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9575 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9580 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9583 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9586 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9587 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9590 add_component_interval (LONGEST low
, LONGEST high
,
9591 std::vector
<LONGEST
> &indices
)
9595 int size
= indices
.size ();
9596 for (i
= 0; i
< size
; i
+= 2) {
9597 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9601 for (kh
= i
+ 2; kh
< size
; kh
+= 2)
9602 if (high
< indices
[kh
])
9604 if (low
< indices
[i
])
9606 indices
[i
+ 1] = indices
[kh
- 1];
9607 if (high
> indices
[i
+ 1])
9608 indices
[i
+ 1] = high
;
9609 memcpy (indices
.data () + i
+ 2, indices
.data () + kh
, size
- kh
);
9610 indices
.resize (kh
- i
- 2);
9613 else if (high
< indices
[i
])
9617 indices
.resize (indices
.size () + 2);
9618 for (j
= indices
.size () - 1; j
>= i
+ 2; j
-= 1)
9619 indices
[j
] = indices
[j
- 2];
9621 indices
[i
+ 1] = high
;
9624 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9627 static struct value
*
9628 ada_value_cast (struct type
*type
, struct value
*arg2
)
9630 if (type
== ada_check_typedef (value_type (arg2
)))
9633 return value_cast (type
, arg2
);
9636 /* Evaluating Ada expressions, and printing their result.
9637 ------------------------------------------------------
9642 We usually evaluate an Ada expression in order to print its value.
9643 We also evaluate an expression in order to print its type, which
9644 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9645 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9646 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9647 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9650 Evaluating expressions is a little more complicated for Ada entities
9651 than it is for entities in languages such as C. The main reason for
9652 this is that Ada provides types whose definition might be dynamic.
9653 One example of such types is variant records. Or another example
9654 would be an array whose bounds can only be known at run time.
9656 The following description is a general guide as to what should be
9657 done (and what should NOT be done) in order to evaluate an expression
9658 involving such types, and when. This does not cover how the semantic
9659 information is encoded by GNAT as this is covered separatly. For the
9660 document used as the reference for the GNAT encoding, see exp_dbug.ads
9661 in the GNAT sources.
9663 Ideally, we should embed each part of this description next to its
9664 associated code. Unfortunately, the amount of code is so vast right
9665 now that it's hard to see whether the code handling a particular
9666 situation might be duplicated or not. One day, when the code is
9667 cleaned up, this guide might become redundant with the comments
9668 inserted in the code, and we might want to remove it.
9670 2. ``Fixing'' an Entity, the Simple Case:
9671 -----------------------------------------
9673 When evaluating Ada expressions, the tricky issue is that they may
9674 reference entities whose type contents and size are not statically
9675 known. Consider for instance a variant record:
9677 type Rec (Empty : Boolean := True) is record
9680 when False => Value : Integer;
9683 Yes : Rec := (Empty => False, Value => 1);
9684 No : Rec := (empty => True);
9686 The size and contents of that record depends on the value of the
9687 descriminant (Rec.Empty). At this point, neither the debugging
9688 information nor the associated type structure in GDB are able to
9689 express such dynamic types. So what the debugger does is to create
9690 "fixed" versions of the type that applies to the specific object.
9691 We also informally refer to this operation as "fixing" an object,
9692 which means creating its associated fixed type.
9694 Example: when printing the value of variable "Yes" above, its fixed
9695 type would look like this:
9702 On the other hand, if we printed the value of "No", its fixed type
9709 Things become a little more complicated when trying to fix an entity
9710 with a dynamic type that directly contains another dynamic type,
9711 such as an array of variant records, for instance. There are
9712 two possible cases: Arrays, and records.
9714 3. ``Fixing'' Arrays:
9715 ---------------------
9717 The type structure in GDB describes an array in terms of its bounds,
9718 and the type of its elements. By design, all elements in the array
9719 have the same type and we cannot represent an array of variant elements
9720 using the current type structure in GDB. When fixing an array,
9721 we cannot fix the array element, as we would potentially need one
9722 fixed type per element of the array. As a result, the best we can do
9723 when fixing an array is to produce an array whose bounds and size
9724 are correct (allowing us to read it from memory), but without having
9725 touched its element type. Fixing each element will be done later,
9726 when (if) necessary.
9728 Arrays are a little simpler to handle than records, because the same
9729 amount of memory is allocated for each element of the array, even if
9730 the amount of space actually used by each element differs from element
9731 to element. Consider for instance the following array of type Rec:
9733 type Rec_Array is array (1 .. 2) of Rec;
9735 The actual amount of memory occupied by each element might be different
9736 from element to element, depending on the value of their discriminant.
9737 But the amount of space reserved for each element in the array remains
9738 fixed regardless. So we simply need to compute that size using
9739 the debugging information available, from which we can then determine
9740 the array size (we multiply the number of elements of the array by
9741 the size of each element).
9743 The simplest case is when we have an array of a constrained element
9744 type. For instance, consider the following type declarations:
9746 type Bounded_String (Max_Size : Integer) is
9748 Buffer : String (1 .. Max_Size);
9750 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9752 In this case, the compiler describes the array as an array of
9753 variable-size elements (identified by its XVS suffix) for which
9754 the size can be read in the parallel XVZ variable.
9756 In the case of an array of an unconstrained element type, the compiler
9757 wraps the array element inside a private PAD type. This type should not
9758 be shown to the user, and must be "unwrap"'ed before printing. Note
9759 that we also use the adjective "aligner" in our code to designate
9760 these wrapper types.
9762 In some cases, the size allocated for each element is statically
9763 known. In that case, the PAD type already has the correct size,
9764 and the array element should remain unfixed.
9766 But there are cases when this size is not statically known.
9767 For instance, assuming that "Five" is an integer variable:
9769 type Dynamic is array (1 .. Five) of Integer;
9770 type Wrapper (Has_Length : Boolean := False) is record
9773 when True => Length : Integer;
9777 type Wrapper_Array is array (1 .. 2) of Wrapper;
9779 Hello : Wrapper_Array := (others => (Has_Length => True,
9780 Data => (others => 17),
9784 The debugging info would describe variable Hello as being an
9785 array of a PAD type. The size of that PAD type is not statically
9786 known, but can be determined using a parallel XVZ variable.
9787 In that case, a copy of the PAD type with the correct size should
9788 be used for the fixed array.
9790 3. ``Fixing'' record type objects:
9791 ----------------------------------
9793 Things are slightly different from arrays in the case of dynamic
9794 record types. In this case, in order to compute the associated
9795 fixed type, we need to determine the size and offset of each of
9796 its components. This, in turn, requires us to compute the fixed
9797 type of each of these components.
9799 Consider for instance the example:
9801 type Bounded_String (Max_Size : Natural) is record
9802 Str : String (1 .. Max_Size);
9805 My_String : Bounded_String (Max_Size => 10);
9807 In that case, the position of field "Length" depends on the size
9808 of field Str, which itself depends on the value of the Max_Size
9809 discriminant. In order to fix the type of variable My_String,
9810 we need to fix the type of field Str. Therefore, fixing a variant
9811 record requires us to fix each of its components.
9813 However, if a component does not have a dynamic size, the component
9814 should not be fixed. In particular, fields that use a PAD type
9815 should not fixed. Here is an example where this might happen
9816 (assuming type Rec above):
9818 type Container (Big : Boolean) is record
9822 when True => Another : Integer;
9826 My_Container : Container := (Big => False,
9827 First => (Empty => True),
9830 In that example, the compiler creates a PAD type for component First,
9831 whose size is constant, and then positions the component After just
9832 right after it. The offset of component After is therefore constant
9835 The debugger computes the position of each field based on an algorithm
9836 that uses, among other things, the actual position and size of the field
9837 preceding it. Let's now imagine that the user is trying to print
9838 the value of My_Container. If the type fixing was recursive, we would
9839 end up computing the offset of field After based on the size of the
9840 fixed version of field First. And since in our example First has
9841 only one actual field, the size of the fixed type is actually smaller
9842 than the amount of space allocated to that field, and thus we would
9843 compute the wrong offset of field After.
9845 To make things more complicated, we need to watch out for dynamic
9846 components of variant records (identified by the ___XVL suffix in
9847 the component name). Even if the target type is a PAD type, the size
9848 of that type might not be statically known. So the PAD type needs
9849 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9850 we might end up with the wrong size for our component. This can be
9851 observed with the following type declarations:
9853 type Octal is new Integer range 0 .. 7;
9854 type Octal_Array is array (Positive range <>) of Octal;
9855 pragma Pack (Octal_Array);
9857 type Octal_Buffer (Size : Positive) is record
9858 Buffer : Octal_Array (1 .. Size);
9862 In that case, Buffer is a PAD type whose size is unset and needs
9863 to be computed by fixing the unwrapped type.
9865 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9866 ----------------------------------------------------------
9868 Lastly, when should the sub-elements of an entity that remained unfixed
9869 thus far, be actually fixed?
9871 The answer is: Only when referencing that element. For instance
9872 when selecting one component of a record, this specific component
9873 should be fixed at that point in time. Or when printing the value
9874 of a record, each component should be fixed before its value gets
9875 printed. Similarly for arrays, the element of the array should be
9876 fixed when printing each element of the array, or when extracting
9877 one element out of that array. On the other hand, fixing should
9878 not be performed on the elements when taking a slice of an array!
9880 Note that one of the side effects of miscomputing the offset and
9881 size of each field is that we end up also miscomputing the size
9882 of the containing type. This can have adverse results when computing
9883 the value of an entity. GDB fetches the value of an entity based
9884 on the size of its type, and thus a wrong size causes GDB to fetch
9885 the wrong amount of memory. In the case where the computed size is
9886 too small, GDB fetches too little data to print the value of our
9887 entity. Results in this case are unpredictable, as we usually read
9888 past the buffer containing the data =:-o. */
9890 /* Evaluate a subexpression of EXP, at index *POS, and return a value
9891 for that subexpression cast to TO_TYPE. Advance *POS over the
9895 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
9896 enum noside noside
, struct type
*to_type
)
9900 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
9901 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
9906 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
9908 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9909 return value_zero (to_type
, not_lval
);
9911 val
= evaluate_var_msym_value (noside
,
9912 exp
->elts
[pc
+ 1].objfile
,
9913 exp
->elts
[pc
+ 2].msymbol
);
9916 val
= evaluate_var_value (noside
,
9917 exp
->elts
[pc
+ 1].block
,
9918 exp
->elts
[pc
+ 2].symbol
);
9920 if (noside
== EVAL_SKIP
)
9921 return eval_skip_value (exp
);
9923 val
= ada_value_cast (to_type
, val
);
9925 /* Follow the Ada language semantics that do not allow taking
9926 an address of the result of a cast (view conversion in Ada). */
9927 if (VALUE_LVAL (val
) == lval_memory
)
9929 if (value_lazy (val
))
9930 value_fetch_lazy (val
);
9931 VALUE_LVAL (val
) = not_lval
;
9936 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
9937 if (noside
== EVAL_SKIP
)
9938 return eval_skip_value (exp
);
9939 return ada_value_cast (to_type
, val
);
9942 /* A helper function for TERNOP_IN_RANGE. */
9945 eval_ternop_in_range (struct type
*expect_type
, struct expression
*exp
,
9947 value
*arg1
, value
*arg2
, value
*arg3
)
9949 if (noside
== EVAL_SKIP
)
9950 return eval_skip_value (exp
);
9952 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9953 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9954 struct type
*type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9956 value_from_longest (type
,
9957 (value_less (arg1
, arg3
)
9958 || value_equal (arg1
, arg3
))
9959 && (value_less (arg2
, arg1
)
9960 || value_equal (arg2
, arg1
)));
9963 /* A helper function for UNOP_NEG. */
9966 ada_unop_neg (struct type
*expect_type
,
9967 struct expression
*exp
,
9968 enum noside noside
, enum exp_opcode op
,
9971 if (noside
== EVAL_SKIP
)
9972 return eval_skip_value (exp
);
9973 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9974 return value_neg (arg1
);
9977 /* A helper function for UNOP_IN_RANGE. */
9980 ada_unop_in_range (struct type
*expect_type
,
9981 struct expression
*exp
,
9982 enum noside noside
, enum exp_opcode op
,
9983 struct value
*arg1
, struct type
*type
)
9985 if (noside
== EVAL_SKIP
)
9986 return eval_skip_value (exp
);
9988 struct value
*arg2
, *arg3
;
9989 switch (type
->code ())
9992 lim_warning (_("Membership test incompletely implemented; "
9993 "always returns true"));
9994 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9995 return value_from_longest (type
, (LONGEST
) 1);
9997 case TYPE_CODE_RANGE
:
9998 arg2
= value_from_longest (type
,
9999 type
->bounds ()->low
.const_val ());
10000 arg3
= value_from_longest (type
,
10001 type
->bounds ()->high
.const_val ());
10002 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10003 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10004 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10006 value_from_longest (type
,
10007 (value_less (arg1
, arg3
)
10008 || value_equal (arg1
, arg3
))
10009 && (value_less (arg2
, arg1
)
10010 || value_equal (arg2
, arg1
)));
10014 /* A helper function for OP_ATR_TAG. */
10017 ada_atr_tag (struct type
*expect_type
,
10018 struct expression
*exp
,
10019 enum noside noside
, enum exp_opcode op
,
10020 struct value
*arg1
)
10022 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10023 return value_zero (ada_tag_type (arg1
), not_lval
);
10025 return ada_value_tag (arg1
);
10028 /* A helper function for OP_ATR_SIZE. */
10031 ada_atr_size (struct type
*expect_type
,
10032 struct expression
*exp
,
10033 enum noside noside
, enum exp_opcode op
,
10034 struct value
*arg1
)
10036 struct type
*type
= value_type (arg1
);
10038 /* If the argument is a reference, then dereference its type, since
10039 the user is really asking for the size of the actual object,
10040 not the size of the pointer. */
10041 if (type
->code () == TYPE_CODE_REF
)
10042 type
= TYPE_TARGET_TYPE (type
);
10044 if (noside
== EVAL_SKIP
)
10045 return eval_skip_value (exp
);
10046 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10047 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10049 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10050 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10053 /* Implement the evaluate_exp routine in the exp_descriptor structure
10054 for the Ada language. */
10056 static struct value
*
10057 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10058 int *pos
, enum noside noside
)
10060 enum exp_opcode op
;
10064 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10067 struct value
**argvec
;
10071 op
= exp
->elts
[pc
].opcode
;
10077 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10079 if (noside
== EVAL_NORMAL
)
10080 arg1
= unwrap_value (arg1
);
10082 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10083 then we need to perform the conversion manually, because
10084 evaluate_subexp_standard doesn't do it. This conversion is
10085 necessary in Ada because the different kinds of float/fixed
10086 types in Ada have different representations.
10088 Similarly, we need to perform the conversion from OP_LONG
10090 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10091 arg1
= ada_value_cast (expect_type
, arg1
);
10097 struct value
*result
;
10100 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10101 /* The result type will have code OP_STRING, bashed there from
10102 OP_ARRAY. Bash it back. */
10103 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10104 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10110 type
= exp
->elts
[pc
+ 1].type
;
10111 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10115 type
= exp
->elts
[pc
+ 1].type
;
10116 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10119 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10120 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10122 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10123 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10125 return ada_value_assign (arg1
, arg1
);
10127 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10128 except if the lhs of our assignment is a convenience variable.
10129 In the case of assigning to a convenience variable, the lhs
10130 should be exactly the result of the evaluation of the rhs. */
10131 type
= value_type (arg1
);
10132 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10134 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10135 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10137 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10142 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10143 return ada_value_assign (arg1
, arg2
);
10146 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10147 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10148 if (noside
== EVAL_SKIP
)
10150 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10151 return (value_from_longest
10152 (value_type (arg1
),
10153 value_as_long (arg1
) + value_as_long (arg2
)));
10154 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10155 return (value_from_longest
10156 (value_type (arg2
),
10157 value_as_long (arg1
) + value_as_long (arg2
)));
10158 /* Preserve the original type for use by the range case below.
10159 We cannot cast the result to a reference type, so if ARG1 is
10160 a reference type, find its underlying type. */
10161 type
= value_type (arg1
);
10162 while (type
->code () == TYPE_CODE_REF
)
10163 type
= TYPE_TARGET_TYPE (type
);
10164 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10165 arg1
= value_binop (arg1
, arg2
, BINOP_ADD
);
10166 /* We need to special-case the result of adding to a range.
10167 This is done for the benefit of "ptype". gdb's Ada support
10168 historically used the LHS to set the result type here, so
10169 preserve this behavior. */
10170 if (type
->code () == TYPE_CODE_RANGE
)
10171 arg1
= value_cast (type
, arg1
);
10175 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10176 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10177 if (noside
== EVAL_SKIP
)
10179 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10180 return (value_from_longest
10181 (value_type (arg1
),
10182 value_as_long (arg1
) - value_as_long (arg2
)));
10183 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10184 return (value_from_longest
10185 (value_type (arg2
),
10186 value_as_long (arg1
) - value_as_long (arg2
)));
10187 /* Preserve the original type for use by the range case below.
10188 We cannot cast the result to a reference type, so if ARG1 is
10189 a reference type, find its underlying type. */
10190 type
= value_type (arg1
);
10191 while (type
->code () == TYPE_CODE_REF
)
10192 type
= TYPE_TARGET_TYPE (type
);
10193 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10194 arg1
= value_binop (arg1
, arg2
, BINOP_SUB
);
10195 /* We need to special-case the result of adding to a range.
10196 This is done for the benefit of "ptype". gdb's Ada support
10197 historically used the LHS to set the result type here, so
10198 preserve this behavior. */
10199 if (type
->code () == TYPE_CODE_RANGE
)
10200 arg1
= value_cast (type
, arg1
);
10207 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10208 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10209 if (noside
== EVAL_SKIP
)
10211 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10213 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10214 return value_zero (value_type (arg1
), not_lval
);
10218 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10219 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10220 return ada_value_binop (arg1
, arg2
, op
);
10224 case BINOP_NOTEQUAL
:
10225 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10226 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10227 if (noside
== EVAL_SKIP
)
10229 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10233 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10234 tem
= ada_value_equal (arg1
, arg2
);
10236 if (op
== BINOP_NOTEQUAL
)
10238 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10239 return value_from_longest (type
, (LONGEST
) tem
);
10242 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10243 return ada_unop_neg (expect_type
, exp
, noside
, op
, arg1
);
10245 case BINOP_LOGICAL_AND
:
10246 case BINOP_LOGICAL_OR
:
10247 case UNOP_LOGICAL_NOT
:
10252 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10253 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10254 return value_cast (type
, val
);
10257 case BINOP_BITWISE_AND
:
10258 case BINOP_BITWISE_IOR
:
10259 case BINOP_BITWISE_XOR
:
10263 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10265 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10267 return value_cast (value_type (arg1
), val
);
10273 if (noside
== EVAL_SKIP
)
10279 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10280 /* Only encountered when an unresolved symbol occurs in a
10281 context other than a function call, in which case, it is
10283 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10284 exp
->elts
[pc
+ 2].symbol
->print_name ());
10286 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10288 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10289 /* Check to see if this is a tagged type. We also need to handle
10290 the case where the type is a reference to a tagged type, but
10291 we have to be careful to exclude pointers to tagged types.
10292 The latter should be shown as usual (as a pointer), whereas
10293 a reference should mostly be transparent to the user. */
10294 if (ada_is_tagged_type (type
, 0)
10295 || (type
->code () == TYPE_CODE_REF
10296 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10298 /* Tagged types are a little special in the fact that the real
10299 type is dynamic and can only be determined by inspecting the
10300 object's tag. This means that we need to get the object's
10301 value first (EVAL_NORMAL) and then extract the actual object
10304 Note that we cannot skip the final step where we extract
10305 the object type from its tag, because the EVAL_NORMAL phase
10306 results in dynamic components being resolved into fixed ones.
10307 This can cause problems when trying to print the type
10308 description of tagged types whose parent has a dynamic size:
10309 We use the type name of the "_parent" component in order
10310 to print the name of the ancestor type in the type description.
10311 If that component had a dynamic size, the resolution into
10312 a fixed type would result in the loss of that type name,
10313 thus preventing us from printing the name of the ancestor
10314 type in the type description. */
10315 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10317 if (type
->code () != TYPE_CODE_REF
)
10319 struct type
*actual_type
;
10321 actual_type
= type_from_tag (ada_value_tag (arg1
));
10322 if (actual_type
== NULL
)
10323 /* If, for some reason, we were unable to determine
10324 the actual type from the tag, then use the static
10325 approximation that we just computed as a fallback.
10326 This can happen if the debugging information is
10327 incomplete, for instance. */
10328 actual_type
= type
;
10329 return value_zero (actual_type
, not_lval
);
10333 /* In the case of a ref, ada_coerce_ref takes care
10334 of determining the actual type. But the evaluation
10335 should return a ref as it should be valid to ask
10336 for its address; so rebuild a ref after coerce. */
10337 arg1
= ada_coerce_ref (arg1
);
10338 return value_ref (arg1
, TYPE_CODE_REF
);
10342 /* Records and unions for which GNAT encodings have been
10343 generated need to be statically fixed as well.
10344 Otherwise, non-static fixing produces a type where
10345 all dynamic properties are removed, which prevents "ptype"
10346 from being able to completely describe the type.
10347 For instance, a case statement in a variant record would be
10348 replaced by the relevant components based on the actual
10349 value of the discriminants. */
10350 if ((type
->code () == TYPE_CODE_STRUCT
10351 && dynamic_template_type (type
) != NULL
)
10352 || (type
->code () == TYPE_CODE_UNION
10353 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10356 return value_zero (to_static_fixed_type (type
), not_lval
);
10360 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10361 return ada_to_fixed_value (arg1
);
10366 /* Allocate arg vector, including space for the function to be
10367 called in argvec[0] and a terminating NULL. */
10368 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10369 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10371 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10372 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10373 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10374 exp
->elts
[pc
+ 5].symbol
->print_name ());
10377 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10378 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10381 if (noside
== EVAL_SKIP
)
10385 if (ada_is_constrained_packed_array_type
10386 (desc_base_type (value_type (argvec
[0]))))
10387 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10388 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10389 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10390 /* This is a packed array that has already been fixed, and
10391 therefore already coerced to a simple array. Nothing further
10394 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10396 /* Make sure we dereference references so that all the code below
10397 feels like it's really handling the referenced value. Wrapping
10398 types (for alignment) may be there, so make sure we strip them as
10400 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10402 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10403 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10404 argvec
[0] = value_addr (argvec
[0]);
10406 type
= ada_check_typedef (value_type (argvec
[0]));
10408 /* Ada allows us to implicitly dereference arrays when subscripting
10409 them. So, if this is an array typedef (encoding use for array
10410 access types encoded as fat pointers), strip it now. */
10411 if (type
->code () == TYPE_CODE_TYPEDEF
)
10412 type
= ada_typedef_target_type (type
);
10414 if (type
->code () == TYPE_CODE_PTR
)
10416 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10418 case TYPE_CODE_FUNC
:
10419 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10421 case TYPE_CODE_ARRAY
:
10423 case TYPE_CODE_STRUCT
:
10424 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10425 argvec
[0] = ada_value_ind (argvec
[0]);
10426 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10429 error (_("cannot subscript or call something of type `%s'"),
10430 ada_type_name (value_type (argvec
[0])));
10435 switch (type
->code ())
10437 case TYPE_CODE_FUNC
:
10438 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10440 if (TYPE_TARGET_TYPE (type
) == NULL
)
10441 error_call_unknown_return_type (NULL
);
10442 return allocate_value (TYPE_TARGET_TYPE (type
));
10444 return call_function_by_hand (argvec
[0], NULL
,
10445 gdb::make_array_view (argvec
+ 1,
10447 case TYPE_CODE_INTERNAL_FUNCTION
:
10448 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10449 /* We don't know anything about what the internal
10450 function might return, but we have to return
10452 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10455 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10456 argvec
[0], nargs
, argvec
+ 1);
10458 case TYPE_CODE_STRUCT
:
10462 arity
= ada_array_arity (type
);
10463 type
= ada_array_element_type (type
, nargs
);
10465 error (_("cannot subscript or call a record"));
10466 if (arity
!= nargs
)
10467 error (_("wrong number of subscripts; expecting %d"), arity
);
10468 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10469 return value_zero (ada_aligned_type (type
), lval_memory
);
10471 unwrap_value (ada_value_subscript
10472 (argvec
[0], nargs
, argvec
+ 1));
10474 case TYPE_CODE_ARRAY
:
10475 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10477 type
= ada_array_element_type (type
, nargs
);
10479 error (_("element type of array unknown"));
10481 return value_zero (ada_aligned_type (type
), lval_memory
);
10484 unwrap_value (ada_value_subscript
10485 (ada_coerce_to_simple_array (argvec
[0]),
10486 nargs
, argvec
+ 1));
10487 case TYPE_CODE_PTR
: /* Pointer to array */
10488 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10490 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10491 type
= ada_array_element_type (type
, nargs
);
10493 error (_("element type of array unknown"));
10495 return value_zero (ada_aligned_type (type
), lval_memory
);
10498 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10499 nargs
, argvec
+ 1));
10502 error (_("Attempt to index or call something other than an "
10503 "array or function"));
10508 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10509 struct value
*low_bound_val
10510 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10511 struct value
*high_bound_val
10512 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10514 LONGEST high_bound
;
10516 low_bound_val
= coerce_ref (low_bound_val
);
10517 high_bound_val
= coerce_ref (high_bound_val
);
10518 low_bound
= value_as_long (low_bound_val
);
10519 high_bound
= value_as_long (high_bound_val
);
10521 if (noside
== EVAL_SKIP
)
10524 /* If this is a reference to an aligner type, then remove all
10526 if (value_type (array
)->code () == TYPE_CODE_REF
10527 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10528 TYPE_TARGET_TYPE (value_type (array
)) =
10529 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10531 if (ada_is_any_packed_array_type (value_type (array
)))
10532 error (_("cannot slice a packed array"));
10534 /* If this is a reference to an array or an array lvalue,
10535 convert to a pointer. */
10536 if (value_type (array
)->code () == TYPE_CODE_REF
10537 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10538 && VALUE_LVAL (array
) == lval_memory
))
10539 array
= value_addr (array
);
10541 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10542 && ada_is_array_descriptor_type (ada_check_typedef
10543 (value_type (array
))))
10544 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10547 array
= ada_coerce_to_simple_array_ptr (array
);
10549 /* If we have more than one level of pointer indirection,
10550 dereference the value until we get only one level. */
10551 while (value_type (array
)->code () == TYPE_CODE_PTR
10552 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10554 array
= value_ind (array
);
10556 /* Make sure we really do have an array type before going further,
10557 to avoid a SEGV when trying to get the index type or the target
10558 type later down the road if the debug info generated by
10559 the compiler is incorrect or incomplete. */
10560 if (!ada_is_simple_array_type (value_type (array
)))
10561 error (_("cannot take slice of non-array"));
10563 if (ada_check_typedef (value_type (array
))->code ()
10566 struct type
*type0
= ada_check_typedef (value_type (array
));
10568 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10569 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10572 struct type
*arr_type0
=
10573 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10575 return ada_value_slice_from_ptr (array
, arr_type0
,
10576 longest_to_int (low_bound
),
10577 longest_to_int (high_bound
));
10580 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10582 else if (high_bound
< low_bound
)
10583 return empty_array (value_type (array
), low_bound
, high_bound
);
10585 return ada_value_slice (array
, longest_to_int (low_bound
),
10586 longest_to_int (high_bound
));
10589 case UNOP_IN_RANGE
:
10591 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10592 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10593 return ada_unop_in_range (expect_type
, exp
, noside
, op
, arg1
, type
);
10595 case BINOP_IN_BOUNDS
:
10597 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10598 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10600 if (noside
== EVAL_SKIP
)
10603 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10605 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10606 return value_zero (type
, not_lval
);
10609 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10611 type
= ada_index_type (value_type (arg2
), tem
, "range");
10613 type
= value_type (arg1
);
10615 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10616 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10618 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10619 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10620 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10622 value_from_longest (type
,
10623 (value_less (arg1
, arg3
)
10624 || value_equal (arg1
, arg3
))
10625 && (value_less (arg2
, arg1
)
10626 || value_equal (arg2
, arg1
)));
10628 case TERNOP_IN_RANGE
:
10629 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10630 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10631 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10633 return eval_ternop_in_range (expect_type
, exp
, noside
, arg1
, arg2
, arg3
);
10637 case OP_ATR_LENGTH
:
10639 struct type
*type_arg
;
10641 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10643 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10645 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10649 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10653 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10654 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10655 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10658 if (noside
== EVAL_SKIP
)
10660 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10662 if (type_arg
== NULL
)
10663 type_arg
= value_type (arg1
);
10665 if (ada_is_constrained_packed_array_type (type_arg
))
10666 type_arg
= decode_constrained_packed_array_type (type_arg
);
10668 if (!discrete_type_p (type_arg
))
10672 default: /* Should never happen. */
10673 error (_("unexpected attribute encountered"));
10676 type_arg
= ada_index_type (type_arg
, tem
,
10677 ada_attribute_name (op
));
10679 case OP_ATR_LENGTH
:
10680 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10685 return value_zero (type_arg
, not_lval
);
10687 else if (type_arg
== NULL
)
10689 arg1
= ada_coerce_ref (arg1
);
10691 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10692 arg1
= ada_coerce_to_simple_array (arg1
);
10694 if (op
== OP_ATR_LENGTH
)
10695 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10698 type
= ada_index_type (value_type (arg1
), tem
,
10699 ada_attribute_name (op
));
10701 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10706 default: /* Should never happen. */
10707 error (_("unexpected attribute encountered"));
10709 return value_from_longest
10710 (type
, ada_array_bound (arg1
, tem
, 0));
10712 return value_from_longest
10713 (type
, ada_array_bound (arg1
, tem
, 1));
10714 case OP_ATR_LENGTH
:
10715 return value_from_longest
10716 (type
, ada_array_length (arg1
, tem
));
10719 else if (discrete_type_p (type_arg
))
10721 struct type
*range_type
;
10722 const char *name
= ada_type_name (type_arg
);
10725 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10726 range_type
= to_fixed_range_type (type_arg
, NULL
);
10727 if (range_type
== NULL
)
10728 range_type
= type_arg
;
10732 error (_("unexpected attribute encountered"));
10734 return value_from_longest
10735 (range_type
, ada_discrete_type_low_bound (range_type
));
10737 return value_from_longest
10738 (range_type
, ada_discrete_type_high_bound (range_type
));
10739 case OP_ATR_LENGTH
:
10740 error (_("the 'length attribute applies only to array types"));
10743 else if (type_arg
->code () == TYPE_CODE_FLT
)
10744 error (_("unimplemented type attribute"));
10749 if (ada_is_constrained_packed_array_type (type_arg
))
10750 type_arg
= decode_constrained_packed_array_type (type_arg
);
10752 if (op
== OP_ATR_LENGTH
)
10753 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10756 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10758 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10764 error (_("unexpected attribute encountered"));
10766 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10767 return value_from_longest (type
, low
);
10769 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10770 return value_from_longest (type
, high
);
10771 case OP_ATR_LENGTH
:
10772 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10773 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10774 return value_from_longest (type
, high
- low
+ 1);
10780 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10781 if (noside
== EVAL_SKIP
)
10783 return ada_atr_tag (expect_type
, exp
, noside
, op
, arg1
);
10787 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10788 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10789 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10790 if (noside
== EVAL_SKIP
)
10792 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10793 return value_zero (value_type (arg1
), not_lval
);
10796 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10797 return value_binop (arg1
, arg2
,
10798 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10801 case OP_ATR_MODULUS
:
10803 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10805 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10806 if (noside
== EVAL_SKIP
)
10809 if (!ada_is_modular_type (type_arg
))
10810 error (_("'modulus must be applied to modular type"));
10812 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10813 ada_modulus (type_arg
));
10818 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10819 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10820 if (noside
== EVAL_SKIP
)
10822 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10823 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10824 return value_zero (type
, not_lval
);
10826 return value_pos_atr (type
, arg1
);
10829 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10830 return ada_atr_size (expect_type
, exp
, noside
, op
, arg1
);
10833 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10834 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10835 type
= exp
->elts
[pc
+ 2].type
;
10836 if (noside
== EVAL_SKIP
)
10838 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10839 return value_zero (type
, not_lval
);
10841 return value_val_atr (type
, arg1
);
10844 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10845 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10846 if (noside
== EVAL_SKIP
)
10848 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10849 return value_zero (value_type (arg1
), not_lval
);
10852 /* For integer exponentiation operations,
10853 only promote the first argument. */
10854 if (is_integral_type (value_type (arg2
)))
10855 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10857 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10859 return value_binop (arg1
, arg2
, op
);
10863 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10864 if (noside
== EVAL_SKIP
)
10870 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10871 if (noside
== EVAL_SKIP
)
10873 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10874 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10875 return value_neg (arg1
);
10880 preeval_pos
= *pos
;
10881 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10882 if (noside
== EVAL_SKIP
)
10884 type
= ada_check_typedef (value_type (arg1
));
10885 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10887 if (ada_is_array_descriptor_type (type
))
10888 /* GDB allows dereferencing GNAT array descriptors. */
10890 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10892 if (arrType
== NULL
)
10893 error (_("Attempt to dereference null array pointer."));
10894 return value_at_lazy (arrType
, 0);
10896 else if (type
->code () == TYPE_CODE_PTR
10897 || type
->code () == TYPE_CODE_REF
10898 /* In C you can dereference an array to get the 1st elt. */
10899 || type
->code () == TYPE_CODE_ARRAY
)
10901 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10902 only be determined by inspecting the object's tag.
10903 This means that we need to evaluate completely the
10904 expression in order to get its type. */
10906 if ((type
->code () == TYPE_CODE_REF
10907 || type
->code () == TYPE_CODE_PTR
)
10908 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10911 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10912 type
= value_type (ada_value_ind (arg1
));
10916 type
= to_static_fixed_type
10918 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10920 ada_ensure_varsize_limit (type
);
10921 return value_zero (type
, lval_memory
);
10923 else if (type
->code () == TYPE_CODE_INT
)
10925 /* GDB allows dereferencing an int. */
10926 if (expect_type
== NULL
)
10927 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10932 to_static_fixed_type (ada_aligned_type (expect_type
));
10933 return value_zero (expect_type
, lval_memory
);
10937 error (_("Attempt to take contents of a non-pointer value."));
10939 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10940 type
= ada_check_typedef (value_type (arg1
));
10942 if (type
->code () == TYPE_CODE_INT
)
10943 /* GDB allows dereferencing an int. If we were given
10944 the expect_type, then use that as the target type.
10945 Otherwise, assume that the target type is an int. */
10947 if (expect_type
!= NULL
)
10948 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
10951 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
10952 (CORE_ADDR
) value_as_address (arg1
));
10955 if (ada_is_array_descriptor_type (type
))
10956 /* GDB allows dereferencing GNAT array descriptors. */
10957 return ada_coerce_to_simple_array (arg1
);
10959 return ada_value_ind (arg1
);
10961 case STRUCTOP_STRUCT
:
10962 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10963 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
10964 preeval_pos
= *pos
;
10965 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10966 if (noside
== EVAL_SKIP
)
10968 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10970 struct type
*type1
= value_type (arg1
);
10972 if (ada_is_tagged_type (type1
, 1))
10974 type
= ada_lookup_struct_elt_type (type1
,
10975 &exp
->elts
[pc
+ 2].string
,
10978 /* If the field is not found, check if it exists in the
10979 extension of this object's type. This means that we
10980 need to evaluate completely the expression. */
10985 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10986 arg1
= ada_value_struct_elt (arg1
,
10987 &exp
->elts
[pc
+ 2].string
,
10989 arg1
= unwrap_value (arg1
);
10990 type
= value_type (ada_to_fixed_value (arg1
));
10995 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
10998 return value_zero (ada_aligned_type (type
), lval_memory
);
11002 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11003 arg1
= unwrap_value (arg1
);
11004 return ada_to_fixed_value (arg1
);
11008 /* The value is not supposed to be used. This is here to make it
11009 easier to accommodate expressions that contain types. */
11011 if (noside
== EVAL_SKIP
)
11013 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11014 return allocate_value (exp
->elts
[pc
+ 1].type
);
11016 error (_("Attempt to use a type name as an expression"));
11021 case OP_DISCRETE_RANGE
:
11022 case OP_POSITIONAL
:
11024 if (noside
== EVAL_NORMAL
)
11028 error (_("Undefined name, ambiguous name, or renaming used in "
11029 "component association: %s."), &exp
->elts
[pc
+2].string
);
11031 error (_("Aggregates only allowed on the right of an assignment"));
11033 internal_error (__FILE__
, __LINE__
,
11034 _("aggregate apparently mangled"));
11037 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11039 for (tem
= 0; tem
< nargs
; tem
+= 1)
11040 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11045 return eval_skip_value (exp
);
11049 /* Return non-zero iff TYPE represents a System.Address type. */
11052 ada_is_system_address_type (struct type
*type
)
11054 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11061 /* Scan STR beginning at position K for a discriminant name, and
11062 return the value of that discriminant field of DVAL in *PX. If
11063 PNEW_K is not null, put the position of the character beyond the
11064 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11065 not alter *PX and *PNEW_K if unsuccessful. */
11068 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11071 static std::string storage
;
11072 const char *pstart
, *pend
, *bound
;
11073 struct value
*bound_val
;
11075 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11079 pend
= strstr (pstart
, "__");
11083 k
+= strlen (bound
);
11087 int len
= pend
- pstart
;
11089 /* Strip __ and beyond. */
11090 storage
= std::string (pstart
, len
);
11091 bound
= storage
.c_str ();
11095 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11096 if (bound_val
== NULL
)
11099 *px
= value_as_long (bound_val
);
11100 if (pnew_k
!= NULL
)
11105 /* Value of variable named NAME. Only exact matches are considered.
11106 If no such variable found, then if ERR_MSG is null, returns 0, and
11107 otherwise causes an error with message ERR_MSG. */
11109 static struct value
*
11110 get_var_value (const char *name
, const char *err_msg
)
11112 std::string quoted_name
= add_angle_brackets (name
);
11114 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11116 std::vector
<struct block_symbol
> syms
11117 = ada_lookup_symbol_list_worker (lookup_name
,
11118 get_selected_block (0),
11121 if (syms
.size () != 1)
11123 if (err_msg
== NULL
)
11126 error (("%s"), err_msg
);
11129 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11132 /* Value of integer variable named NAME in the current environment.
11133 If no such variable is found, returns false. Otherwise, sets VALUE
11134 to the variable's value and returns true. */
11137 get_int_var_value (const char *name
, LONGEST
&value
)
11139 struct value
*var_val
= get_var_value (name
, 0);
11144 value
= value_as_long (var_val
);
11149 /* Return a range type whose base type is that of the range type named
11150 NAME in the current environment, and whose bounds are calculated
11151 from NAME according to the GNAT range encoding conventions.
11152 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11153 corresponding range type from debug information; fall back to using it
11154 if symbol lookup fails. If a new type must be created, allocate it
11155 like ORIG_TYPE was. The bounds information, in general, is encoded
11156 in NAME, the base type given in the named range type. */
11158 static struct type
*
11159 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11162 struct type
*base_type
;
11163 const char *subtype_info
;
11165 gdb_assert (raw_type
!= NULL
);
11166 gdb_assert (raw_type
->name () != NULL
);
11168 if (raw_type
->code () == TYPE_CODE_RANGE
)
11169 base_type
= TYPE_TARGET_TYPE (raw_type
);
11171 base_type
= raw_type
;
11173 name
= raw_type
->name ();
11174 subtype_info
= strstr (name
, "___XD");
11175 if (subtype_info
== NULL
)
11177 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11178 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11180 if (L
< INT_MIN
|| U
> INT_MAX
)
11183 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11188 int prefix_len
= subtype_info
- name
;
11191 const char *bounds_str
;
11195 bounds_str
= strchr (subtype_info
, '_');
11198 if (*subtype_info
== 'L')
11200 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11201 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11203 if (bounds_str
[n
] == '_')
11205 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11211 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11212 if (!get_int_var_value (name_buf
.c_str (), L
))
11214 lim_warning (_("Unknown lower bound, using 1."));
11219 if (*subtype_info
== 'U')
11221 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11222 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11227 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11228 if (!get_int_var_value (name_buf
.c_str (), U
))
11230 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11235 type
= create_static_range_type (alloc_type_copy (raw_type
),
11237 /* create_static_range_type alters the resulting type's length
11238 to match the size of the base_type, which is not what we want.
11239 Set it back to the original range type's length. */
11240 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11241 type
->set_name (name
);
11246 /* True iff NAME is the name of a range type. */
11249 ada_is_range_type_name (const char *name
)
11251 return (name
!= NULL
&& strstr (name
, "___XD"));
11255 /* Modular types */
11257 /* True iff TYPE is an Ada modular type. */
11260 ada_is_modular_type (struct type
*type
)
11262 struct type
*subranged_type
= get_base_type (type
);
11264 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11265 && subranged_type
->code () == TYPE_CODE_INT
11266 && subranged_type
->is_unsigned ());
11269 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11272 ada_modulus (struct type
*type
)
11274 const dynamic_prop
&high
= type
->bounds ()->high
;
11276 if (high
.kind () == PROP_CONST
)
11277 return (ULONGEST
) high
.const_val () + 1;
11279 /* If TYPE is unresolved, the high bound might be a location list. Return
11280 0, for lack of a better value to return. */
11285 /* Ada exception catchpoint support:
11286 ---------------------------------
11288 We support 3 kinds of exception catchpoints:
11289 . catchpoints on Ada exceptions
11290 . catchpoints on unhandled Ada exceptions
11291 . catchpoints on failed assertions
11293 Exceptions raised during failed assertions, or unhandled exceptions
11294 could perfectly be caught with the general catchpoint on Ada exceptions.
11295 However, we can easily differentiate these two special cases, and having
11296 the option to distinguish these two cases from the rest can be useful
11297 to zero-in on certain situations.
11299 Exception catchpoints are a specialized form of breakpoint,
11300 since they rely on inserting breakpoints inside known routines
11301 of the GNAT runtime. The implementation therefore uses a standard
11302 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11305 Support in the runtime for exception catchpoints have been changed
11306 a few times already, and these changes affect the implementation
11307 of these catchpoints. In order to be able to support several
11308 variants of the runtime, we use a sniffer that will determine
11309 the runtime variant used by the program being debugged. */
11311 /* Ada's standard exceptions.
11313 The Ada 83 standard also defined Numeric_Error. But there so many
11314 situations where it was unclear from the Ada 83 Reference Manual
11315 (RM) whether Constraint_Error or Numeric_Error should be raised,
11316 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11317 Interpretation saying that anytime the RM says that Numeric_Error
11318 should be raised, the implementation may raise Constraint_Error.
11319 Ada 95 went one step further and pretty much removed Numeric_Error
11320 from the list of standard exceptions (it made it a renaming of
11321 Constraint_Error, to help preserve compatibility when compiling
11322 an Ada83 compiler). As such, we do not include Numeric_Error from
11323 this list of standard exceptions. */
11325 static const char * const standard_exc
[] = {
11326 "constraint_error",
11332 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11334 /* A structure that describes how to support exception catchpoints
11335 for a given executable. */
11337 struct exception_support_info
11339 /* The name of the symbol to break on in order to insert
11340 a catchpoint on exceptions. */
11341 const char *catch_exception_sym
;
11343 /* The name of the symbol to break on in order to insert
11344 a catchpoint on unhandled exceptions. */
11345 const char *catch_exception_unhandled_sym
;
11347 /* The name of the symbol to break on in order to insert
11348 a catchpoint on failed assertions. */
11349 const char *catch_assert_sym
;
11351 /* The name of the symbol to break on in order to insert
11352 a catchpoint on exception handling. */
11353 const char *catch_handlers_sym
;
11355 /* Assuming that the inferior just triggered an unhandled exception
11356 catchpoint, this function is responsible for returning the address
11357 in inferior memory where the name of that exception is stored.
11358 Return zero if the address could not be computed. */
11359 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11362 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11363 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11365 /* The following exception support info structure describes how to
11366 implement exception catchpoints with the latest version of the
11367 Ada runtime (as of 2019-08-??). */
11369 static const struct exception_support_info default_exception_support_info
=
11371 "__gnat_debug_raise_exception", /* catch_exception_sym */
11372 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11373 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11374 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11375 ada_unhandled_exception_name_addr
11378 /* The following exception support info structure describes how to
11379 implement exception catchpoints with an earlier version of the
11380 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11382 static const struct exception_support_info exception_support_info_v0
=
11384 "__gnat_debug_raise_exception", /* catch_exception_sym */
11385 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11386 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11387 "__gnat_begin_handler", /* catch_handlers_sym */
11388 ada_unhandled_exception_name_addr
11391 /* The following exception support info structure describes how to
11392 implement exception catchpoints with a slightly older version
11393 of the Ada runtime. */
11395 static const struct exception_support_info exception_support_info_fallback
=
11397 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11398 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11399 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11400 "__gnat_begin_handler", /* catch_handlers_sym */
11401 ada_unhandled_exception_name_addr_from_raise
11404 /* Return nonzero if we can detect the exception support routines
11405 described in EINFO.
11407 This function errors out if an abnormal situation is detected
11408 (for instance, if we find the exception support routines, but
11409 that support is found to be incomplete). */
11412 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11414 struct symbol
*sym
;
11416 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11417 that should be compiled with debugging information. As a result, we
11418 expect to find that symbol in the symtabs. */
11420 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11423 /* Perhaps we did not find our symbol because the Ada runtime was
11424 compiled without debugging info, or simply stripped of it.
11425 It happens on some GNU/Linux distributions for instance, where
11426 users have to install a separate debug package in order to get
11427 the runtime's debugging info. In that situation, let the user
11428 know why we cannot insert an Ada exception catchpoint.
11430 Note: Just for the purpose of inserting our Ada exception
11431 catchpoint, we could rely purely on the associated minimal symbol.
11432 But we would be operating in degraded mode anyway, since we are
11433 still lacking the debugging info needed later on to extract
11434 the name of the exception being raised (this name is printed in
11435 the catchpoint message, and is also used when trying to catch
11436 a specific exception). We do not handle this case for now. */
11437 struct bound_minimal_symbol msym
11438 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11440 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11441 error (_("Your Ada runtime appears to be missing some debugging "
11442 "information.\nCannot insert Ada exception catchpoint "
11443 "in this configuration."));
11448 /* Make sure that the symbol we found corresponds to a function. */
11450 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11452 error (_("Symbol \"%s\" is not a function (class = %d)"),
11453 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11457 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11460 struct bound_minimal_symbol msym
11461 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11463 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11464 error (_("Your Ada runtime appears to be missing some debugging "
11465 "information.\nCannot insert Ada exception catchpoint "
11466 "in this configuration."));
11471 /* Make sure that the symbol we found corresponds to a function. */
11473 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11475 error (_("Symbol \"%s\" is not a function (class = %d)"),
11476 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11483 /* Inspect the Ada runtime and determine which exception info structure
11484 should be used to provide support for exception catchpoints.
11486 This function will always set the per-inferior exception_info,
11487 or raise an error. */
11490 ada_exception_support_info_sniffer (void)
11492 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11494 /* If the exception info is already known, then no need to recompute it. */
11495 if (data
->exception_info
!= NULL
)
11498 /* Check the latest (default) exception support info. */
11499 if (ada_has_this_exception_support (&default_exception_support_info
))
11501 data
->exception_info
= &default_exception_support_info
;
11505 /* Try the v0 exception suport info. */
11506 if (ada_has_this_exception_support (&exception_support_info_v0
))
11508 data
->exception_info
= &exception_support_info_v0
;
11512 /* Try our fallback exception suport info. */
11513 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11515 data
->exception_info
= &exception_support_info_fallback
;
11519 /* Sometimes, it is normal for us to not be able to find the routine
11520 we are looking for. This happens when the program is linked with
11521 the shared version of the GNAT runtime, and the program has not been
11522 started yet. Inform the user of these two possible causes if
11525 if (ada_update_initial_language (language_unknown
) != language_ada
)
11526 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11528 /* If the symbol does not exist, then check that the program is
11529 already started, to make sure that shared libraries have been
11530 loaded. If it is not started, this may mean that the symbol is
11531 in a shared library. */
11533 if (inferior_ptid
.pid () == 0)
11534 error (_("Unable to insert catchpoint. Try to start the program first."));
11536 /* At this point, we know that we are debugging an Ada program and
11537 that the inferior has been started, but we still are not able to
11538 find the run-time symbols. That can mean that we are in
11539 configurable run time mode, or that a-except as been optimized
11540 out by the linker... In any case, at this point it is not worth
11541 supporting this feature. */
11543 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11546 /* True iff FRAME is very likely to be that of a function that is
11547 part of the runtime system. This is all very heuristic, but is
11548 intended to be used as advice as to what frames are uninteresting
11552 is_known_support_routine (struct frame_info
*frame
)
11554 enum language func_lang
;
11556 const char *fullname
;
11558 /* If this code does not have any debugging information (no symtab),
11559 This cannot be any user code. */
11561 symtab_and_line sal
= find_frame_sal (frame
);
11562 if (sal
.symtab
== NULL
)
11565 /* If there is a symtab, but the associated source file cannot be
11566 located, then assume this is not user code: Selecting a frame
11567 for which we cannot display the code would not be very helpful
11568 for the user. This should also take care of case such as VxWorks
11569 where the kernel has some debugging info provided for a few units. */
11571 fullname
= symtab_to_fullname (sal
.symtab
);
11572 if (access (fullname
, R_OK
) != 0)
11575 /* Check the unit filename against the Ada runtime file naming.
11576 We also check the name of the objfile against the name of some
11577 known system libraries that sometimes come with debugging info
11580 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11582 re_comp (known_runtime_file_name_patterns
[i
]);
11583 if (re_exec (lbasename (sal
.symtab
->filename
)))
11585 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11586 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11590 /* Check whether the function is a GNAT-generated entity. */
11592 gdb::unique_xmalloc_ptr
<char> func_name
11593 = find_frame_funname (frame
, &func_lang
, NULL
);
11594 if (func_name
== NULL
)
11597 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11599 re_comp (known_auxiliary_function_name_patterns
[i
]);
11600 if (re_exec (func_name
.get ()))
11607 /* Find the first frame that contains debugging information and that is not
11608 part of the Ada run-time, starting from FI and moving upward. */
11611 ada_find_printable_frame (struct frame_info
*fi
)
11613 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11615 if (!is_known_support_routine (fi
))
11624 /* Assuming that the inferior just triggered an unhandled exception
11625 catchpoint, return the address in inferior memory where the name
11626 of the exception is stored.
11628 Return zero if the address could not be computed. */
11631 ada_unhandled_exception_name_addr (void)
11633 return parse_and_eval_address ("e.full_name");
11636 /* Same as ada_unhandled_exception_name_addr, except that this function
11637 should be used when the inferior uses an older version of the runtime,
11638 where the exception name needs to be extracted from a specific frame
11639 several frames up in the callstack. */
11642 ada_unhandled_exception_name_addr_from_raise (void)
11645 struct frame_info
*fi
;
11646 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11648 /* To determine the name of this exception, we need to select
11649 the frame corresponding to RAISE_SYM_NAME. This frame is
11650 at least 3 levels up, so we simply skip the first 3 frames
11651 without checking the name of their associated function. */
11652 fi
= get_current_frame ();
11653 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11655 fi
= get_prev_frame (fi
);
11659 enum language func_lang
;
11661 gdb::unique_xmalloc_ptr
<char> func_name
11662 = find_frame_funname (fi
, &func_lang
, NULL
);
11663 if (func_name
!= NULL
)
11665 if (strcmp (func_name
.get (),
11666 data
->exception_info
->catch_exception_sym
) == 0)
11667 break; /* We found the frame we were looking for... */
11669 fi
= get_prev_frame (fi
);
11676 return parse_and_eval_address ("id.full_name");
11679 /* Assuming the inferior just triggered an Ada exception catchpoint
11680 (of any type), return the address in inferior memory where the name
11681 of the exception is stored, if applicable.
11683 Assumes the selected frame is the current frame.
11685 Return zero if the address could not be computed, or if not relevant. */
11688 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11689 struct breakpoint
*b
)
11691 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11695 case ada_catch_exception
:
11696 return (parse_and_eval_address ("e.full_name"));
11699 case ada_catch_exception_unhandled
:
11700 return data
->exception_info
->unhandled_exception_name_addr ();
11703 case ada_catch_handlers
:
11704 return 0; /* The runtimes does not provide access to the exception
11708 case ada_catch_assert
:
11709 return 0; /* Exception name is not relevant in this case. */
11713 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11717 return 0; /* Should never be reached. */
11720 /* Assuming the inferior is stopped at an exception catchpoint,
11721 return the message which was associated to the exception, if
11722 available. Return NULL if the message could not be retrieved.
11724 Note: The exception message can be associated to an exception
11725 either through the use of the Raise_Exception function, or
11726 more simply (Ada 2005 and later), via:
11728 raise Exception_Name with "exception message";
11732 static gdb::unique_xmalloc_ptr
<char>
11733 ada_exception_message_1 (void)
11735 struct value
*e_msg_val
;
11738 /* For runtimes that support this feature, the exception message
11739 is passed as an unbounded string argument called "message". */
11740 e_msg_val
= parse_and_eval ("message");
11741 if (e_msg_val
== NULL
)
11742 return NULL
; /* Exception message not supported. */
11744 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11745 gdb_assert (e_msg_val
!= NULL
);
11746 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11748 /* If the message string is empty, then treat it as if there was
11749 no exception message. */
11750 if (e_msg_len
<= 0)
11753 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11754 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11756 e_msg
.get ()[e_msg_len
] = '\0';
11761 /* Same as ada_exception_message_1, except that all exceptions are
11762 contained here (returning NULL instead). */
11764 static gdb::unique_xmalloc_ptr
<char>
11765 ada_exception_message (void)
11767 gdb::unique_xmalloc_ptr
<char> e_msg
;
11771 e_msg
= ada_exception_message_1 ();
11773 catch (const gdb_exception_error
&e
)
11775 e_msg
.reset (nullptr);
11781 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11782 any error that ada_exception_name_addr_1 might cause to be thrown.
11783 When an error is intercepted, a warning with the error message is printed,
11784 and zero is returned. */
11787 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11788 struct breakpoint
*b
)
11790 CORE_ADDR result
= 0;
11794 result
= ada_exception_name_addr_1 (ex
, b
);
11797 catch (const gdb_exception_error
&e
)
11799 warning (_("failed to get exception name: %s"), e
.what ());
11806 static std::string ada_exception_catchpoint_cond_string
11807 (const char *excep_string
,
11808 enum ada_exception_catchpoint_kind ex
);
11810 /* Ada catchpoints.
11812 In the case of catchpoints on Ada exceptions, the catchpoint will
11813 stop the target on every exception the program throws. When a user
11814 specifies the name of a specific exception, we translate this
11815 request into a condition expression (in text form), and then parse
11816 it into an expression stored in each of the catchpoint's locations.
11817 We then use this condition to check whether the exception that was
11818 raised is the one the user is interested in. If not, then the
11819 target is resumed again. We store the name of the requested
11820 exception, in order to be able to re-set the condition expression
11821 when symbols change. */
11823 /* An instance of this type is used to represent an Ada catchpoint
11824 breakpoint location. */
11826 class ada_catchpoint_location
: public bp_location
11829 ada_catchpoint_location (breakpoint
*owner
)
11830 : bp_location (owner
, bp_loc_software_breakpoint
)
11833 /* The condition that checks whether the exception that was raised
11834 is the specific exception the user specified on catchpoint
11836 expression_up excep_cond_expr
;
11839 /* An instance of this type is used to represent an Ada catchpoint. */
11841 struct ada_catchpoint
: public breakpoint
11843 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
11848 /* The name of the specific exception the user specified. */
11849 std::string excep_string
;
11851 /* What kind of catchpoint this is. */
11852 enum ada_exception_catchpoint_kind m_kind
;
11855 /* Parse the exception condition string in the context of each of the
11856 catchpoint's locations, and store them for later evaluation. */
11859 create_excep_cond_exprs (struct ada_catchpoint
*c
,
11860 enum ada_exception_catchpoint_kind ex
)
11862 struct bp_location
*bl
;
11864 /* Nothing to do if there's no specific exception to catch. */
11865 if (c
->excep_string
.empty ())
11868 /* Same if there are no locations... */
11869 if (c
->loc
== NULL
)
11872 /* Compute the condition expression in text form, from the specific
11873 expection we want to catch. */
11874 std::string cond_string
11875 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
11877 /* Iterate over all the catchpoint's locations, and parse an
11878 expression for each. */
11879 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
11881 struct ada_catchpoint_location
*ada_loc
11882 = (struct ada_catchpoint_location
*) bl
;
11885 if (!bl
->shlib_disabled
)
11889 s
= cond_string
.c_str ();
11892 exp
= parse_exp_1 (&s
, bl
->address
,
11893 block_for_pc (bl
->address
),
11896 catch (const gdb_exception_error
&e
)
11898 warning (_("failed to reevaluate internal exception condition "
11899 "for catchpoint %d: %s"),
11900 c
->number
, e
.what ());
11904 ada_loc
->excep_cond_expr
= std::move (exp
);
11908 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11909 structure for all exception catchpoint kinds. */
11911 static struct bp_location
*
11912 allocate_location_exception (struct breakpoint
*self
)
11914 return new ada_catchpoint_location (self
);
11917 /* Implement the RE_SET method in the breakpoint_ops structure for all
11918 exception catchpoint kinds. */
11921 re_set_exception (struct breakpoint
*b
)
11923 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11925 /* Call the base class's method. This updates the catchpoint's
11927 bkpt_breakpoint_ops
.re_set (b
);
11929 /* Reparse the exception conditional expressions. One for each
11931 create_excep_cond_exprs (c
, c
->m_kind
);
11934 /* Returns true if we should stop for this breakpoint hit. If the
11935 user specified a specific exception, we only want to cause a stop
11936 if the program thrown that exception. */
11939 should_stop_exception (const struct bp_location
*bl
)
11941 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
11942 const struct ada_catchpoint_location
*ada_loc
11943 = (const struct ada_catchpoint_location
*) bl
;
11946 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
11947 if (c
->m_kind
== ada_catch_assert
)
11948 clear_internalvar (var
);
11955 if (c
->m_kind
== ada_catch_handlers
)
11956 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
11957 ".all.occurrence.id");
11961 struct value
*exc
= parse_and_eval (expr
);
11962 set_internalvar (var
, exc
);
11964 catch (const gdb_exception_error
&ex
)
11966 clear_internalvar (var
);
11970 /* With no specific exception, should always stop. */
11971 if (c
->excep_string
.empty ())
11974 if (ada_loc
->excep_cond_expr
== NULL
)
11976 /* We will have a NULL expression if back when we were creating
11977 the expressions, this location's had failed to parse. */
11984 struct value
*mark
;
11986 mark
= value_mark ();
11987 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
11988 value_free_to_mark (mark
);
11990 catch (const gdb_exception
&ex
)
11992 exception_fprintf (gdb_stderr
, ex
,
11993 _("Error in testing exception condition:\n"));
11999 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12000 for all exception catchpoint kinds. */
12003 check_status_exception (bpstat bs
)
12005 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12008 /* Implement the PRINT_IT method in the breakpoint_ops structure
12009 for all exception catchpoint kinds. */
12011 static enum print_stop_action
12012 print_it_exception (bpstat bs
)
12014 struct ui_out
*uiout
= current_uiout
;
12015 struct breakpoint
*b
= bs
->breakpoint_at
;
12017 annotate_catchpoint (b
->number
);
12019 if (uiout
->is_mi_like_p ())
12021 uiout
->field_string ("reason",
12022 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12023 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12026 uiout
->text (b
->disposition
== disp_del
12027 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12028 uiout
->field_signed ("bkptno", b
->number
);
12029 uiout
->text (", ");
12031 /* ada_exception_name_addr relies on the selected frame being the
12032 current frame. Need to do this here because this function may be
12033 called more than once when printing a stop, and below, we'll
12034 select the first frame past the Ada run-time (see
12035 ada_find_printable_frame). */
12036 select_frame (get_current_frame ());
12038 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12041 case ada_catch_exception
:
12042 case ada_catch_exception_unhandled
:
12043 case ada_catch_handlers
:
12045 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12046 char exception_name
[256];
12050 read_memory (addr
, (gdb_byte
*) exception_name
,
12051 sizeof (exception_name
) - 1);
12052 exception_name
[sizeof (exception_name
) - 1] = '\0';
12056 /* For some reason, we were unable to read the exception
12057 name. This could happen if the Runtime was compiled
12058 without debugging info, for instance. In that case,
12059 just replace the exception name by the generic string
12060 "exception" - it will read as "an exception" in the
12061 notification we are about to print. */
12062 memcpy (exception_name
, "exception", sizeof ("exception"));
12064 /* In the case of unhandled exception breakpoints, we print
12065 the exception name as "unhandled EXCEPTION_NAME", to make
12066 it clearer to the user which kind of catchpoint just got
12067 hit. We used ui_out_text to make sure that this extra
12068 info does not pollute the exception name in the MI case. */
12069 if (c
->m_kind
== ada_catch_exception_unhandled
)
12070 uiout
->text ("unhandled ");
12071 uiout
->field_string ("exception-name", exception_name
);
12074 case ada_catch_assert
:
12075 /* In this case, the name of the exception is not really
12076 important. Just print "failed assertion" to make it clearer
12077 that his program just hit an assertion-failure catchpoint.
12078 We used ui_out_text because this info does not belong in
12080 uiout
->text ("failed assertion");
12084 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12085 if (exception_message
!= NULL
)
12087 uiout
->text (" (");
12088 uiout
->field_string ("exception-message", exception_message
.get ());
12092 uiout
->text (" at ");
12093 ada_find_printable_frame (get_current_frame ());
12095 return PRINT_SRC_AND_LOC
;
12098 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12099 for all exception catchpoint kinds. */
12102 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12104 struct ui_out
*uiout
= current_uiout
;
12105 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12106 struct value_print_options opts
;
12108 get_user_print_options (&opts
);
12110 if (opts
.addressprint
)
12111 uiout
->field_skip ("addr");
12113 annotate_field (5);
12116 case ada_catch_exception
:
12117 if (!c
->excep_string
.empty ())
12119 std::string msg
= string_printf (_("`%s' Ada exception"),
12120 c
->excep_string
.c_str ());
12122 uiout
->field_string ("what", msg
);
12125 uiout
->field_string ("what", "all Ada exceptions");
12129 case ada_catch_exception_unhandled
:
12130 uiout
->field_string ("what", "unhandled Ada exceptions");
12133 case ada_catch_handlers
:
12134 if (!c
->excep_string
.empty ())
12136 uiout
->field_fmt ("what",
12137 _("`%s' Ada exception handlers"),
12138 c
->excep_string
.c_str ());
12141 uiout
->field_string ("what", "all Ada exceptions handlers");
12144 case ada_catch_assert
:
12145 uiout
->field_string ("what", "failed Ada assertions");
12149 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12154 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12155 for all exception catchpoint kinds. */
12158 print_mention_exception (struct breakpoint
*b
)
12160 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12161 struct ui_out
*uiout
= current_uiout
;
12163 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12164 : _("Catchpoint "));
12165 uiout
->field_signed ("bkptno", b
->number
);
12166 uiout
->text (": ");
12170 case ada_catch_exception
:
12171 if (!c
->excep_string
.empty ())
12173 std::string info
= string_printf (_("`%s' Ada exception"),
12174 c
->excep_string
.c_str ());
12175 uiout
->text (info
.c_str ());
12178 uiout
->text (_("all Ada exceptions"));
12181 case ada_catch_exception_unhandled
:
12182 uiout
->text (_("unhandled Ada exceptions"));
12185 case ada_catch_handlers
:
12186 if (!c
->excep_string
.empty ())
12189 = string_printf (_("`%s' Ada exception handlers"),
12190 c
->excep_string
.c_str ());
12191 uiout
->text (info
.c_str ());
12194 uiout
->text (_("all Ada exceptions handlers"));
12197 case ada_catch_assert
:
12198 uiout
->text (_("failed Ada assertions"));
12202 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12207 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12208 for all exception catchpoint kinds. */
12211 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12213 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12217 case ada_catch_exception
:
12218 fprintf_filtered (fp
, "catch exception");
12219 if (!c
->excep_string
.empty ())
12220 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12223 case ada_catch_exception_unhandled
:
12224 fprintf_filtered (fp
, "catch exception unhandled");
12227 case ada_catch_handlers
:
12228 fprintf_filtered (fp
, "catch handlers");
12231 case ada_catch_assert
:
12232 fprintf_filtered (fp
, "catch assert");
12236 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12238 print_recreate_thread (b
, fp
);
12241 /* Virtual tables for various breakpoint types. */
12242 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12243 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12244 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12245 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12247 /* See ada-lang.h. */
12250 is_ada_exception_catchpoint (breakpoint
*bp
)
12252 return (bp
->ops
== &catch_exception_breakpoint_ops
12253 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12254 || bp
->ops
== &catch_assert_breakpoint_ops
12255 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12258 /* Split the arguments specified in a "catch exception" command.
12259 Set EX to the appropriate catchpoint type.
12260 Set EXCEP_STRING to the name of the specific exception if
12261 specified by the user.
12262 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12263 "catch handlers" command. False otherwise.
12264 If a condition is found at the end of the arguments, the condition
12265 expression is stored in COND_STRING (memory must be deallocated
12266 after use). Otherwise COND_STRING is set to NULL. */
12269 catch_ada_exception_command_split (const char *args
,
12270 bool is_catch_handlers_cmd
,
12271 enum ada_exception_catchpoint_kind
*ex
,
12272 std::string
*excep_string
,
12273 std::string
*cond_string
)
12275 std::string exception_name
;
12277 exception_name
= extract_arg (&args
);
12278 if (exception_name
== "if")
12280 /* This is not an exception name; this is the start of a condition
12281 expression for a catchpoint on all exceptions. So, "un-get"
12282 this token, and set exception_name to NULL. */
12283 exception_name
.clear ();
12287 /* Check to see if we have a condition. */
12289 args
= skip_spaces (args
);
12290 if (startswith (args
, "if")
12291 && (isspace (args
[2]) || args
[2] == '\0'))
12294 args
= skip_spaces (args
);
12296 if (args
[0] == '\0')
12297 error (_("Condition missing after `if' keyword"));
12298 *cond_string
= args
;
12300 args
+= strlen (args
);
12303 /* Check that we do not have any more arguments. Anything else
12306 if (args
[0] != '\0')
12307 error (_("Junk at end of expression"));
12309 if (is_catch_handlers_cmd
)
12311 /* Catch handling of exceptions. */
12312 *ex
= ada_catch_handlers
;
12313 *excep_string
= exception_name
;
12315 else if (exception_name
.empty ())
12317 /* Catch all exceptions. */
12318 *ex
= ada_catch_exception
;
12319 excep_string
->clear ();
12321 else if (exception_name
== "unhandled")
12323 /* Catch unhandled exceptions. */
12324 *ex
= ada_catch_exception_unhandled
;
12325 excep_string
->clear ();
12329 /* Catch a specific exception. */
12330 *ex
= ada_catch_exception
;
12331 *excep_string
= exception_name
;
12335 /* Return the name of the symbol on which we should break in order to
12336 implement a catchpoint of the EX kind. */
12338 static const char *
12339 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12341 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12343 gdb_assert (data
->exception_info
!= NULL
);
12347 case ada_catch_exception
:
12348 return (data
->exception_info
->catch_exception_sym
);
12350 case ada_catch_exception_unhandled
:
12351 return (data
->exception_info
->catch_exception_unhandled_sym
);
12353 case ada_catch_assert
:
12354 return (data
->exception_info
->catch_assert_sym
);
12356 case ada_catch_handlers
:
12357 return (data
->exception_info
->catch_handlers_sym
);
12360 internal_error (__FILE__
, __LINE__
,
12361 _("unexpected catchpoint kind (%d)"), ex
);
12365 /* Return the breakpoint ops "virtual table" used for catchpoints
12368 static const struct breakpoint_ops
*
12369 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12373 case ada_catch_exception
:
12374 return (&catch_exception_breakpoint_ops
);
12376 case ada_catch_exception_unhandled
:
12377 return (&catch_exception_unhandled_breakpoint_ops
);
12379 case ada_catch_assert
:
12380 return (&catch_assert_breakpoint_ops
);
12382 case ada_catch_handlers
:
12383 return (&catch_handlers_breakpoint_ops
);
12386 internal_error (__FILE__
, __LINE__
,
12387 _("unexpected catchpoint kind (%d)"), ex
);
12391 /* Return the condition that will be used to match the current exception
12392 being raised with the exception that the user wants to catch. This
12393 assumes that this condition is used when the inferior just triggered
12394 an exception catchpoint.
12395 EX: the type of catchpoints used for catching Ada exceptions. */
12398 ada_exception_catchpoint_cond_string (const char *excep_string
,
12399 enum ada_exception_catchpoint_kind ex
)
12402 bool is_standard_exc
= false;
12403 std::string result
;
12405 if (ex
== ada_catch_handlers
)
12407 /* For exception handlers catchpoints, the condition string does
12408 not use the same parameter as for the other exceptions. */
12409 result
= ("long_integer (GNAT_GCC_exception_Access"
12410 "(gcc_exception).all.occurrence.id)");
12413 result
= "long_integer (e)";
12415 /* The standard exceptions are a special case. They are defined in
12416 runtime units that have been compiled without debugging info; if
12417 EXCEP_STRING is the not-fully-qualified name of a standard
12418 exception (e.g. "constraint_error") then, during the evaluation
12419 of the condition expression, the symbol lookup on this name would
12420 *not* return this standard exception. The catchpoint condition
12421 may then be set only on user-defined exceptions which have the
12422 same not-fully-qualified name (e.g. my_package.constraint_error).
12424 To avoid this unexcepted behavior, these standard exceptions are
12425 systematically prefixed by "standard". This means that "catch
12426 exception constraint_error" is rewritten into "catch exception
12427 standard.constraint_error".
12429 If an exception named constraint_error is defined in another package of
12430 the inferior program, then the only way to specify this exception as a
12431 breakpoint condition is to use its fully-qualified named:
12432 e.g. my_package.constraint_error. */
12434 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12436 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12438 is_standard_exc
= true;
12445 if (is_standard_exc
)
12446 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12448 string_appendf (result
, "long_integer (&%s)", excep_string
);
12453 /* Return the symtab_and_line that should be used to insert an exception
12454 catchpoint of the TYPE kind.
12456 ADDR_STRING returns the name of the function where the real
12457 breakpoint that implements the catchpoints is set, depending on the
12458 type of catchpoint we need to create. */
12460 static struct symtab_and_line
12461 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12462 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12464 const char *sym_name
;
12465 struct symbol
*sym
;
12467 /* First, find out which exception support info to use. */
12468 ada_exception_support_info_sniffer ();
12470 /* Then lookup the function on which we will break in order to catch
12471 the Ada exceptions requested by the user. */
12472 sym_name
= ada_exception_sym_name (ex
);
12473 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12476 error (_("Catchpoint symbol not found: %s"), sym_name
);
12478 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12479 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12481 /* Set ADDR_STRING. */
12482 *addr_string
= sym_name
;
12485 *ops
= ada_exception_breakpoint_ops (ex
);
12487 return find_function_start_sal (sym
, 1);
12490 /* Create an Ada exception catchpoint.
12492 EX_KIND is the kind of exception catchpoint to be created.
12494 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12495 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12496 of the exception to which this catchpoint applies.
12498 COND_STRING, if not empty, is the catchpoint condition.
12500 TEMPFLAG, if nonzero, means that the underlying breakpoint
12501 should be temporary.
12503 FROM_TTY is the usual argument passed to all commands implementations. */
12506 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12507 enum ada_exception_catchpoint_kind ex_kind
,
12508 const std::string
&excep_string
,
12509 const std::string
&cond_string
,
12514 std::string addr_string
;
12515 const struct breakpoint_ops
*ops
= NULL
;
12516 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12518 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12519 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12520 ops
, tempflag
, disabled
, from_tty
);
12521 c
->excep_string
= excep_string
;
12522 create_excep_cond_exprs (c
.get (), ex_kind
);
12523 if (!cond_string
.empty ())
12524 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12525 install_breakpoint (0, std::move (c
), 1);
12528 /* Implement the "catch exception" command. */
12531 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12532 struct cmd_list_element
*command
)
12534 const char *arg
= arg_entry
;
12535 struct gdbarch
*gdbarch
= get_current_arch ();
12537 enum ada_exception_catchpoint_kind ex_kind
;
12538 std::string excep_string
;
12539 std::string cond_string
;
12541 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12545 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12547 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12548 excep_string
, cond_string
,
12549 tempflag
, 1 /* enabled */,
12553 /* Implement the "catch handlers" command. */
12556 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12557 struct cmd_list_element
*command
)
12559 const char *arg
= arg_entry
;
12560 struct gdbarch
*gdbarch
= get_current_arch ();
12562 enum ada_exception_catchpoint_kind ex_kind
;
12563 std::string excep_string
;
12564 std::string cond_string
;
12566 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12570 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12572 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12573 excep_string
, cond_string
,
12574 tempflag
, 1 /* enabled */,
12578 /* Completion function for the Ada "catch" commands. */
12581 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12582 const char *text
, const char *word
)
12584 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12586 for (const ada_exc_info
&info
: exceptions
)
12588 if (startswith (info
.name
, word
))
12589 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12593 /* Split the arguments specified in a "catch assert" command.
12595 ARGS contains the command's arguments (or the empty string if
12596 no arguments were passed).
12598 If ARGS contains a condition, set COND_STRING to that condition
12599 (the memory needs to be deallocated after use). */
12602 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12604 args
= skip_spaces (args
);
12606 /* Check whether a condition was provided. */
12607 if (startswith (args
, "if")
12608 && (isspace (args
[2]) || args
[2] == '\0'))
12611 args
= skip_spaces (args
);
12612 if (args
[0] == '\0')
12613 error (_("condition missing after `if' keyword"));
12614 cond_string
.assign (args
);
12617 /* Otherwise, there should be no other argument at the end of
12619 else if (args
[0] != '\0')
12620 error (_("Junk at end of arguments."));
12623 /* Implement the "catch assert" command. */
12626 catch_assert_command (const char *arg_entry
, int from_tty
,
12627 struct cmd_list_element
*command
)
12629 const char *arg
= arg_entry
;
12630 struct gdbarch
*gdbarch
= get_current_arch ();
12632 std::string cond_string
;
12634 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12638 catch_ada_assert_command_split (arg
, cond_string
);
12639 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12641 tempflag
, 1 /* enabled */,
12645 /* Return non-zero if the symbol SYM is an Ada exception object. */
12648 ada_is_exception_sym (struct symbol
*sym
)
12650 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12652 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12653 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12654 && SYMBOL_CLASS (sym
) != LOC_CONST
12655 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12656 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12659 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12660 Ada exception object. This matches all exceptions except the ones
12661 defined by the Ada language. */
12664 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12668 if (!ada_is_exception_sym (sym
))
12671 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12672 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12673 return 0; /* A standard exception. */
12675 /* Numeric_Error is also a standard exception, so exclude it.
12676 See the STANDARD_EXC description for more details as to why
12677 this exception is not listed in that array. */
12678 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12684 /* A helper function for std::sort, comparing two struct ada_exc_info
12687 The comparison is determined first by exception name, and then
12688 by exception address. */
12691 ada_exc_info::operator< (const ada_exc_info
&other
) const
12695 result
= strcmp (name
, other
.name
);
12698 if (result
== 0 && addr
< other
.addr
)
12704 ada_exc_info::operator== (const ada_exc_info
&other
) const
12706 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12709 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12710 routine, but keeping the first SKIP elements untouched.
12712 All duplicates are also removed. */
12715 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12718 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12719 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12720 exceptions
->end ());
12723 /* Add all exceptions defined by the Ada standard whose name match
12724 a regular expression.
12726 If PREG is not NULL, then this regexp_t object is used to
12727 perform the symbol name matching. Otherwise, no name-based
12728 filtering is performed.
12730 EXCEPTIONS is a vector of exceptions to which matching exceptions
12734 ada_add_standard_exceptions (compiled_regex
*preg
,
12735 std::vector
<ada_exc_info
> *exceptions
)
12739 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12742 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12744 struct bound_minimal_symbol msymbol
12745 = ada_lookup_simple_minsym (standard_exc
[i
]);
12747 if (msymbol
.minsym
!= NULL
)
12749 struct ada_exc_info info
12750 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12752 exceptions
->push_back (info
);
12758 /* Add all Ada exceptions defined locally and accessible from the given
12761 If PREG is not NULL, then this regexp_t object is used to
12762 perform the symbol name matching. Otherwise, no name-based
12763 filtering is performed.
12765 EXCEPTIONS is a vector of exceptions to which matching exceptions
12769 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12770 struct frame_info
*frame
,
12771 std::vector
<ada_exc_info
> *exceptions
)
12773 const struct block
*block
= get_frame_block (frame
, 0);
12777 struct block_iterator iter
;
12778 struct symbol
*sym
;
12780 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12782 switch (SYMBOL_CLASS (sym
))
12789 if (ada_is_exception_sym (sym
))
12791 struct ada_exc_info info
= {sym
->print_name (),
12792 SYMBOL_VALUE_ADDRESS (sym
)};
12794 exceptions
->push_back (info
);
12798 if (BLOCK_FUNCTION (block
) != NULL
)
12800 block
= BLOCK_SUPERBLOCK (block
);
12804 /* Return true if NAME matches PREG or if PREG is NULL. */
12807 name_matches_regex (const char *name
, compiled_regex
*preg
)
12809 return (preg
== NULL
12810 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
12813 /* Add all exceptions defined globally whose name name match
12814 a regular expression, excluding standard exceptions.
12816 The reason we exclude standard exceptions is that they need
12817 to be handled separately: Standard exceptions are defined inside
12818 a runtime unit which is normally not compiled with debugging info,
12819 and thus usually do not show up in our symbol search. However,
12820 if the unit was in fact built with debugging info, we need to
12821 exclude them because they would duplicate the entry we found
12822 during the special loop that specifically searches for those
12823 standard exceptions.
12825 If PREG is not NULL, then this regexp_t object is used to
12826 perform the symbol name matching. Otherwise, no name-based
12827 filtering is performed.
12829 EXCEPTIONS is a vector of exceptions to which matching exceptions
12833 ada_add_global_exceptions (compiled_regex
*preg
,
12834 std::vector
<ada_exc_info
> *exceptions
)
12836 /* In Ada, the symbol "search name" is a linkage name, whereas the
12837 regular expression used to do the matching refers to the natural
12838 name. So match against the decoded name. */
12839 expand_symtabs_matching (NULL
,
12840 lookup_name_info::match_any (),
12841 [&] (const char *search_name
)
12843 std::string decoded
= ada_decode (search_name
);
12844 return name_matches_regex (decoded
.c_str (), preg
);
12849 for (objfile
*objfile
: current_program_space
->objfiles ())
12851 for (compunit_symtab
*s
: objfile
->compunits ())
12853 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
12856 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12858 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12859 struct block_iterator iter
;
12860 struct symbol
*sym
;
12862 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12863 if (ada_is_non_standard_exception_sym (sym
)
12864 && name_matches_regex (sym
->natural_name (), preg
))
12866 struct ada_exc_info info
12867 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
12869 exceptions
->push_back (info
);
12876 /* Implements ada_exceptions_list with the regular expression passed
12877 as a regex_t, rather than a string.
12879 If not NULL, PREG is used to filter out exceptions whose names
12880 do not match. Otherwise, all exceptions are listed. */
12882 static std::vector
<ada_exc_info
>
12883 ada_exceptions_list_1 (compiled_regex
*preg
)
12885 std::vector
<ada_exc_info
> result
;
12888 /* First, list the known standard exceptions. These exceptions
12889 need to be handled separately, as they are usually defined in
12890 runtime units that have been compiled without debugging info. */
12892 ada_add_standard_exceptions (preg
, &result
);
12894 /* Next, find all exceptions whose scope is local and accessible
12895 from the currently selected frame. */
12897 if (has_stack_frames ())
12899 prev_len
= result
.size ();
12900 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12902 if (result
.size () > prev_len
)
12903 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12906 /* Add all exceptions whose scope is global. */
12908 prev_len
= result
.size ();
12909 ada_add_global_exceptions (preg
, &result
);
12910 if (result
.size () > prev_len
)
12911 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12916 /* Return a vector of ada_exc_info.
12918 If REGEXP is NULL, all exceptions are included in the result.
12919 Otherwise, it should contain a valid regular expression,
12920 and only the exceptions whose names match that regular expression
12921 are included in the result.
12923 The exceptions are sorted in the following order:
12924 - Standard exceptions (defined by the Ada language), in
12925 alphabetical order;
12926 - Exceptions only visible from the current frame, in
12927 alphabetical order;
12928 - Exceptions whose scope is global, in alphabetical order. */
12930 std::vector
<ada_exc_info
>
12931 ada_exceptions_list (const char *regexp
)
12933 if (regexp
== NULL
)
12934 return ada_exceptions_list_1 (NULL
);
12936 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
12937 return ada_exceptions_list_1 (®
);
12940 /* Implement the "info exceptions" command. */
12943 info_exceptions_command (const char *regexp
, int from_tty
)
12945 struct gdbarch
*gdbarch
= get_current_arch ();
12947 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
12949 if (regexp
!= NULL
)
12951 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
12953 printf_filtered (_("All defined Ada exceptions:\n"));
12955 for (const ada_exc_info
&info
: exceptions
)
12956 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
12960 /* Information about operators given special treatment in functions
12962 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12964 #define ADA_OPERATORS \
12965 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12966 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12967 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12968 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12969 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12970 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12971 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12972 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12973 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12974 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12975 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12976 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12977 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12978 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12979 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
12980 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12981 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12982 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12983 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
12986 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
12989 switch (exp
->elts
[pc
- 1].opcode
)
12992 operator_length_standard (exp
, pc
, oplenp
, argsp
);
12995 #define OP_DEFN(op, len, args, binop) \
12996 case op: *oplenp = len; *argsp = args; break;
13002 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13007 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13012 /* Implementation of the exp_descriptor method operator_check. */
13015 ada_operator_check (struct expression
*exp
, int pos
,
13016 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13019 const union exp_element
*const elts
= exp
->elts
;
13020 struct type
*type
= NULL
;
13022 switch (elts
[pos
].opcode
)
13024 case UNOP_IN_RANGE
:
13026 type
= elts
[pos
+ 1].type
;
13030 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13033 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13035 if (type
!= nullptr && type
->objfile_owner () != nullptr
13036 && objfile_func (type
->objfile_owner (), data
))
13042 /* As for operator_length, but assumes PC is pointing at the first
13043 element of the operator, and gives meaningful results only for the
13044 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13047 ada_forward_operator_length (struct expression
*exp
, int pc
,
13048 int *oplenp
, int *argsp
)
13050 switch (exp
->elts
[pc
].opcode
)
13053 *oplenp
= *argsp
= 0;
13056 #define OP_DEFN(op, len, args, binop) \
13057 case op: *oplenp = len; *argsp = args; break;
13063 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13068 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13074 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13076 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13084 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13086 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13091 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13095 /* Ada attributes ('Foo). */
13098 case OP_ATR_LENGTH
:
13102 case OP_ATR_MODULUS
:
13109 case UNOP_IN_RANGE
:
13111 /* XXX: gdb_sprint_host_address, type_sprint */
13112 fprintf_filtered (stream
, _("Type @"));
13113 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13114 fprintf_filtered (stream
, " (");
13115 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13116 fprintf_filtered (stream
, ")");
13118 case BINOP_IN_BOUNDS
:
13119 fprintf_filtered (stream
, " (%d)",
13120 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13122 case TERNOP_IN_RANGE
:
13127 case OP_DISCRETE_RANGE
:
13128 case OP_POSITIONAL
:
13135 char *name
= &exp
->elts
[elt
+ 2].string
;
13136 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13138 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13143 return dump_subexp_body_standard (exp
, stream
, elt
);
13147 for (i
= 0; i
< nargs
; i
+= 1)
13148 elt
= dump_subexp (exp
, stream
, elt
);
13153 /* The Ada extension of print_subexp (q.v.). */
13156 ada_print_subexp (struct expression
*exp
, int *pos
,
13157 struct ui_file
*stream
, enum precedence prec
)
13159 int oplen
, nargs
, i
;
13161 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13163 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13170 print_subexp_standard (exp
, pos
, stream
, prec
);
13174 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13177 case BINOP_IN_BOUNDS
:
13178 /* XXX: sprint_subexp */
13179 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13180 fputs_filtered (" in ", stream
);
13181 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13182 fputs_filtered ("'range", stream
);
13183 if (exp
->elts
[pc
+ 1].longconst
> 1)
13184 fprintf_filtered (stream
, "(%ld)",
13185 (long) exp
->elts
[pc
+ 1].longconst
);
13188 case TERNOP_IN_RANGE
:
13189 if (prec
>= PREC_EQUAL
)
13190 fputs_filtered ("(", stream
);
13191 /* XXX: sprint_subexp */
13192 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13193 fputs_filtered (" in ", stream
);
13194 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13195 fputs_filtered (" .. ", stream
);
13196 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13197 if (prec
>= PREC_EQUAL
)
13198 fputs_filtered (")", stream
);
13203 case OP_ATR_LENGTH
:
13207 case OP_ATR_MODULUS
:
13212 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13214 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13215 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13216 &type_print_raw_options
);
13220 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13221 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13226 for (tem
= 1; tem
< nargs
; tem
+= 1)
13228 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13229 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13231 fputs_filtered (")", stream
);
13236 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13237 fputs_filtered ("'(", stream
);
13238 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13239 fputs_filtered (")", stream
);
13242 case UNOP_IN_RANGE
:
13243 /* XXX: sprint_subexp */
13244 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13245 fputs_filtered (" in ", stream
);
13246 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13247 &type_print_raw_options
);
13250 case OP_DISCRETE_RANGE
:
13251 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13252 fputs_filtered ("..", stream
);
13253 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13257 fputs_filtered ("others => ", stream
);
13258 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13262 for (i
= 0; i
< nargs
-1; i
+= 1)
13265 fputs_filtered ("|", stream
);
13266 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13268 fputs_filtered (" => ", stream
);
13269 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13272 case OP_POSITIONAL
:
13273 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13277 fputs_filtered ("(", stream
);
13278 for (i
= 0; i
< nargs
; i
+= 1)
13281 fputs_filtered (", ", stream
);
13282 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13284 fputs_filtered (")", stream
);
13289 /* Table mapping opcodes into strings for printing operators
13290 and precedences of the operators. */
13292 static const struct op_print ada_op_print_tab
[] = {
13293 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13294 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13295 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13296 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13297 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13298 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13299 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13300 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13301 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13302 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13303 {">", BINOP_GTR
, PREC_ORDER
, 0},
13304 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13305 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13306 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13307 {"+", BINOP_ADD
, PREC_ADD
, 0},
13308 {"-", BINOP_SUB
, PREC_ADD
, 0},
13309 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13310 {"*", BINOP_MUL
, PREC_MUL
, 0},
13311 {"/", BINOP_DIV
, PREC_MUL
, 0},
13312 {"rem", BINOP_REM
, PREC_MUL
, 0},
13313 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13314 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13315 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13316 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13317 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13318 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13319 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13320 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13321 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13322 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13323 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13324 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13327 /* Language vector */
13329 static const struct exp_descriptor ada_exp_descriptor
= {
13331 ada_operator_length
,
13332 ada_operator_check
,
13333 ada_dump_subexp_body
,
13334 ada_evaluate_subexp
13337 /* symbol_name_matcher_ftype adapter for wild_match. */
13340 do_wild_match (const char *symbol_search_name
,
13341 const lookup_name_info
&lookup_name
,
13342 completion_match_result
*comp_match_res
)
13344 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13347 /* symbol_name_matcher_ftype adapter for full_match. */
13350 do_full_match (const char *symbol_search_name
,
13351 const lookup_name_info
&lookup_name
,
13352 completion_match_result
*comp_match_res
)
13354 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13356 /* If both symbols start with "_ada_", just let the loop below
13357 handle the comparison. However, if only the symbol name starts
13358 with "_ada_", skip the prefix and let the match proceed as
13360 if (startswith (symbol_search_name
, "_ada_")
13361 && !startswith (lname
, "_ada"))
13362 symbol_search_name
+= 5;
13364 int uscore_count
= 0;
13365 while (*lname
!= '\0')
13367 if (*symbol_search_name
!= *lname
)
13369 if (*symbol_search_name
== 'B' && uscore_count
== 2
13370 && symbol_search_name
[1] == '_')
13372 symbol_search_name
+= 2;
13373 while (isdigit (*symbol_search_name
))
13374 ++symbol_search_name
;
13375 if (symbol_search_name
[0] == '_'
13376 && symbol_search_name
[1] == '_')
13378 symbol_search_name
+= 2;
13385 if (*symbol_search_name
== '_')
13390 ++symbol_search_name
;
13394 return is_name_suffix (symbol_search_name
);
13397 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13400 do_exact_match (const char *symbol_search_name
,
13401 const lookup_name_info
&lookup_name
,
13402 completion_match_result
*comp_match_res
)
13404 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13407 /* Build the Ada lookup name for LOOKUP_NAME. */
13409 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13411 gdb::string_view user_name
= lookup_name
.name ();
13413 if (!user_name
.empty () && user_name
[0] == '<')
13415 if (user_name
.back () == '>')
13417 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13420 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13421 m_encoded_p
= true;
13422 m_verbatim_p
= true;
13423 m_wild_match_p
= false;
13424 m_standard_p
= false;
13428 m_verbatim_p
= false;
13430 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13434 const char *folded
= ada_fold_name (user_name
);
13435 m_encoded_name
= ada_encode_1 (folded
, false);
13436 if (m_encoded_name
.empty ())
13437 m_encoded_name
= gdb::to_string (user_name
);
13440 m_encoded_name
= gdb::to_string (user_name
);
13442 /* Handle the 'package Standard' special case. See description
13443 of m_standard_p. */
13444 if (startswith (m_encoded_name
.c_str (), "standard__"))
13446 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13447 m_standard_p
= true;
13450 m_standard_p
= false;
13452 /* If the name contains a ".", then the user is entering a fully
13453 qualified entity name, and the match must not be done in wild
13454 mode. Similarly, if the user wants to complete what looks
13455 like an encoded name, the match must not be done in wild
13456 mode. Also, in the standard__ special case always do
13457 non-wild matching. */
13459 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13462 && user_name
.find ('.') == std::string::npos
);
13466 /* symbol_name_matcher_ftype method for Ada. This only handles
13467 completion mode. */
13470 ada_symbol_name_matches (const char *symbol_search_name
,
13471 const lookup_name_info
&lookup_name
,
13472 completion_match_result
*comp_match_res
)
13474 return lookup_name
.ada ().matches (symbol_search_name
,
13475 lookup_name
.match_type (),
13479 /* A name matcher that matches the symbol name exactly, with
13483 literal_symbol_name_matcher (const char *symbol_search_name
,
13484 const lookup_name_info
&lookup_name
,
13485 completion_match_result
*comp_match_res
)
13487 gdb::string_view name_view
= lookup_name
.name ();
13489 if (lookup_name
.completion_mode ()
13490 ? (strncmp (symbol_search_name
, name_view
.data (),
13491 name_view
.size ()) == 0)
13492 : symbol_search_name
== name_view
)
13494 if (comp_match_res
!= NULL
)
13495 comp_match_res
->set_match (symbol_search_name
);
13502 /* Implement the "get_symbol_name_matcher" language_defn method for
13505 static symbol_name_matcher_ftype
*
13506 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13508 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13509 return literal_symbol_name_matcher
;
13511 if (lookup_name
.completion_mode ())
13512 return ada_symbol_name_matches
;
13515 if (lookup_name
.ada ().wild_match_p ())
13516 return do_wild_match
;
13517 else if (lookup_name
.ada ().verbatim_p ())
13518 return do_exact_match
;
13520 return do_full_match
;
13524 /* Class representing the Ada language. */
13526 class ada_language
: public language_defn
13530 : language_defn (language_ada
)
13533 /* See language.h. */
13535 const char *name () const override
13538 /* See language.h. */
13540 const char *natural_name () const override
13543 /* See language.h. */
13545 const std::vector
<const char *> &filename_extensions () const override
13547 static const std::vector
<const char *> extensions
13548 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13552 /* Print an array element index using the Ada syntax. */
13554 void print_array_index (struct type
*index_type
,
13556 struct ui_file
*stream
,
13557 const value_print_options
*options
) const override
13559 struct value
*index_value
= val_atr (index_type
, index
);
13561 value_print (index_value
, stream
, options
);
13562 fprintf_filtered (stream
, " => ");
13565 /* Implement the "read_var_value" language_defn method for Ada. */
13567 struct value
*read_var_value (struct symbol
*var
,
13568 const struct block
*var_block
,
13569 struct frame_info
*frame
) const override
13571 /* The only case where default_read_var_value is not sufficient
13572 is when VAR is a renaming... */
13573 if (frame
!= nullptr)
13575 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13576 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13577 return ada_read_renaming_var_value (var
, frame_block
);
13580 /* This is a typical case where we expect the default_read_var_value
13581 function to work. */
13582 return language_defn::read_var_value (var
, var_block
, frame
);
13585 /* See language.h. */
13586 void language_arch_info (struct gdbarch
*gdbarch
,
13587 struct language_arch_info
*lai
) const override
13589 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13591 /* Helper function to allow shorter lines below. */
13592 auto add
= [&] (struct type
*t
)
13594 lai
->add_primitive_type (t
);
13597 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13599 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13600 0, "long_integer"));
13601 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13602 0, "short_integer"));
13603 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13605 lai
->set_string_char_type (char_type
);
13607 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13608 "float", gdbarch_float_format (gdbarch
)));
13609 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13610 "long_float", gdbarch_double_format (gdbarch
)));
13611 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13612 0, "long_long_integer"));
13613 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13615 gdbarch_long_double_format (gdbarch
)));
13616 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13618 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13620 add (builtin
->builtin_void
);
13622 struct type
*system_addr_ptr
13623 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13625 system_addr_ptr
->set_name ("system__address");
13626 add (system_addr_ptr
);
13628 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13629 type. This is a signed integral type whose size is the same as
13630 the size of addresses. */
13631 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13632 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13633 "storage_offset"));
13635 lai
->set_bool_type (builtin
->builtin_bool
);
13638 /* See language.h. */
13640 bool iterate_over_symbols
13641 (const struct block
*block
, const lookup_name_info
&name
,
13642 domain_enum domain
,
13643 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13645 std::vector
<struct block_symbol
> results
13646 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13647 for (block_symbol
&sym
: results
)
13649 if (!callback (&sym
))
13656 /* See language.h. */
13657 bool sniff_from_mangled_name (const char *mangled
,
13658 char **out
) const override
13660 std::string demangled
= ada_decode (mangled
);
13664 if (demangled
!= mangled
&& demangled
[0] != '<')
13666 /* Set the gsymbol language to Ada, but still return 0.
13667 Two reasons for that:
13669 1. For Ada, we prefer computing the symbol's decoded name
13670 on the fly rather than pre-compute it, in order to save
13671 memory (Ada projects are typically very large).
13673 2. There are some areas in the definition of the GNAT
13674 encoding where, with a bit of bad luck, we might be able
13675 to decode a non-Ada symbol, generating an incorrect
13676 demangled name (Eg: names ending with "TB" for instance
13677 are identified as task bodies and so stripped from
13678 the decoded name returned).
13680 Returning true, here, but not setting *DEMANGLED, helps us get
13681 a little bit of the best of both worlds. Because we're last,
13682 we should not affect any of the other languages that were
13683 able to demangle the symbol before us; we get to correctly
13684 tag Ada symbols as such; and even if we incorrectly tagged a
13685 non-Ada symbol, which should be rare, any routing through the
13686 Ada language should be transparent (Ada tries to behave much
13687 like C/C++ with non-Ada symbols). */
13694 /* See language.h. */
13696 char *demangle_symbol (const char *mangled
, int options
) const override
13698 return ada_la_decode (mangled
, options
);
13701 /* See language.h. */
13703 void print_type (struct type
*type
, const char *varstring
,
13704 struct ui_file
*stream
, int show
, int level
,
13705 const struct type_print_options
*flags
) const override
13707 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13710 /* See language.h. */
13712 const char *word_break_characters (void) const override
13714 return ada_completer_word_break_characters
;
13717 /* See language.h. */
13719 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13720 complete_symbol_mode mode
,
13721 symbol_name_match_type name_match_type
,
13722 const char *text
, const char *word
,
13723 enum type_code code
) const override
13725 struct symbol
*sym
;
13726 const struct block
*b
, *surrounding_static_block
= 0;
13727 struct block_iterator iter
;
13729 gdb_assert (code
== TYPE_CODE_UNDEF
);
13731 lookup_name_info
lookup_name (text
, name_match_type
, true);
13733 /* First, look at the partial symtab symbols. */
13734 expand_symtabs_matching (NULL
,
13740 /* At this point scan through the misc symbol vectors and add each
13741 symbol you find to the list. Eventually we want to ignore
13742 anything that isn't a text symbol (everything else will be
13743 handled by the psymtab code above). */
13745 for (objfile
*objfile
: current_program_space
->objfiles ())
13747 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13751 if (completion_skip_symbol (mode
, msymbol
))
13754 language symbol_language
= msymbol
->language ();
13756 /* Ada minimal symbols won't have their language set to Ada. If
13757 we let completion_list_add_name compare using the
13758 default/C-like matcher, then when completing e.g., symbols in a
13759 package named "pck", we'd match internal Ada symbols like
13760 "pckS", which are invalid in an Ada expression, unless you wrap
13761 them in '<' '>' to request a verbatim match.
13763 Unfortunately, some Ada encoded names successfully demangle as
13764 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13765 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13766 with the wrong language set. Paper over that issue here. */
13767 if (symbol_language
== language_auto
13768 || symbol_language
== language_cplus
)
13769 symbol_language
= language_ada
;
13771 completion_list_add_name (tracker
,
13773 msymbol
->linkage_name (),
13774 lookup_name
, text
, word
);
13778 /* Search upwards from currently selected frame (so that we can
13779 complete on local vars. */
13781 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13783 if (!BLOCK_SUPERBLOCK (b
))
13784 surrounding_static_block
= b
; /* For elmin of dups */
13786 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13788 if (completion_skip_symbol (mode
, sym
))
13791 completion_list_add_name (tracker
,
13793 sym
->linkage_name (),
13794 lookup_name
, text
, word
);
13798 /* Go through the symtabs and check the externs and statics for
13799 symbols which match. */
13801 for (objfile
*objfile
: current_program_space
->objfiles ())
13803 for (compunit_symtab
*s
: objfile
->compunits ())
13806 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
13807 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13809 if (completion_skip_symbol (mode
, sym
))
13812 completion_list_add_name (tracker
,
13814 sym
->linkage_name (),
13815 lookup_name
, text
, word
);
13820 for (objfile
*objfile
: current_program_space
->objfiles ())
13822 for (compunit_symtab
*s
: objfile
->compunits ())
13825 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
13826 /* Don't do this block twice. */
13827 if (b
== surrounding_static_block
)
13829 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13831 if (completion_skip_symbol (mode
, sym
))
13834 completion_list_add_name (tracker
,
13836 sym
->linkage_name (),
13837 lookup_name
, text
, word
);
13843 /* See language.h. */
13845 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13846 (struct type
*type
, CORE_ADDR addr
) const override
13848 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
13849 std::string name
= type_to_string (type
);
13850 return gdb::unique_xmalloc_ptr
<char>
13851 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
13854 /* See language.h. */
13856 void value_print (struct value
*val
, struct ui_file
*stream
,
13857 const struct value_print_options
*options
) const override
13859 return ada_value_print (val
, stream
, options
);
13862 /* See language.h. */
13864 void value_print_inner
13865 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13866 const struct value_print_options
*options
) const override
13868 return ada_value_print_inner (val
, stream
, recurse
, options
);
13871 /* See language.h. */
13873 struct block_symbol lookup_symbol_nonlocal
13874 (const char *name
, const struct block
*block
,
13875 const domain_enum domain
) const override
13877 struct block_symbol sym
;
13879 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13880 if (sym
.symbol
!= NULL
)
13883 /* If we haven't found a match at this point, try the primitive
13884 types. In other languages, this search is performed before
13885 searching for global symbols in order to short-circuit that
13886 global-symbol search if it happens that the name corresponds
13887 to a primitive type. But we cannot do the same in Ada, because
13888 it is perfectly legitimate for a program to declare a type which
13889 has the same name as a standard type. If looking up a type in
13890 that situation, we have traditionally ignored the primitive type
13891 in favor of user-defined types. This is why, unlike most other
13892 languages, we search the primitive types this late and only after
13893 having searched the global symbols without success. */
13895 if (domain
== VAR_DOMAIN
)
13897 struct gdbarch
*gdbarch
;
13900 gdbarch
= target_gdbarch ();
13902 gdbarch
= block_gdbarch (block
);
13904 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
13905 if (sym
.symbol
!= NULL
)
13912 /* See language.h. */
13914 int parser (struct parser_state
*ps
) const override
13916 warnings_issued
= 0;
13917 return ada_parse (ps
);
13922 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
13923 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
13924 namespace) and converts operators that are user-defined into
13925 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
13926 a preferred result type [at the moment, only type void has any
13927 effect---causing procedures to be preferred over functions in calls].
13928 A null CONTEXT_TYPE indicates that a non-void return type is
13929 preferred. May change (expand) *EXP. */
13931 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
13934 struct type
*context_type
= NULL
;
13937 if (ps
->void_context_p
)
13938 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
13940 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
13941 ps
->block_tracker
);
13944 /* See language.h. */
13946 void emitchar (int ch
, struct type
*chtype
,
13947 struct ui_file
*stream
, int quoter
) const override
13949 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
13952 /* See language.h. */
13954 void printchar (int ch
, struct type
*chtype
,
13955 struct ui_file
*stream
) const override
13957 ada_printchar (ch
, chtype
, stream
);
13960 /* See language.h. */
13962 void printstr (struct ui_file
*stream
, struct type
*elttype
,
13963 const gdb_byte
*string
, unsigned int length
,
13964 const char *encoding
, int force_ellipses
,
13965 const struct value_print_options
*options
) const override
13967 ada_printstr (stream
, elttype
, string
, length
, encoding
,
13968 force_ellipses
, options
);
13971 /* See language.h. */
13973 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
13974 struct ui_file
*stream
) const override
13976 ada_print_typedef (type
, new_symbol
, stream
);
13979 /* See language.h. */
13981 bool is_string_type_p (struct type
*type
) const override
13983 return ada_is_string_type (type
);
13986 /* See language.h. */
13988 const char *struct_too_deep_ellipsis () const override
13989 { return "(...)"; }
13991 /* See language.h. */
13993 bool c_style_arrays_p () const override
13996 /* See language.h. */
13998 bool store_sym_names_in_linkage_form_p () const override
14001 /* See language.h. */
14003 const struct lang_varobj_ops
*varobj_ops () const override
14004 { return &ada_varobj_ops
; }
14006 /* See language.h. */
14008 const struct exp_descriptor
*expression_ops () const override
14009 { return &ada_exp_descriptor
; }
14011 /* See language.h. */
14013 const struct op_print
*opcode_print_table () const override
14014 { return ada_op_print_tab
; }
14017 /* See language.h. */
14019 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14020 (const lookup_name_info
&lookup_name
) const override
14022 return ada_get_symbol_name_matcher (lookup_name
);
14026 /* Single instance of the Ada language class. */
14028 static ada_language ada_language_defn
;
14030 /* Command-list for the "set/show ada" prefix command. */
14031 static struct cmd_list_element
*set_ada_list
;
14032 static struct cmd_list_element
*show_ada_list
;
14035 initialize_ada_catchpoint_ops (void)
14037 struct breakpoint_ops
*ops
;
14039 initialize_breakpoint_ops ();
14041 ops
= &catch_exception_breakpoint_ops
;
14042 *ops
= bkpt_breakpoint_ops
;
14043 ops
->allocate_location
= allocate_location_exception
;
14044 ops
->re_set
= re_set_exception
;
14045 ops
->check_status
= check_status_exception
;
14046 ops
->print_it
= print_it_exception
;
14047 ops
->print_one
= print_one_exception
;
14048 ops
->print_mention
= print_mention_exception
;
14049 ops
->print_recreate
= print_recreate_exception
;
14051 ops
= &catch_exception_unhandled_breakpoint_ops
;
14052 *ops
= bkpt_breakpoint_ops
;
14053 ops
->allocate_location
= allocate_location_exception
;
14054 ops
->re_set
= re_set_exception
;
14055 ops
->check_status
= check_status_exception
;
14056 ops
->print_it
= print_it_exception
;
14057 ops
->print_one
= print_one_exception
;
14058 ops
->print_mention
= print_mention_exception
;
14059 ops
->print_recreate
= print_recreate_exception
;
14061 ops
= &catch_assert_breakpoint_ops
;
14062 *ops
= bkpt_breakpoint_ops
;
14063 ops
->allocate_location
= allocate_location_exception
;
14064 ops
->re_set
= re_set_exception
;
14065 ops
->check_status
= check_status_exception
;
14066 ops
->print_it
= print_it_exception
;
14067 ops
->print_one
= print_one_exception
;
14068 ops
->print_mention
= print_mention_exception
;
14069 ops
->print_recreate
= print_recreate_exception
;
14071 ops
= &catch_handlers_breakpoint_ops
;
14072 *ops
= bkpt_breakpoint_ops
;
14073 ops
->allocate_location
= allocate_location_exception
;
14074 ops
->re_set
= re_set_exception
;
14075 ops
->check_status
= check_status_exception
;
14076 ops
->print_it
= print_it_exception
;
14077 ops
->print_one
= print_one_exception
;
14078 ops
->print_mention
= print_mention_exception
;
14079 ops
->print_recreate
= print_recreate_exception
;
14082 /* This module's 'new_objfile' observer. */
14085 ada_new_objfile_observer (struct objfile
*objfile
)
14087 ada_clear_symbol_cache ();
14090 /* This module's 'free_objfile' observer. */
14093 ada_free_objfile_observer (struct objfile
*objfile
)
14095 ada_clear_symbol_cache ();
14098 void _initialize_ada_language ();
14100 _initialize_ada_language ()
14102 initialize_ada_catchpoint_ops ();
14104 add_basic_prefix_cmd ("ada", no_class
,
14105 _("Prefix command for changing Ada-specific settings."),
14106 &set_ada_list
, "set ada ", 0, &setlist
);
14108 add_show_prefix_cmd ("ada", no_class
,
14109 _("Generic command for showing Ada-specific settings."),
14110 &show_ada_list
, "show ada ", 0, &showlist
);
14112 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14113 &trust_pad_over_xvs
, _("\
14114 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14115 Show whether an optimization trusting PAD types over XVS types is activated."),
14117 This is related to the encoding used by the GNAT compiler. The debugger\n\
14118 should normally trust the contents of PAD types, but certain older versions\n\
14119 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14120 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14121 work around this bug. It is always safe to turn this option \"off\", but\n\
14122 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14123 this option to \"off\" unless necessary."),
14124 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14126 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14127 &print_signatures
, _("\
14128 Enable or disable the output of formal and return types for functions in the \
14129 overloads selection menu."), _("\
14130 Show whether the output of formal and return types for functions in the \
14131 overloads selection menu is activated."),
14132 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14134 add_catch_command ("exception", _("\
14135 Catch Ada exceptions, when raised.\n\
14136 Usage: catch exception [ARG] [if CONDITION]\n\
14137 Without any argument, stop when any Ada exception is raised.\n\
14138 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14139 being raised does not have a handler (and will therefore lead to the task's\n\
14141 Otherwise, the catchpoint only stops when the name of the exception being\n\
14142 raised is the same as ARG.\n\
14143 CONDITION is a boolean expression that is evaluated to see whether the\n\
14144 exception should cause a stop."),
14145 catch_ada_exception_command
,
14146 catch_ada_completer
,
14150 add_catch_command ("handlers", _("\
14151 Catch Ada exceptions, when handled.\n\
14152 Usage: catch handlers [ARG] [if CONDITION]\n\
14153 Without any argument, stop when any Ada exception is handled.\n\
14154 With an argument, catch only exceptions with the given name.\n\
14155 CONDITION is a boolean expression that is evaluated to see whether the\n\
14156 exception should cause a stop."),
14157 catch_ada_handlers_command
,
14158 catch_ada_completer
,
14161 add_catch_command ("assert", _("\
14162 Catch failed Ada assertions, when raised.\n\
14163 Usage: catch assert [if CONDITION]\n\
14164 CONDITION is a boolean expression that is evaluated to see whether the\n\
14165 exception should cause a stop."),
14166 catch_assert_command
,
14171 varsize_limit
= 65536;
14172 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14173 &varsize_limit
, _("\
14174 Set the maximum number of bytes allowed in a variable-size object."), _("\
14175 Show the maximum number of bytes allowed in a variable-size object."), _("\
14176 Attempts to access an object whose size is not a compile-time constant\n\
14177 and exceeds this limit will cause an error."),
14178 NULL
, NULL
, &setlist
, &showlist
);
14180 add_info ("exceptions", info_exceptions_command
,
14182 List all Ada exception names.\n\
14183 Usage: info exceptions [REGEXP]\n\
14184 If a regular expression is passed as an argument, only those matching\n\
14185 the regular expression are listed."));
14187 add_basic_prefix_cmd ("ada", class_maintenance
,
14188 _("Set Ada maintenance-related variables."),
14189 &maint_set_ada_cmdlist
, "maintenance set ada ",
14190 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14192 add_show_prefix_cmd ("ada", class_maintenance
,
14193 _("Show Ada maintenance-related variables."),
14194 &maint_show_ada_cmdlist
, "maintenance show ada ",
14195 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14197 add_setshow_boolean_cmd
14198 ("ignore-descriptive-types", class_maintenance
,
14199 &ada_ignore_descriptive_types_p
,
14200 _("Set whether descriptive types generated by GNAT should be ignored."),
14201 _("Show whether descriptive types generated by GNAT should be ignored."),
14203 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14204 DWARF attribute."),
14205 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14207 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14208 NULL
, xcalloc
, xfree
);
14210 /* The ada-lang observers. */
14211 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14212 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14213 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);