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 /* A helper function for UNOP_ABS. */
10056 ada_abs (struct type
*expect_type
,
10057 struct expression
*exp
,
10058 enum noside noside
, enum exp_opcode op
,
10059 struct value
*arg1
)
10061 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10062 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10063 return value_neg (arg1
);
10068 /* A helper function for BINOP_MUL. */
10071 ada_mult_binop (struct type
*expect_type
,
10072 struct expression
*exp
,
10073 enum noside noside
, enum exp_opcode op
,
10074 struct value
*arg1
, struct value
*arg2
)
10076 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10078 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10079 return value_zero (value_type (arg1
), not_lval
);
10083 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10084 return ada_value_binop (arg1
, arg2
, op
);
10088 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10091 ada_equal_binop (struct type
*expect_type
,
10092 struct expression
*exp
,
10093 enum noside noside
, enum exp_opcode op
,
10094 struct value
*arg1
, struct value
*arg2
)
10097 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10101 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10102 tem
= ada_value_equal (arg1
, arg2
);
10104 if (op
== BINOP_NOTEQUAL
)
10106 struct type
*type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10107 return value_from_longest (type
, (LONGEST
) tem
);
10110 /* A helper function for TERNOP_SLICE. */
10113 ada_ternop_slice (struct expression
*exp
,
10114 enum noside noside
,
10115 struct value
*array
, struct value
*low_bound_val
,
10116 struct value
*high_bound_val
)
10119 LONGEST high_bound
;
10121 low_bound_val
= coerce_ref (low_bound_val
);
10122 high_bound_val
= coerce_ref (high_bound_val
);
10123 low_bound
= value_as_long (low_bound_val
);
10124 high_bound
= value_as_long (high_bound_val
);
10126 /* If this is a reference to an aligner type, then remove all
10128 if (value_type (array
)->code () == TYPE_CODE_REF
10129 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10130 TYPE_TARGET_TYPE (value_type (array
)) =
10131 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10133 if (ada_is_any_packed_array_type (value_type (array
)))
10134 error (_("cannot slice a packed array"));
10136 /* If this is a reference to an array or an array lvalue,
10137 convert to a pointer. */
10138 if (value_type (array
)->code () == TYPE_CODE_REF
10139 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10140 && VALUE_LVAL (array
) == lval_memory
))
10141 array
= value_addr (array
);
10143 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10144 && ada_is_array_descriptor_type (ada_check_typedef
10145 (value_type (array
))))
10146 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10149 array
= ada_coerce_to_simple_array_ptr (array
);
10151 /* If we have more than one level of pointer indirection,
10152 dereference the value until we get only one level. */
10153 while (value_type (array
)->code () == TYPE_CODE_PTR
10154 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10156 array
= value_ind (array
);
10158 /* Make sure we really do have an array type before going further,
10159 to avoid a SEGV when trying to get the index type or the target
10160 type later down the road if the debug info generated by
10161 the compiler is incorrect or incomplete. */
10162 if (!ada_is_simple_array_type (value_type (array
)))
10163 error (_("cannot take slice of non-array"));
10165 if (ada_check_typedef (value_type (array
))->code ()
10168 struct type
*type0
= ada_check_typedef (value_type (array
));
10170 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10171 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10174 struct type
*arr_type0
=
10175 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10177 return ada_value_slice_from_ptr (array
, arr_type0
,
10178 longest_to_int (low_bound
),
10179 longest_to_int (high_bound
));
10182 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10184 else if (high_bound
< low_bound
)
10185 return empty_array (value_type (array
), low_bound
, high_bound
);
10187 return ada_value_slice (array
, longest_to_int (low_bound
),
10188 longest_to_int (high_bound
));
10191 /* A helper function for BINOP_IN_BOUNDS. */
10194 ada_binop_in_bounds (struct expression
*exp
, enum noside noside
,
10195 struct value
*arg1
, struct value
*arg2
, int n
)
10197 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10199 struct type
*type
= language_bool_type (exp
->language_defn
,
10201 return value_zero (type
, not_lval
);
10204 struct type
*type
= ada_index_type (value_type (arg2
), n
, "range");
10206 type
= value_type (arg1
);
10208 value
*arg3
= value_from_longest (type
, ada_array_bound (arg2
, n
, 1));
10209 arg2
= value_from_longest (type
, ada_array_bound (arg2
, n
, 0));
10211 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10212 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10213 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10214 return value_from_longest (type
,
10215 (value_less (arg1
, arg3
)
10216 || value_equal (arg1
, arg3
))
10217 && (value_less (arg2
, arg1
)
10218 || value_equal (arg2
, arg1
)));
10221 /* A helper function for some attribute operations. */
10224 ada_unop_atr (struct expression
*exp
, enum noside noside
, enum exp_opcode op
,
10225 struct value
*arg1
, struct type
*type_arg
, int tem
)
10227 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10229 if (type_arg
== NULL
)
10230 type_arg
= value_type (arg1
);
10232 if (ada_is_constrained_packed_array_type (type_arg
))
10233 type_arg
= decode_constrained_packed_array_type (type_arg
);
10235 if (!discrete_type_p (type_arg
))
10239 default: /* Should never happen. */
10240 error (_("unexpected attribute encountered"));
10243 type_arg
= ada_index_type (type_arg
, tem
,
10244 ada_attribute_name (op
));
10246 case OP_ATR_LENGTH
:
10247 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10252 return value_zero (type_arg
, not_lval
);
10254 else if (type_arg
== NULL
)
10256 arg1
= ada_coerce_ref (arg1
);
10258 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10259 arg1
= ada_coerce_to_simple_array (arg1
);
10262 if (op
== OP_ATR_LENGTH
)
10263 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10266 type
= ada_index_type (value_type (arg1
), tem
,
10267 ada_attribute_name (op
));
10269 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10274 default: /* Should never happen. */
10275 error (_("unexpected attribute encountered"));
10277 return value_from_longest
10278 (type
, ada_array_bound (arg1
, tem
, 0));
10280 return value_from_longest
10281 (type
, ada_array_bound (arg1
, tem
, 1));
10282 case OP_ATR_LENGTH
:
10283 return value_from_longest
10284 (type
, ada_array_length (arg1
, tem
));
10287 else if (discrete_type_p (type_arg
))
10289 struct type
*range_type
;
10290 const char *name
= ada_type_name (type_arg
);
10293 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10294 range_type
= to_fixed_range_type (type_arg
, NULL
);
10295 if (range_type
== NULL
)
10296 range_type
= type_arg
;
10300 error (_("unexpected attribute encountered"));
10302 return value_from_longest
10303 (range_type
, ada_discrete_type_low_bound (range_type
));
10305 return value_from_longest
10306 (range_type
, ada_discrete_type_high_bound (range_type
));
10307 case OP_ATR_LENGTH
:
10308 error (_("the 'length attribute applies only to array types"));
10311 else if (type_arg
->code () == TYPE_CODE_FLT
)
10312 error (_("unimplemented type attribute"));
10317 if (ada_is_constrained_packed_array_type (type_arg
))
10318 type_arg
= decode_constrained_packed_array_type (type_arg
);
10321 if (op
== OP_ATR_LENGTH
)
10322 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10325 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10327 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10333 error (_("unexpected attribute encountered"));
10335 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10336 return value_from_longest (type
, low
);
10338 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10339 return value_from_longest (type
, high
);
10340 case OP_ATR_LENGTH
:
10341 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10342 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10343 return value_from_longest (type
, high
- low
+ 1);
10348 /* Implement the evaluate_exp routine in the exp_descriptor structure
10349 for the Ada language. */
10351 static struct value
*
10352 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10353 int *pos
, enum noside noside
)
10355 enum exp_opcode op
;
10359 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10362 struct value
**argvec
;
10366 op
= exp
->elts
[pc
].opcode
;
10372 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10374 if (noside
== EVAL_NORMAL
)
10375 arg1
= unwrap_value (arg1
);
10377 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10378 then we need to perform the conversion manually, because
10379 evaluate_subexp_standard doesn't do it. This conversion is
10380 necessary in Ada because the different kinds of float/fixed
10381 types in Ada have different representations.
10383 Similarly, we need to perform the conversion from OP_LONG
10385 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10386 arg1
= ada_value_cast (expect_type
, arg1
);
10392 struct value
*result
;
10395 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10396 /* The result type will have code OP_STRING, bashed there from
10397 OP_ARRAY. Bash it back. */
10398 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10399 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10405 type
= exp
->elts
[pc
+ 1].type
;
10406 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10410 type
= exp
->elts
[pc
+ 1].type
;
10411 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10414 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10415 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10417 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10418 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10420 return ada_value_assign (arg1
, arg1
);
10422 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10423 except if the lhs of our assignment is a convenience variable.
10424 In the case of assigning to a convenience variable, the lhs
10425 should be exactly the result of the evaluation of the rhs. */
10426 type
= value_type (arg1
);
10427 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10429 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10430 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10432 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10437 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10438 return ada_value_assign (arg1
, arg2
);
10441 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10442 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10443 if (noside
== EVAL_SKIP
)
10445 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10446 return (value_from_longest
10447 (value_type (arg1
),
10448 value_as_long (arg1
) + value_as_long (arg2
)));
10449 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10450 return (value_from_longest
10451 (value_type (arg2
),
10452 value_as_long (arg1
) + value_as_long (arg2
)));
10453 /* Preserve the original type for use by the range case below.
10454 We cannot cast the result to a reference type, so if ARG1 is
10455 a reference type, find its underlying type. */
10456 type
= value_type (arg1
);
10457 while (type
->code () == TYPE_CODE_REF
)
10458 type
= TYPE_TARGET_TYPE (type
);
10459 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10460 arg1
= value_binop (arg1
, arg2
, BINOP_ADD
);
10461 /* We need to special-case the result of adding to a range.
10462 This is done for the benefit of "ptype". gdb's Ada support
10463 historically used the LHS to set the result type here, so
10464 preserve this behavior. */
10465 if (type
->code () == TYPE_CODE_RANGE
)
10466 arg1
= value_cast (type
, arg1
);
10470 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10471 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10472 if (noside
== EVAL_SKIP
)
10474 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10475 return (value_from_longest
10476 (value_type (arg1
),
10477 value_as_long (arg1
) - value_as_long (arg2
)));
10478 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10479 return (value_from_longest
10480 (value_type (arg2
),
10481 value_as_long (arg1
) - value_as_long (arg2
)));
10482 /* Preserve the original type for use by the range case below.
10483 We cannot cast the result to a reference type, so if ARG1 is
10484 a reference type, find its underlying type. */
10485 type
= value_type (arg1
);
10486 while (type
->code () == TYPE_CODE_REF
)
10487 type
= TYPE_TARGET_TYPE (type
);
10488 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10489 arg1
= value_binop (arg1
, arg2
, BINOP_SUB
);
10490 /* We need to special-case the result of adding to a range.
10491 This is done for the benefit of "ptype". gdb's Ada support
10492 historically used the LHS to set the result type here, so
10493 preserve this behavior. */
10494 if (type
->code () == TYPE_CODE_RANGE
)
10495 arg1
= value_cast (type
, arg1
);
10502 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10503 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10504 if (noside
== EVAL_SKIP
)
10506 return ada_mult_binop (expect_type
, exp
, noside
, op
,
10510 case BINOP_NOTEQUAL
:
10511 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10512 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10513 if (noside
== EVAL_SKIP
)
10515 return ada_equal_binop (expect_type
, exp
, noside
, op
, arg1
, arg2
);
10518 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10519 return ada_unop_neg (expect_type
, exp
, noside
, op
, arg1
);
10521 case BINOP_LOGICAL_AND
:
10522 case BINOP_LOGICAL_OR
:
10523 case UNOP_LOGICAL_NOT
:
10528 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10529 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10530 return value_cast (type
, val
);
10533 case BINOP_BITWISE_AND
:
10534 case BINOP_BITWISE_IOR
:
10535 case BINOP_BITWISE_XOR
:
10539 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10541 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10543 return value_cast (value_type (arg1
), val
);
10549 if (noside
== EVAL_SKIP
)
10555 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10556 /* Only encountered when an unresolved symbol occurs in a
10557 context other than a function call, in which case, it is
10559 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10560 exp
->elts
[pc
+ 2].symbol
->print_name ());
10562 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10564 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10565 /* Check to see if this is a tagged type. We also need to handle
10566 the case where the type is a reference to a tagged type, but
10567 we have to be careful to exclude pointers to tagged types.
10568 The latter should be shown as usual (as a pointer), whereas
10569 a reference should mostly be transparent to the user. */
10570 if (ada_is_tagged_type (type
, 0)
10571 || (type
->code () == TYPE_CODE_REF
10572 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10574 /* Tagged types are a little special in the fact that the real
10575 type is dynamic and can only be determined by inspecting the
10576 object's tag. This means that we need to get the object's
10577 value first (EVAL_NORMAL) and then extract the actual object
10580 Note that we cannot skip the final step where we extract
10581 the object type from its tag, because the EVAL_NORMAL phase
10582 results in dynamic components being resolved into fixed ones.
10583 This can cause problems when trying to print the type
10584 description of tagged types whose parent has a dynamic size:
10585 We use the type name of the "_parent" component in order
10586 to print the name of the ancestor type in the type description.
10587 If that component had a dynamic size, the resolution into
10588 a fixed type would result in the loss of that type name,
10589 thus preventing us from printing the name of the ancestor
10590 type in the type description. */
10591 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10593 if (type
->code () != TYPE_CODE_REF
)
10595 struct type
*actual_type
;
10597 actual_type
= type_from_tag (ada_value_tag (arg1
));
10598 if (actual_type
== NULL
)
10599 /* If, for some reason, we were unable to determine
10600 the actual type from the tag, then use the static
10601 approximation that we just computed as a fallback.
10602 This can happen if the debugging information is
10603 incomplete, for instance. */
10604 actual_type
= type
;
10605 return value_zero (actual_type
, not_lval
);
10609 /* In the case of a ref, ada_coerce_ref takes care
10610 of determining the actual type. But the evaluation
10611 should return a ref as it should be valid to ask
10612 for its address; so rebuild a ref after coerce. */
10613 arg1
= ada_coerce_ref (arg1
);
10614 return value_ref (arg1
, TYPE_CODE_REF
);
10618 /* Records and unions for which GNAT encodings have been
10619 generated need to be statically fixed as well.
10620 Otherwise, non-static fixing produces a type where
10621 all dynamic properties are removed, which prevents "ptype"
10622 from being able to completely describe the type.
10623 For instance, a case statement in a variant record would be
10624 replaced by the relevant components based on the actual
10625 value of the discriminants. */
10626 if ((type
->code () == TYPE_CODE_STRUCT
10627 && dynamic_template_type (type
) != NULL
)
10628 || (type
->code () == TYPE_CODE_UNION
10629 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10632 return value_zero (to_static_fixed_type (type
), not_lval
);
10636 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10637 return ada_to_fixed_value (arg1
);
10642 /* Allocate arg vector, including space for the function to be
10643 called in argvec[0] and a terminating NULL. */
10644 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10645 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10647 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10648 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10649 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10650 exp
->elts
[pc
+ 5].symbol
->print_name ());
10653 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10654 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10657 if (noside
== EVAL_SKIP
)
10661 if (ada_is_constrained_packed_array_type
10662 (desc_base_type (value_type (argvec
[0]))))
10663 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10664 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10665 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10666 /* This is a packed array that has already been fixed, and
10667 therefore already coerced to a simple array. Nothing further
10670 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10672 /* Make sure we dereference references so that all the code below
10673 feels like it's really handling the referenced value. Wrapping
10674 types (for alignment) may be there, so make sure we strip them as
10676 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10678 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10679 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10680 argvec
[0] = value_addr (argvec
[0]);
10682 type
= ada_check_typedef (value_type (argvec
[0]));
10684 /* Ada allows us to implicitly dereference arrays when subscripting
10685 them. So, if this is an array typedef (encoding use for array
10686 access types encoded as fat pointers), strip it now. */
10687 if (type
->code () == TYPE_CODE_TYPEDEF
)
10688 type
= ada_typedef_target_type (type
);
10690 if (type
->code () == TYPE_CODE_PTR
)
10692 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10694 case TYPE_CODE_FUNC
:
10695 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10697 case TYPE_CODE_ARRAY
:
10699 case TYPE_CODE_STRUCT
:
10700 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10701 argvec
[0] = ada_value_ind (argvec
[0]);
10702 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10705 error (_("cannot subscript or call something of type `%s'"),
10706 ada_type_name (value_type (argvec
[0])));
10711 switch (type
->code ())
10713 case TYPE_CODE_FUNC
:
10714 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10716 if (TYPE_TARGET_TYPE (type
) == NULL
)
10717 error_call_unknown_return_type (NULL
);
10718 return allocate_value (TYPE_TARGET_TYPE (type
));
10720 return call_function_by_hand (argvec
[0], NULL
,
10721 gdb::make_array_view (argvec
+ 1,
10723 case TYPE_CODE_INTERNAL_FUNCTION
:
10724 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10725 /* We don't know anything about what the internal
10726 function might return, but we have to return
10728 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10731 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10732 argvec
[0], nargs
, argvec
+ 1);
10734 case TYPE_CODE_STRUCT
:
10738 arity
= ada_array_arity (type
);
10739 type
= ada_array_element_type (type
, nargs
);
10741 error (_("cannot subscript or call a record"));
10742 if (arity
!= nargs
)
10743 error (_("wrong number of subscripts; expecting %d"), arity
);
10744 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10745 return value_zero (ada_aligned_type (type
), lval_memory
);
10747 unwrap_value (ada_value_subscript
10748 (argvec
[0], nargs
, argvec
+ 1));
10750 case TYPE_CODE_ARRAY
:
10751 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10753 type
= ada_array_element_type (type
, nargs
);
10755 error (_("element type of array unknown"));
10757 return value_zero (ada_aligned_type (type
), lval_memory
);
10760 unwrap_value (ada_value_subscript
10761 (ada_coerce_to_simple_array (argvec
[0]),
10762 nargs
, argvec
+ 1));
10763 case TYPE_CODE_PTR
: /* Pointer to array */
10764 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10766 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10767 type
= ada_array_element_type (type
, nargs
);
10769 error (_("element type of array unknown"));
10771 return value_zero (ada_aligned_type (type
), lval_memory
);
10774 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10775 nargs
, argvec
+ 1));
10778 error (_("Attempt to index or call something other than an "
10779 "array or function"));
10784 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10785 struct value
*low_bound_val
10786 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10787 struct value
*high_bound_val
10788 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10790 if (noside
== EVAL_SKIP
)
10793 return ada_ternop_slice (exp
, noside
, array
, low_bound_val
,
10797 case UNOP_IN_RANGE
:
10799 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10800 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10801 return ada_unop_in_range (expect_type
, exp
, noside
, op
, arg1
, type
);
10803 case BINOP_IN_BOUNDS
:
10805 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10806 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10808 if (noside
== EVAL_SKIP
)
10811 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10813 return ada_binop_in_bounds (exp
, noside
, arg1
, arg2
, tem
);
10815 case TERNOP_IN_RANGE
:
10816 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10817 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10818 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10820 return eval_ternop_in_range (expect_type
, exp
, noside
, arg1
, arg2
, arg3
);
10824 case OP_ATR_LENGTH
:
10826 struct type
*type_arg
;
10828 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10830 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10832 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10836 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10840 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10841 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10842 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10845 if (noside
== EVAL_SKIP
)
10848 return ada_unop_atr (exp
, noside
, op
, arg1
, type_arg
, tem
);
10852 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10853 if (noside
== EVAL_SKIP
)
10855 return ada_atr_tag (expect_type
, exp
, noside
, op
, arg1
);
10859 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10860 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10861 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10862 if (noside
== EVAL_SKIP
)
10864 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10865 return value_zero (value_type (arg1
), not_lval
);
10868 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10869 return value_binop (arg1
, arg2
,
10870 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10873 case OP_ATR_MODULUS
:
10875 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10877 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10878 if (noside
== EVAL_SKIP
)
10881 if (!ada_is_modular_type (type_arg
))
10882 error (_("'modulus must be applied to modular type"));
10884 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10885 ada_modulus (type_arg
));
10890 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10891 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10892 if (noside
== EVAL_SKIP
)
10894 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10895 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10896 return value_zero (type
, not_lval
);
10898 return value_pos_atr (type
, arg1
);
10901 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10902 return ada_atr_size (expect_type
, exp
, noside
, op
, arg1
);
10905 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10906 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10907 type
= exp
->elts
[pc
+ 2].type
;
10908 if (noside
== EVAL_SKIP
)
10910 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10911 return value_zero (type
, not_lval
);
10913 return value_val_atr (type
, arg1
);
10916 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10917 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10918 if (noside
== EVAL_SKIP
)
10920 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10921 return value_zero (value_type (arg1
), not_lval
);
10924 /* For integer exponentiation operations,
10925 only promote the first argument. */
10926 if (is_integral_type (value_type (arg2
)))
10927 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10929 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10931 return value_binop (arg1
, arg2
, op
);
10935 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10936 if (noside
== EVAL_SKIP
)
10942 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10943 if (noside
== EVAL_SKIP
)
10945 return ada_abs (expect_type
, exp
, noside
, op
, arg1
);
10948 preeval_pos
= *pos
;
10949 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10950 if (noside
== EVAL_SKIP
)
10952 type
= ada_check_typedef (value_type (arg1
));
10953 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10955 if (ada_is_array_descriptor_type (type
))
10956 /* GDB allows dereferencing GNAT array descriptors. */
10958 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10960 if (arrType
== NULL
)
10961 error (_("Attempt to dereference null array pointer."));
10962 return value_at_lazy (arrType
, 0);
10964 else if (type
->code () == TYPE_CODE_PTR
10965 || type
->code () == TYPE_CODE_REF
10966 /* In C you can dereference an array to get the 1st elt. */
10967 || type
->code () == TYPE_CODE_ARRAY
)
10969 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10970 only be determined by inspecting the object's tag.
10971 This means that we need to evaluate completely the
10972 expression in order to get its type. */
10974 if ((type
->code () == TYPE_CODE_REF
10975 || type
->code () == TYPE_CODE_PTR
)
10976 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10979 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10980 type
= value_type (ada_value_ind (arg1
));
10984 type
= to_static_fixed_type
10986 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10988 ada_ensure_varsize_limit (type
);
10989 return value_zero (type
, lval_memory
);
10991 else if (type
->code () == TYPE_CODE_INT
)
10993 /* GDB allows dereferencing an int. */
10994 if (expect_type
== NULL
)
10995 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11000 to_static_fixed_type (ada_aligned_type (expect_type
));
11001 return value_zero (expect_type
, lval_memory
);
11005 error (_("Attempt to take contents of a non-pointer value."));
11007 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11008 type
= ada_check_typedef (value_type (arg1
));
11010 if (type
->code () == TYPE_CODE_INT
)
11011 /* GDB allows dereferencing an int. If we were given
11012 the expect_type, then use that as the target type.
11013 Otherwise, assume that the target type is an int. */
11015 if (expect_type
!= NULL
)
11016 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11019 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11020 (CORE_ADDR
) value_as_address (arg1
));
11023 if (ada_is_array_descriptor_type (type
))
11024 /* GDB allows dereferencing GNAT array descriptors. */
11025 return ada_coerce_to_simple_array (arg1
);
11027 return ada_value_ind (arg1
);
11029 case STRUCTOP_STRUCT
:
11030 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11031 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11032 preeval_pos
= *pos
;
11033 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11034 if (noside
== EVAL_SKIP
)
11036 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11038 struct type
*type1
= value_type (arg1
);
11040 if (ada_is_tagged_type (type1
, 1))
11042 type
= ada_lookup_struct_elt_type (type1
,
11043 &exp
->elts
[pc
+ 2].string
,
11046 /* If the field is not found, check if it exists in the
11047 extension of this object's type. This means that we
11048 need to evaluate completely the expression. */
11053 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11054 arg1
= ada_value_struct_elt (arg1
,
11055 &exp
->elts
[pc
+ 2].string
,
11057 arg1
= unwrap_value (arg1
);
11058 type
= value_type (ada_to_fixed_value (arg1
));
11063 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11066 return value_zero (ada_aligned_type (type
), lval_memory
);
11070 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11071 arg1
= unwrap_value (arg1
);
11072 return ada_to_fixed_value (arg1
);
11076 /* The value is not supposed to be used. This is here to make it
11077 easier to accommodate expressions that contain types. */
11079 if (noside
== EVAL_SKIP
)
11081 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11082 return allocate_value (exp
->elts
[pc
+ 1].type
);
11084 error (_("Attempt to use a type name as an expression"));
11089 case OP_DISCRETE_RANGE
:
11090 case OP_POSITIONAL
:
11092 if (noside
== EVAL_NORMAL
)
11096 error (_("Undefined name, ambiguous name, or renaming used in "
11097 "component association: %s."), &exp
->elts
[pc
+2].string
);
11099 error (_("Aggregates only allowed on the right of an assignment"));
11101 internal_error (__FILE__
, __LINE__
,
11102 _("aggregate apparently mangled"));
11105 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11107 for (tem
= 0; tem
< nargs
; tem
+= 1)
11108 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11113 return eval_skip_value (exp
);
11117 /* Return non-zero iff TYPE represents a System.Address type. */
11120 ada_is_system_address_type (struct type
*type
)
11122 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11129 /* Scan STR beginning at position K for a discriminant name, and
11130 return the value of that discriminant field of DVAL in *PX. If
11131 PNEW_K is not null, put the position of the character beyond the
11132 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11133 not alter *PX and *PNEW_K if unsuccessful. */
11136 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11139 static std::string storage
;
11140 const char *pstart
, *pend
, *bound
;
11141 struct value
*bound_val
;
11143 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11147 pend
= strstr (pstart
, "__");
11151 k
+= strlen (bound
);
11155 int len
= pend
- pstart
;
11157 /* Strip __ and beyond. */
11158 storage
= std::string (pstart
, len
);
11159 bound
= storage
.c_str ();
11163 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11164 if (bound_val
== NULL
)
11167 *px
= value_as_long (bound_val
);
11168 if (pnew_k
!= NULL
)
11173 /* Value of variable named NAME. Only exact matches are considered.
11174 If no such variable found, then if ERR_MSG is null, returns 0, and
11175 otherwise causes an error with message ERR_MSG. */
11177 static struct value
*
11178 get_var_value (const char *name
, const char *err_msg
)
11180 std::string quoted_name
= add_angle_brackets (name
);
11182 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11184 std::vector
<struct block_symbol
> syms
11185 = ada_lookup_symbol_list_worker (lookup_name
,
11186 get_selected_block (0),
11189 if (syms
.size () != 1)
11191 if (err_msg
== NULL
)
11194 error (("%s"), err_msg
);
11197 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11200 /* Value of integer variable named NAME in the current environment.
11201 If no such variable is found, returns false. Otherwise, sets VALUE
11202 to the variable's value and returns true. */
11205 get_int_var_value (const char *name
, LONGEST
&value
)
11207 struct value
*var_val
= get_var_value (name
, 0);
11212 value
= value_as_long (var_val
);
11217 /* Return a range type whose base type is that of the range type named
11218 NAME in the current environment, and whose bounds are calculated
11219 from NAME according to the GNAT range encoding conventions.
11220 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11221 corresponding range type from debug information; fall back to using it
11222 if symbol lookup fails. If a new type must be created, allocate it
11223 like ORIG_TYPE was. The bounds information, in general, is encoded
11224 in NAME, the base type given in the named range type. */
11226 static struct type
*
11227 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11230 struct type
*base_type
;
11231 const char *subtype_info
;
11233 gdb_assert (raw_type
!= NULL
);
11234 gdb_assert (raw_type
->name () != NULL
);
11236 if (raw_type
->code () == TYPE_CODE_RANGE
)
11237 base_type
= TYPE_TARGET_TYPE (raw_type
);
11239 base_type
= raw_type
;
11241 name
= raw_type
->name ();
11242 subtype_info
= strstr (name
, "___XD");
11243 if (subtype_info
== NULL
)
11245 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11246 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11248 if (L
< INT_MIN
|| U
> INT_MAX
)
11251 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11256 int prefix_len
= subtype_info
- name
;
11259 const char *bounds_str
;
11263 bounds_str
= strchr (subtype_info
, '_');
11266 if (*subtype_info
== 'L')
11268 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11269 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11271 if (bounds_str
[n
] == '_')
11273 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11279 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11280 if (!get_int_var_value (name_buf
.c_str (), L
))
11282 lim_warning (_("Unknown lower bound, using 1."));
11287 if (*subtype_info
== 'U')
11289 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11290 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11295 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11296 if (!get_int_var_value (name_buf
.c_str (), U
))
11298 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11303 type
= create_static_range_type (alloc_type_copy (raw_type
),
11305 /* create_static_range_type alters the resulting type's length
11306 to match the size of the base_type, which is not what we want.
11307 Set it back to the original range type's length. */
11308 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11309 type
->set_name (name
);
11314 /* True iff NAME is the name of a range type. */
11317 ada_is_range_type_name (const char *name
)
11319 return (name
!= NULL
&& strstr (name
, "___XD"));
11323 /* Modular types */
11325 /* True iff TYPE is an Ada modular type. */
11328 ada_is_modular_type (struct type
*type
)
11330 struct type
*subranged_type
= get_base_type (type
);
11332 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11333 && subranged_type
->code () == TYPE_CODE_INT
11334 && subranged_type
->is_unsigned ());
11337 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11340 ada_modulus (struct type
*type
)
11342 const dynamic_prop
&high
= type
->bounds ()->high
;
11344 if (high
.kind () == PROP_CONST
)
11345 return (ULONGEST
) high
.const_val () + 1;
11347 /* If TYPE is unresolved, the high bound might be a location list. Return
11348 0, for lack of a better value to return. */
11353 /* Ada exception catchpoint support:
11354 ---------------------------------
11356 We support 3 kinds of exception catchpoints:
11357 . catchpoints on Ada exceptions
11358 . catchpoints on unhandled Ada exceptions
11359 . catchpoints on failed assertions
11361 Exceptions raised during failed assertions, or unhandled exceptions
11362 could perfectly be caught with the general catchpoint on Ada exceptions.
11363 However, we can easily differentiate these two special cases, and having
11364 the option to distinguish these two cases from the rest can be useful
11365 to zero-in on certain situations.
11367 Exception catchpoints are a specialized form of breakpoint,
11368 since they rely on inserting breakpoints inside known routines
11369 of the GNAT runtime. The implementation therefore uses a standard
11370 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11373 Support in the runtime for exception catchpoints have been changed
11374 a few times already, and these changes affect the implementation
11375 of these catchpoints. In order to be able to support several
11376 variants of the runtime, we use a sniffer that will determine
11377 the runtime variant used by the program being debugged. */
11379 /* Ada's standard exceptions.
11381 The Ada 83 standard also defined Numeric_Error. But there so many
11382 situations where it was unclear from the Ada 83 Reference Manual
11383 (RM) whether Constraint_Error or Numeric_Error should be raised,
11384 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11385 Interpretation saying that anytime the RM says that Numeric_Error
11386 should be raised, the implementation may raise Constraint_Error.
11387 Ada 95 went one step further and pretty much removed Numeric_Error
11388 from the list of standard exceptions (it made it a renaming of
11389 Constraint_Error, to help preserve compatibility when compiling
11390 an Ada83 compiler). As such, we do not include Numeric_Error from
11391 this list of standard exceptions. */
11393 static const char * const standard_exc
[] = {
11394 "constraint_error",
11400 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11402 /* A structure that describes how to support exception catchpoints
11403 for a given executable. */
11405 struct exception_support_info
11407 /* The name of the symbol to break on in order to insert
11408 a catchpoint on exceptions. */
11409 const char *catch_exception_sym
;
11411 /* The name of the symbol to break on in order to insert
11412 a catchpoint on unhandled exceptions. */
11413 const char *catch_exception_unhandled_sym
;
11415 /* The name of the symbol to break on in order to insert
11416 a catchpoint on failed assertions. */
11417 const char *catch_assert_sym
;
11419 /* The name of the symbol to break on in order to insert
11420 a catchpoint on exception handling. */
11421 const char *catch_handlers_sym
;
11423 /* Assuming that the inferior just triggered an unhandled exception
11424 catchpoint, this function is responsible for returning the address
11425 in inferior memory where the name of that exception is stored.
11426 Return zero if the address could not be computed. */
11427 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11430 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11431 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11433 /* The following exception support info structure describes how to
11434 implement exception catchpoints with the latest version of the
11435 Ada runtime (as of 2019-08-??). */
11437 static const struct exception_support_info default_exception_support_info
=
11439 "__gnat_debug_raise_exception", /* catch_exception_sym */
11440 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11441 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11442 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11443 ada_unhandled_exception_name_addr
11446 /* The following exception support info structure describes how to
11447 implement exception catchpoints with an earlier version of the
11448 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11450 static const struct exception_support_info exception_support_info_v0
=
11452 "__gnat_debug_raise_exception", /* catch_exception_sym */
11453 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11454 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11455 "__gnat_begin_handler", /* catch_handlers_sym */
11456 ada_unhandled_exception_name_addr
11459 /* The following exception support info structure describes how to
11460 implement exception catchpoints with a slightly older version
11461 of the Ada runtime. */
11463 static const struct exception_support_info exception_support_info_fallback
=
11465 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11466 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11467 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11468 "__gnat_begin_handler", /* catch_handlers_sym */
11469 ada_unhandled_exception_name_addr_from_raise
11472 /* Return nonzero if we can detect the exception support routines
11473 described in EINFO.
11475 This function errors out if an abnormal situation is detected
11476 (for instance, if we find the exception support routines, but
11477 that support is found to be incomplete). */
11480 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11482 struct symbol
*sym
;
11484 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11485 that should be compiled with debugging information. As a result, we
11486 expect to find that symbol in the symtabs. */
11488 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11491 /* Perhaps we did not find our symbol because the Ada runtime was
11492 compiled without debugging info, or simply stripped of it.
11493 It happens on some GNU/Linux distributions for instance, where
11494 users have to install a separate debug package in order to get
11495 the runtime's debugging info. In that situation, let the user
11496 know why we cannot insert an Ada exception catchpoint.
11498 Note: Just for the purpose of inserting our Ada exception
11499 catchpoint, we could rely purely on the associated minimal symbol.
11500 But we would be operating in degraded mode anyway, since we are
11501 still lacking the debugging info needed later on to extract
11502 the name of the exception being raised (this name is printed in
11503 the catchpoint message, and is also used when trying to catch
11504 a specific exception). We do not handle this case for now. */
11505 struct bound_minimal_symbol msym
11506 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11508 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11509 error (_("Your Ada runtime appears to be missing some debugging "
11510 "information.\nCannot insert Ada exception catchpoint "
11511 "in this configuration."));
11516 /* Make sure that the symbol we found corresponds to a function. */
11518 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11520 error (_("Symbol \"%s\" is not a function (class = %d)"),
11521 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11525 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11528 struct bound_minimal_symbol msym
11529 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11531 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11532 error (_("Your Ada runtime appears to be missing some debugging "
11533 "information.\nCannot insert Ada exception catchpoint "
11534 "in this configuration."));
11539 /* Make sure that the symbol we found corresponds to a function. */
11541 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11543 error (_("Symbol \"%s\" is not a function (class = %d)"),
11544 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11551 /* Inspect the Ada runtime and determine which exception info structure
11552 should be used to provide support for exception catchpoints.
11554 This function will always set the per-inferior exception_info,
11555 or raise an error. */
11558 ada_exception_support_info_sniffer (void)
11560 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11562 /* If the exception info is already known, then no need to recompute it. */
11563 if (data
->exception_info
!= NULL
)
11566 /* Check the latest (default) exception support info. */
11567 if (ada_has_this_exception_support (&default_exception_support_info
))
11569 data
->exception_info
= &default_exception_support_info
;
11573 /* Try the v0 exception suport info. */
11574 if (ada_has_this_exception_support (&exception_support_info_v0
))
11576 data
->exception_info
= &exception_support_info_v0
;
11580 /* Try our fallback exception suport info. */
11581 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11583 data
->exception_info
= &exception_support_info_fallback
;
11587 /* Sometimes, it is normal for us to not be able to find the routine
11588 we are looking for. This happens when the program is linked with
11589 the shared version of the GNAT runtime, and the program has not been
11590 started yet. Inform the user of these two possible causes if
11593 if (ada_update_initial_language (language_unknown
) != language_ada
)
11594 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11596 /* If the symbol does not exist, then check that the program is
11597 already started, to make sure that shared libraries have been
11598 loaded. If it is not started, this may mean that the symbol is
11599 in a shared library. */
11601 if (inferior_ptid
.pid () == 0)
11602 error (_("Unable to insert catchpoint. Try to start the program first."));
11604 /* At this point, we know that we are debugging an Ada program and
11605 that the inferior has been started, but we still are not able to
11606 find the run-time symbols. That can mean that we are in
11607 configurable run time mode, or that a-except as been optimized
11608 out by the linker... In any case, at this point it is not worth
11609 supporting this feature. */
11611 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11614 /* True iff FRAME is very likely to be that of a function that is
11615 part of the runtime system. This is all very heuristic, but is
11616 intended to be used as advice as to what frames are uninteresting
11620 is_known_support_routine (struct frame_info
*frame
)
11622 enum language func_lang
;
11624 const char *fullname
;
11626 /* If this code does not have any debugging information (no symtab),
11627 This cannot be any user code. */
11629 symtab_and_line sal
= find_frame_sal (frame
);
11630 if (sal
.symtab
== NULL
)
11633 /* If there is a symtab, but the associated source file cannot be
11634 located, then assume this is not user code: Selecting a frame
11635 for which we cannot display the code would not be very helpful
11636 for the user. This should also take care of case such as VxWorks
11637 where the kernel has some debugging info provided for a few units. */
11639 fullname
= symtab_to_fullname (sal
.symtab
);
11640 if (access (fullname
, R_OK
) != 0)
11643 /* Check the unit filename against the Ada runtime file naming.
11644 We also check the name of the objfile against the name of some
11645 known system libraries that sometimes come with debugging info
11648 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11650 re_comp (known_runtime_file_name_patterns
[i
]);
11651 if (re_exec (lbasename (sal
.symtab
->filename
)))
11653 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11654 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11658 /* Check whether the function is a GNAT-generated entity. */
11660 gdb::unique_xmalloc_ptr
<char> func_name
11661 = find_frame_funname (frame
, &func_lang
, NULL
);
11662 if (func_name
== NULL
)
11665 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11667 re_comp (known_auxiliary_function_name_patterns
[i
]);
11668 if (re_exec (func_name
.get ()))
11675 /* Find the first frame that contains debugging information and that is not
11676 part of the Ada run-time, starting from FI and moving upward. */
11679 ada_find_printable_frame (struct frame_info
*fi
)
11681 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11683 if (!is_known_support_routine (fi
))
11692 /* Assuming that the inferior just triggered an unhandled exception
11693 catchpoint, return the address in inferior memory where the name
11694 of the exception is stored.
11696 Return zero if the address could not be computed. */
11699 ada_unhandled_exception_name_addr (void)
11701 return parse_and_eval_address ("e.full_name");
11704 /* Same as ada_unhandled_exception_name_addr, except that this function
11705 should be used when the inferior uses an older version of the runtime,
11706 where the exception name needs to be extracted from a specific frame
11707 several frames up in the callstack. */
11710 ada_unhandled_exception_name_addr_from_raise (void)
11713 struct frame_info
*fi
;
11714 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11716 /* To determine the name of this exception, we need to select
11717 the frame corresponding to RAISE_SYM_NAME. This frame is
11718 at least 3 levels up, so we simply skip the first 3 frames
11719 without checking the name of their associated function. */
11720 fi
= get_current_frame ();
11721 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11723 fi
= get_prev_frame (fi
);
11727 enum language func_lang
;
11729 gdb::unique_xmalloc_ptr
<char> func_name
11730 = find_frame_funname (fi
, &func_lang
, NULL
);
11731 if (func_name
!= NULL
)
11733 if (strcmp (func_name
.get (),
11734 data
->exception_info
->catch_exception_sym
) == 0)
11735 break; /* We found the frame we were looking for... */
11737 fi
= get_prev_frame (fi
);
11744 return parse_and_eval_address ("id.full_name");
11747 /* Assuming the inferior just triggered an Ada exception catchpoint
11748 (of any type), return the address in inferior memory where the name
11749 of the exception is stored, if applicable.
11751 Assumes the selected frame is the current frame.
11753 Return zero if the address could not be computed, or if not relevant. */
11756 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11757 struct breakpoint
*b
)
11759 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11763 case ada_catch_exception
:
11764 return (parse_and_eval_address ("e.full_name"));
11767 case ada_catch_exception_unhandled
:
11768 return data
->exception_info
->unhandled_exception_name_addr ();
11771 case ada_catch_handlers
:
11772 return 0; /* The runtimes does not provide access to the exception
11776 case ada_catch_assert
:
11777 return 0; /* Exception name is not relevant in this case. */
11781 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11785 return 0; /* Should never be reached. */
11788 /* Assuming the inferior is stopped at an exception catchpoint,
11789 return the message which was associated to the exception, if
11790 available. Return NULL if the message could not be retrieved.
11792 Note: The exception message can be associated to an exception
11793 either through the use of the Raise_Exception function, or
11794 more simply (Ada 2005 and later), via:
11796 raise Exception_Name with "exception message";
11800 static gdb::unique_xmalloc_ptr
<char>
11801 ada_exception_message_1 (void)
11803 struct value
*e_msg_val
;
11806 /* For runtimes that support this feature, the exception message
11807 is passed as an unbounded string argument called "message". */
11808 e_msg_val
= parse_and_eval ("message");
11809 if (e_msg_val
== NULL
)
11810 return NULL
; /* Exception message not supported. */
11812 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11813 gdb_assert (e_msg_val
!= NULL
);
11814 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11816 /* If the message string is empty, then treat it as if there was
11817 no exception message. */
11818 if (e_msg_len
<= 0)
11821 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11822 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11824 e_msg
.get ()[e_msg_len
] = '\0';
11829 /* Same as ada_exception_message_1, except that all exceptions are
11830 contained here (returning NULL instead). */
11832 static gdb::unique_xmalloc_ptr
<char>
11833 ada_exception_message (void)
11835 gdb::unique_xmalloc_ptr
<char> e_msg
;
11839 e_msg
= ada_exception_message_1 ();
11841 catch (const gdb_exception_error
&e
)
11843 e_msg
.reset (nullptr);
11849 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11850 any error that ada_exception_name_addr_1 might cause to be thrown.
11851 When an error is intercepted, a warning with the error message is printed,
11852 and zero is returned. */
11855 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11856 struct breakpoint
*b
)
11858 CORE_ADDR result
= 0;
11862 result
= ada_exception_name_addr_1 (ex
, b
);
11865 catch (const gdb_exception_error
&e
)
11867 warning (_("failed to get exception name: %s"), e
.what ());
11874 static std::string ada_exception_catchpoint_cond_string
11875 (const char *excep_string
,
11876 enum ada_exception_catchpoint_kind ex
);
11878 /* Ada catchpoints.
11880 In the case of catchpoints on Ada exceptions, the catchpoint will
11881 stop the target on every exception the program throws. When a user
11882 specifies the name of a specific exception, we translate this
11883 request into a condition expression (in text form), and then parse
11884 it into an expression stored in each of the catchpoint's locations.
11885 We then use this condition to check whether the exception that was
11886 raised is the one the user is interested in. If not, then the
11887 target is resumed again. We store the name of the requested
11888 exception, in order to be able to re-set the condition expression
11889 when symbols change. */
11891 /* An instance of this type is used to represent an Ada catchpoint
11892 breakpoint location. */
11894 class ada_catchpoint_location
: public bp_location
11897 ada_catchpoint_location (breakpoint
*owner
)
11898 : bp_location (owner
, bp_loc_software_breakpoint
)
11901 /* The condition that checks whether the exception that was raised
11902 is the specific exception the user specified on catchpoint
11904 expression_up excep_cond_expr
;
11907 /* An instance of this type is used to represent an Ada catchpoint. */
11909 struct ada_catchpoint
: public breakpoint
11911 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
11916 /* The name of the specific exception the user specified. */
11917 std::string excep_string
;
11919 /* What kind of catchpoint this is. */
11920 enum ada_exception_catchpoint_kind m_kind
;
11923 /* Parse the exception condition string in the context of each of the
11924 catchpoint's locations, and store them for later evaluation. */
11927 create_excep_cond_exprs (struct ada_catchpoint
*c
,
11928 enum ada_exception_catchpoint_kind ex
)
11930 struct bp_location
*bl
;
11932 /* Nothing to do if there's no specific exception to catch. */
11933 if (c
->excep_string
.empty ())
11936 /* Same if there are no locations... */
11937 if (c
->loc
== NULL
)
11940 /* Compute the condition expression in text form, from the specific
11941 expection we want to catch. */
11942 std::string cond_string
11943 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
11945 /* Iterate over all the catchpoint's locations, and parse an
11946 expression for each. */
11947 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
11949 struct ada_catchpoint_location
*ada_loc
11950 = (struct ada_catchpoint_location
*) bl
;
11953 if (!bl
->shlib_disabled
)
11957 s
= cond_string
.c_str ();
11960 exp
= parse_exp_1 (&s
, bl
->address
,
11961 block_for_pc (bl
->address
),
11964 catch (const gdb_exception_error
&e
)
11966 warning (_("failed to reevaluate internal exception condition "
11967 "for catchpoint %d: %s"),
11968 c
->number
, e
.what ());
11972 ada_loc
->excep_cond_expr
= std::move (exp
);
11976 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11977 structure for all exception catchpoint kinds. */
11979 static struct bp_location
*
11980 allocate_location_exception (struct breakpoint
*self
)
11982 return new ada_catchpoint_location (self
);
11985 /* Implement the RE_SET method in the breakpoint_ops structure for all
11986 exception catchpoint kinds. */
11989 re_set_exception (struct breakpoint
*b
)
11991 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11993 /* Call the base class's method. This updates the catchpoint's
11995 bkpt_breakpoint_ops
.re_set (b
);
11997 /* Reparse the exception conditional expressions. One for each
11999 create_excep_cond_exprs (c
, c
->m_kind
);
12002 /* Returns true if we should stop for this breakpoint hit. If the
12003 user specified a specific exception, we only want to cause a stop
12004 if the program thrown that exception. */
12007 should_stop_exception (const struct bp_location
*bl
)
12009 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12010 const struct ada_catchpoint_location
*ada_loc
12011 = (const struct ada_catchpoint_location
*) bl
;
12014 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12015 if (c
->m_kind
== ada_catch_assert
)
12016 clear_internalvar (var
);
12023 if (c
->m_kind
== ada_catch_handlers
)
12024 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12025 ".all.occurrence.id");
12029 struct value
*exc
= parse_and_eval (expr
);
12030 set_internalvar (var
, exc
);
12032 catch (const gdb_exception_error
&ex
)
12034 clear_internalvar (var
);
12038 /* With no specific exception, should always stop. */
12039 if (c
->excep_string
.empty ())
12042 if (ada_loc
->excep_cond_expr
== NULL
)
12044 /* We will have a NULL expression if back when we were creating
12045 the expressions, this location's had failed to parse. */
12052 struct value
*mark
;
12054 mark
= value_mark ();
12055 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12056 value_free_to_mark (mark
);
12058 catch (const gdb_exception
&ex
)
12060 exception_fprintf (gdb_stderr
, ex
,
12061 _("Error in testing exception condition:\n"));
12067 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12068 for all exception catchpoint kinds. */
12071 check_status_exception (bpstat bs
)
12073 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12076 /* Implement the PRINT_IT method in the breakpoint_ops structure
12077 for all exception catchpoint kinds. */
12079 static enum print_stop_action
12080 print_it_exception (bpstat bs
)
12082 struct ui_out
*uiout
= current_uiout
;
12083 struct breakpoint
*b
= bs
->breakpoint_at
;
12085 annotate_catchpoint (b
->number
);
12087 if (uiout
->is_mi_like_p ())
12089 uiout
->field_string ("reason",
12090 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12091 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12094 uiout
->text (b
->disposition
== disp_del
12095 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12096 uiout
->field_signed ("bkptno", b
->number
);
12097 uiout
->text (", ");
12099 /* ada_exception_name_addr relies on the selected frame being the
12100 current frame. Need to do this here because this function may be
12101 called more than once when printing a stop, and below, we'll
12102 select the first frame past the Ada run-time (see
12103 ada_find_printable_frame). */
12104 select_frame (get_current_frame ());
12106 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12109 case ada_catch_exception
:
12110 case ada_catch_exception_unhandled
:
12111 case ada_catch_handlers
:
12113 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12114 char exception_name
[256];
12118 read_memory (addr
, (gdb_byte
*) exception_name
,
12119 sizeof (exception_name
) - 1);
12120 exception_name
[sizeof (exception_name
) - 1] = '\0';
12124 /* For some reason, we were unable to read the exception
12125 name. This could happen if the Runtime was compiled
12126 without debugging info, for instance. In that case,
12127 just replace the exception name by the generic string
12128 "exception" - it will read as "an exception" in the
12129 notification we are about to print. */
12130 memcpy (exception_name
, "exception", sizeof ("exception"));
12132 /* In the case of unhandled exception breakpoints, we print
12133 the exception name as "unhandled EXCEPTION_NAME", to make
12134 it clearer to the user which kind of catchpoint just got
12135 hit. We used ui_out_text to make sure that this extra
12136 info does not pollute the exception name in the MI case. */
12137 if (c
->m_kind
== ada_catch_exception_unhandled
)
12138 uiout
->text ("unhandled ");
12139 uiout
->field_string ("exception-name", exception_name
);
12142 case ada_catch_assert
:
12143 /* In this case, the name of the exception is not really
12144 important. Just print "failed assertion" to make it clearer
12145 that his program just hit an assertion-failure catchpoint.
12146 We used ui_out_text because this info does not belong in
12148 uiout
->text ("failed assertion");
12152 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12153 if (exception_message
!= NULL
)
12155 uiout
->text (" (");
12156 uiout
->field_string ("exception-message", exception_message
.get ());
12160 uiout
->text (" at ");
12161 ada_find_printable_frame (get_current_frame ());
12163 return PRINT_SRC_AND_LOC
;
12166 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12167 for all exception catchpoint kinds. */
12170 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12172 struct ui_out
*uiout
= current_uiout
;
12173 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12174 struct value_print_options opts
;
12176 get_user_print_options (&opts
);
12178 if (opts
.addressprint
)
12179 uiout
->field_skip ("addr");
12181 annotate_field (5);
12184 case ada_catch_exception
:
12185 if (!c
->excep_string
.empty ())
12187 std::string msg
= string_printf (_("`%s' Ada exception"),
12188 c
->excep_string
.c_str ());
12190 uiout
->field_string ("what", msg
);
12193 uiout
->field_string ("what", "all Ada exceptions");
12197 case ada_catch_exception_unhandled
:
12198 uiout
->field_string ("what", "unhandled Ada exceptions");
12201 case ada_catch_handlers
:
12202 if (!c
->excep_string
.empty ())
12204 uiout
->field_fmt ("what",
12205 _("`%s' Ada exception handlers"),
12206 c
->excep_string
.c_str ());
12209 uiout
->field_string ("what", "all Ada exceptions handlers");
12212 case ada_catch_assert
:
12213 uiout
->field_string ("what", "failed Ada assertions");
12217 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12222 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12223 for all exception catchpoint kinds. */
12226 print_mention_exception (struct breakpoint
*b
)
12228 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12229 struct ui_out
*uiout
= current_uiout
;
12231 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12232 : _("Catchpoint "));
12233 uiout
->field_signed ("bkptno", b
->number
);
12234 uiout
->text (": ");
12238 case ada_catch_exception
:
12239 if (!c
->excep_string
.empty ())
12241 std::string info
= string_printf (_("`%s' Ada exception"),
12242 c
->excep_string
.c_str ());
12243 uiout
->text (info
.c_str ());
12246 uiout
->text (_("all Ada exceptions"));
12249 case ada_catch_exception_unhandled
:
12250 uiout
->text (_("unhandled Ada exceptions"));
12253 case ada_catch_handlers
:
12254 if (!c
->excep_string
.empty ())
12257 = string_printf (_("`%s' Ada exception handlers"),
12258 c
->excep_string
.c_str ());
12259 uiout
->text (info
.c_str ());
12262 uiout
->text (_("all Ada exceptions handlers"));
12265 case ada_catch_assert
:
12266 uiout
->text (_("failed Ada assertions"));
12270 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12275 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12276 for all exception catchpoint kinds. */
12279 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12281 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12285 case ada_catch_exception
:
12286 fprintf_filtered (fp
, "catch exception");
12287 if (!c
->excep_string
.empty ())
12288 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12291 case ada_catch_exception_unhandled
:
12292 fprintf_filtered (fp
, "catch exception unhandled");
12295 case ada_catch_handlers
:
12296 fprintf_filtered (fp
, "catch handlers");
12299 case ada_catch_assert
:
12300 fprintf_filtered (fp
, "catch assert");
12304 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12306 print_recreate_thread (b
, fp
);
12309 /* Virtual tables for various breakpoint types. */
12310 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12311 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12312 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12313 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12315 /* See ada-lang.h. */
12318 is_ada_exception_catchpoint (breakpoint
*bp
)
12320 return (bp
->ops
== &catch_exception_breakpoint_ops
12321 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12322 || bp
->ops
== &catch_assert_breakpoint_ops
12323 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12326 /* Split the arguments specified in a "catch exception" command.
12327 Set EX to the appropriate catchpoint type.
12328 Set EXCEP_STRING to the name of the specific exception if
12329 specified by the user.
12330 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12331 "catch handlers" command. False otherwise.
12332 If a condition is found at the end of the arguments, the condition
12333 expression is stored in COND_STRING (memory must be deallocated
12334 after use). Otherwise COND_STRING is set to NULL. */
12337 catch_ada_exception_command_split (const char *args
,
12338 bool is_catch_handlers_cmd
,
12339 enum ada_exception_catchpoint_kind
*ex
,
12340 std::string
*excep_string
,
12341 std::string
*cond_string
)
12343 std::string exception_name
;
12345 exception_name
= extract_arg (&args
);
12346 if (exception_name
== "if")
12348 /* This is not an exception name; this is the start of a condition
12349 expression for a catchpoint on all exceptions. So, "un-get"
12350 this token, and set exception_name to NULL. */
12351 exception_name
.clear ();
12355 /* Check to see if we have a condition. */
12357 args
= skip_spaces (args
);
12358 if (startswith (args
, "if")
12359 && (isspace (args
[2]) || args
[2] == '\0'))
12362 args
= skip_spaces (args
);
12364 if (args
[0] == '\0')
12365 error (_("Condition missing after `if' keyword"));
12366 *cond_string
= args
;
12368 args
+= strlen (args
);
12371 /* Check that we do not have any more arguments. Anything else
12374 if (args
[0] != '\0')
12375 error (_("Junk at end of expression"));
12377 if (is_catch_handlers_cmd
)
12379 /* Catch handling of exceptions. */
12380 *ex
= ada_catch_handlers
;
12381 *excep_string
= exception_name
;
12383 else if (exception_name
.empty ())
12385 /* Catch all exceptions. */
12386 *ex
= ada_catch_exception
;
12387 excep_string
->clear ();
12389 else if (exception_name
== "unhandled")
12391 /* Catch unhandled exceptions. */
12392 *ex
= ada_catch_exception_unhandled
;
12393 excep_string
->clear ();
12397 /* Catch a specific exception. */
12398 *ex
= ada_catch_exception
;
12399 *excep_string
= exception_name
;
12403 /* Return the name of the symbol on which we should break in order to
12404 implement a catchpoint of the EX kind. */
12406 static const char *
12407 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12409 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12411 gdb_assert (data
->exception_info
!= NULL
);
12415 case ada_catch_exception
:
12416 return (data
->exception_info
->catch_exception_sym
);
12418 case ada_catch_exception_unhandled
:
12419 return (data
->exception_info
->catch_exception_unhandled_sym
);
12421 case ada_catch_assert
:
12422 return (data
->exception_info
->catch_assert_sym
);
12424 case ada_catch_handlers
:
12425 return (data
->exception_info
->catch_handlers_sym
);
12428 internal_error (__FILE__
, __LINE__
,
12429 _("unexpected catchpoint kind (%d)"), ex
);
12433 /* Return the breakpoint ops "virtual table" used for catchpoints
12436 static const struct breakpoint_ops
*
12437 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12441 case ada_catch_exception
:
12442 return (&catch_exception_breakpoint_ops
);
12444 case ada_catch_exception_unhandled
:
12445 return (&catch_exception_unhandled_breakpoint_ops
);
12447 case ada_catch_assert
:
12448 return (&catch_assert_breakpoint_ops
);
12450 case ada_catch_handlers
:
12451 return (&catch_handlers_breakpoint_ops
);
12454 internal_error (__FILE__
, __LINE__
,
12455 _("unexpected catchpoint kind (%d)"), ex
);
12459 /* Return the condition that will be used to match the current exception
12460 being raised with the exception that the user wants to catch. This
12461 assumes that this condition is used when the inferior just triggered
12462 an exception catchpoint.
12463 EX: the type of catchpoints used for catching Ada exceptions. */
12466 ada_exception_catchpoint_cond_string (const char *excep_string
,
12467 enum ada_exception_catchpoint_kind ex
)
12470 bool is_standard_exc
= false;
12471 std::string result
;
12473 if (ex
== ada_catch_handlers
)
12475 /* For exception handlers catchpoints, the condition string does
12476 not use the same parameter as for the other exceptions. */
12477 result
= ("long_integer (GNAT_GCC_exception_Access"
12478 "(gcc_exception).all.occurrence.id)");
12481 result
= "long_integer (e)";
12483 /* The standard exceptions are a special case. They are defined in
12484 runtime units that have been compiled without debugging info; if
12485 EXCEP_STRING is the not-fully-qualified name of a standard
12486 exception (e.g. "constraint_error") then, during the evaluation
12487 of the condition expression, the symbol lookup on this name would
12488 *not* return this standard exception. The catchpoint condition
12489 may then be set only on user-defined exceptions which have the
12490 same not-fully-qualified name (e.g. my_package.constraint_error).
12492 To avoid this unexcepted behavior, these standard exceptions are
12493 systematically prefixed by "standard". This means that "catch
12494 exception constraint_error" is rewritten into "catch exception
12495 standard.constraint_error".
12497 If an exception named constraint_error is defined in another package of
12498 the inferior program, then the only way to specify this exception as a
12499 breakpoint condition is to use its fully-qualified named:
12500 e.g. my_package.constraint_error. */
12502 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12504 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12506 is_standard_exc
= true;
12513 if (is_standard_exc
)
12514 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12516 string_appendf (result
, "long_integer (&%s)", excep_string
);
12521 /* Return the symtab_and_line that should be used to insert an exception
12522 catchpoint of the TYPE kind.
12524 ADDR_STRING returns the name of the function where the real
12525 breakpoint that implements the catchpoints is set, depending on the
12526 type of catchpoint we need to create. */
12528 static struct symtab_and_line
12529 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12530 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12532 const char *sym_name
;
12533 struct symbol
*sym
;
12535 /* First, find out which exception support info to use. */
12536 ada_exception_support_info_sniffer ();
12538 /* Then lookup the function on which we will break in order to catch
12539 the Ada exceptions requested by the user. */
12540 sym_name
= ada_exception_sym_name (ex
);
12541 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12544 error (_("Catchpoint symbol not found: %s"), sym_name
);
12546 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12547 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12549 /* Set ADDR_STRING. */
12550 *addr_string
= sym_name
;
12553 *ops
= ada_exception_breakpoint_ops (ex
);
12555 return find_function_start_sal (sym
, 1);
12558 /* Create an Ada exception catchpoint.
12560 EX_KIND is the kind of exception catchpoint to be created.
12562 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12563 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12564 of the exception to which this catchpoint applies.
12566 COND_STRING, if not empty, is the catchpoint condition.
12568 TEMPFLAG, if nonzero, means that the underlying breakpoint
12569 should be temporary.
12571 FROM_TTY is the usual argument passed to all commands implementations. */
12574 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12575 enum ada_exception_catchpoint_kind ex_kind
,
12576 const std::string
&excep_string
,
12577 const std::string
&cond_string
,
12582 std::string addr_string
;
12583 const struct breakpoint_ops
*ops
= NULL
;
12584 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12586 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12587 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12588 ops
, tempflag
, disabled
, from_tty
);
12589 c
->excep_string
= excep_string
;
12590 create_excep_cond_exprs (c
.get (), ex_kind
);
12591 if (!cond_string
.empty ())
12592 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12593 install_breakpoint (0, std::move (c
), 1);
12596 /* Implement the "catch exception" command. */
12599 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12600 struct cmd_list_element
*command
)
12602 const char *arg
= arg_entry
;
12603 struct gdbarch
*gdbarch
= get_current_arch ();
12605 enum ada_exception_catchpoint_kind ex_kind
;
12606 std::string excep_string
;
12607 std::string cond_string
;
12609 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12613 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12615 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12616 excep_string
, cond_string
,
12617 tempflag
, 1 /* enabled */,
12621 /* Implement the "catch handlers" command. */
12624 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12625 struct cmd_list_element
*command
)
12627 const char *arg
= arg_entry
;
12628 struct gdbarch
*gdbarch
= get_current_arch ();
12630 enum ada_exception_catchpoint_kind ex_kind
;
12631 std::string excep_string
;
12632 std::string cond_string
;
12634 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12638 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12640 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12641 excep_string
, cond_string
,
12642 tempflag
, 1 /* enabled */,
12646 /* Completion function for the Ada "catch" commands. */
12649 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12650 const char *text
, const char *word
)
12652 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12654 for (const ada_exc_info
&info
: exceptions
)
12656 if (startswith (info
.name
, word
))
12657 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12661 /* Split the arguments specified in a "catch assert" command.
12663 ARGS contains the command's arguments (or the empty string if
12664 no arguments were passed).
12666 If ARGS contains a condition, set COND_STRING to that condition
12667 (the memory needs to be deallocated after use). */
12670 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12672 args
= skip_spaces (args
);
12674 /* Check whether a condition was provided. */
12675 if (startswith (args
, "if")
12676 && (isspace (args
[2]) || args
[2] == '\0'))
12679 args
= skip_spaces (args
);
12680 if (args
[0] == '\0')
12681 error (_("condition missing after `if' keyword"));
12682 cond_string
.assign (args
);
12685 /* Otherwise, there should be no other argument at the end of
12687 else if (args
[0] != '\0')
12688 error (_("Junk at end of arguments."));
12691 /* Implement the "catch assert" command. */
12694 catch_assert_command (const char *arg_entry
, int from_tty
,
12695 struct cmd_list_element
*command
)
12697 const char *arg
= arg_entry
;
12698 struct gdbarch
*gdbarch
= get_current_arch ();
12700 std::string cond_string
;
12702 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12706 catch_ada_assert_command_split (arg
, cond_string
);
12707 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12709 tempflag
, 1 /* enabled */,
12713 /* Return non-zero if the symbol SYM is an Ada exception object. */
12716 ada_is_exception_sym (struct symbol
*sym
)
12718 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12720 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12721 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12722 && SYMBOL_CLASS (sym
) != LOC_CONST
12723 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12724 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12727 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12728 Ada exception object. This matches all exceptions except the ones
12729 defined by the Ada language. */
12732 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12736 if (!ada_is_exception_sym (sym
))
12739 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12740 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12741 return 0; /* A standard exception. */
12743 /* Numeric_Error is also a standard exception, so exclude it.
12744 See the STANDARD_EXC description for more details as to why
12745 this exception is not listed in that array. */
12746 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12752 /* A helper function for std::sort, comparing two struct ada_exc_info
12755 The comparison is determined first by exception name, and then
12756 by exception address. */
12759 ada_exc_info::operator< (const ada_exc_info
&other
) const
12763 result
= strcmp (name
, other
.name
);
12766 if (result
== 0 && addr
< other
.addr
)
12772 ada_exc_info::operator== (const ada_exc_info
&other
) const
12774 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12777 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12778 routine, but keeping the first SKIP elements untouched.
12780 All duplicates are also removed. */
12783 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12786 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12787 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12788 exceptions
->end ());
12791 /* Add all exceptions defined by the Ada standard whose name match
12792 a regular expression.
12794 If PREG is not NULL, then this regexp_t object is used to
12795 perform the symbol name matching. Otherwise, no name-based
12796 filtering is performed.
12798 EXCEPTIONS is a vector of exceptions to which matching exceptions
12802 ada_add_standard_exceptions (compiled_regex
*preg
,
12803 std::vector
<ada_exc_info
> *exceptions
)
12807 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12810 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12812 struct bound_minimal_symbol msymbol
12813 = ada_lookup_simple_minsym (standard_exc
[i
]);
12815 if (msymbol
.minsym
!= NULL
)
12817 struct ada_exc_info info
12818 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12820 exceptions
->push_back (info
);
12826 /* Add all Ada exceptions defined locally and accessible from the given
12829 If PREG is not NULL, then this regexp_t object is used to
12830 perform the symbol name matching. Otherwise, no name-based
12831 filtering is performed.
12833 EXCEPTIONS is a vector of exceptions to which matching exceptions
12837 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12838 struct frame_info
*frame
,
12839 std::vector
<ada_exc_info
> *exceptions
)
12841 const struct block
*block
= get_frame_block (frame
, 0);
12845 struct block_iterator iter
;
12846 struct symbol
*sym
;
12848 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12850 switch (SYMBOL_CLASS (sym
))
12857 if (ada_is_exception_sym (sym
))
12859 struct ada_exc_info info
= {sym
->print_name (),
12860 SYMBOL_VALUE_ADDRESS (sym
)};
12862 exceptions
->push_back (info
);
12866 if (BLOCK_FUNCTION (block
) != NULL
)
12868 block
= BLOCK_SUPERBLOCK (block
);
12872 /* Return true if NAME matches PREG or if PREG is NULL. */
12875 name_matches_regex (const char *name
, compiled_regex
*preg
)
12877 return (preg
== NULL
12878 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
12881 /* Add all exceptions defined globally whose name name match
12882 a regular expression, excluding standard exceptions.
12884 The reason we exclude standard exceptions is that they need
12885 to be handled separately: Standard exceptions are defined inside
12886 a runtime unit which is normally not compiled with debugging info,
12887 and thus usually do not show up in our symbol search. However,
12888 if the unit was in fact built with debugging info, we need to
12889 exclude them because they would duplicate the entry we found
12890 during the special loop that specifically searches for those
12891 standard exceptions.
12893 If PREG is not NULL, then this regexp_t object is used to
12894 perform the symbol name matching. Otherwise, no name-based
12895 filtering is performed.
12897 EXCEPTIONS is a vector of exceptions to which matching exceptions
12901 ada_add_global_exceptions (compiled_regex
*preg
,
12902 std::vector
<ada_exc_info
> *exceptions
)
12904 /* In Ada, the symbol "search name" is a linkage name, whereas the
12905 regular expression used to do the matching refers to the natural
12906 name. So match against the decoded name. */
12907 expand_symtabs_matching (NULL
,
12908 lookup_name_info::match_any (),
12909 [&] (const char *search_name
)
12911 std::string decoded
= ada_decode (search_name
);
12912 return name_matches_regex (decoded
.c_str (), preg
);
12917 for (objfile
*objfile
: current_program_space
->objfiles ())
12919 for (compunit_symtab
*s
: objfile
->compunits ())
12921 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
12924 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12926 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12927 struct block_iterator iter
;
12928 struct symbol
*sym
;
12930 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12931 if (ada_is_non_standard_exception_sym (sym
)
12932 && name_matches_regex (sym
->natural_name (), preg
))
12934 struct ada_exc_info info
12935 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
12937 exceptions
->push_back (info
);
12944 /* Implements ada_exceptions_list with the regular expression passed
12945 as a regex_t, rather than a string.
12947 If not NULL, PREG is used to filter out exceptions whose names
12948 do not match. Otherwise, all exceptions are listed. */
12950 static std::vector
<ada_exc_info
>
12951 ada_exceptions_list_1 (compiled_regex
*preg
)
12953 std::vector
<ada_exc_info
> result
;
12956 /* First, list the known standard exceptions. These exceptions
12957 need to be handled separately, as they are usually defined in
12958 runtime units that have been compiled without debugging info. */
12960 ada_add_standard_exceptions (preg
, &result
);
12962 /* Next, find all exceptions whose scope is local and accessible
12963 from the currently selected frame. */
12965 if (has_stack_frames ())
12967 prev_len
= result
.size ();
12968 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12970 if (result
.size () > prev_len
)
12971 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12974 /* Add all exceptions whose scope is global. */
12976 prev_len
= result
.size ();
12977 ada_add_global_exceptions (preg
, &result
);
12978 if (result
.size () > prev_len
)
12979 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12984 /* Return a vector of ada_exc_info.
12986 If REGEXP is NULL, all exceptions are included in the result.
12987 Otherwise, it should contain a valid regular expression,
12988 and only the exceptions whose names match that regular expression
12989 are included in the result.
12991 The exceptions are sorted in the following order:
12992 - Standard exceptions (defined by the Ada language), in
12993 alphabetical order;
12994 - Exceptions only visible from the current frame, in
12995 alphabetical order;
12996 - Exceptions whose scope is global, in alphabetical order. */
12998 std::vector
<ada_exc_info
>
12999 ada_exceptions_list (const char *regexp
)
13001 if (regexp
== NULL
)
13002 return ada_exceptions_list_1 (NULL
);
13004 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13005 return ada_exceptions_list_1 (®
);
13008 /* Implement the "info exceptions" command. */
13011 info_exceptions_command (const char *regexp
, int from_tty
)
13013 struct gdbarch
*gdbarch
= get_current_arch ();
13015 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13017 if (regexp
!= NULL
)
13019 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13021 printf_filtered (_("All defined Ada exceptions:\n"));
13023 for (const ada_exc_info
&info
: exceptions
)
13024 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13028 /* Information about operators given special treatment in functions
13030 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13032 #define ADA_OPERATORS \
13033 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13034 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13035 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13036 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13037 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13038 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13039 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13040 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13041 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13042 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13043 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13044 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13045 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13046 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13047 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13048 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13049 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13050 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13051 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13054 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13057 switch (exp
->elts
[pc
- 1].opcode
)
13060 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13063 #define OP_DEFN(op, len, args, binop) \
13064 case op: *oplenp = len; *argsp = args; break;
13070 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13075 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13080 /* Implementation of the exp_descriptor method operator_check. */
13083 ada_operator_check (struct expression
*exp
, int pos
,
13084 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13087 const union exp_element
*const elts
= exp
->elts
;
13088 struct type
*type
= NULL
;
13090 switch (elts
[pos
].opcode
)
13092 case UNOP_IN_RANGE
:
13094 type
= elts
[pos
+ 1].type
;
13098 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13101 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13103 if (type
!= nullptr && type
->objfile_owner () != nullptr
13104 && objfile_func (type
->objfile_owner (), data
))
13110 /* As for operator_length, but assumes PC is pointing at the first
13111 element of the operator, and gives meaningful results only for the
13112 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13115 ada_forward_operator_length (struct expression
*exp
, int pc
,
13116 int *oplenp
, int *argsp
)
13118 switch (exp
->elts
[pc
].opcode
)
13121 *oplenp
= *argsp
= 0;
13124 #define OP_DEFN(op, len, args, binop) \
13125 case op: *oplenp = len; *argsp = args; break;
13131 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13136 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13142 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13144 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13152 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13154 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13159 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13163 /* Ada attributes ('Foo). */
13166 case OP_ATR_LENGTH
:
13170 case OP_ATR_MODULUS
:
13177 case UNOP_IN_RANGE
:
13179 /* XXX: gdb_sprint_host_address, type_sprint */
13180 fprintf_filtered (stream
, _("Type @"));
13181 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13182 fprintf_filtered (stream
, " (");
13183 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13184 fprintf_filtered (stream
, ")");
13186 case BINOP_IN_BOUNDS
:
13187 fprintf_filtered (stream
, " (%d)",
13188 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13190 case TERNOP_IN_RANGE
:
13195 case OP_DISCRETE_RANGE
:
13196 case OP_POSITIONAL
:
13203 char *name
= &exp
->elts
[elt
+ 2].string
;
13204 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13206 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13211 return dump_subexp_body_standard (exp
, stream
, elt
);
13215 for (i
= 0; i
< nargs
; i
+= 1)
13216 elt
= dump_subexp (exp
, stream
, elt
);
13221 /* The Ada extension of print_subexp (q.v.). */
13224 ada_print_subexp (struct expression
*exp
, int *pos
,
13225 struct ui_file
*stream
, enum precedence prec
)
13227 int oplen
, nargs
, i
;
13229 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13231 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13238 print_subexp_standard (exp
, pos
, stream
, prec
);
13242 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13245 case BINOP_IN_BOUNDS
:
13246 /* XXX: sprint_subexp */
13247 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13248 fputs_filtered (" in ", stream
);
13249 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13250 fputs_filtered ("'range", stream
);
13251 if (exp
->elts
[pc
+ 1].longconst
> 1)
13252 fprintf_filtered (stream
, "(%ld)",
13253 (long) exp
->elts
[pc
+ 1].longconst
);
13256 case TERNOP_IN_RANGE
:
13257 if (prec
>= PREC_EQUAL
)
13258 fputs_filtered ("(", stream
);
13259 /* XXX: sprint_subexp */
13260 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13261 fputs_filtered (" in ", stream
);
13262 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13263 fputs_filtered (" .. ", stream
);
13264 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13265 if (prec
>= PREC_EQUAL
)
13266 fputs_filtered (")", stream
);
13271 case OP_ATR_LENGTH
:
13275 case OP_ATR_MODULUS
:
13280 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13282 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13283 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13284 &type_print_raw_options
);
13288 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13289 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13294 for (tem
= 1; tem
< nargs
; tem
+= 1)
13296 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13297 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13299 fputs_filtered (")", stream
);
13304 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13305 fputs_filtered ("'(", stream
);
13306 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13307 fputs_filtered (")", stream
);
13310 case UNOP_IN_RANGE
:
13311 /* XXX: sprint_subexp */
13312 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13313 fputs_filtered (" in ", stream
);
13314 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13315 &type_print_raw_options
);
13318 case OP_DISCRETE_RANGE
:
13319 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13320 fputs_filtered ("..", stream
);
13321 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13325 fputs_filtered ("others => ", stream
);
13326 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13330 for (i
= 0; i
< nargs
-1; i
+= 1)
13333 fputs_filtered ("|", stream
);
13334 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13336 fputs_filtered (" => ", stream
);
13337 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13340 case OP_POSITIONAL
:
13341 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13345 fputs_filtered ("(", stream
);
13346 for (i
= 0; i
< nargs
; i
+= 1)
13349 fputs_filtered (", ", stream
);
13350 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13352 fputs_filtered (")", stream
);
13357 /* Table mapping opcodes into strings for printing operators
13358 and precedences of the operators. */
13360 static const struct op_print ada_op_print_tab
[] = {
13361 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13362 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13363 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13364 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13365 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13366 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13367 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13368 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13369 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13370 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13371 {">", BINOP_GTR
, PREC_ORDER
, 0},
13372 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13373 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13374 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13375 {"+", BINOP_ADD
, PREC_ADD
, 0},
13376 {"-", BINOP_SUB
, PREC_ADD
, 0},
13377 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13378 {"*", BINOP_MUL
, PREC_MUL
, 0},
13379 {"/", BINOP_DIV
, PREC_MUL
, 0},
13380 {"rem", BINOP_REM
, PREC_MUL
, 0},
13381 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13382 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13383 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13384 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13385 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13386 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13387 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13388 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13389 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13390 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13391 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13392 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13395 /* Language vector */
13397 static const struct exp_descriptor ada_exp_descriptor
= {
13399 ada_operator_length
,
13400 ada_operator_check
,
13401 ada_dump_subexp_body
,
13402 ada_evaluate_subexp
13405 /* symbol_name_matcher_ftype adapter for wild_match. */
13408 do_wild_match (const char *symbol_search_name
,
13409 const lookup_name_info
&lookup_name
,
13410 completion_match_result
*comp_match_res
)
13412 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13415 /* symbol_name_matcher_ftype adapter for full_match. */
13418 do_full_match (const char *symbol_search_name
,
13419 const lookup_name_info
&lookup_name
,
13420 completion_match_result
*comp_match_res
)
13422 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13424 /* If both symbols start with "_ada_", just let the loop below
13425 handle the comparison. However, if only the symbol name starts
13426 with "_ada_", skip the prefix and let the match proceed as
13428 if (startswith (symbol_search_name
, "_ada_")
13429 && !startswith (lname
, "_ada"))
13430 symbol_search_name
+= 5;
13432 int uscore_count
= 0;
13433 while (*lname
!= '\0')
13435 if (*symbol_search_name
!= *lname
)
13437 if (*symbol_search_name
== 'B' && uscore_count
== 2
13438 && symbol_search_name
[1] == '_')
13440 symbol_search_name
+= 2;
13441 while (isdigit (*symbol_search_name
))
13442 ++symbol_search_name
;
13443 if (symbol_search_name
[0] == '_'
13444 && symbol_search_name
[1] == '_')
13446 symbol_search_name
+= 2;
13453 if (*symbol_search_name
== '_')
13458 ++symbol_search_name
;
13462 return is_name_suffix (symbol_search_name
);
13465 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13468 do_exact_match (const char *symbol_search_name
,
13469 const lookup_name_info
&lookup_name
,
13470 completion_match_result
*comp_match_res
)
13472 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13475 /* Build the Ada lookup name for LOOKUP_NAME. */
13477 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13479 gdb::string_view user_name
= lookup_name
.name ();
13481 if (!user_name
.empty () && user_name
[0] == '<')
13483 if (user_name
.back () == '>')
13485 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13488 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13489 m_encoded_p
= true;
13490 m_verbatim_p
= true;
13491 m_wild_match_p
= false;
13492 m_standard_p
= false;
13496 m_verbatim_p
= false;
13498 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13502 const char *folded
= ada_fold_name (user_name
);
13503 m_encoded_name
= ada_encode_1 (folded
, false);
13504 if (m_encoded_name
.empty ())
13505 m_encoded_name
= gdb::to_string (user_name
);
13508 m_encoded_name
= gdb::to_string (user_name
);
13510 /* Handle the 'package Standard' special case. See description
13511 of m_standard_p. */
13512 if (startswith (m_encoded_name
.c_str (), "standard__"))
13514 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13515 m_standard_p
= true;
13518 m_standard_p
= false;
13520 /* If the name contains a ".", then the user is entering a fully
13521 qualified entity name, and the match must not be done in wild
13522 mode. Similarly, if the user wants to complete what looks
13523 like an encoded name, the match must not be done in wild
13524 mode. Also, in the standard__ special case always do
13525 non-wild matching. */
13527 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13530 && user_name
.find ('.') == std::string::npos
);
13534 /* symbol_name_matcher_ftype method for Ada. This only handles
13535 completion mode. */
13538 ada_symbol_name_matches (const char *symbol_search_name
,
13539 const lookup_name_info
&lookup_name
,
13540 completion_match_result
*comp_match_res
)
13542 return lookup_name
.ada ().matches (symbol_search_name
,
13543 lookup_name
.match_type (),
13547 /* A name matcher that matches the symbol name exactly, with
13551 literal_symbol_name_matcher (const char *symbol_search_name
,
13552 const lookup_name_info
&lookup_name
,
13553 completion_match_result
*comp_match_res
)
13555 gdb::string_view name_view
= lookup_name
.name ();
13557 if (lookup_name
.completion_mode ()
13558 ? (strncmp (symbol_search_name
, name_view
.data (),
13559 name_view
.size ()) == 0)
13560 : symbol_search_name
== name_view
)
13562 if (comp_match_res
!= NULL
)
13563 comp_match_res
->set_match (symbol_search_name
);
13570 /* Implement the "get_symbol_name_matcher" language_defn method for
13573 static symbol_name_matcher_ftype
*
13574 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13576 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13577 return literal_symbol_name_matcher
;
13579 if (lookup_name
.completion_mode ())
13580 return ada_symbol_name_matches
;
13583 if (lookup_name
.ada ().wild_match_p ())
13584 return do_wild_match
;
13585 else if (lookup_name
.ada ().verbatim_p ())
13586 return do_exact_match
;
13588 return do_full_match
;
13592 /* Class representing the Ada language. */
13594 class ada_language
: public language_defn
13598 : language_defn (language_ada
)
13601 /* See language.h. */
13603 const char *name () const override
13606 /* See language.h. */
13608 const char *natural_name () const override
13611 /* See language.h. */
13613 const std::vector
<const char *> &filename_extensions () const override
13615 static const std::vector
<const char *> extensions
13616 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13620 /* Print an array element index using the Ada syntax. */
13622 void print_array_index (struct type
*index_type
,
13624 struct ui_file
*stream
,
13625 const value_print_options
*options
) const override
13627 struct value
*index_value
= val_atr (index_type
, index
);
13629 value_print (index_value
, stream
, options
);
13630 fprintf_filtered (stream
, " => ");
13633 /* Implement the "read_var_value" language_defn method for Ada. */
13635 struct value
*read_var_value (struct symbol
*var
,
13636 const struct block
*var_block
,
13637 struct frame_info
*frame
) const override
13639 /* The only case where default_read_var_value is not sufficient
13640 is when VAR is a renaming... */
13641 if (frame
!= nullptr)
13643 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13644 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13645 return ada_read_renaming_var_value (var
, frame_block
);
13648 /* This is a typical case where we expect the default_read_var_value
13649 function to work. */
13650 return language_defn::read_var_value (var
, var_block
, frame
);
13653 /* See language.h. */
13654 void language_arch_info (struct gdbarch
*gdbarch
,
13655 struct language_arch_info
*lai
) const override
13657 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13659 /* Helper function to allow shorter lines below. */
13660 auto add
= [&] (struct type
*t
)
13662 lai
->add_primitive_type (t
);
13665 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13667 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13668 0, "long_integer"));
13669 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13670 0, "short_integer"));
13671 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13673 lai
->set_string_char_type (char_type
);
13675 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13676 "float", gdbarch_float_format (gdbarch
)));
13677 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13678 "long_float", gdbarch_double_format (gdbarch
)));
13679 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13680 0, "long_long_integer"));
13681 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13683 gdbarch_long_double_format (gdbarch
)));
13684 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13686 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13688 add (builtin
->builtin_void
);
13690 struct type
*system_addr_ptr
13691 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13693 system_addr_ptr
->set_name ("system__address");
13694 add (system_addr_ptr
);
13696 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13697 type. This is a signed integral type whose size is the same as
13698 the size of addresses. */
13699 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13700 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13701 "storage_offset"));
13703 lai
->set_bool_type (builtin
->builtin_bool
);
13706 /* See language.h. */
13708 bool iterate_over_symbols
13709 (const struct block
*block
, const lookup_name_info
&name
,
13710 domain_enum domain
,
13711 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13713 std::vector
<struct block_symbol
> results
13714 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13715 for (block_symbol
&sym
: results
)
13717 if (!callback (&sym
))
13724 /* See language.h. */
13725 bool sniff_from_mangled_name (const char *mangled
,
13726 char **out
) const override
13728 std::string demangled
= ada_decode (mangled
);
13732 if (demangled
!= mangled
&& demangled
[0] != '<')
13734 /* Set the gsymbol language to Ada, but still return 0.
13735 Two reasons for that:
13737 1. For Ada, we prefer computing the symbol's decoded name
13738 on the fly rather than pre-compute it, in order to save
13739 memory (Ada projects are typically very large).
13741 2. There are some areas in the definition of the GNAT
13742 encoding where, with a bit of bad luck, we might be able
13743 to decode a non-Ada symbol, generating an incorrect
13744 demangled name (Eg: names ending with "TB" for instance
13745 are identified as task bodies and so stripped from
13746 the decoded name returned).
13748 Returning true, here, but not setting *DEMANGLED, helps us get
13749 a little bit of the best of both worlds. Because we're last,
13750 we should not affect any of the other languages that were
13751 able to demangle the symbol before us; we get to correctly
13752 tag Ada symbols as such; and even if we incorrectly tagged a
13753 non-Ada symbol, which should be rare, any routing through the
13754 Ada language should be transparent (Ada tries to behave much
13755 like C/C++ with non-Ada symbols). */
13762 /* See language.h. */
13764 char *demangle_symbol (const char *mangled
, int options
) const override
13766 return ada_la_decode (mangled
, options
);
13769 /* See language.h. */
13771 void print_type (struct type
*type
, const char *varstring
,
13772 struct ui_file
*stream
, int show
, int level
,
13773 const struct type_print_options
*flags
) const override
13775 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13778 /* See language.h. */
13780 const char *word_break_characters (void) const override
13782 return ada_completer_word_break_characters
;
13785 /* See language.h. */
13787 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13788 complete_symbol_mode mode
,
13789 symbol_name_match_type name_match_type
,
13790 const char *text
, const char *word
,
13791 enum type_code code
) const override
13793 struct symbol
*sym
;
13794 const struct block
*b
, *surrounding_static_block
= 0;
13795 struct block_iterator iter
;
13797 gdb_assert (code
== TYPE_CODE_UNDEF
);
13799 lookup_name_info
lookup_name (text
, name_match_type
, true);
13801 /* First, look at the partial symtab symbols. */
13802 expand_symtabs_matching (NULL
,
13808 /* At this point scan through the misc symbol vectors and add each
13809 symbol you find to the list. Eventually we want to ignore
13810 anything that isn't a text symbol (everything else will be
13811 handled by the psymtab code above). */
13813 for (objfile
*objfile
: current_program_space
->objfiles ())
13815 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13819 if (completion_skip_symbol (mode
, msymbol
))
13822 language symbol_language
= msymbol
->language ();
13824 /* Ada minimal symbols won't have their language set to Ada. If
13825 we let completion_list_add_name compare using the
13826 default/C-like matcher, then when completing e.g., symbols in a
13827 package named "pck", we'd match internal Ada symbols like
13828 "pckS", which are invalid in an Ada expression, unless you wrap
13829 them in '<' '>' to request a verbatim match.
13831 Unfortunately, some Ada encoded names successfully demangle as
13832 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13833 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13834 with the wrong language set. Paper over that issue here. */
13835 if (symbol_language
== language_auto
13836 || symbol_language
== language_cplus
)
13837 symbol_language
= language_ada
;
13839 completion_list_add_name (tracker
,
13841 msymbol
->linkage_name (),
13842 lookup_name
, text
, word
);
13846 /* Search upwards from currently selected frame (so that we can
13847 complete on local vars. */
13849 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13851 if (!BLOCK_SUPERBLOCK (b
))
13852 surrounding_static_block
= b
; /* For elmin of dups */
13854 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13856 if (completion_skip_symbol (mode
, sym
))
13859 completion_list_add_name (tracker
,
13861 sym
->linkage_name (),
13862 lookup_name
, text
, word
);
13866 /* Go through the symtabs and check the externs and statics for
13867 symbols which match. */
13869 for (objfile
*objfile
: current_program_space
->objfiles ())
13871 for (compunit_symtab
*s
: objfile
->compunits ())
13874 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
13875 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13877 if (completion_skip_symbol (mode
, sym
))
13880 completion_list_add_name (tracker
,
13882 sym
->linkage_name (),
13883 lookup_name
, text
, word
);
13888 for (objfile
*objfile
: current_program_space
->objfiles ())
13890 for (compunit_symtab
*s
: objfile
->compunits ())
13893 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
13894 /* Don't do this block twice. */
13895 if (b
== surrounding_static_block
)
13897 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13899 if (completion_skip_symbol (mode
, sym
))
13902 completion_list_add_name (tracker
,
13904 sym
->linkage_name (),
13905 lookup_name
, text
, word
);
13911 /* See language.h. */
13913 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13914 (struct type
*type
, CORE_ADDR addr
) const override
13916 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
13917 std::string name
= type_to_string (type
);
13918 return gdb::unique_xmalloc_ptr
<char>
13919 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
13922 /* See language.h. */
13924 void value_print (struct value
*val
, struct ui_file
*stream
,
13925 const struct value_print_options
*options
) const override
13927 return ada_value_print (val
, stream
, options
);
13930 /* See language.h. */
13932 void value_print_inner
13933 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13934 const struct value_print_options
*options
) const override
13936 return ada_value_print_inner (val
, stream
, recurse
, options
);
13939 /* See language.h. */
13941 struct block_symbol lookup_symbol_nonlocal
13942 (const char *name
, const struct block
*block
,
13943 const domain_enum domain
) const override
13945 struct block_symbol sym
;
13947 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13948 if (sym
.symbol
!= NULL
)
13951 /* If we haven't found a match at this point, try the primitive
13952 types. In other languages, this search is performed before
13953 searching for global symbols in order to short-circuit that
13954 global-symbol search if it happens that the name corresponds
13955 to a primitive type. But we cannot do the same in Ada, because
13956 it is perfectly legitimate for a program to declare a type which
13957 has the same name as a standard type. If looking up a type in
13958 that situation, we have traditionally ignored the primitive type
13959 in favor of user-defined types. This is why, unlike most other
13960 languages, we search the primitive types this late and only after
13961 having searched the global symbols without success. */
13963 if (domain
== VAR_DOMAIN
)
13965 struct gdbarch
*gdbarch
;
13968 gdbarch
= target_gdbarch ();
13970 gdbarch
= block_gdbarch (block
);
13972 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
13973 if (sym
.symbol
!= NULL
)
13980 /* See language.h. */
13982 int parser (struct parser_state
*ps
) const override
13984 warnings_issued
= 0;
13985 return ada_parse (ps
);
13990 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
13991 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
13992 namespace) and converts operators that are user-defined into
13993 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
13994 a preferred result type [at the moment, only type void has any
13995 effect---causing procedures to be preferred over functions in calls].
13996 A null CONTEXT_TYPE indicates that a non-void return type is
13997 preferred. May change (expand) *EXP. */
13999 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
14002 struct type
*context_type
= NULL
;
14005 if (ps
->void_context_p
)
14006 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14008 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
14009 ps
->block_tracker
);
14012 /* See language.h. */
14014 void emitchar (int ch
, struct type
*chtype
,
14015 struct ui_file
*stream
, int quoter
) const override
14017 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14020 /* See language.h. */
14022 void printchar (int ch
, struct type
*chtype
,
14023 struct ui_file
*stream
) const override
14025 ada_printchar (ch
, chtype
, stream
);
14028 /* See language.h. */
14030 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14031 const gdb_byte
*string
, unsigned int length
,
14032 const char *encoding
, int force_ellipses
,
14033 const struct value_print_options
*options
) const override
14035 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14036 force_ellipses
, options
);
14039 /* See language.h. */
14041 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14042 struct ui_file
*stream
) const override
14044 ada_print_typedef (type
, new_symbol
, stream
);
14047 /* See language.h. */
14049 bool is_string_type_p (struct type
*type
) const override
14051 return ada_is_string_type (type
);
14054 /* See language.h. */
14056 const char *struct_too_deep_ellipsis () const override
14057 { return "(...)"; }
14059 /* See language.h. */
14061 bool c_style_arrays_p () const override
14064 /* See language.h. */
14066 bool store_sym_names_in_linkage_form_p () const override
14069 /* See language.h. */
14071 const struct lang_varobj_ops
*varobj_ops () const override
14072 { return &ada_varobj_ops
; }
14074 /* See language.h. */
14076 const struct exp_descriptor
*expression_ops () const override
14077 { return &ada_exp_descriptor
; }
14079 /* See language.h. */
14081 const struct op_print
*opcode_print_table () const override
14082 { return ada_op_print_tab
; }
14085 /* See language.h. */
14087 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14088 (const lookup_name_info
&lookup_name
) const override
14090 return ada_get_symbol_name_matcher (lookup_name
);
14094 /* Single instance of the Ada language class. */
14096 static ada_language ada_language_defn
;
14098 /* Command-list for the "set/show ada" prefix command. */
14099 static struct cmd_list_element
*set_ada_list
;
14100 static struct cmd_list_element
*show_ada_list
;
14103 initialize_ada_catchpoint_ops (void)
14105 struct breakpoint_ops
*ops
;
14107 initialize_breakpoint_ops ();
14109 ops
= &catch_exception_breakpoint_ops
;
14110 *ops
= bkpt_breakpoint_ops
;
14111 ops
->allocate_location
= allocate_location_exception
;
14112 ops
->re_set
= re_set_exception
;
14113 ops
->check_status
= check_status_exception
;
14114 ops
->print_it
= print_it_exception
;
14115 ops
->print_one
= print_one_exception
;
14116 ops
->print_mention
= print_mention_exception
;
14117 ops
->print_recreate
= print_recreate_exception
;
14119 ops
= &catch_exception_unhandled_breakpoint_ops
;
14120 *ops
= bkpt_breakpoint_ops
;
14121 ops
->allocate_location
= allocate_location_exception
;
14122 ops
->re_set
= re_set_exception
;
14123 ops
->check_status
= check_status_exception
;
14124 ops
->print_it
= print_it_exception
;
14125 ops
->print_one
= print_one_exception
;
14126 ops
->print_mention
= print_mention_exception
;
14127 ops
->print_recreate
= print_recreate_exception
;
14129 ops
= &catch_assert_breakpoint_ops
;
14130 *ops
= bkpt_breakpoint_ops
;
14131 ops
->allocate_location
= allocate_location_exception
;
14132 ops
->re_set
= re_set_exception
;
14133 ops
->check_status
= check_status_exception
;
14134 ops
->print_it
= print_it_exception
;
14135 ops
->print_one
= print_one_exception
;
14136 ops
->print_mention
= print_mention_exception
;
14137 ops
->print_recreate
= print_recreate_exception
;
14139 ops
= &catch_handlers_breakpoint_ops
;
14140 *ops
= bkpt_breakpoint_ops
;
14141 ops
->allocate_location
= allocate_location_exception
;
14142 ops
->re_set
= re_set_exception
;
14143 ops
->check_status
= check_status_exception
;
14144 ops
->print_it
= print_it_exception
;
14145 ops
->print_one
= print_one_exception
;
14146 ops
->print_mention
= print_mention_exception
;
14147 ops
->print_recreate
= print_recreate_exception
;
14150 /* This module's 'new_objfile' observer. */
14153 ada_new_objfile_observer (struct objfile
*objfile
)
14155 ada_clear_symbol_cache ();
14158 /* This module's 'free_objfile' observer. */
14161 ada_free_objfile_observer (struct objfile
*objfile
)
14163 ada_clear_symbol_cache ();
14166 void _initialize_ada_language ();
14168 _initialize_ada_language ()
14170 initialize_ada_catchpoint_ops ();
14172 add_basic_prefix_cmd ("ada", no_class
,
14173 _("Prefix command for changing Ada-specific settings."),
14174 &set_ada_list
, "set ada ", 0, &setlist
);
14176 add_show_prefix_cmd ("ada", no_class
,
14177 _("Generic command for showing Ada-specific settings."),
14178 &show_ada_list
, "show ada ", 0, &showlist
);
14180 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14181 &trust_pad_over_xvs
, _("\
14182 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14183 Show whether an optimization trusting PAD types over XVS types is activated."),
14185 This is related to the encoding used by the GNAT compiler. The debugger\n\
14186 should normally trust the contents of PAD types, but certain older versions\n\
14187 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14188 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14189 work around this bug. It is always safe to turn this option \"off\", but\n\
14190 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14191 this option to \"off\" unless necessary."),
14192 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14194 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14195 &print_signatures
, _("\
14196 Enable or disable the output of formal and return types for functions in the \
14197 overloads selection menu."), _("\
14198 Show whether the output of formal and return types for functions in the \
14199 overloads selection menu is activated."),
14200 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14202 add_catch_command ("exception", _("\
14203 Catch Ada exceptions, when raised.\n\
14204 Usage: catch exception [ARG] [if CONDITION]\n\
14205 Without any argument, stop when any Ada exception is raised.\n\
14206 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14207 being raised does not have a handler (and will therefore lead to the task's\n\
14209 Otherwise, the catchpoint only stops when the name of the exception being\n\
14210 raised is the same as ARG.\n\
14211 CONDITION is a boolean expression that is evaluated to see whether the\n\
14212 exception should cause a stop."),
14213 catch_ada_exception_command
,
14214 catch_ada_completer
,
14218 add_catch_command ("handlers", _("\
14219 Catch Ada exceptions, when handled.\n\
14220 Usage: catch handlers [ARG] [if CONDITION]\n\
14221 Without any argument, stop when any Ada exception is handled.\n\
14222 With an argument, catch only exceptions with the given name.\n\
14223 CONDITION is a boolean expression that is evaluated to see whether the\n\
14224 exception should cause a stop."),
14225 catch_ada_handlers_command
,
14226 catch_ada_completer
,
14229 add_catch_command ("assert", _("\
14230 Catch failed Ada assertions, when raised.\n\
14231 Usage: catch assert [if CONDITION]\n\
14232 CONDITION is a boolean expression that is evaluated to see whether the\n\
14233 exception should cause a stop."),
14234 catch_assert_command
,
14239 varsize_limit
= 65536;
14240 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14241 &varsize_limit
, _("\
14242 Set the maximum number of bytes allowed in a variable-size object."), _("\
14243 Show the maximum number of bytes allowed in a variable-size object."), _("\
14244 Attempts to access an object whose size is not a compile-time constant\n\
14245 and exceeds this limit will cause an error."),
14246 NULL
, NULL
, &setlist
, &showlist
);
14248 add_info ("exceptions", info_exceptions_command
,
14250 List all Ada exception names.\n\
14251 Usage: info exceptions [REGEXP]\n\
14252 If a regular expression is passed as an argument, only those matching\n\
14253 the regular expression are listed."));
14255 add_basic_prefix_cmd ("ada", class_maintenance
,
14256 _("Set Ada maintenance-related variables."),
14257 &maint_set_ada_cmdlist
, "maintenance set ada ",
14258 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14260 add_show_prefix_cmd ("ada", class_maintenance
,
14261 _("Show Ada maintenance-related variables."),
14262 &maint_show_ada_cmdlist
, "maintenance show ada ",
14263 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14265 add_setshow_boolean_cmd
14266 ("ignore-descriptive-types", class_maintenance
,
14267 &ada_ignore_descriptive_types_p
,
14268 _("Set whether descriptive types generated by GNAT should be ignored."),
14269 _("Show whether descriptive types generated by GNAT should be ignored."),
14271 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14272 DWARF attribute."),
14273 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14275 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14276 NULL
, xcalloc
, xfree
);
14278 /* The ada-lang observers. */
14279 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14280 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14281 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);