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 /* Implement the evaluate_exp routine in the exp_descriptor structure
10222 for the Ada language. */
10224 static struct value
*
10225 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10226 int *pos
, enum noside noside
)
10228 enum exp_opcode op
;
10232 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10235 struct value
**argvec
;
10239 op
= exp
->elts
[pc
].opcode
;
10245 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10247 if (noside
== EVAL_NORMAL
)
10248 arg1
= unwrap_value (arg1
);
10250 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10251 then we need to perform the conversion manually, because
10252 evaluate_subexp_standard doesn't do it. This conversion is
10253 necessary in Ada because the different kinds of float/fixed
10254 types in Ada have different representations.
10256 Similarly, we need to perform the conversion from OP_LONG
10258 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10259 arg1
= ada_value_cast (expect_type
, arg1
);
10265 struct value
*result
;
10268 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10269 /* The result type will have code OP_STRING, bashed there from
10270 OP_ARRAY. Bash it back. */
10271 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10272 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10278 type
= exp
->elts
[pc
+ 1].type
;
10279 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10283 type
= exp
->elts
[pc
+ 1].type
;
10284 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10287 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10288 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10290 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10291 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10293 return ada_value_assign (arg1
, arg1
);
10295 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10296 except if the lhs of our assignment is a convenience variable.
10297 In the case of assigning to a convenience variable, the lhs
10298 should be exactly the result of the evaluation of the rhs. */
10299 type
= value_type (arg1
);
10300 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10302 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10303 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10305 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10310 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10311 return ada_value_assign (arg1
, arg2
);
10314 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10315 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10316 if (noside
== EVAL_SKIP
)
10318 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10319 return (value_from_longest
10320 (value_type (arg1
),
10321 value_as_long (arg1
) + value_as_long (arg2
)));
10322 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10323 return (value_from_longest
10324 (value_type (arg2
),
10325 value_as_long (arg1
) + value_as_long (arg2
)));
10326 /* Preserve the original type for use by the range case below.
10327 We cannot cast the result to a reference type, so if ARG1 is
10328 a reference type, find its underlying type. */
10329 type
= value_type (arg1
);
10330 while (type
->code () == TYPE_CODE_REF
)
10331 type
= TYPE_TARGET_TYPE (type
);
10332 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10333 arg1
= value_binop (arg1
, arg2
, BINOP_ADD
);
10334 /* We need to special-case the result of adding to a range.
10335 This is done for the benefit of "ptype". gdb's Ada support
10336 historically used the LHS to set the result type here, so
10337 preserve this behavior. */
10338 if (type
->code () == TYPE_CODE_RANGE
)
10339 arg1
= value_cast (type
, arg1
);
10343 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10344 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10345 if (noside
== EVAL_SKIP
)
10347 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10348 return (value_from_longest
10349 (value_type (arg1
),
10350 value_as_long (arg1
) - value_as_long (arg2
)));
10351 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10352 return (value_from_longest
10353 (value_type (arg2
),
10354 value_as_long (arg1
) - value_as_long (arg2
)));
10355 /* Preserve the original type for use by the range case below.
10356 We cannot cast the result to a reference type, so if ARG1 is
10357 a reference type, find its underlying type. */
10358 type
= value_type (arg1
);
10359 while (type
->code () == TYPE_CODE_REF
)
10360 type
= TYPE_TARGET_TYPE (type
);
10361 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10362 arg1
= value_binop (arg1
, arg2
, BINOP_SUB
);
10363 /* We need to special-case the result of adding to a range.
10364 This is done for the benefit of "ptype". gdb's Ada support
10365 historically used the LHS to set the result type here, so
10366 preserve this behavior. */
10367 if (type
->code () == TYPE_CODE_RANGE
)
10368 arg1
= value_cast (type
, arg1
);
10375 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10376 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10377 if (noside
== EVAL_SKIP
)
10379 return ada_mult_binop (expect_type
, exp
, noside
, op
,
10383 case BINOP_NOTEQUAL
:
10384 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10385 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10386 if (noside
== EVAL_SKIP
)
10388 return ada_equal_binop (expect_type
, exp
, noside
, op
, arg1
, arg2
);
10391 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10392 return ada_unop_neg (expect_type
, exp
, noside
, op
, arg1
);
10394 case BINOP_LOGICAL_AND
:
10395 case BINOP_LOGICAL_OR
:
10396 case UNOP_LOGICAL_NOT
:
10401 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10402 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10403 return value_cast (type
, val
);
10406 case BINOP_BITWISE_AND
:
10407 case BINOP_BITWISE_IOR
:
10408 case BINOP_BITWISE_XOR
:
10412 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10414 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10416 return value_cast (value_type (arg1
), val
);
10422 if (noside
== EVAL_SKIP
)
10428 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10429 /* Only encountered when an unresolved symbol occurs in a
10430 context other than a function call, in which case, it is
10432 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10433 exp
->elts
[pc
+ 2].symbol
->print_name ());
10435 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10437 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10438 /* Check to see if this is a tagged type. We also need to handle
10439 the case where the type is a reference to a tagged type, but
10440 we have to be careful to exclude pointers to tagged types.
10441 The latter should be shown as usual (as a pointer), whereas
10442 a reference should mostly be transparent to the user. */
10443 if (ada_is_tagged_type (type
, 0)
10444 || (type
->code () == TYPE_CODE_REF
10445 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10447 /* Tagged types are a little special in the fact that the real
10448 type is dynamic and can only be determined by inspecting the
10449 object's tag. This means that we need to get the object's
10450 value first (EVAL_NORMAL) and then extract the actual object
10453 Note that we cannot skip the final step where we extract
10454 the object type from its tag, because the EVAL_NORMAL phase
10455 results in dynamic components being resolved into fixed ones.
10456 This can cause problems when trying to print the type
10457 description of tagged types whose parent has a dynamic size:
10458 We use the type name of the "_parent" component in order
10459 to print the name of the ancestor type in the type description.
10460 If that component had a dynamic size, the resolution into
10461 a fixed type would result in the loss of that type name,
10462 thus preventing us from printing the name of the ancestor
10463 type in the type description. */
10464 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10466 if (type
->code () != TYPE_CODE_REF
)
10468 struct type
*actual_type
;
10470 actual_type
= type_from_tag (ada_value_tag (arg1
));
10471 if (actual_type
== NULL
)
10472 /* If, for some reason, we were unable to determine
10473 the actual type from the tag, then use the static
10474 approximation that we just computed as a fallback.
10475 This can happen if the debugging information is
10476 incomplete, for instance. */
10477 actual_type
= type
;
10478 return value_zero (actual_type
, not_lval
);
10482 /* In the case of a ref, ada_coerce_ref takes care
10483 of determining the actual type. But the evaluation
10484 should return a ref as it should be valid to ask
10485 for its address; so rebuild a ref after coerce. */
10486 arg1
= ada_coerce_ref (arg1
);
10487 return value_ref (arg1
, TYPE_CODE_REF
);
10491 /* Records and unions for which GNAT encodings have been
10492 generated need to be statically fixed as well.
10493 Otherwise, non-static fixing produces a type where
10494 all dynamic properties are removed, which prevents "ptype"
10495 from being able to completely describe the type.
10496 For instance, a case statement in a variant record would be
10497 replaced by the relevant components based on the actual
10498 value of the discriminants. */
10499 if ((type
->code () == TYPE_CODE_STRUCT
10500 && dynamic_template_type (type
) != NULL
)
10501 || (type
->code () == TYPE_CODE_UNION
10502 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10505 return value_zero (to_static_fixed_type (type
), not_lval
);
10509 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10510 return ada_to_fixed_value (arg1
);
10515 /* Allocate arg vector, including space for the function to be
10516 called in argvec[0] and a terminating NULL. */
10517 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10518 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10520 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10521 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10522 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10523 exp
->elts
[pc
+ 5].symbol
->print_name ());
10526 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10527 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10530 if (noside
== EVAL_SKIP
)
10534 if (ada_is_constrained_packed_array_type
10535 (desc_base_type (value_type (argvec
[0]))))
10536 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10537 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10538 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10539 /* This is a packed array that has already been fixed, and
10540 therefore already coerced to a simple array. Nothing further
10543 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10545 /* Make sure we dereference references so that all the code below
10546 feels like it's really handling the referenced value. Wrapping
10547 types (for alignment) may be there, so make sure we strip them as
10549 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10551 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10552 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10553 argvec
[0] = value_addr (argvec
[0]);
10555 type
= ada_check_typedef (value_type (argvec
[0]));
10557 /* Ada allows us to implicitly dereference arrays when subscripting
10558 them. So, if this is an array typedef (encoding use for array
10559 access types encoded as fat pointers), strip it now. */
10560 if (type
->code () == TYPE_CODE_TYPEDEF
)
10561 type
= ada_typedef_target_type (type
);
10563 if (type
->code () == TYPE_CODE_PTR
)
10565 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10567 case TYPE_CODE_FUNC
:
10568 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10570 case TYPE_CODE_ARRAY
:
10572 case TYPE_CODE_STRUCT
:
10573 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10574 argvec
[0] = ada_value_ind (argvec
[0]);
10575 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10578 error (_("cannot subscript or call something of type `%s'"),
10579 ada_type_name (value_type (argvec
[0])));
10584 switch (type
->code ())
10586 case TYPE_CODE_FUNC
:
10587 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10589 if (TYPE_TARGET_TYPE (type
) == NULL
)
10590 error_call_unknown_return_type (NULL
);
10591 return allocate_value (TYPE_TARGET_TYPE (type
));
10593 return call_function_by_hand (argvec
[0], NULL
,
10594 gdb::make_array_view (argvec
+ 1,
10596 case TYPE_CODE_INTERNAL_FUNCTION
:
10597 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10598 /* We don't know anything about what the internal
10599 function might return, but we have to return
10601 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10604 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10605 argvec
[0], nargs
, argvec
+ 1);
10607 case TYPE_CODE_STRUCT
:
10611 arity
= ada_array_arity (type
);
10612 type
= ada_array_element_type (type
, nargs
);
10614 error (_("cannot subscript or call a record"));
10615 if (arity
!= nargs
)
10616 error (_("wrong number of subscripts; expecting %d"), arity
);
10617 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10618 return value_zero (ada_aligned_type (type
), lval_memory
);
10620 unwrap_value (ada_value_subscript
10621 (argvec
[0], nargs
, argvec
+ 1));
10623 case TYPE_CODE_ARRAY
:
10624 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10626 type
= ada_array_element_type (type
, nargs
);
10628 error (_("element type of array unknown"));
10630 return value_zero (ada_aligned_type (type
), lval_memory
);
10633 unwrap_value (ada_value_subscript
10634 (ada_coerce_to_simple_array (argvec
[0]),
10635 nargs
, argvec
+ 1));
10636 case TYPE_CODE_PTR
: /* Pointer to array */
10637 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10639 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10640 type
= ada_array_element_type (type
, nargs
);
10642 error (_("element type of array unknown"));
10644 return value_zero (ada_aligned_type (type
), lval_memory
);
10647 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10648 nargs
, argvec
+ 1));
10651 error (_("Attempt to index or call something other than an "
10652 "array or function"));
10657 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10658 struct value
*low_bound_val
10659 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10660 struct value
*high_bound_val
10661 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10663 if (noside
== EVAL_SKIP
)
10666 return ada_ternop_slice (exp
, noside
, array
, low_bound_val
,
10670 case UNOP_IN_RANGE
:
10672 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10673 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10674 return ada_unop_in_range (expect_type
, exp
, noside
, op
, arg1
, type
);
10676 case BINOP_IN_BOUNDS
:
10678 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10679 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10681 if (noside
== EVAL_SKIP
)
10684 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10686 return ada_binop_in_bounds (exp
, noside
, arg1
, arg2
, tem
);
10688 case TERNOP_IN_RANGE
:
10689 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10690 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10691 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10693 return eval_ternop_in_range (expect_type
, exp
, noside
, arg1
, arg2
, arg3
);
10697 case OP_ATR_LENGTH
:
10699 struct type
*type_arg
;
10701 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10703 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10705 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10709 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10713 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10714 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10715 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10718 if (noside
== EVAL_SKIP
)
10720 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10722 if (type_arg
== NULL
)
10723 type_arg
= value_type (arg1
);
10725 if (ada_is_constrained_packed_array_type (type_arg
))
10726 type_arg
= decode_constrained_packed_array_type (type_arg
);
10728 if (!discrete_type_p (type_arg
))
10732 default: /* Should never happen. */
10733 error (_("unexpected attribute encountered"));
10736 type_arg
= ada_index_type (type_arg
, tem
,
10737 ada_attribute_name (op
));
10739 case OP_ATR_LENGTH
:
10740 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10745 return value_zero (type_arg
, not_lval
);
10747 else if (type_arg
== NULL
)
10749 arg1
= ada_coerce_ref (arg1
);
10751 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10752 arg1
= ada_coerce_to_simple_array (arg1
);
10754 if (op
== OP_ATR_LENGTH
)
10755 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10758 type
= ada_index_type (value_type (arg1
), tem
,
10759 ada_attribute_name (op
));
10761 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10766 default: /* Should never happen. */
10767 error (_("unexpected attribute encountered"));
10769 return value_from_longest
10770 (type
, ada_array_bound (arg1
, tem
, 0));
10772 return value_from_longest
10773 (type
, ada_array_bound (arg1
, tem
, 1));
10774 case OP_ATR_LENGTH
:
10775 return value_from_longest
10776 (type
, ada_array_length (arg1
, tem
));
10779 else if (discrete_type_p (type_arg
))
10781 struct type
*range_type
;
10782 const char *name
= ada_type_name (type_arg
);
10785 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10786 range_type
= to_fixed_range_type (type_arg
, NULL
);
10787 if (range_type
== NULL
)
10788 range_type
= type_arg
;
10792 error (_("unexpected attribute encountered"));
10794 return value_from_longest
10795 (range_type
, ada_discrete_type_low_bound (range_type
));
10797 return value_from_longest
10798 (range_type
, ada_discrete_type_high_bound (range_type
));
10799 case OP_ATR_LENGTH
:
10800 error (_("the 'length attribute applies only to array types"));
10803 else if (type_arg
->code () == TYPE_CODE_FLT
)
10804 error (_("unimplemented type attribute"));
10809 if (ada_is_constrained_packed_array_type (type_arg
))
10810 type_arg
= decode_constrained_packed_array_type (type_arg
);
10812 if (op
== OP_ATR_LENGTH
)
10813 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10816 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10818 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10824 error (_("unexpected attribute encountered"));
10826 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10827 return value_from_longest (type
, low
);
10829 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10830 return value_from_longest (type
, high
);
10831 case OP_ATR_LENGTH
:
10832 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10833 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10834 return value_from_longest (type
, high
- low
+ 1);
10840 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10841 if (noside
== EVAL_SKIP
)
10843 return ada_atr_tag (expect_type
, exp
, noside
, op
, arg1
);
10847 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10848 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10849 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10850 if (noside
== EVAL_SKIP
)
10852 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10853 return value_zero (value_type (arg1
), not_lval
);
10856 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10857 return value_binop (arg1
, arg2
,
10858 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10861 case OP_ATR_MODULUS
:
10863 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10865 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10866 if (noside
== EVAL_SKIP
)
10869 if (!ada_is_modular_type (type_arg
))
10870 error (_("'modulus must be applied to modular type"));
10872 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10873 ada_modulus (type_arg
));
10878 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10879 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10880 if (noside
== EVAL_SKIP
)
10882 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10883 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10884 return value_zero (type
, not_lval
);
10886 return value_pos_atr (type
, arg1
);
10889 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10890 return ada_atr_size (expect_type
, exp
, noside
, op
, arg1
);
10893 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10894 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10895 type
= exp
->elts
[pc
+ 2].type
;
10896 if (noside
== EVAL_SKIP
)
10898 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10899 return value_zero (type
, not_lval
);
10901 return value_val_atr (type
, arg1
);
10904 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10905 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10906 if (noside
== EVAL_SKIP
)
10908 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10909 return value_zero (value_type (arg1
), not_lval
);
10912 /* For integer exponentiation operations,
10913 only promote the first argument. */
10914 if (is_integral_type (value_type (arg2
)))
10915 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10917 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10919 return value_binop (arg1
, arg2
, op
);
10923 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10924 if (noside
== EVAL_SKIP
)
10930 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10931 if (noside
== EVAL_SKIP
)
10933 return ada_abs (expect_type
, exp
, noside
, op
, arg1
);
10936 preeval_pos
= *pos
;
10937 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10938 if (noside
== EVAL_SKIP
)
10940 type
= ada_check_typedef (value_type (arg1
));
10941 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10943 if (ada_is_array_descriptor_type (type
))
10944 /* GDB allows dereferencing GNAT array descriptors. */
10946 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10948 if (arrType
== NULL
)
10949 error (_("Attempt to dereference null array pointer."));
10950 return value_at_lazy (arrType
, 0);
10952 else if (type
->code () == TYPE_CODE_PTR
10953 || type
->code () == TYPE_CODE_REF
10954 /* In C you can dereference an array to get the 1st elt. */
10955 || type
->code () == TYPE_CODE_ARRAY
)
10957 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10958 only be determined by inspecting the object's tag.
10959 This means that we need to evaluate completely the
10960 expression in order to get its type. */
10962 if ((type
->code () == TYPE_CODE_REF
10963 || type
->code () == TYPE_CODE_PTR
)
10964 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10967 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10968 type
= value_type (ada_value_ind (arg1
));
10972 type
= to_static_fixed_type
10974 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10976 ada_ensure_varsize_limit (type
);
10977 return value_zero (type
, lval_memory
);
10979 else if (type
->code () == TYPE_CODE_INT
)
10981 /* GDB allows dereferencing an int. */
10982 if (expect_type
== NULL
)
10983 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10988 to_static_fixed_type (ada_aligned_type (expect_type
));
10989 return value_zero (expect_type
, lval_memory
);
10993 error (_("Attempt to take contents of a non-pointer value."));
10995 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10996 type
= ada_check_typedef (value_type (arg1
));
10998 if (type
->code () == TYPE_CODE_INT
)
10999 /* GDB allows dereferencing an int. If we were given
11000 the expect_type, then use that as the target type.
11001 Otherwise, assume that the target type is an int. */
11003 if (expect_type
!= NULL
)
11004 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11007 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11008 (CORE_ADDR
) value_as_address (arg1
));
11011 if (ada_is_array_descriptor_type (type
))
11012 /* GDB allows dereferencing GNAT array descriptors. */
11013 return ada_coerce_to_simple_array (arg1
);
11015 return ada_value_ind (arg1
);
11017 case STRUCTOP_STRUCT
:
11018 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11019 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11020 preeval_pos
= *pos
;
11021 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11022 if (noside
== EVAL_SKIP
)
11024 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11026 struct type
*type1
= value_type (arg1
);
11028 if (ada_is_tagged_type (type1
, 1))
11030 type
= ada_lookup_struct_elt_type (type1
,
11031 &exp
->elts
[pc
+ 2].string
,
11034 /* If the field is not found, check if it exists in the
11035 extension of this object's type. This means that we
11036 need to evaluate completely the expression. */
11041 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11042 arg1
= ada_value_struct_elt (arg1
,
11043 &exp
->elts
[pc
+ 2].string
,
11045 arg1
= unwrap_value (arg1
);
11046 type
= value_type (ada_to_fixed_value (arg1
));
11051 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11054 return value_zero (ada_aligned_type (type
), lval_memory
);
11058 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11059 arg1
= unwrap_value (arg1
);
11060 return ada_to_fixed_value (arg1
);
11064 /* The value is not supposed to be used. This is here to make it
11065 easier to accommodate expressions that contain types. */
11067 if (noside
== EVAL_SKIP
)
11069 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11070 return allocate_value (exp
->elts
[pc
+ 1].type
);
11072 error (_("Attempt to use a type name as an expression"));
11077 case OP_DISCRETE_RANGE
:
11078 case OP_POSITIONAL
:
11080 if (noside
== EVAL_NORMAL
)
11084 error (_("Undefined name, ambiguous name, or renaming used in "
11085 "component association: %s."), &exp
->elts
[pc
+2].string
);
11087 error (_("Aggregates only allowed on the right of an assignment"));
11089 internal_error (__FILE__
, __LINE__
,
11090 _("aggregate apparently mangled"));
11093 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11095 for (tem
= 0; tem
< nargs
; tem
+= 1)
11096 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11101 return eval_skip_value (exp
);
11105 /* Return non-zero iff TYPE represents a System.Address type. */
11108 ada_is_system_address_type (struct type
*type
)
11110 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11117 /* Scan STR beginning at position K for a discriminant name, and
11118 return the value of that discriminant field of DVAL in *PX. If
11119 PNEW_K is not null, put the position of the character beyond the
11120 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11121 not alter *PX and *PNEW_K if unsuccessful. */
11124 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11127 static std::string storage
;
11128 const char *pstart
, *pend
, *bound
;
11129 struct value
*bound_val
;
11131 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11135 pend
= strstr (pstart
, "__");
11139 k
+= strlen (bound
);
11143 int len
= pend
- pstart
;
11145 /* Strip __ and beyond. */
11146 storage
= std::string (pstart
, len
);
11147 bound
= storage
.c_str ();
11151 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11152 if (bound_val
== NULL
)
11155 *px
= value_as_long (bound_val
);
11156 if (pnew_k
!= NULL
)
11161 /* Value of variable named NAME. Only exact matches are considered.
11162 If no such variable found, then if ERR_MSG is null, returns 0, and
11163 otherwise causes an error with message ERR_MSG. */
11165 static struct value
*
11166 get_var_value (const char *name
, const char *err_msg
)
11168 std::string quoted_name
= add_angle_brackets (name
);
11170 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11172 std::vector
<struct block_symbol
> syms
11173 = ada_lookup_symbol_list_worker (lookup_name
,
11174 get_selected_block (0),
11177 if (syms
.size () != 1)
11179 if (err_msg
== NULL
)
11182 error (("%s"), err_msg
);
11185 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11188 /* Value of integer variable named NAME in the current environment.
11189 If no such variable is found, returns false. Otherwise, sets VALUE
11190 to the variable's value and returns true. */
11193 get_int_var_value (const char *name
, LONGEST
&value
)
11195 struct value
*var_val
= get_var_value (name
, 0);
11200 value
= value_as_long (var_val
);
11205 /* Return a range type whose base type is that of the range type named
11206 NAME in the current environment, and whose bounds are calculated
11207 from NAME according to the GNAT range encoding conventions.
11208 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11209 corresponding range type from debug information; fall back to using it
11210 if symbol lookup fails. If a new type must be created, allocate it
11211 like ORIG_TYPE was. The bounds information, in general, is encoded
11212 in NAME, the base type given in the named range type. */
11214 static struct type
*
11215 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11218 struct type
*base_type
;
11219 const char *subtype_info
;
11221 gdb_assert (raw_type
!= NULL
);
11222 gdb_assert (raw_type
->name () != NULL
);
11224 if (raw_type
->code () == TYPE_CODE_RANGE
)
11225 base_type
= TYPE_TARGET_TYPE (raw_type
);
11227 base_type
= raw_type
;
11229 name
= raw_type
->name ();
11230 subtype_info
= strstr (name
, "___XD");
11231 if (subtype_info
== NULL
)
11233 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11234 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11236 if (L
< INT_MIN
|| U
> INT_MAX
)
11239 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11244 int prefix_len
= subtype_info
- name
;
11247 const char *bounds_str
;
11251 bounds_str
= strchr (subtype_info
, '_');
11254 if (*subtype_info
== 'L')
11256 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11257 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11259 if (bounds_str
[n
] == '_')
11261 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11267 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11268 if (!get_int_var_value (name_buf
.c_str (), L
))
11270 lim_warning (_("Unknown lower bound, using 1."));
11275 if (*subtype_info
== 'U')
11277 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11278 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11283 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11284 if (!get_int_var_value (name_buf
.c_str (), U
))
11286 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11291 type
= create_static_range_type (alloc_type_copy (raw_type
),
11293 /* create_static_range_type alters the resulting type's length
11294 to match the size of the base_type, which is not what we want.
11295 Set it back to the original range type's length. */
11296 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11297 type
->set_name (name
);
11302 /* True iff NAME is the name of a range type. */
11305 ada_is_range_type_name (const char *name
)
11307 return (name
!= NULL
&& strstr (name
, "___XD"));
11311 /* Modular types */
11313 /* True iff TYPE is an Ada modular type. */
11316 ada_is_modular_type (struct type
*type
)
11318 struct type
*subranged_type
= get_base_type (type
);
11320 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11321 && subranged_type
->code () == TYPE_CODE_INT
11322 && subranged_type
->is_unsigned ());
11325 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11328 ada_modulus (struct type
*type
)
11330 const dynamic_prop
&high
= type
->bounds ()->high
;
11332 if (high
.kind () == PROP_CONST
)
11333 return (ULONGEST
) high
.const_val () + 1;
11335 /* If TYPE is unresolved, the high bound might be a location list. Return
11336 0, for lack of a better value to return. */
11341 /* Ada exception catchpoint support:
11342 ---------------------------------
11344 We support 3 kinds of exception catchpoints:
11345 . catchpoints on Ada exceptions
11346 . catchpoints on unhandled Ada exceptions
11347 . catchpoints on failed assertions
11349 Exceptions raised during failed assertions, or unhandled exceptions
11350 could perfectly be caught with the general catchpoint on Ada exceptions.
11351 However, we can easily differentiate these two special cases, and having
11352 the option to distinguish these two cases from the rest can be useful
11353 to zero-in on certain situations.
11355 Exception catchpoints are a specialized form of breakpoint,
11356 since they rely on inserting breakpoints inside known routines
11357 of the GNAT runtime. The implementation therefore uses a standard
11358 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11361 Support in the runtime for exception catchpoints have been changed
11362 a few times already, and these changes affect the implementation
11363 of these catchpoints. In order to be able to support several
11364 variants of the runtime, we use a sniffer that will determine
11365 the runtime variant used by the program being debugged. */
11367 /* Ada's standard exceptions.
11369 The Ada 83 standard also defined Numeric_Error. But there so many
11370 situations where it was unclear from the Ada 83 Reference Manual
11371 (RM) whether Constraint_Error or Numeric_Error should be raised,
11372 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11373 Interpretation saying that anytime the RM says that Numeric_Error
11374 should be raised, the implementation may raise Constraint_Error.
11375 Ada 95 went one step further and pretty much removed Numeric_Error
11376 from the list of standard exceptions (it made it a renaming of
11377 Constraint_Error, to help preserve compatibility when compiling
11378 an Ada83 compiler). As such, we do not include Numeric_Error from
11379 this list of standard exceptions. */
11381 static const char * const standard_exc
[] = {
11382 "constraint_error",
11388 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11390 /* A structure that describes how to support exception catchpoints
11391 for a given executable. */
11393 struct exception_support_info
11395 /* The name of the symbol to break on in order to insert
11396 a catchpoint on exceptions. */
11397 const char *catch_exception_sym
;
11399 /* The name of the symbol to break on in order to insert
11400 a catchpoint on unhandled exceptions. */
11401 const char *catch_exception_unhandled_sym
;
11403 /* The name of the symbol to break on in order to insert
11404 a catchpoint on failed assertions. */
11405 const char *catch_assert_sym
;
11407 /* The name of the symbol to break on in order to insert
11408 a catchpoint on exception handling. */
11409 const char *catch_handlers_sym
;
11411 /* Assuming that the inferior just triggered an unhandled exception
11412 catchpoint, this function is responsible for returning the address
11413 in inferior memory where the name of that exception is stored.
11414 Return zero if the address could not be computed. */
11415 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11418 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11419 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11421 /* The following exception support info structure describes how to
11422 implement exception catchpoints with the latest version of the
11423 Ada runtime (as of 2019-08-??). */
11425 static const struct exception_support_info default_exception_support_info
=
11427 "__gnat_debug_raise_exception", /* catch_exception_sym */
11428 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11429 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11430 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11431 ada_unhandled_exception_name_addr
11434 /* The following exception support info structure describes how to
11435 implement exception catchpoints with an earlier version of the
11436 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11438 static const struct exception_support_info exception_support_info_v0
=
11440 "__gnat_debug_raise_exception", /* catch_exception_sym */
11441 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11442 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11443 "__gnat_begin_handler", /* catch_handlers_sym */
11444 ada_unhandled_exception_name_addr
11447 /* The following exception support info structure describes how to
11448 implement exception catchpoints with a slightly older version
11449 of the Ada runtime. */
11451 static const struct exception_support_info exception_support_info_fallback
=
11453 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11454 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11455 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11456 "__gnat_begin_handler", /* catch_handlers_sym */
11457 ada_unhandled_exception_name_addr_from_raise
11460 /* Return nonzero if we can detect the exception support routines
11461 described in EINFO.
11463 This function errors out if an abnormal situation is detected
11464 (for instance, if we find the exception support routines, but
11465 that support is found to be incomplete). */
11468 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11470 struct symbol
*sym
;
11472 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11473 that should be compiled with debugging information. As a result, we
11474 expect to find that symbol in the symtabs. */
11476 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11479 /* Perhaps we did not find our symbol because the Ada runtime was
11480 compiled without debugging info, or simply stripped of it.
11481 It happens on some GNU/Linux distributions for instance, where
11482 users have to install a separate debug package in order to get
11483 the runtime's debugging info. In that situation, let the user
11484 know why we cannot insert an Ada exception catchpoint.
11486 Note: Just for the purpose of inserting our Ada exception
11487 catchpoint, we could rely purely on the associated minimal symbol.
11488 But we would be operating in degraded mode anyway, since we are
11489 still lacking the debugging info needed later on to extract
11490 the name of the exception being raised (this name is printed in
11491 the catchpoint message, and is also used when trying to catch
11492 a specific exception). We do not handle this case for now. */
11493 struct bound_minimal_symbol msym
11494 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11496 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11497 error (_("Your Ada runtime appears to be missing some debugging "
11498 "information.\nCannot insert Ada exception catchpoint "
11499 "in this configuration."));
11504 /* Make sure that the symbol we found corresponds to a function. */
11506 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11508 error (_("Symbol \"%s\" is not a function (class = %d)"),
11509 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11513 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11516 struct bound_minimal_symbol msym
11517 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11519 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11520 error (_("Your Ada runtime appears to be missing some debugging "
11521 "information.\nCannot insert Ada exception catchpoint "
11522 "in this configuration."));
11527 /* Make sure that the symbol we found corresponds to a function. */
11529 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11531 error (_("Symbol \"%s\" is not a function (class = %d)"),
11532 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11539 /* Inspect the Ada runtime and determine which exception info structure
11540 should be used to provide support for exception catchpoints.
11542 This function will always set the per-inferior exception_info,
11543 or raise an error. */
11546 ada_exception_support_info_sniffer (void)
11548 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11550 /* If the exception info is already known, then no need to recompute it. */
11551 if (data
->exception_info
!= NULL
)
11554 /* Check the latest (default) exception support info. */
11555 if (ada_has_this_exception_support (&default_exception_support_info
))
11557 data
->exception_info
= &default_exception_support_info
;
11561 /* Try the v0 exception suport info. */
11562 if (ada_has_this_exception_support (&exception_support_info_v0
))
11564 data
->exception_info
= &exception_support_info_v0
;
11568 /* Try our fallback exception suport info. */
11569 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11571 data
->exception_info
= &exception_support_info_fallback
;
11575 /* Sometimes, it is normal for us to not be able to find the routine
11576 we are looking for. This happens when the program is linked with
11577 the shared version of the GNAT runtime, and the program has not been
11578 started yet. Inform the user of these two possible causes if
11581 if (ada_update_initial_language (language_unknown
) != language_ada
)
11582 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11584 /* If the symbol does not exist, then check that the program is
11585 already started, to make sure that shared libraries have been
11586 loaded. If it is not started, this may mean that the symbol is
11587 in a shared library. */
11589 if (inferior_ptid
.pid () == 0)
11590 error (_("Unable to insert catchpoint. Try to start the program first."));
11592 /* At this point, we know that we are debugging an Ada program and
11593 that the inferior has been started, but we still are not able to
11594 find the run-time symbols. That can mean that we are in
11595 configurable run time mode, or that a-except as been optimized
11596 out by the linker... In any case, at this point it is not worth
11597 supporting this feature. */
11599 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11602 /* True iff FRAME is very likely to be that of a function that is
11603 part of the runtime system. This is all very heuristic, but is
11604 intended to be used as advice as to what frames are uninteresting
11608 is_known_support_routine (struct frame_info
*frame
)
11610 enum language func_lang
;
11612 const char *fullname
;
11614 /* If this code does not have any debugging information (no symtab),
11615 This cannot be any user code. */
11617 symtab_and_line sal
= find_frame_sal (frame
);
11618 if (sal
.symtab
== NULL
)
11621 /* If there is a symtab, but the associated source file cannot be
11622 located, then assume this is not user code: Selecting a frame
11623 for which we cannot display the code would not be very helpful
11624 for the user. This should also take care of case such as VxWorks
11625 where the kernel has some debugging info provided for a few units. */
11627 fullname
= symtab_to_fullname (sal
.symtab
);
11628 if (access (fullname
, R_OK
) != 0)
11631 /* Check the unit filename against the Ada runtime file naming.
11632 We also check the name of the objfile against the name of some
11633 known system libraries that sometimes come with debugging info
11636 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11638 re_comp (known_runtime_file_name_patterns
[i
]);
11639 if (re_exec (lbasename (sal
.symtab
->filename
)))
11641 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11642 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11646 /* Check whether the function is a GNAT-generated entity. */
11648 gdb::unique_xmalloc_ptr
<char> func_name
11649 = find_frame_funname (frame
, &func_lang
, NULL
);
11650 if (func_name
== NULL
)
11653 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11655 re_comp (known_auxiliary_function_name_patterns
[i
]);
11656 if (re_exec (func_name
.get ()))
11663 /* Find the first frame that contains debugging information and that is not
11664 part of the Ada run-time, starting from FI and moving upward. */
11667 ada_find_printable_frame (struct frame_info
*fi
)
11669 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11671 if (!is_known_support_routine (fi
))
11680 /* Assuming that the inferior just triggered an unhandled exception
11681 catchpoint, return the address in inferior memory where the name
11682 of the exception is stored.
11684 Return zero if the address could not be computed. */
11687 ada_unhandled_exception_name_addr (void)
11689 return parse_and_eval_address ("e.full_name");
11692 /* Same as ada_unhandled_exception_name_addr, except that this function
11693 should be used when the inferior uses an older version of the runtime,
11694 where the exception name needs to be extracted from a specific frame
11695 several frames up in the callstack. */
11698 ada_unhandled_exception_name_addr_from_raise (void)
11701 struct frame_info
*fi
;
11702 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11704 /* To determine the name of this exception, we need to select
11705 the frame corresponding to RAISE_SYM_NAME. This frame is
11706 at least 3 levels up, so we simply skip the first 3 frames
11707 without checking the name of their associated function. */
11708 fi
= get_current_frame ();
11709 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11711 fi
= get_prev_frame (fi
);
11715 enum language func_lang
;
11717 gdb::unique_xmalloc_ptr
<char> func_name
11718 = find_frame_funname (fi
, &func_lang
, NULL
);
11719 if (func_name
!= NULL
)
11721 if (strcmp (func_name
.get (),
11722 data
->exception_info
->catch_exception_sym
) == 0)
11723 break; /* We found the frame we were looking for... */
11725 fi
= get_prev_frame (fi
);
11732 return parse_and_eval_address ("id.full_name");
11735 /* Assuming the inferior just triggered an Ada exception catchpoint
11736 (of any type), return the address in inferior memory where the name
11737 of the exception is stored, if applicable.
11739 Assumes the selected frame is the current frame.
11741 Return zero if the address could not be computed, or if not relevant. */
11744 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11745 struct breakpoint
*b
)
11747 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11751 case ada_catch_exception
:
11752 return (parse_and_eval_address ("e.full_name"));
11755 case ada_catch_exception_unhandled
:
11756 return data
->exception_info
->unhandled_exception_name_addr ();
11759 case ada_catch_handlers
:
11760 return 0; /* The runtimes does not provide access to the exception
11764 case ada_catch_assert
:
11765 return 0; /* Exception name is not relevant in this case. */
11769 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11773 return 0; /* Should never be reached. */
11776 /* Assuming the inferior is stopped at an exception catchpoint,
11777 return the message which was associated to the exception, if
11778 available. Return NULL if the message could not be retrieved.
11780 Note: The exception message can be associated to an exception
11781 either through the use of the Raise_Exception function, or
11782 more simply (Ada 2005 and later), via:
11784 raise Exception_Name with "exception message";
11788 static gdb::unique_xmalloc_ptr
<char>
11789 ada_exception_message_1 (void)
11791 struct value
*e_msg_val
;
11794 /* For runtimes that support this feature, the exception message
11795 is passed as an unbounded string argument called "message". */
11796 e_msg_val
= parse_and_eval ("message");
11797 if (e_msg_val
== NULL
)
11798 return NULL
; /* Exception message not supported. */
11800 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11801 gdb_assert (e_msg_val
!= NULL
);
11802 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11804 /* If the message string is empty, then treat it as if there was
11805 no exception message. */
11806 if (e_msg_len
<= 0)
11809 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11810 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11812 e_msg
.get ()[e_msg_len
] = '\0';
11817 /* Same as ada_exception_message_1, except that all exceptions are
11818 contained here (returning NULL instead). */
11820 static gdb::unique_xmalloc_ptr
<char>
11821 ada_exception_message (void)
11823 gdb::unique_xmalloc_ptr
<char> e_msg
;
11827 e_msg
= ada_exception_message_1 ();
11829 catch (const gdb_exception_error
&e
)
11831 e_msg
.reset (nullptr);
11837 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11838 any error that ada_exception_name_addr_1 might cause to be thrown.
11839 When an error is intercepted, a warning with the error message is printed,
11840 and zero is returned. */
11843 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11844 struct breakpoint
*b
)
11846 CORE_ADDR result
= 0;
11850 result
= ada_exception_name_addr_1 (ex
, b
);
11853 catch (const gdb_exception_error
&e
)
11855 warning (_("failed to get exception name: %s"), e
.what ());
11862 static std::string ada_exception_catchpoint_cond_string
11863 (const char *excep_string
,
11864 enum ada_exception_catchpoint_kind ex
);
11866 /* Ada catchpoints.
11868 In the case of catchpoints on Ada exceptions, the catchpoint will
11869 stop the target on every exception the program throws. When a user
11870 specifies the name of a specific exception, we translate this
11871 request into a condition expression (in text form), and then parse
11872 it into an expression stored in each of the catchpoint's locations.
11873 We then use this condition to check whether the exception that was
11874 raised is the one the user is interested in. If not, then the
11875 target is resumed again. We store the name of the requested
11876 exception, in order to be able to re-set the condition expression
11877 when symbols change. */
11879 /* An instance of this type is used to represent an Ada catchpoint
11880 breakpoint location. */
11882 class ada_catchpoint_location
: public bp_location
11885 ada_catchpoint_location (breakpoint
*owner
)
11886 : bp_location (owner
, bp_loc_software_breakpoint
)
11889 /* The condition that checks whether the exception that was raised
11890 is the specific exception the user specified on catchpoint
11892 expression_up excep_cond_expr
;
11895 /* An instance of this type is used to represent an Ada catchpoint. */
11897 struct ada_catchpoint
: public breakpoint
11899 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
11904 /* The name of the specific exception the user specified. */
11905 std::string excep_string
;
11907 /* What kind of catchpoint this is. */
11908 enum ada_exception_catchpoint_kind m_kind
;
11911 /* Parse the exception condition string in the context of each of the
11912 catchpoint's locations, and store them for later evaluation. */
11915 create_excep_cond_exprs (struct ada_catchpoint
*c
,
11916 enum ada_exception_catchpoint_kind ex
)
11918 struct bp_location
*bl
;
11920 /* Nothing to do if there's no specific exception to catch. */
11921 if (c
->excep_string
.empty ())
11924 /* Same if there are no locations... */
11925 if (c
->loc
== NULL
)
11928 /* Compute the condition expression in text form, from the specific
11929 expection we want to catch. */
11930 std::string cond_string
11931 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
11933 /* Iterate over all the catchpoint's locations, and parse an
11934 expression for each. */
11935 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
11937 struct ada_catchpoint_location
*ada_loc
11938 = (struct ada_catchpoint_location
*) bl
;
11941 if (!bl
->shlib_disabled
)
11945 s
= cond_string
.c_str ();
11948 exp
= parse_exp_1 (&s
, bl
->address
,
11949 block_for_pc (bl
->address
),
11952 catch (const gdb_exception_error
&e
)
11954 warning (_("failed to reevaluate internal exception condition "
11955 "for catchpoint %d: %s"),
11956 c
->number
, e
.what ());
11960 ada_loc
->excep_cond_expr
= std::move (exp
);
11964 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11965 structure for all exception catchpoint kinds. */
11967 static struct bp_location
*
11968 allocate_location_exception (struct breakpoint
*self
)
11970 return new ada_catchpoint_location (self
);
11973 /* Implement the RE_SET method in the breakpoint_ops structure for all
11974 exception catchpoint kinds. */
11977 re_set_exception (struct breakpoint
*b
)
11979 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11981 /* Call the base class's method. This updates the catchpoint's
11983 bkpt_breakpoint_ops
.re_set (b
);
11985 /* Reparse the exception conditional expressions. One for each
11987 create_excep_cond_exprs (c
, c
->m_kind
);
11990 /* Returns true if we should stop for this breakpoint hit. If the
11991 user specified a specific exception, we only want to cause a stop
11992 if the program thrown that exception. */
11995 should_stop_exception (const struct bp_location
*bl
)
11997 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
11998 const struct ada_catchpoint_location
*ada_loc
11999 = (const struct ada_catchpoint_location
*) bl
;
12002 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12003 if (c
->m_kind
== ada_catch_assert
)
12004 clear_internalvar (var
);
12011 if (c
->m_kind
== ada_catch_handlers
)
12012 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12013 ".all.occurrence.id");
12017 struct value
*exc
= parse_and_eval (expr
);
12018 set_internalvar (var
, exc
);
12020 catch (const gdb_exception_error
&ex
)
12022 clear_internalvar (var
);
12026 /* With no specific exception, should always stop. */
12027 if (c
->excep_string
.empty ())
12030 if (ada_loc
->excep_cond_expr
== NULL
)
12032 /* We will have a NULL expression if back when we were creating
12033 the expressions, this location's had failed to parse. */
12040 struct value
*mark
;
12042 mark
= value_mark ();
12043 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12044 value_free_to_mark (mark
);
12046 catch (const gdb_exception
&ex
)
12048 exception_fprintf (gdb_stderr
, ex
,
12049 _("Error in testing exception condition:\n"));
12055 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12056 for all exception catchpoint kinds. */
12059 check_status_exception (bpstat bs
)
12061 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12064 /* Implement the PRINT_IT method in the breakpoint_ops structure
12065 for all exception catchpoint kinds. */
12067 static enum print_stop_action
12068 print_it_exception (bpstat bs
)
12070 struct ui_out
*uiout
= current_uiout
;
12071 struct breakpoint
*b
= bs
->breakpoint_at
;
12073 annotate_catchpoint (b
->number
);
12075 if (uiout
->is_mi_like_p ())
12077 uiout
->field_string ("reason",
12078 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12079 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12082 uiout
->text (b
->disposition
== disp_del
12083 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12084 uiout
->field_signed ("bkptno", b
->number
);
12085 uiout
->text (", ");
12087 /* ada_exception_name_addr relies on the selected frame being the
12088 current frame. Need to do this here because this function may be
12089 called more than once when printing a stop, and below, we'll
12090 select the first frame past the Ada run-time (see
12091 ada_find_printable_frame). */
12092 select_frame (get_current_frame ());
12094 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12097 case ada_catch_exception
:
12098 case ada_catch_exception_unhandled
:
12099 case ada_catch_handlers
:
12101 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12102 char exception_name
[256];
12106 read_memory (addr
, (gdb_byte
*) exception_name
,
12107 sizeof (exception_name
) - 1);
12108 exception_name
[sizeof (exception_name
) - 1] = '\0';
12112 /* For some reason, we were unable to read the exception
12113 name. This could happen if the Runtime was compiled
12114 without debugging info, for instance. In that case,
12115 just replace the exception name by the generic string
12116 "exception" - it will read as "an exception" in the
12117 notification we are about to print. */
12118 memcpy (exception_name
, "exception", sizeof ("exception"));
12120 /* In the case of unhandled exception breakpoints, we print
12121 the exception name as "unhandled EXCEPTION_NAME", to make
12122 it clearer to the user which kind of catchpoint just got
12123 hit. We used ui_out_text to make sure that this extra
12124 info does not pollute the exception name in the MI case. */
12125 if (c
->m_kind
== ada_catch_exception_unhandled
)
12126 uiout
->text ("unhandled ");
12127 uiout
->field_string ("exception-name", exception_name
);
12130 case ada_catch_assert
:
12131 /* In this case, the name of the exception is not really
12132 important. Just print "failed assertion" to make it clearer
12133 that his program just hit an assertion-failure catchpoint.
12134 We used ui_out_text because this info does not belong in
12136 uiout
->text ("failed assertion");
12140 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12141 if (exception_message
!= NULL
)
12143 uiout
->text (" (");
12144 uiout
->field_string ("exception-message", exception_message
.get ());
12148 uiout
->text (" at ");
12149 ada_find_printable_frame (get_current_frame ());
12151 return PRINT_SRC_AND_LOC
;
12154 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12155 for all exception catchpoint kinds. */
12158 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12160 struct ui_out
*uiout
= current_uiout
;
12161 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12162 struct value_print_options opts
;
12164 get_user_print_options (&opts
);
12166 if (opts
.addressprint
)
12167 uiout
->field_skip ("addr");
12169 annotate_field (5);
12172 case ada_catch_exception
:
12173 if (!c
->excep_string
.empty ())
12175 std::string msg
= string_printf (_("`%s' Ada exception"),
12176 c
->excep_string
.c_str ());
12178 uiout
->field_string ("what", msg
);
12181 uiout
->field_string ("what", "all Ada exceptions");
12185 case ada_catch_exception_unhandled
:
12186 uiout
->field_string ("what", "unhandled Ada exceptions");
12189 case ada_catch_handlers
:
12190 if (!c
->excep_string
.empty ())
12192 uiout
->field_fmt ("what",
12193 _("`%s' Ada exception handlers"),
12194 c
->excep_string
.c_str ());
12197 uiout
->field_string ("what", "all Ada exceptions handlers");
12200 case ada_catch_assert
:
12201 uiout
->field_string ("what", "failed Ada assertions");
12205 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12210 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12211 for all exception catchpoint kinds. */
12214 print_mention_exception (struct breakpoint
*b
)
12216 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12217 struct ui_out
*uiout
= current_uiout
;
12219 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12220 : _("Catchpoint "));
12221 uiout
->field_signed ("bkptno", b
->number
);
12222 uiout
->text (": ");
12226 case ada_catch_exception
:
12227 if (!c
->excep_string
.empty ())
12229 std::string info
= string_printf (_("`%s' Ada exception"),
12230 c
->excep_string
.c_str ());
12231 uiout
->text (info
.c_str ());
12234 uiout
->text (_("all Ada exceptions"));
12237 case ada_catch_exception_unhandled
:
12238 uiout
->text (_("unhandled Ada exceptions"));
12241 case ada_catch_handlers
:
12242 if (!c
->excep_string
.empty ())
12245 = string_printf (_("`%s' Ada exception handlers"),
12246 c
->excep_string
.c_str ());
12247 uiout
->text (info
.c_str ());
12250 uiout
->text (_("all Ada exceptions handlers"));
12253 case ada_catch_assert
:
12254 uiout
->text (_("failed Ada assertions"));
12258 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12263 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12264 for all exception catchpoint kinds. */
12267 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12269 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12273 case ada_catch_exception
:
12274 fprintf_filtered (fp
, "catch exception");
12275 if (!c
->excep_string
.empty ())
12276 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12279 case ada_catch_exception_unhandled
:
12280 fprintf_filtered (fp
, "catch exception unhandled");
12283 case ada_catch_handlers
:
12284 fprintf_filtered (fp
, "catch handlers");
12287 case ada_catch_assert
:
12288 fprintf_filtered (fp
, "catch assert");
12292 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12294 print_recreate_thread (b
, fp
);
12297 /* Virtual tables for various breakpoint types. */
12298 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12299 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12300 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12301 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12303 /* See ada-lang.h. */
12306 is_ada_exception_catchpoint (breakpoint
*bp
)
12308 return (bp
->ops
== &catch_exception_breakpoint_ops
12309 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12310 || bp
->ops
== &catch_assert_breakpoint_ops
12311 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12314 /* Split the arguments specified in a "catch exception" command.
12315 Set EX to the appropriate catchpoint type.
12316 Set EXCEP_STRING to the name of the specific exception if
12317 specified by the user.
12318 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12319 "catch handlers" command. False otherwise.
12320 If a condition is found at the end of the arguments, the condition
12321 expression is stored in COND_STRING (memory must be deallocated
12322 after use). Otherwise COND_STRING is set to NULL. */
12325 catch_ada_exception_command_split (const char *args
,
12326 bool is_catch_handlers_cmd
,
12327 enum ada_exception_catchpoint_kind
*ex
,
12328 std::string
*excep_string
,
12329 std::string
*cond_string
)
12331 std::string exception_name
;
12333 exception_name
= extract_arg (&args
);
12334 if (exception_name
== "if")
12336 /* This is not an exception name; this is the start of a condition
12337 expression for a catchpoint on all exceptions. So, "un-get"
12338 this token, and set exception_name to NULL. */
12339 exception_name
.clear ();
12343 /* Check to see if we have a condition. */
12345 args
= skip_spaces (args
);
12346 if (startswith (args
, "if")
12347 && (isspace (args
[2]) || args
[2] == '\0'))
12350 args
= skip_spaces (args
);
12352 if (args
[0] == '\0')
12353 error (_("Condition missing after `if' keyword"));
12354 *cond_string
= args
;
12356 args
+= strlen (args
);
12359 /* Check that we do not have any more arguments. Anything else
12362 if (args
[0] != '\0')
12363 error (_("Junk at end of expression"));
12365 if (is_catch_handlers_cmd
)
12367 /* Catch handling of exceptions. */
12368 *ex
= ada_catch_handlers
;
12369 *excep_string
= exception_name
;
12371 else if (exception_name
.empty ())
12373 /* Catch all exceptions. */
12374 *ex
= ada_catch_exception
;
12375 excep_string
->clear ();
12377 else if (exception_name
== "unhandled")
12379 /* Catch unhandled exceptions. */
12380 *ex
= ada_catch_exception_unhandled
;
12381 excep_string
->clear ();
12385 /* Catch a specific exception. */
12386 *ex
= ada_catch_exception
;
12387 *excep_string
= exception_name
;
12391 /* Return the name of the symbol on which we should break in order to
12392 implement a catchpoint of the EX kind. */
12394 static const char *
12395 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12397 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12399 gdb_assert (data
->exception_info
!= NULL
);
12403 case ada_catch_exception
:
12404 return (data
->exception_info
->catch_exception_sym
);
12406 case ada_catch_exception_unhandled
:
12407 return (data
->exception_info
->catch_exception_unhandled_sym
);
12409 case ada_catch_assert
:
12410 return (data
->exception_info
->catch_assert_sym
);
12412 case ada_catch_handlers
:
12413 return (data
->exception_info
->catch_handlers_sym
);
12416 internal_error (__FILE__
, __LINE__
,
12417 _("unexpected catchpoint kind (%d)"), ex
);
12421 /* Return the breakpoint ops "virtual table" used for catchpoints
12424 static const struct breakpoint_ops
*
12425 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12429 case ada_catch_exception
:
12430 return (&catch_exception_breakpoint_ops
);
12432 case ada_catch_exception_unhandled
:
12433 return (&catch_exception_unhandled_breakpoint_ops
);
12435 case ada_catch_assert
:
12436 return (&catch_assert_breakpoint_ops
);
12438 case ada_catch_handlers
:
12439 return (&catch_handlers_breakpoint_ops
);
12442 internal_error (__FILE__
, __LINE__
,
12443 _("unexpected catchpoint kind (%d)"), ex
);
12447 /* Return the condition that will be used to match the current exception
12448 being raised with the exception that the user wants to catch. This
12449 assumes that this condition is used when the inferior just triggered
12450 an exception catchpoint.
12451 EX: the type of catchpoints used for catching Ada exceptions. */
12454 ada_exception_catchpoint_cond_string (const char *excep_string
,
12455 enum ada_exception_catchpoint_kind ex
)
12458 bool is_standard_exc
= false;
12459 std::string result
;
12461 if (ex
== ada_catch_handlers
)
12463 /* For exception handlers catchpoints, the condition string does
12464 not use the same parameter as for the other exceptions. */
12465 result
= ("long_integer (GNAT_GCC_exception_Access"
12466 "(gcc_exception).all.occurrence.id)");
12469 result
= "long_integer (e)";
12471 /* The standard exceptions are a special case. They are defined in
12472 runtime units that have been compiled without debugging info; if
12473 EXCEP_STRING is the not-fully-qualified name of a standard
12474 exception (e.g. "constraint_error") then, during the evaluation
12475 of the condition expression, the symbol lookup on this name would
12476 *not* return this standard exception. The catchpoint condition
12477 may then be set only on user-defined exceptions which have the
12478 same not-fully-qualified name (e.g. my_package.constraint_error).
12480 To avoid this unexcepted behavior, these standard exceptions are
12481 systematically prefixed by "standard". This means that "catch
12482 exception constraint_error" is rewritten into "catch exception
12483 standard.constraint_error".
12485 If an exception named constraint_error is defined in another package of
12486 the inferior program, then the only way to specify this exception as a
12487 breakpoint condition is to use its fully-qualified named:
12488 e.g. my_package.constraint_error. */
12490 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12492 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12494 is_standard_exc
= true;
12501 if (is_standard_exc
)
12502 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12504 string_appendf (result
, "long_integer (&%s)", excep_string
);
12509 /* Return the symtab_and_line that should be used to insert an exception
12510 catchpoint of the TYPE kind.
12512 ADDR_STRING returns the name of the function where the real
12513 breakpoint that implements the catchpoints is set, depending on the
12514 type of catchpoint we need to create. */
12516 static struct symtab_and_line
12517 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12518 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12520 const char *sym_name
;
12521 struct symbol
*sym
;
12523 /* First, find out which exception support info to use. */
12524 ada_exception_support_info_sniffer ();
12526 /* Then lookup the function on which we will break in order to catch
12527 the Ada exceptions requested by the user. */
12528 sym_name
= ada_exception_sym_name (ex
);
12529 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12532 error (_("Catchpoint symbol not found: %s"), sym_name
);
12534 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12535 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12537 /* Set ADDR_STRING. */
12538 *addr_string
= sym_name
;
12541 *ops
= ada_exception_breakpoint_ops (ex
);
12543 return find_function_start_sal (sym
, 1);
12546 /* Create an Ada exception catchpoint.
12548 EX_KIND is the kind of exception catchpoint to be created.
12550 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12551 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12552 of the exception to which this catchpoint applies.
12554 COND_STRING, if not empty, is the catchpoint condition.
12556 TEMPFLAG, if nonzero, means that the underlying breakpoint
12557 should be temporary.
12559 FROM_TTY is the usual argument passed to all commands implementations. */
12562 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12563 enum ada_exception_catchpoint_kind ex_kind
,
12564 const std::string
&excep_string
,
12565 const std::string
&cond_string
,
12570 std::string addr_string
;
12571 const struct breakpoint_ops
*ops
= NULL
;
12572 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12574 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12575 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12576 ops
, tempflag
, disabled
, from_tty
);
12577 c
->excep_string
= excep_string
;
12578 create_excep_cond_exprs (c
.get (), ex_kind
);
12579 if (!cond_string
.empty ())
12580 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12581 install_breakpoint (0, std::move (c
), 1);
12584 /* Implement the "catch exception" command. */
12587 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12588 struct cmd_list_element
*command
)
12590 const char *arg
= arg_entry
;
12591 struct gdbarch
*gdbarch
= get_current_arch ();
12593 enum ada_exception_catchpoint_kind ex_kind
;
12594 std::string excep_string
;
12595 std::string cond_string
;
12597 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12601 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12603 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12604 excep_string
, cond_string
,
12605 tempflag
, 1 /* enabled */,
12609 /* Implement the "catch handlers" command. */
12612 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12613 struct cmd_list_element
*command
)
12615 const char *arg
= arg_entry
;
12616 struct gdbarch
*gdbarch
= get_current_arch ();
12618 enum ada_exception_catchpoint_kind ex_kind
;
12619 std::string excep_string
;
12620 std::string cond_string
;
12622 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12626 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12628 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12629 excep_string
, cond_string
,
12630 tempflag
, 1 /* enabled */,
12634 /* Completion function for the Ada "catch" commands. */
12637 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12638 const char *text
, const char *word
)
12640 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12642 for (const ada_exc_info
&info
: exceptions
)
12644 if (startswith (info
.name
, word
))
12645 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12649 /* Split the arguments specified in a "catch assert" command.
12651 ARGS contains the command's arguments (or the empty string if
12652 no arguments were passed).
12654 If ARGS contains a condition, set COND_STRING to that condition
12655 (the memory needs to be deallocated after use). */
12658 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12660 args
= skip_spaces (args
);
12662 /* Check whether a condition was provided. */
12663 if (startswith (args
, "if")
12664 && (isspace (args
[2]) || args
[2] == '\0'))
12667 args
= skip_spaces (args
);
12668 if (args
[0] == '\0')
12669 error (_("condition missing after `if' keyword"));
12670 cond_string
.assign (args
);
12673 /* Otherwise, there should be no other argument at the end of
12675 else if (args
[0] != '\0')
12676 error (_("Junk at end of arguments."));
12679 /* Implement the "catch assert" command. */
12682 catch_assert_command (const char *arg_entry
, int from_tty
,
12683 struct cmd_list_element
*command
)
12685 const char *arg
= arg_entry
;
12686 struct gdbarch
*gdbarch
= get_current_arch ();
12688 std::string cond_string
;
12690 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12694 catch_ada_assert_command_split (arg
, cond_string
);
12695 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12697 tempflag
, 1 /* enabled */,
12701 /* Return non-zero if the symbol SYM is an Ada exception object. */
12704 ada_is_exception_sym (struct symbol
*sym
)
12706 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12708 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12709 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12710 && SYMBOL_CLASS (sym
) != LOC_CONST
12711 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12712 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12715 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12716 Ada exception object. This matches all exceptions except the ones
12717 defined by the Ada language. */
12720 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12724 if (!ada_is_exception_sym (sym
))
12727 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12728 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12729 return 0; /* A standard exception. */
12731 /* Numeric_Error is also a standard exception, so exclude it.
12732 See the STANDARD_EXC description for more details as to why
12733 this exception is not listed in that array. */
12734 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12740 /* A helper function for std::sort, comparing two struct ada_exc_info
12743 The comparison is determined first by exception name, and then
12744 by exception address. */
12747 ada_exc_info::operator< (const ada_exc_info
&other
) const
12751 result
= strcmp (name
, other
.name
);
12754 if (result
== 0 && addr
< other
.addr
)
12760 ada_exc_info::operator== (const ada_exc_info
&other
) const
12762 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12765 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12766 routine, but keeping the first SKIP elements untouched.
12768 All duplicates are also removed. */
12771 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12774 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12775 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12776 exceptions
->end ());
12779 /* Add all exceptions defined by the Ada standard whose name match
12780 a regular expression.
12782 If PREG is not NULL, then this regexp_t object is used to
12783 perform the symbol name matching. Otherwise, no name-based
12784 filtering is performed.
12786 EXCEPTIONS is a vector of exceptions to which matching exceptions
12790 ada_add_standard_exceptions (compiled_regex
*preg
,
12791 std::vector
<ada_exc_info
> *exceptions
)
12795 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12798 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12800 struct bound_minimal_symbol msymbol
12801 = ada_lookup_simple_minsym (standard_exc
[i
]);
12803 if (msymbol
.minsym
!= NULL
)
12805 struct ada_exc_info info
12806 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12808 exceptions
->push_back (info
);
12814 /* Add all Ada exceptions defined locally and accessible from the given
12817 If PREG is not NULL, then this regexp_t object is used to
12818 perform the symbol name matching. Otherwise, no name-based
12819 filtering is performed.
12821 EXCEPTIONS is a vector of exceptions to which matching exceptions
12825 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12826 struct frame_info
*frame
,
12827 std::vector
<ada_exc_info
> *exceptions
)
12829 const struct block
*block
= get_frame_block (frame
, 0);
12833 struct block_iterator iter
;
12834 struct symbol
*sym
;
12836 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12838 switch (SYMBOL_CLASS (sym
))
12845 if (ada_is_exception_sym (sym
))
12847 struct ada_exc_info info
= {sym
->print_name (),
12848 SYMBOL_VALUE_ADDRESS (sym
)};
12850 exceptions
->push_back (info
);
12854 if (BLOCK_FUNCTION (block
) != NULL
)
12856 block
= BLOCK_SUPERBLOCK (block
);
12860 /* Return true if NAME matches PREG or if PREG is NULL. */
12863 name_matches_regex (const char *name
, compiled_regex
*preg
)
12865 return (preg
== NULL
12866 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
12869 /* Add all exceptions defined globally whose name name match
12870 a regular expression, excluding standard exceptions.
12872 The reason we exclude standard exceptions is that they need
12873 to be handled separately: Standard exceptions are defined inside
12874 a runtime unit which is normally not compiled with debugging info,
12875 and thus usually do not show up in our symbol search. However,
12876 if the unit was in fact built with debugging info, we need to
12877 exclude them because they would duplicate the entry we found
12878 during the special loop that specifically searches for those
12879 standard exceptions.
12881 If PREG is not NULL, then this regexp_t object is used to
12882 perform the symbol name matching. Otherwise, no name-based
12883 filtering is performed.
12885 EXCEPTIONS is a vector of exceptions to which matching exceptions
12889 ada_add_global_exceptions (compiled_regex
*preg
,
12890 std::vector
<ada_exc_info
> *exceptions
)
12892 /* In Ada, the symbol "search name" is a linkage name, whereas the
12893 regular expression used to do the matching refers to the natural
12894 name. So match against the decoded name. */
12895 expand_symtabs_matching (NULL
,
12896 lookup_name_info::match_any (),
12897 [&] (const char *search_name
)
12899 std::string decoded
= ada_decode (search_name
);
12900 return name_matches_regex (decoded
.c_str (), preg
);
12905 for (objfile
*objfile
: current_program_space
->objfiles ())
12907 for (compunit_symtab
*s
: objfile
->compunits ())
12909 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
12912 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12914 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12915 struct block_iterator iter
;
12916 struct symbol
*sym
;
12918 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12919 if (ada_is_non_standard_exception_sym (sym
)
12920 && name_matches_regex (sym
->natural_name (), preg
))
12922 struct ada_exc_info info
12923 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
12925 exceptions
->push_back (info
);
12932 /* Implements ada_exceptions_list with the regular expression passed
12933 as a regex_t, rather than a string.
12935 If not NULL, PREG is used to filter out exceptions whose names
12936 do not match. Otherwise, all exceptions are listed. */
12938 static std::vector
<ada_exc_info
>
12939 ada_exceptions_list_1 (compiled_regex
*preg
)
12941 std::vector
<ada_exc_info
> result
;
12944 /* First, list the known standard exceptions. These exceptions
12945 need to be handled separately, as they are usually defined in
12946 runtime units that have been compiled without debugging info. */
12948 ada_add_standard_exceptions (preg
, &result
);
12950 /* Next, find all exceptions whose scope is local and accessible
12951 from the currently selected frame. */
12953 if (has_stack_frames ())
12955 prev_len
= result
.size ();
12956 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12958 if (result
.size () > prev_len
)
12959 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12962 /* Add all exceptions whose scope is global. */
12964 prev_len
= result
.size ();
12965 ada_add_global_exceptions (preg
, &result
);
12966 if (result
.size () > prev_len
)
12967 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12972 /* Return a vector of ada_exc_info.
12974 If REGEXP is NULL, all exceptions are included in the result.
12975 Otherwise, it should contain a valid regular expression,
12976 and only the exceptions whose names match that regular expression
12977 are included in the result.
12979 The exceptions are sorted in the following order:
12980 - Standard exceptions (defined by the Ada language), in
12981 alphabetical order;
12982 - Exceptions only visible from the current frame, in
12983 alphabetical order;
12984 - Exceptions whose scope is global, in alphabetical order. */
12986 std::vector
<ada_exc_info
>
12987 ada_exceptions_list (const char *regexp
)
12989 if (regexp
== NULL
)
12990 return ada_exceptions_list_1 (NULL
);
12992 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
12993 return ada_exceptions_list_1 (®
);
12996 /* Implement the "info exceptions" command. */
12999 info_exceptions_command (const char *regexp
, int from_tty
)
13001 struct gdbarch
*gdbarch
= get_current_arch ();
13003 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13005 if (regexp
!= NULL
)
13007 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13009 printf_filtered (_("All defined Ada exceptions:\n"));
13011 for (const ada_exc_info
&info
: exceptions
)
13012 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13016 /* Information about operators given special treatment in functions
13018 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13020 #define ADA_OPERATORS \
13021 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13022 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13023 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13024 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13025 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13026 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13027 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13028 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13029 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13030 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13031 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13032 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13033 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13034 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13035 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13036 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13037 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13038 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13039 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13042 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13045 switch (exp
->elts
[pc
- 1].opcode
)
13048 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13051 #define OP_DEFN(op, len, args, binop) \
13052 case op: *oplenp = len; *argsp = args; break;
13058 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13063 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13068 /* Implementation of the exp_descriptor method operator_check. */
13071 ada_operator_check (struct expression
*exp
, int pos
,
13072 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13075 const union exp_element
*const elts
= exp
->elts
;
13076 struct type
*type
= NULL
;
13078 switch (elts
[pos
].opcode
)
13080 case UNOP_IN_RANGE
:
13082 type
= elts
[pos
+ 1].type
;
13086 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13089 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13091 if (type
!= nullptr && type
->objfile_owner () != nullptr
13092 && objfile_func (type
->objfile_owner (), data
))
13098 /* As for operator_length, but assumes PC is pointing at the first
13099 element of the operator, and gives meaningful results only for the
13100 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13103 ada_forward_operator_length (struct expression
*exp
, int pc
,
13104 int *oplenp
, int *argsp
)
13106 switch (exp
->elts
[pc
].opcode
)
13109 *oplenp
= *argsp
= 0;
13112 #define OP_DEFN(op, len, args, binop) \
13113 case op: *oplenp = len; *argsp = args; break;
13119 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13124 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13130 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13132 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13140 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13142 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13147 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13151 /* Ada attributes ('Foo). */
13154 case OP_ATR_LENGTH
:
13158 case OP_ATR_MODULUS
:
13165 case UNOP_IN_RANGE
:
13167 /* XXX: gdb_sprint_host_address, type_sprint */
13168 fprintf_filtered (stream
, _("Type @"));
13169 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13170 fprintf_filtered (stream
, " (");
13171 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13172 fprintf_filtered (stream
, ")");
13174 case BINOP_IN_BOUNDS
:
13175 fprintf_filtered (stream
, " (%d)",
13176 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13178 case TERNOP_IN_RANGE
:
13183 case OP_DISCRETE_RANGE
:
13184 case OP_POSITIONAL
:
13191 char *name
= &exp
->elts
[elt
+ 2].string
;
13192 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13194 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13199 return dump_subexp_body_standard (exp
, stream
, elt
);
13203 for (i
= 0; i
< nargs
; i
+= 1)
13204 elt
= dump_subexp (exp
, stream
, elt
);
13209 /* The Ada extension of print_subexp (q.v.). */
13212 ada_print_subexp (struct expression
*exp
, int *pos
,
13213 struct ui_file
*stream
, enum precedence prec
)
13215 int oplen
, nargs
, i
;
13217 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13219 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13226 print_subexp_standard (exp
, pos
, stream
, prec
);
13230 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13233 case BINOP_IN_BOUNDS
:
13234 /* XXX: sprint_subexp */
13235 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13236 fputs_filtered (" in ", stream
);
13237 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13238 fputs_filtered ("'range", stream
);
13239 if (exp
->elts
[pc
+ 1].longconst
> 1)
13240 fprintf_filtered (stream
, "(%ld)",
13241 (long) exp
->elts
[pc
+ 1].longconst
);
13244 case TERNOP_IN_RANGE
:
13245 if (prec
>= PREC_EQUAL
)
13246 fputs_filtered ("(", stream
);
13247 /* XXX: sprint_subexp */
13248 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13249 fputs_filtered (" in ", stream
);
13250 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13251 fputs_filtered (" .. ", stream
);
13252 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13253 if (prec
>= PREC_EQUAL
)
13254 fputs_filtered (")", stream
);
13259 case OP_ATR_LENGTH
:
13263 case OP_ATR_MODULUS
:
13268 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13270 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13271 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13272 &type_print_raw_options
);
13276 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13277 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13282 for (tem
= 1; tem
< nargs
; tem
+= 1)
13284 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13285 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13287 fputs_filtered (")", stream
);
13292 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13293 fputs_filtered ("'(", stream
);
13294 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13295 fputs_filtered (")", stream
);
13298 case UNOP_IN_RANGE
:
13299 /* XXX: sprint_subexp */
13300 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13301 fputs_filtered (" in ", stream
);
13302 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13303 &type_print_raw_options
);
13306 case OP_DISCRETE_RANGE
:
13307 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13308 fputs_filtered ("..", stream
);
13309 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13313 fputs_filtered ("others => ", stream
);
13314 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13318 for (i
= 0; i
< nargs
-1; i
+= 1)
13321 fputs_filtered ("|", stream
);
13322 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13324 fputs_filtered (" => ", stream
);
13325 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13328 case OP_POSITIONAL
:
13329 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13333 fputs_filtered ("(", stream
);
13334 for (i
= 0; i
< nargs
; i
+= 1)
13337 fputs_filtered (", ", stream
);
13338 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13340 fputs_filtered (")", stream
);
13345 /* Table mapping opcodes into strings for printing operators
13346 and precedences of the operators. */
13348 static const struct op_print ada_op_print_tab
[] = {
13349 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13350 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13351 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13352 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13353 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13354 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13355 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13356 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13357 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13358 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13359 {">", BINOP_GTR
, PREC_ORDER
, 0},
13360 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13361 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13362 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13363 {"+", BINOP_ADD
, PREC_ADD
, 0},
13364 {"-", BINOP_SUB
, PREC_ADD
, 0},
13365 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13366 {"*", BINOP_MUL
, PREC_MUL
, 0},
13367 {"/", BINOP_DIV
, PREC_MUL
, 0},
13368 {"rem", BINOP_REM
, PREC_MUL
, 0},
13369 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13370 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13371 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13372 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13373 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13374 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13375 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13376 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13377 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13378 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13379 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13380 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13383 /* Language vector */
13385 static const struct exp_descriptor ada_exp_descriptor
= {
13387 ada_operator_length
,
13388 ada_operator_check
,
13389 ada_dump_subexp_body
,
13390 ada_evaluate_subexp
13393 /* symbol_name_matcher_ftype adapter for wild_match. */
13396 do_wild_match (const char *symbol_search_name
,
13397 const lookup_name_info
&lookup_name
,
13398 completion_match_result
*comp_match_res
)
13400 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13403 /* symbol_name_matcher_ftype adapter for full_match. */
13406 do_full_match (const char *symbol_search_name
,
13407 const lookup_name_info
&lookup_name
,
13408 completion_match_result
*comp_match_res
)
13410 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13412 /* If both symbols start with "_ada_", just let the loop below
13413 handle the comparison. However, if only the symbol name starts
13414 with "_ada_", skip the prefix and let the match proceed as
13416 if (startswith (symbol_search_name
, "_ada_")
13417 && !startswith (lname
, "_ada"))
13418 symbol_search_name
+= 5;
13420 int uscore_count
= 0;
13421 while (*lname
!= '\0')
13423 if (*symbol_search_name
!= *lname
)
13425 if (*symbol_search_name
== 'B' && uscore_count
== 2
13426 && symbol_search_name
[1] == '_')
13428 symbol_search_name
+= 2;
13429 while (isdigit (*symbol_search_name
))
13430 ++symbol_search_name
;
13431 if (symbol_search_name
[0] == '_'
13432 && symbol_search_name
[1] == '_')
13434 symbol_search_name
+= 2;
13441 if (*symbol_search_name
== '_')
13446 ++symbol_search_name
;
13450 return is_name_suffix (symbol_search_name
);
13453 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13456 do_exact_match (const char *symbol_search_name
,
13457 const lookup_name_info
&lookup_name
,
13458 completion_match_result
*comp_match_res
)
13460 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13463 /* Build the Ada lookup name for LOOKUP_NAME. */
13465 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13467 gdb::string_view user_name
= lookup_name
.name ();
13469 if (!user_name
.empty () && user_name
[0] == '<')
13471 if (user_name
.back () == '>')
13473 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13476 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13477 m_encoded_p
= true;
13478 m_verbatim_p
= true;
13479 m_wild_match_p
= false;
13480 m_standard_p
= false;
13484 m_verbatim_p
= false;
13486 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13490 const char *folded
= ada_fold_name (user_name
);
13491 m_encoded_name
= ada_encode_1 (folded
, false);
13492 if (m_encoded_name
.empty ())
13493 m_encoded_name
= gdb::to_string (user_name
);
13496 m_encoded_name
= gdb::to_string (user_name
);
13498 /* Handle the 'package Standard' special case. See description
13499 of m_standard_p. */
13500 if (startswith (m_encoded_name
.c_str (), "standard__"))
13502 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13503 m_standard_p
= true;
13506 m_standard_p
= false;
13508 /* If the name contains a ".", then the user is entering a fully
13509 qualified entity name, and the match must not be done in wild
13510 mode. Similarly, if the user wants to complete what looks
13511 like an encoded name, the match must not be done in wild
13512 mode. Also, in the standard__ special case always do
13513 non-wild matching. */
13515 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13518 && user_name
.find ('.') == std::string::npos
);
13522 /* symbol_name_matcher_ftype method for Ada. This only handles
13523 completion mode. */
13526 ada_symbol_name_matches (const char *symbol_search_name
,
13527 const lookup_name_info
&lookup_name
,
13528 completion_match_result
*comp_match_res
)
13530 return lookup_name
.ada ().matches (symbol_search_name
,
13531 lookup_name
.match_type (),
13535 /* A name matcher that matches the symbol name exactly, with
13539 literal_symbol_name_matcher (const char *symbol_search_name
,
13540 const lookup_name_info
&lookup_name
,
13541 completion_match_result
*comp_match_res
)
13543 gdb::string_view name_view
= lookup_name
.name ();
13545 if (lookup_name
.completion_mode ()
13546 ? (strncmp (symbol_search_name
, name_view
.data (),
13547 name_view
.size ()) == 0)
13548 : symbol_search_name
== name_view
)
13550 if (comp_match_res
!= NULL
)
13551 comp_match_res
->set_match (symbol_search_name
);
13558 /* Implement the "get_symbol_name_matcher" language_defn method for
13561 static symbol_name_matcher_ftype
*
13562 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13564 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13565 return literal_symbol_name_matcher
;
13567 if (lookup_name
.completion_mode ())
13568 return ada_symbol_name_matches
;
13571 if (lookup_name
.ada ().wild_match_p ())
13572 return do_wild_match
;
13573 else if (lookup_name
.ada ().verbatim_p ())
13574 return do_exact_match
;
13576 return do_full_match
;
13580 /* Class representing the Ada language. */
13582 class ada_language
: public language_defn
13586 : language_defn (language_ada
)
13589 /* See language.h. */
13591 const char *name () const override
13594 /* See language.h. */
13596 const char *natural_name () const override
13599 /* See language.h. */
13601 const std::vector
<const char *> &filename_extensions () const override
13603 static const std::vector
<const char *> extensions
13604 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13608 /* Print an array element index using the Ada syntax. */
13610 void print_array_index (struct type
*index_type
,
13612 struct ui_file
*stream
,
13613 const value_print_options
*options
) const override
13615 struct value
*index_value
= val_atr (index_type
, index
);
13617 value_print (index_value
, stream
, options
);
13618 fprintf_filtered (stream
, " => ");
13621 /* Implement the "read_var_value" language_defn method for Ada. */
13623 struct value
*read_var_value (struct symbol
*var
,
13624 const struct block
*var_block
,
13625 struct frame_info
*frame
) const override
13627 /* The only case where default_read_var_value is not sufficient
13628 is when VAR is a renaming... */
13629 if (frame
!= nullptr)
13631 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13632 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13633 return ada_read_renaming_var_value (var
, frame_block
);
13636 /* This is a typical case where we expect the default_read_var_value
13637 function to work. */
13638 return language_defn::read_var_value (var
, var_block
, frame
);
13641 /* See language.h. */
13642 void language_arch_info (struct gdbarch
*gdbarch
,
13643 struct language_arch_info
*lai
) const override
13645 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13647 /* Helper function to allow shorter lines below. */
13648 auto add
= [&] (struct type
*t
)
13650 lai
->add_primitive_type (t
);
13653 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13655 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13656 0, "long_integer"));
13657 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13658 0, "short_integer"));
13659 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13661 lai
->set_string_char_type (char_type
);
13663 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13664 "float", gdbarch_float_format (gdbarch
)));
13665 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13666 "long_float", gdbarch_double_format (gdbarch
)));
13667 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13668 0, "long_long_integer"));
13669 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13671 gdbarch_long_double_format (gdbarch
)));
13672 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13674 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13676 add (builtin
->builtin_void
);
13678 struct type
*system_addr_ptr
13679 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13681 system_addr_ptr
->set_name ("system__address");
13682 add (system_addr_ptr
);
13684 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13685 type. This is a signed integral type whose size is the same as
13686 the size of addresses. */
13687 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13688 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13689 "storage_offset"));
13691 lai
->set_bool_type (builtin
->builtin_bool
);
13694 /* See language.h. */
13696 bool iterate_over_symbols
13697 (const struct block
*block
, const lookup_name_info
&name
,
13698 domain_enum domain
,
13699 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13701 std::vector
<struct block_symbol
> results
13702 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13703 for (block_symbol
&sym
: results
)
13705 if (!callback (&sym
))
13712 /* See language.h. */
13713 bool sniff_from_mangled_name (const char *mangled
,
13714 char **out
) const override
13716 std::string demangled
= ada_decode (mangled
);
13720 if (demangled
!= mangled
&& demangled
[0] != '<')
13722 /* Set the gsymbol language to Ada, but still return 0.
13723 Two reasons for that:
13725 1. For Ada, we prefer computing the symbol's decoded name
13726 on the fly rather than pre-compute it, in order to save
13727 memory (Ada projects are typically very large).
13729 2. There are some areas in the definition of the GNAT
13730 encoding where, with a bit of bad luck, we might be able
13731 to decode a non-Ada symbol, generating an incorrect
13732 demangled name (Eg: names ending with "TB" for instance
13733 are identified as task bodies and so stripped from
13734 the decoded name returned).
13736 Returning true, here, but not setting *DEMANGLED, helps us get
13737 a little bit of the best of both worlds. Because we're last,
13738 we should not affect any of the other languages that were
13739 able to demangle the symbol before us; we get to correctly
13740 tag Ada symbols as such; and even if we incorrectly tagged a
13741 non-Ada symbol, which should be rare, any routing through the
13742 Ada language should be transparent (Ada tries to behave much
13743 like C/C++ with non-Ada symbols). */
13750 /* See language.h. */
13752 char *demangle_symbol (const char *mangled
, int options
) const override
13754 return ada_la_decode (mangled
, options
);
13757 /* See language.h. */
13759 void print_type (struct type
*type
, const char *varstring
,
13760 struct ui_file
*stream
, int show
, int level
,
13761 const struct type_print_options
*flags
) const override
13763 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13766 /* See language.h. */
13768 const char *word_break_characters (void) const override
13770 return ada_completer_word_break_characters
;
13773 /* See language.h. */
13775 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13776 complete_symbol_mode mode
,
13777 symbol_name_match_type name_match_type
,
13778 const char *text
, const char *word
,
13779 enum type_code code
) const override
13781 struct symbol
*sym
;
13782 const struct block
*b
, *surrounding_static_block
= 0;
13783 struct block_iterator iter
;
13785 gdb_assert (code
== TYPE_CODE_UNDEF
);
13787 lookup_name_info
lookup_name (text
, name_match_type
, true);
13789 /* First, look at the partial symtab symbols. */
13790 expand_symtabs_matching (NULL
,
13796 /* At this point scan through the misc symbol vectors and add each
13797 symbol you find to the list. Eventually we want to ignore
13798 anything that isn't a text symbol (everything else will be
13799 handled by the psymtab code above). */
13801 for (objfile
*objfile
: current_program_space
->objfiles ())
13803 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13807 if (completion_skip_symbol (mode
, msymbol
))
13810 language symbol_language
= msymbol
->language ();
13812 /* Ada minimal symbols won't have their language set to Ada. If
13813 we let completion_list_add_name compare using the
13814 default/C-like matcher, then when completing e.g., symbols in a
13815 package named "pck", we'd match internal Ada symbols like
13816 "pckS", which are invalid in an Ada expression, unless you wrap
13817 them in '<' '>' to request a verbatim match.
13819 Unfortunately, some Ada encoded names successfully demangle as
13820 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13821 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13822 with the wrong language set. Paper over that issue here. */
13823 if (symbol_language
== language_auto
13824 || symbol_language
== language_cplus
)
13825 symbol_language
= language_ada
;
13827 completion_list_add_name (tracker
,
13829 msymbol
->linkage_name (),
13830 lookup_name
, text
, word
);
13834 /* Search upwards from currently selected frame (so that we can
13835 complete on local vars. */
13837 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13839 if (!BLOCK_SUPERBLOCK (b
))
13840 surrounding_static_block
= b
; /* For elmin of dups */
13842 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13844 if (completion_skip_symbol (mode
, sym
))
13847 completion_list_add_name (tracker
,
13849 sym
->linkage_name (),
13850 lookup_name
, text
, word
);
13854 /* Go through the symtabs and check the externs and statics for
13855 symbols which match. */
13857 for (objfile
*objfile
: current_program_space
->objfiles ())
13859 for (compunit_symtab
*s
: objfile
->compunits ())
13862 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
13863 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13865 if (completion_skip_symbol (mode
, sym
))
13868 completion_list_add_name (tracker
,
13870 sym
->linkage_name (),
13871 lookup_name
, text
, word
);
13876 for (objfile
*objfile
: current_program_space
->objfiles ())
13878 for (compunit_symtab
*s
: objfile
->compunits ())
13881 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
13882 /* Don't do this block twice. */
13883 if (b
== surrounding_static_block
)
13885 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13887 if (completion_skip_symbol (mode
, sym
))
13890 completion_list_add_name (tracker
,
13892 sym
->linkage_name (),
13893 lookup_name
, text
, word
);
13899 /* See language.h. */
13901 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13902 (struct type
*type
, CORE_ADDR addr
) const override
13904 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
13905 std::string name
= type_to_string (type
);
13906 return gdb::unique_xmalloc_ptr
<char>
13907 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
13910 /* See language.h. */
13912 void value_print (struct value
*val
, struct ui_file
*stream
,
13913 const struct value_print_options
*options
) const override
13915 return ada_value_print (val
, stream
, options
);
13918 /* See language.h. */
13920 void value_print_inner
13921 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13922 const struct value_print_options
*options
) const override
13924 return ada_value_print_inner (val
, stream
, recurse
, options
);
13927 /* See language.h. */
13929 struct block_symbol lookup_symbol_nonlocal
13930 (const char *name
, const struct block
*block
,
13931 const domain_enum domain
) const override
13933 struct block_symbol sym
;
13935 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13936 if (sym
.symbol
!= NULL
)
13939 /* If we haven't found a match at this point, try the primitive
13940 types. In other languages, this search is performed before
13941 searching for global symbols in order to short-circuit that
13942 global-symbol search if it happens that the name corresponds
13943 to a primitive type. But we cannot do the same in Ada, because
13944 it is perfectly legitimate for a program to declare a type which
13945 has the same name as a standard type. If looking up a type in
13946 that situation, we have traditionally ignored the primitive type
13947 in favor of user-defined types. This is why, unlike most other
13948 languages, we search the primitive types this late and only after
13949 having searched the global symbols without success. */
13951 if (domain
== VAR_DOMAIN
)
13953 struct gdbarch
*gdbarch
;
13956 gdbarch
= target_gdbarch ();
13958 gdbarch
= block_gdbarch (block
);
13960 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
13961 if (sym
.symbol
!= NULL
)
13968 /* See language.h. */
13970 int parser (struct parser_state
*ps
) const override
13972 warnings_issued
= 0;
13973 return ada_parse (ps
);
13978 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
13979 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
13980 namespace) and converts operators that are user-defined into
13981 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
13982 a preferred result type [at the moment, only type void has any
13983 effect---causing procedures to be preferred over functions in calls].
13984 A null CONTEXT_TYPE indicates that a non-void return type is
13985 preferred. May change (expand) *EXP. */
13987 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
13990 struct type
*context_type
= NULL
;
13993 if (ps
->void_context_p
)
13994 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
13996 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
13997 ps
->block_tracker
);
14000 /* See language.h. */
14002 void emitchar (int ch
, struct type
*chtype
,
14003 struct ui_file
*stream
, int quoter
) const override
14005 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14008 /* See language.h. */
14010 void printchar (int ch
, struct type
*chtype
,
14011 struct ui_file
*stream
) const override
14013 ada_printchar (ch
, chtype
, stream
);
14016 /* See language.h. */
14018 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14019 const gdb_byte
*string
, unsigned int length
,
14020 const char *encoding
, int force_ellipses
,
14021 const struct value_print_options
*options
) const override
14023 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14024 force_ellipses
, options
);
14027 /* See language.h. */
14029 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14030 struct ui_file
*stream
) const override
14032 ada_print_typedef (type
, new_symbol
, stream
);
14035 /* See language.h. */
14037 bool is_string_type_p (struct type
*type
) const override
14039 return ada_is_string_type (type
);
14042 /* See language.h. */
14044 const char *struct_too_deep_ellipsis () const override
14045 { return "(...)"; }
14047 /* See language.h. */
14049 bool c_style_arrays_p () const override
14052 /* See language.h. */
14054 bool store_sym_names_in_linkage_form_p () const override
14057 /* See language.h. */
14059 const struct lang_varobj_ops
*varobj_ops () const override
14060 { return &ada_varobj_ops
; }
14062 /* See language.h. */
14064 const struct exp_descriptor
*expression_ops () const override
14065 { return &ada_exp_descriptor
; }
14067 /* See language.h. */
14069 const struct op_print
*opcode_print_table () const override
14070 { return ada_op_print_tab
; }
14073 /* See language.h. */
14075 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14076 (const lookup_name_info
&lookup_name
) const override
14078 return ada_get_symbol_name_matcher (lookup_name
);
14082 /* Single instance of the Ada language class. */
14084 static ada_language ada_language_defn
;
14086 /* Command-list for the "set/show ada" prefix command. */
14087 static struct cmd_list_element
*set_ada_list
;
14088 static struct cmd_list_element
*show_ada_list
;
14091 initialize_ada_catchpoint_ops (void)
14093 struct breakpoint_ops
*ops
;
14095 initialize_breakpoint_ops ();
14097 ops
= &catch_exception_breakpoint_ops
;
14098 *ops
= bkpt_breakpoint_ops
;
14099 ops
->allocate_location
= allocate_location_exception
;
14100 ops
->re_set
= re_set_exception
;
14101 ops
->check_status
= check_status_exception
;
14102 ops
->print_it
= print_it_exception
;
14103 ops
->print_one
= print_one_exception
;
14104 ops
->print_mention
= print_mention_exception
;
14105 ops
->print_recreate
= print_recreate_exception
;
14107 ops
= &catch_exception_unhandled_breakpoint_ops
;
14108 *ops
= bkpt_breakpoint_ops
;
14109 ops
->allocate_location
= allocate_location_exception
;
14110 ops
->re_set
= re_set_exception
;
14111 ops
->check_status
= check_status_exception
;
14112 ops
->print_it
= print_it_exception
;
14113 ops
->print_one
= print_one_exception
;
14114 ops
->print_mention
= print_mention_exception
;
14115 ops
->print_recreate
= print_recreate_exception
;
14117 ops
= &catch_assert_breakpoint_ops
;
14118 *ops
= bkpt_breakpoint_ops
;
14119 ops
->allocate_location
= allocate_location_exception
;
14120 ops
->re_set
= re_set_exception
;
14121 ops
->check_status
= check_status_exception
;
14122 ops
->print_it
= print_it_exception
;
14123 ops
->print_one
= print_one_exception
;
14124 ops
->print_mention
= print_mention_exception
;
14125 ops
->print_recreate
= print_recreate_exception
;
14127 ops
= &catch_handlers_breakpoint_ops
;
14128 *ops
= bkpt_breakpoint_ops
;
14129 ops
->allocate_location
= allocate_location_exception
;
14130 ops
->re_set
= re_set_exception
;
14131 ops
->check_status
= check_status_exception
;
14132 ops
->print_it
= print_it_exception
;
14133 ops
->print_one
= print_one_exception
;
14134 ops
->print_mention
= print_mention_exception
;
14135 ops
->print_recreate
= print_recreate_exception
;
14138 /* This module's 'new_objfile' observer. */
14141 ada_new_objfile_observer (struct objfile
*objfile
)
14143 ada_clear_symbol_cache ();
14146 /* This module's 'free_objfile' observer. */
14149 ada_free_objfile_observer (struct objfile
*objfile
)
14151 ada_clear_symbol_cache ();
14154 void _initialize_ada_language ();
14156 _initialize_ada_language ()
14158 initialize_ada_catchpoint_ops ();
14160 add_basic_prefix_cmd ("ada", no_class
,
14161 _("Prefix command for changing Ada-specific settings."),
14162 &set_ada_list
, "set ada ", 0, &setlist
);
14164 add_show_prefix_cmd ("ada", no_class
,
14165 _("Generic command for showing Ada-specific settings."),
14166 &show_ada_list
, "show ada ", 0, &showlist
);
14168 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14169 &trust_pad_over_xvs
, _("\
14170 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14171 Show whether an optimization trusting PAD types over XVS types is activated."),
14173 This is related to the encoding used by the GNAT compiler. The debugger\n\
14174 should normally trust the contents of PAD types, but certain older versions\n\
14175 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14176 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14177 work around this bug. It is always safe to turn this option \"off\", but\n\
14178 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14179 this option to \"off\" unless necessary."),
14180 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14182 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14183 &print_signatures
, _("\
14184 Enable or disable the output of formal and return types for functions in the \
14185 overloads selection menu."), _("\
14186 Show whether the output of formal and return types for functions in the \
14187 overloads selection menu is activated."),
14188 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14190 add_catch_command ("exception", _("\
14191 Catch Ada exceptions, when raised.\n\
14192 Usage: catch exception [ARG] [if CONDITION]\n\
14193 Without any argument, stop when any Ada exception is raised.\n\
14194 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14195 being raised does not have a handler (and will therefore lead to the task's\n\
14197 Otherwise, the catchpoint only stops when the name of the exception being\n\
14198 raised is the same as ARG.\n\
14199 CONDITION is a boolean expression that is evaluated to see whether the\n\
14200 exception should cause a stop."),
14201 catch_ada_exception_command
,
14202 catch_ada_completer
,
14206 add_catch_command ("handlers", _("\
14207 Catch Ada exceptions, when handled.\n\
14208 Usage: catch handlers [ARG] [if CONDITION]\n\
14209 Without any argument, stop when any Ada exception is handled.\n\
14210 With an argument, catch only exceptions with the given name.\n\
14211 CONDITION is a boolean expression that is evaluated to see whether the\n\
14212 exception should cause a stop."),
14213 catch_ada_handlers_command
,
14214 catch_ada_completer
,
14217 add_catch_command ("assert", _("\
14218 Catch failed Ada assertions, when raised.\n\
14219 Usage: catch assert [if CONDITION]\n\
14220 CONDITION is a boolean expression that is evaluated to see whether the\n\
14221 exception should cause a stop."),
14222 catch_assert_command
,
14227 varsize_limit
= 65536;
14228 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14229 &varsize_limit
, _("\
14230 Set the maximum number of bytes allowed in a variable-size object."), _("\
14231 Show the maximum number of bytes allowed in a variable-size object."), _("\
14232 Attempts to access an object whose size is not a compile-time constant\n\
14233 and exceeds this limit will cause an error."),
14234 NULL
, NULL
, &setlist
, &showlist
);
14236 add_info ("exceptions", info_exceptions_command
,
14238 List all Ada exception names.\n\
14239 Usage: info exceptions [REGEXP]\n\
14240 If a regular expression is passed as an argument, only those matching\n\
14241 the regular expression are listed."));
14243 add_basic_prefix_cmd ("ada", class_maintenance
,
14244 _("Set Ada maintenance-related variables."),
14245 &maint_set_ada_cmdlist
, "maintenance set ada ",
14246 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14248 add_show_prefix_cmd ("ada", class_maintenance
,
14249 _("Show Ada maintenance-related variables."),
14250 &maint_show_ada_cmdlist
, "maintenance show ada ",
14251 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14253 add_setshow_boolean_cmd
14254 ("ignore-descriptive-types", class_maintenance
,
14255 &ada_ignore_descriptive_types_p
,
14256 _("Set whether descriptive types generated by GNAT should be ignored."),
14257 _("Show whether descriptive types generated by GNAT should be ignored."),
14259 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14260 DWARF attribute."),
14261 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14263 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14264 NULL
, xcalloc
, xfree
);
14266 /* The ada-lang observers. */
14267 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14268 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14269 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);