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 /* Implement the evaluate_exp routine in the exp_descriptor structure
10111 for the Ada language. */
10113 static struct value
*
10114 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10115 int *pos
, enum noside noside
)
10117 enum exp_opcode op
;
10121 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10124 struct value
**argvec
;
10128 op
= exp
->elts
[pc
].opcode
;
10134 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10136 if (noside
== EVAL_NORMAL
)
10137 arg1
= unwrap_value (arg1
);
10139 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10140 then we need to perform the conversion manually, because
10141 evaluate_subexp_standard doesn't do it. This conversion is
10142 necessary in Ada because the different kinds of float/fixed
10143 types in Ada have different representations.
10145 Similarly, we need to perform the conversion from OP_LONG
10147 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10148 arg1
= ada_value_cast (expect_type
, arg1
);
10154 struct value
*result
;
10157 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10158 /* The result type will have code OP_STRING, bashed there from
10159 OP_ARRAY. Bash it back. */
10160 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10161 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10167 type
= exp
->elts
[pc
+ 1].type
;
10168 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10172 type
= exp
->elts
[pc
+ 1].type
;
10173 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10176 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10177 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10179 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10180 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10182 return ada_value_assign (arg1
, arg1
);
10184 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10185 except if the lhs of our assignment is a convenience variable.
10186 In the case of assigning to a convenience variable, the lhs
10187 should be exactly the result of the evaluation of the rhs. */
10188 type
= value_type (arg1
);
10189 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10191 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10192 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10194 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10199 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10200 return ada_value_assign (arg1
, arg2
);
10203 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10204 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10205 if (noside
== EVAL_SKIP
)
10207 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10208 return (value_from_longest
10209 (value_type (arg1
),
10210 value_as_long (arg1
) + value_as_long (arg2
)));
10211 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10212 return (value_from_longest
10213 (value_type (arg2
),
10214 value_as_long (arg1
) + value_as_long (arg2
)));
10215 /* Preserve the original type for use by the range case below.
10216 We cannot cast the result to a reference type, so if ARG1 is
10217 a reference type, find its underlying type. */
10218 type
= value_type (arg1
);
10219 while (type
->code () == TYPE_CODE_REF
)
10220 type
= TYPE_TARGET_TYPE (type
);
10221 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10222 arg1
= value_binop (arg1
, arg2
, BINOP_ADD
);
10223 /* We need to special-case the result of adding to a range.
10224 This is done for the benefit of "ptype". gdb's Ada support
10225 historically used the LHS to set the result type here, so
10226 preserve this behavior. */
10227 if (type
->code () == TYPE_CODE_RANGE
)
10228 arg1
= value_cast (type
, arg1
);
10232 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10233 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10234 if (noside
== EVAL_SKIP
)
10236 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10237 return (value_from_longest
10238 (value_type (arg1
),
10239 value_as_long (arg1
) - value_as_long (arg2
)));
10240 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10241 return (value_from_longest
10242 (value_type (arg2
),
10243 value_as_long (arg1
) - value_as_long (arg2
)));
10244 /* Preserve the original type for use by the range case below.
10245 We cannot cast the result to a reference type, so if ARG1 is
10246 a reference type, find its underlying type. */
10247 type
= value_type (arg1
);
10248 while (type
->code () == TYPE_CODE_REF
)
10249 type
= TYPE_TARGET_TYPE (type
);
10250 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10251 arg1
= value_binop (arg1
, arg2
, BINOP_SUB
);
10252 /* We need to special-case the result of adding to a range.
10253 This is done for the benefit of "ptype". gdb's Ada support
10254 historically used the LHS to set the result type here, so
10255 preserve this behavior. */
10256 if (type
->code () == TYPE_CODE_RANGE
)
10257 arg1
= value_cast (type
, arg1
);
10264 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10265 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10266 if (noside
== EVAL_SKIP
)
10268 return ada_mult_binop (expect_type
, exp
, noside
, op
,
10272 case BINOP_NOTEQUAL
:
10273 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10274 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10275 if (noside
== EVAL_SKIP
)
10277 return ada_equal_binop (expect_type
, exp
, noside
, op
, arg1
, arg2
);
10280 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10281 return ada_unop_neg (expect_type
, exp
, noside
, op
, arg1
);
10283 case BINOP_LOGICAL_AND
:
10284 case BINOP_LOGICAL_OR
:
10285 case UNOP_LOGICAL_NOT
:
10290 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10291 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10292 return value_cast (type
, val
);
10295 case BINOP_BITWISE_AND
:
10296 case BINOP_BITWISE_IOR
:
10297 case BINOP_BITWISE_XOR
:
10301 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10303 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10305 return value_cast (value_type (arg1
), val
);
10311 if (noside
== EVAL_SKIP
)
10317 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10318 /* Only encountered when an unresolved symbol occurs in a
10319 context other than a function call, in which case, it is
10321 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10322 exp
->elts
[pc
+ 2].symbol
->print_name ());
10324 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10326 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10327 /* Check to see if this is a tagged type. We also need to handle
10328 the case where the type is a reference to a tagged type, but
10329 we have to be careful to exclude pointers to tagged types.
10330 The latter should be shown as usual (as a pointer), whereas
10331 a reference should mostly be transparent to the user. */
10332 if (ada_is_tagged_type (type
, 0)
10333 || (type
->code () == TYPE_CODE_REF
10334 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10336 /* Tagged types are a little special in the fact that the real
10337 type is dynamic and can only be determined by inspecting the
10338 object's tag. This means that we need to get the object's
10339 value first (EVAL_NORMAL) and then extract the actual object
10342 Note that we cannot skip the final step where we extract
10343 the object type from its tag, because the EVAL_NORMAL phase
10344 results in dynamic components being resolved into fixed ones.
10345 This can cause problems when trying to print the type
10346 description of tagged types whose parent has a dynamic size:
10347 We use the type name of the "_parent" component in order
10348 to print the name of the ancestor type in the type description.
10349 If that component had a dynamic size, the resolution into
10350 a fixed type would result in the loss of that type name,
10351 thus preventing us from printing the name of the ancestor
10352 type in the type description. */
10353 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10355 if (type
->code () != TYPE_CODE_REF
)
10357 struct type
*actual_type
;
10359 actual_type
= type_from_tag (ada_value_tag (arg1
));
10360 if (actual_type
== NULL
)
10361 /* If, for some reason, we were unable to determine
10362 the actual type from the tag, then use the static
10363 approximation that we just computed as a fallback.
10364 This can happen if the debugging information is
10365 incomplete, for instance. */
10366 actual_type
= type
;
10367 return value_zero (actual_type
, not_lval
);
10371 /* In the case of a ref, ada_coerce_ref takes care
10372 of determining the actual type. But the evaluation
10373 should return a ref as it should be valid to ask
10374 for its address; so rebuild a ref after coerce. */
10375 arg1
= ada_coerce_ref (arg1
);
10376 return value_ref (arg1
, TYPE_CODE_REF
);
10380 /* Records and unions for which GNAT encodings have been
10381 generated need to be statically fixed as well.
10382 Otherwise, non-static fixing produces a type where
10383 all dynamic properties are removed, which prevents "ptype"
10384 from being able to completely describe the type.
10385 For instance, a case statement in a variant record would be
10386 replaced by the relevant components based on the actual
10387 value of the discriminants. */
10388 if ((type
->code () == TYPE_CODE_STRUCT
10389 && dynamic_template_type (type
) != NULL
)
10390 || (type
->code () == TYPE_CODE_UNION
10391 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10394 return value_zero (to_static_fixed_type (type
), not_lval
);
10398 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10399 return ada_to_fixed_value (arg1
);
10404 /* Allocate arg vector, including space for the function to be
10405 called in argvec[0] and a terminating NULL. */
10406 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10407 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10409 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10410 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10411 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10412 exp
->elts
[pc
+ 5].symbol
->print_name ());
10415 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10416 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10419 if (noside
== EVAL_SKIP
)
10423 if (ada_is_constrained_packed_array_type
10424 (desc_base_type (value_type (argvec
[0]))))
10425 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10426 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10427 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10428 /* This is a packed array that has already been fixed, and
10429 therefore already coerced to a simple array. Nothing further
10432 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10434 /* Make sure we dereference references so that all the code below
10435 feels like it's really handling the referenced value. Wrapping
10436 types (for alignment) may be there, so make sure we strip them as
10438 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10440 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10441 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10442 argvec
[0] = value_addr (argvec
[0]);
10444 type
= ada_check_typedef (value_type (argvec
[0]));
10446 /* Ada allows us to implicitly dereference arrays when subscripting
10447 them. So, if this is an array typedef (encoding use for array
10448 access types encoded as fat pointers), strip it now. */
10449 if (type
->code () == TYPE_CODE_TYPEDEF
)
10450 type
= ada_typedef_target_type (type
);
10452 if (type
->code () == TYPE_CODE_PTR
)
10454 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10456 case TYPE_CODE_FUNC
:
10457 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10459 case TYPE_CODE_ARRAY
:
10461 case TYPE_CODE_STRUCT
:
10462 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10463 argvec
[0] = ada_value_ind (argvec
[0]);
10464 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10467 error (_("cannot subscript or call something of type `%s'"),
10468 ada_type_name (value_type (argvec
[0])));
10473 switch (type
->code ())
10475 case TYPE_CODE_FUNC
:
10476 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10478 if (TYPE_TARGET_TYPE (type
) == NULL
)
10479 error_call_unknown_return_type (NULL
);
10480 return allocate_value (TYPE_TARGET_TYPE (type
));
10482 return call_function_by_hand (argvec
[0], NULL
,
10483 gdb::make_array_view (argvec
+ 1,
10485 case TYPE_CODE_INTERNAL_FUNCTION
:
10486 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10487 /* We don't know anything about what the internal
10488 function might return, but we have to return
10490 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10493 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10494 argvec
[0], nargs
, argvec
+ 1);
10496 case TYPE_CODE_STRUCT
:
10500 arity
= ada_array_arity (type
);
10501 type
= ada_array_element_type (type
, nargs
);
10503 error (_("cannot subscript or call a record"));
10504 if (arity
!= nargs
)
10505 error (_("wrong number of subscripts; expecting %d"), arity
);
10506 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10507 return value_zero (ada_aligned_type (type
), lval_memory
);
10509 unwrap_value (ada_value_subscript
10510 (argvec
[0], nargs
, argvec
+ 1));
10512 case TYPE_CODE_ARRAY
:
10513 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10515 type
= ada_array_element_type (type
, nargs
);
10517 error (_("element type of array unknown"));
10519 return value_zero (ada_aligned_type (type
), lval_memory
);
10522 unwrap_value (ada_value_subscript
10523 (ada_coerce_to_simple_array (argvec
[0]),
10524 nargs
, argvec
+ 1));
10525 case TYPE_CODE_PTR
: /* Pointer to array */
10526 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10528 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10529 type
= ada_array_element_type (type
, nargs
);
10531 error (_("element type of array unknown"));
10533 return value_zero (ada_aligned_type (type
), lval_memory
);
10536 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10537 nargs
, argvec
+ 1));
10540 error (_("Attempt to index or call something other than an "
10541 "array or function"));
10546 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10547 struct value
*low_bound_val
10548 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10549 struct value
*high_bound_val
10550 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10552 LONGEST high_bound
;
10554 low_bound_val
= coerce_ref (low_bound_val
);
10555 high_bound_val
= coerce_ref (high_bound_val
);
10556 low_bound
= value_as_long (low_bound_val
);
10557 high_bound
= value_as_long (high_bound_val
);
10559 if (noside
== EVAL_SKIP
)
10562 /* If this is a reference to an aligner type, then remove all
10564 if (value_type (array
)->code () == TYPE_CODE_REF
10565 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10566 TYPE_TARGET_TYPE (value_type (array
)) =
10567 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10569 if (ada_is_any_packed_array_type (value_type (array
)))
10570 error (_("cannot slice a packed array"));
10572 /* If this is a reference to an array or an array lvalue,
10573 convert to a pointer. */
10574 if (value_type (array
)->code () == TYPE_CODE_REF
10575 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10576 && VALUE_LVAL (array
) == lval_memory
))
10577 array
= value_addr (array
);
10579 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10580 && ada_is_array_descriptor_type (ada_check_typedef
10581 (value_type (array
))))
10582 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10585 array
= ada_coerce_to_simple_array_ptr (array
);
10587 /* If we have more than one level of pointer indirection,
10588 dereference the value until we get only one level. */
10589 while (value_type (array
)->code () == TYPE_CODE_PTR
10590 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10592 array
= value_ind (array
);
10594 /* Make sure we really do have an array type before going further,
10595 to avoid a SEGV when trying to get the index type or the target
10596 type later down the road if the debug info generated by
10597 the compiler is incorrect or incomplete. */
10598 if (!ada_is_simple_array_type (value_type (array
)))
10599 error (_("cannot take slice of non-array"));
10601 if (ada_check_typedef (value_type (array
))->code ()
10604 struct type
*type0
= ada_check_typedef (value_type (array
));
10606 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10607 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10610 struct type
*arr_type0
=
10611 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10613 return ada_value_slice_from_ptr (array
, arr_type0
,
10614 longest_to_int (low_bound
),
10615 longest_to_int (high_bound
));
10618 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10620 else if (high_bound
< low_bound
)
10621 return empty_array (value_type (array
), low_bound
, high_bound
);
10623 return ada_value_slice (array
, longest_to_int (low_bound
),
10624 longest_to_int (high_bound
));
10627 case UNOP_IN_RANGE
:
10629 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10630 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10631 return ada_unop_in_range (expect_type
, exp
, noside
, op
, arg1
, type
);
10633 case BINOP_IN_BOUNDS
:
10635 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10636 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10638 if (noside
== EVAL_SKIP
)
10641 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10643 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10644 return value_zero (type
, not_lval
);
10647 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10649 type
= ada_index_type (value_type (arg2
), tem
, "range");
10651 type
= value_type (arg1
);
10653 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10654 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10656 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10657 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10658 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10660 value_from_longest (type
,
10661 (value_less (arg1
, arg3
)
10662 || value_equal (arg1
, arg3
))
10663 && (value_less (arg2
, arg1
)
10664 || value_equal (arg2
, arg1
)));
10666 case TERNOP_IN_RANGE
:
10667 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10668 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10669 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10671 return eval_ternop_in_range (expect_type
, exp
, noside
, arg1
, arg2
, arg3
);
10675 case OP_ATR_LENGTH
:
10677 struct type
*type_arg
;
10679 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10681 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10683 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10687 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10691 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10692 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10693 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10696 if (noside
== EVAL_SKIP
)
10698 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10700 if (type_arg
== NULL
)
10701 type_arg
= value_type (arg1
);
10703 if (ada_is_constrained_packed_array_type (type_arg
))
10704 type_arg
= decode_constrained_packed_array_type (type_arg
);
10706 if (!discrete_type_p (type_arg
))
10710 default: /* Should never happen. */
10711 error (_("unexpected attribute encountered"));
10714 type_arg
= ada_index_type (type_arg
, tem
,
10715 ada_attribute_name (op
));
10717 case OP_ATR_LENGTH
:
10718 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10723 return value_zero (type_arg
, not_lval
);
10725 else if (type_arg
== NULL
)
10727 arg1
= ada_coerce_ref (arg1
);
10729 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10730 arg1
= ada_coerce_to_simple_array (arg1
);
10732 if (op
== OP_ATR_LENGTH
)
10733 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10736 type
= ada_index_type (value_type (arg1
), tem
,
10737 ada_attribute_name (op
));
10739 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10744 default: /* Should never happen. */
10745 error (_("unexpected attribute encountered"));
10747 return value_from_longest
10748 (type
, ada_array_bound (arg1
, tem
, 0));
10750 return value_from_longest
10751 (type
, ada_array_bound (arg1
, tem
, 1));
10752 case OP_ATR_LENGTH
:
10753 return value_from_longest
10754 (type
, ada_array_length (arg1
, tem
));
10757 else if (discrete_type_p (type_arg
))
10759 struct type
*range_type
;
10760 const char *name
= ada_type_name (type_arg
);
10763 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10764 range_type
= to_fixed_range_type (type_arg
, NULL
);
10765 if (range_type
== NULL
)
10766 range_type
= type_arg
;
10770 error (_("unexpected attribute encountered"));
10772 return value_from_longest
10773 (range_type
, ada_discrete_type_low_bound (range_type
));
10775 return value_from_longest
10776 (range_type
, ada_discrete_type_high_bound (range_type
));
10777 case OP_ATR_LENGTH
:
10778 error (_("the 'length attribute applies only to array types"));
10781 else if (type_arg
->code () == TYPE_CODE_FLT
)
10782 error (_("unimplemented type attribute"));
10787 if (ada_is_constrained_packed_array_type (type_arg
))
10788 type_arg
= decode_constrained_packed_array_type (type_arg
);
10790 if (op
== OP_ATR_LENGTH
)
10791 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10794 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10796 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10802 error (_("unexpected attribute encountered"));
10804 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10805 return value_from_longest (type
, low
);
10807 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10808 return value_from_longest (type
, high
);
10809 case OP_ATR_LENGTH
:
10810 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10811 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10812 return value_from_longest (type
, high
- low
+ 1);
10818 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10819 if (noside
== EVAL_SKIP
)
10821 return ada_atr_tag (expect_type
, exp
, noside
, op
, arg1
);
10825 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10826 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10827 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10828 if (noside
== EVAL_SKIP
)
10830 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10831 return value_zero (value_type (arg1
), not_lval
);
10834 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10835 return value_binop (arg1
, arg2
,
10836 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10839 case OP_ATR_MODULUS
:
10841 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10843 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10844 if (noside
== EVAL_SKIP
)
10847 if (!ada_is_modular_type (type_arg
))
10848 error (_("'modulus must be applied to modular type"));
10850 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10851 ada_modulus (type_arg
));
10856 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10857 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10858 if (noside
== EVAL_SKIP
)
10860 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10861 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10862 return value_zero (type
, not_lval
);
10864 return value_pos_atr (type
, arg1
);
10867 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10868 return ada_atr_size (expect_type
, exp
, noside
, op
, arg1
);
10871 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10872 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10873 type
= exp
->elts
[pc
+ 2].type
;
10874 if (noside
== EVAL_SKIP
)
10876 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10877 return value_zero (type
, not_lval
);
10879 return value_val_atr (type
, arg1
);
10882 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10883 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10884 if (noside
== EVAL_SKIP
)
10886 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10887 return value_zero (value_type (arg1
), not_lval
);
10890 /* For integer exponentiation operations,
10891 only promote the first argument. */
10892 if (is_integral_type (value_type (arg2
)))
10893 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10895 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10897 return value_binop (arg1
, arg2
, op
);
10901 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10902 if (noside
== EVAL_SKIP
)
10908 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10909 if (noside
== EVAL_SKIP
)
10911 return ada_abs (expect_type
, exp
, noside
, op
, arg1
);
10914 preeval_pos
= *pos
;
10915 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10916 if (noside
== EVAL_SKIP
)
10918 type
= ada_check_typedef (value_type (arg1
));
10919 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10921 if (ada_is_array_descriptor_type (type
))
10922 /* GDB allows dereferencing GNAT array descriptors. */
10924 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10926 if (arrType
== NULL
)
10927 error (_("Attempt to dereference null array pointer."));
10928 return value_at_lazy (arrType
, 0);
10930 else if (type
->code () == TYPE_CODE_PTR
10931 || type
->code () == TYPE_CODE_REF
10932 /* In C you can dereference an array to get the 1st elt. */
10933 || type
->code () == TYPE_CODE_ARRAY
)
10935 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10936 only be determined by inspecting the object's tag.
10937 This means that we need to evaluate completely the
10938 expression in order to get its type. */
10940 if ((type
->code () == TYPE_CODE_REF
10941 || type
->code () == TYPE_CODE_PTR
)
10942 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10945 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10946 type
= value_type (ada_value_ind (arg1
));
10950 type
= to_static_fixed_type
10952 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10954 ada_ensure_varsize_limit (type
);
10955 return value_zero (type
, lval_memory
);
10957 else if (type
->code () == TYPE_CODE_INT
)
10959 /* GDB allows dereferencing an int. */
10960 if (expect_type
== NULL
)
10961 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10966 to_static_fixed_type (ada_aligned_type (expect_type
));
10967 return value_zero (expect_type
, lval_memory
);
10971 error (_("Attempt to take contents of a non-pointer value."));
10973 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10974 type
= ada_check_typedef (value_type (arg1
));
10976 if (type
->code () == TYPE_CODE_INT
)
10977 /* GDB allows dereferencing an int. If we were given
10978 the expect_type, then use that as the target type.
10979 Otherwise, assume that the target type is an int. */
10981 if (expect_type
!= NULL
)
10982 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
10985 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
10986 (CORE_ADDR
) value_as_address (arg1
));
10989 if (ada_is_array_descriptor_type (type
))
10990 /* GDB allows dereferencing GNAT array descriptors. */
10991 return ada_coerce_to_simple_array (arg1
);
10993 return ada_value_ind (arg1
);
10995 case STRUCTOP_STRUCT
:
10996 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10997 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
10998 preeval_pos
= *pos
;
10999 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11000 if (noside
== EVAL_SKIP
)
11002 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11004 struct type
*type1
= value_type (arg1
);
11006 if (ada_is_tagged_type (type1
, 1))
11008 type
= ada_lookup_struct_elt_type (type1
,
11009 &exp
->elts
[pc
+ 2].string
,
11012 /* If the field is not found, check if it exists in the
11013 extension of this object's type. This means that we
11014 need to evaluate completely the expression. */
11019 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11020 arg1
= ada_value_struct_elt (arg1
,
11021 &exp
->elts
[pc
+ 2].string
,
11023 arg1
= unwrap_value (arg1
);
11024 type
= value_type (ada_to_fixed_value (arg1
));
11029 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11032 return value_zero (ada_aligned_type (type
), lval_memory
);
11036 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11037 arg1
= unwrap_value (arg1
);
11038 return ada_to_fixed_value (arg1
);
11042 /* The value is not supposed to be used. This is here to make it
11043 easier to accommodate expressions that contain types. */
11045 if (noside
== EVAL_SKIP
)
11047 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11048 return allocate_value (exp
->elts
[pc
+ 1].type
);
11050 error (_("Attempt to use a type name as an expression"));
11055 case OP_DISCRETE_RANGE
:
11056 case OP_POSITIONAL
:
11058 if (noside
== EVAL_NORMAL
)
11062 error (_("Undefined name, ambiguous name, or renaming used in "
11063 "component association: %s."), &exp
->elts
[pc
+2].string
);
11065 error (_("Aggregates only allowed on the right of an assignment"));
11067 internal_error (__FILE__
, __LINE__
,
11068 _("aggregate apparently mangled"));
11071 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11073 for (tem
= 0; tem
< nargs
; tem
+= 1)
11074 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11079 return eval_skip_value (exp
);
11083 /* Return non-zero iff TYPE represents a System.Address type. */
11086 ada_is_system_address_type (struct type
*type
)
11088 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11095 /* Scan STR beginning at position K for a discriminant name, and
11096 return the value of that discriminant field of DVAL in *PX. If
11097 PNEW_K is not null, put the position of the character beyond the
11098 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11099 not alter *PX and *PNEW_K if unsuccessful. */
11102 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11105 static std::string storage
;
11106 const char *pstart
, *pend
, *bound
;
11107 struct value
*bound_val
;
11109 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11113 pend
= strstr (pstart
, "__");
11117 k
+= strlen (bound
);
11121 int len
= pend
- pstart
;
11123 /* Strip __ and beyond. */
11124 storage
= std::string (pstart
, len
);
11125 bound
= storage
.c_str ();
11129 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11130 if (bound_val
== NULL
)
11133 *px
= value_as_long (bound_val
);
11134 if (pnew_k
!= NULL
)
11139 /* Value of variable named NAME. Only exact matches are considered.
11140 If no such variable found, then if ERR_MSG is null, returns 0, and
11141 otherwise causes an error with message ERR_MSG. */
11143 static struct value
*
11144 get_var_value (const char *name
, const char *err_msg
)
11146 std::string quoted_name
= add_angle_brackets (name
);
11148 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11150 std::vector
<struct block_symbol
> syms
11151 = ada_lookup_symbol_list_worker (lookup_name
,
11152 get_selected_block (0),
11155 if (syms
.size () != 1)
11157 if (err_msg
== NULL
)
11160 error (("%s"), err_msg
);
11163 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11166 /* Value of integer variable named NAME in the current environment.
11167 If no such variable is found, returns false. Otherwise, sets VALUE
11168 to the variable's value and returns true. */
11171 get_int_var_value (const char *name
, LONGEST
&value
)
11173 struct value
*var_val
= get_var_value (name
, 0);
11178 value
= value_as_long (var_val
);
11183 /* Return a range type whose base type is that of the range type named
11184 NAME in the current environment, and whose bounds are calculated
11185 from NAME according to the GNAT range encoding conventions.
11186 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11187 corresponding range type from debug information; fall back to using it
11188 if symbol lookup fails. If a new type must be created, allocate it
11189 like ORIG_TYPE was. The bounds information, in general, is encoded
11190 in NAME, the base type given in the named range type. */
11192 static struct type
*
11193 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11196 struct type
*base_type
;
11197 const char *subtype_info
;
11199 gdb_assert (raw_type
!= NULL
);
11200 gdb_assert (raw_type
->name () != NULL
);
11202 if (raw_type
->code () == TYPE_CODE_RANGE
)
11203 base_type
= TYPE_TARGET_TYPE (raw_type
);
11205 base_type
= raw_type
;
11207 name
= raw_type
->name ();
11208 subtype_info
= strstr (name
, "___XD");
11209 if (subtype_info
== NULL
)
11211 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11212 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11214 if (L
< INT_MIN
|| U
> INT_MAX
)
11217 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11222 int prefix_len
= subtype_info
- name
;
11225 const char *bounds_str
;
11229 bounds_str
= strchr (subtype_info
, '_');
11232 if (*subtype_info
== 'L')
11234 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11235 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11237 if (bounds_str
[n
] == '_')
11239 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11245 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11246 if (!get_int_var_value (name_buf
.c_str (), L
))
11248 lim_warning (_("Unknown lower bound, using 1."));
11253 if (*subtype_info
== 'U')
11255 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11256 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11261 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11262 if (!get_int_var_value (name_buf
.c_str (), U
))
11264 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11269 type
= create_static_range_type (alloc_type_copy (raw_type
),
11271 /* create_static_range_type alters the resulting type's length
11272 to match the size of the base_type, which is not what we want.
11273 Set it back to the original range type's length. */
11274 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11275 type
->set_name (name
);
11280 /* True iff NAME is the name of a range type. */
11283 ada_is_range_type_name (const char *name
)
11285 return (name
!= NULL
&& strstr (name
, "___XD"));
11289 /* Modular types */
11291 /* True iff TYPE is an Ada modular type. */
11294 ada_is_modular_type (struct type
*type
)
11296 struct type
*subranged_type
= get_base_type (type
);
11298 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11299 && subranged_type
->code () == TYPE_CODE_INT
11300 && subranged_type
->is_unsigned ());
11303 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11306 ada_modulus (struct type
*type
)
11308 const dynamic_prop
&high
= type
->bounds ()->high
;
11310 if (high
.kind () == PROP_CONST
)
11311 return (ULONGEST
) high
.const_val () + 1;
11313 /* If TYPE is unresolved, the high bound might be a location list. Return
11314 0, for lack of a better value to return. */
11319 /* Ada exception catchpoint support:
11320 ---------------------------------
11322 We support 3 kinds of exception catchpoints:
11323 . catchpoints on Ada exceptions
11324 . catchpoints on unhandled Ada exceptions
11325 . catchpoints on failed assertions
11327 Exceptions raised during failed assertions, or unhandled exceptions
11328 could perfectly be caught with the general catchpoint on Ada exceptions.
11329 However, we can easily differentiate these two special cases, and having
11330 the option to distinguish these two cases from the rest can be useful
11331 to zero-in on certain situations.
11333 Exception catchpoints are a specialized form of breakpoint,
11334 since they rely on inserting breakpoints inside known routines
11335 of the GNAT runtime. The implementation therefore uses a standard
11336 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11339 Support in the runtime for exception catchpoints have been changed
11340 a few times already, and these changes affect the implementation
11341 of these catchpoints. In order to be able to support several
11342 variants of the runtime, we use a sniffer that will determine
11343 the runtime variant used by the program being debugged. */
11345 /* Ada's standard exceptions.
11347 The Ada 83 standard also defined Numeric_Error. But there so many
11348 situations where it was unclear from the Ada 83 Reference Manual
11349 (RM) whether Constraint_Error or Numeric_Error should be raised,
11350 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11351 Interpretation saying that anytime the RM says that Numeric_Error
11352 should be raised, the implementation may raise Constraint_Error.
11353 Ada 95 went one step further and pretty much removed Numeric_Error
11354 from the list of standard exceptions (it made it a renaming of
11355 Constraint_Error, to help preserve compatibility when compiling
11356 an Ada83 compiler). As such, we do not include Numeric_Error from
11357 this list of standard exceptions. */
11359 static const char * const standard_exc
[] = {
11360 "constraint_error",
11366 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11368 /* A structure that describes how to support exception catchpoints
11369 for a given executable. */
11371 struct exception_support_info
11373 /* The name of the symbol to break on in order to insert
11374 a catchpoint on exceptions. */
11375 const char *catch_exception_sym
;
11377 /* The name of the symbol to break on in order to insert
11378 a catchpoint on unhandled exceptions. */
11379 const char *catch_exception_unhandled_sym
;
11381 /* The name of the symbol to break on in order to insert
11382 a catchpoint on failed assertions. */
11383 const char *catch_assert_sym
;
11385 /* The name of the symbol to break on in order to insert
11386 a catchpoint on exception handling. */
11387 const char *catch_handlers_sym
;
11389 /* Assuming that the inferior just triggered an unhandled exception
11390 catchpoint, this function is responsible for returning the address
11391 in inferior memory where the name of that exception is stored.
11392 Return zero if the address could not be computed. */
11393 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11396 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11397 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11399 /* The following exception support info structure describes how to
11400 implement exception catchpoints with the latest version of the
11401 Ada runtime (as of 2019-08-??). */
11403 static const struct exception_support_info default_exception_support_info
=
11405 "__gnat_debug_raise_exception", /* catch_exception_sym */
11406 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11407 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11408 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11409 ada_unhandled_exception_name_addr
11412 /* The following exception support info structure describes how to
11413 implement exception catchpoints with an earlier version of the
11414 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11416 static const struct exception_support_info exception_support_info_v0
=
11418 "__gnat_debug_raise_exception", /* catch_exception_sym */
11419 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11420 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11421 "__gnat_begin_handler", /* catch_handlers_sym */
11422 ada_unhandled_exception_name_addr
11425 /* The following exception support info structure describes how to
11426 implement exception catchpoints with a slightly older version
11427 of the Ada runtime. */
11429 static const struct exception_support_info exception_support_info_fallback
=
11431 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11432 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11433 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11434 "__gnat_begin_handler", /* catch_handlers_sym */
11435 ada_unhandled_exception_name_addr_from_raise
11438 /* Return nonzero if we can detect the exception support routines
11439 described in EINFO.
11441 This function errors out if an abnormal situation is detected
11442 (for instance, if we find the exception support routines, but
11443 that support is found to be incomplete). */
11446 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11448 struct symbol
*sym
;
11450 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11451 that should be compiled with debugging information. As a result, we
11452 expect to find that symbol in the symtabs. */
11454 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11457 /* Perhaps we did not find our symbol because the Ada runtime was
11458 compiled without debugging info, or simply stripped of it.
11459 It happens on some GNU/Linux distributions for instance, where
11460 users have to install a separate debug package in order to get
11461 the runtime's debugging info. In that situation, let the user
11462 know why we cannot insert an Ada exception catchpoint.
11464 Note: Just for the purpose of inserting our Ada exception
11465 catchpoint, we could rely purely on the associated minimal symbol.
11466 But we would be operating in degraded mode anyway, since we are
11467 still lacking the debugging info needed later on to extract
11468 the name of the exception being raised (this name is printed in
11469 the catchpoint message, and is also used when trying to catch
11470 a specific exception). We do not handle this case for now. */
11471 struct bound_minimal_symbol msym
11472 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11474 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11475 error (_("Your Ada runtime appears to be missing some debugging "
11476 "information.\nCannot insert Ada exception catchpoint "
11477 "in this configuration."));
11482 /* Make sure that the symbol we found corresponds to a function. */
11484 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11486 error (_("Symbol \"%s\" is not a function (class = %d)"),
11487 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11491 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11494 struct bound_minimal_symbol msym
11495 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11497 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11498 error (_("Your Ada runtime appears to be missing some debugging "
11499 "information.\nCannot insert Ada exception catchpoint "
11500 "in this configuration."));
11505 /* Make sure that the symbol we found corresponds to a function. */
11507 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11509 error (_("Symbol \"%s\" is not a function (class = %d)"),
11510 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11517 /* Inspect the Ada runtime and determine which exception info structure
11518 should be used to provide support for exception catchpoints.
11520 This function will always set the per-inferior exception_info,
11521 or raise an error. */
11524 ada_exception_support_info_sniffer (void)
11526 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11528 /* If the exception info is already known, then no need to recompute it. */
11529 if (data
->exception_info
!= NULL
)
11532 /* Check the latest (default) exception support info. */
11533 if (ada_has_this_exception_support (&default_exception_support_info
))
11535 data
->exception_info
= &default_exception_support_info
;
11539 /* Try the v0 exception suport info. */
11540 if (ada_has_this_exception_support (&exception_support_info_v0
))
11542 data
->exception_info
= &exception_support_info_v0
;
11546 /* Try our fallback exception suport info. */
11547 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11549 data
->exception_info
= &exception_support_info_fallback
;
11553 /* Sometimes, it is normal for us to not be able to find the routine
11554 we are looking for. This happens when the program is linked with
11555 the shared version of the GNAT runtime, and the program has not been
11556 started yet. Inform the user of these two possible causes if
11559 if (ada_update_initial_language (language_unknown
) != language_ada
)
11560 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11562 /* If the symbol does not exist, then check that the program is
11563 already started, to make sure that shared libraries have been
11564 loaded. If it is not started, this may mean that the symbol is
11565 in a shared library. */
11567 if (inferior_ptid
.pid () == 0)
11568 error (_("Unable to insert catchpoint. Try to start the program first."));
11570 /* At this point, we know that we are debugging an Ada program and
11571 that the inferior has been started, but we still are not able to
11572 find the run-time symbols. That can mean that we are in
11573 configurable run time mode, or that a-except as been optimized
11574 out by the linker... In any case, at this point it is not worth
11575 supporting this feature. */
11577 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11580 /* True iff FRAME is very likely to be that of a function that is
11581 part of the runtime system. This is all very heuristic, but is
11582 intended to be used as advice as to what frames are uninteresting
11586 is_known_support_routine (struct frame_info
*frame
)
11588 enum language func_lang
;
11590 const char *fullname
;
11592 /* If this code does not have any debugging information (no symtab),
11593 This cannot be any user code. */
11595 symtab_and_line sal
= find_frame_sal (frame
);
11596 if (sal
.symtab
== NULL
)
11599 /* If there is a symtab, but the associated source file cannot be
11600 located, then assume this is not user code: Selecting a frame
11601 for which we cannot display the code would not be very helpful
11602 for the user. This should also take care of case such as VxWorks
11603 where the kernel has some debugging info provided for a few units. */
11605 fullname
= symtab_to_fullname (sal
.symtab
);
11606 if (access (fullname
, R_OK
) != 0)
11609 /* Check the unit filename against the Ada runtime file naming.
11610 We also check the name of the objfile against the name of some
11611 known system libraries that sometimes come with debugging info
11614 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11616 re_comp (known_runtime_file_name_patterns
[i
]);
11617 if (re_exec (lbasename (sal
.symtab
->filename
)))
11619 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11620 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11624 /* Check whether the function is a GNAT-generated entity. */
11626 gdb::unique_xmalloc_ptr
<char> func_name
11627 = find_frame_funname (frame
, &func_lang
, NULL
);
11628 if (func_name
== NULL
)
11631 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11633 re_comp (known_auxiliary_function_name_patterns
[i
]);
11634 if (re_exec (func_name
.get ()))
11641 /* Find the first frame that contains debugging information and that is not
11642 part of the Ada run-time, starting from FI and moving upward. */
11645 ada_find_printable_frame (struct frame_info
*fi
)
11647 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11649 if (!is_known_support_routine (fi
))
11658 /* Assuming that the inferior just triggered an unhandled exception
11659 catchpoint, return the address in inferior memory where the name
11660 of the exception is stored.
11662 Return zero if the address could not be computed. */
11665 ada_unhandled_exception_name_addr (void)
11667 return parse_and_eval_address ("e.full_name");
11670 /* Same as ada_unhandled_exception_name_addr, except that this function
11671 should be used when the inferior uses an older version of the runtime,
11672 where the exception name needs to be extracted from a specific frame
11673 several frames up in the callstack. */
11676 ada_unhandled_exception_name_addr_from_raise (void)
11679 struct frame_info
*fi
;
11680 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11682 /* To determine the name of this exception, we need to select
11683 the frame corresponding to RAISE_SYM_NAME. This frame is
11684 at least 3 levels up, so we simply skip the first 3 frames
11685 without checking the name of their associated function. */
11686 fi
= get_current_frame ();
11687 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11689 fi
= get_prev_frame (fi
);
11693 enum language func_lang
;
11695 gdb::unique_xmalloc_ptr
<char> func_name
11696 = find_frame_funname (fi
, &func_lang
, NULL
);
11697 if (func_name
!= NULL
)
11699 if (strcmp (func_name
.get (),
11700 data
->exception_info
->catch_exception_sym
) == 0)
11701 break; /* We found the frame we were looking for... */
11703 fi
= get_prev_frame (fi
);
11710 return parse_and_eval_address ("id.full_name");
11713 /* Assuming the inferior just triggered an Ada exception catchpoint
11714 (of any type), return the address in inferior memory where the name
11715 of the exception is stored, if applicable.
11717 Assumes the selected frame is the current frame.
11719 Return zero if the address could not be computed, or if not relevant. */
11722 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11723 struct breakpoint
*b
)
11725 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11729 case ada_catch_exception
:
11730 return (parse_and_eval_address ("e.full_name"));
11733 case ada_catch_exception_unhandled
:
11734 return data
->exception_info
->unhandled_exception_name_addr ();
11737 case ada_catch_handlers
:
11738 return 0; /* The runtimes does not provide access to the exception
11742 case ada_catch_assert
:
11743 return 0; /* Exception name is not relevant in this case. */
11747 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11751 return 0; /* Should never be reached. */
11754 /* Assuming the inferior is stopped at an exception catchpoint,
11755 return the message which was associated to the exception, if
11756 available. Return NULL if the message could not be retrieved.
11758 Note: The exception message can be associated to an exception
11759 either through the use of the Raise_Exception function, or
11760 more simply (Ada 2005 and later), via:
11762 raise Exception_Name with "exception message";
11766 static gdb::unique_xmalloc_ptr
<char>
11767 ada_exception_message_1 (void)
11769 struct value
*e_msg_val
;
11772 /* For runtimes that support this feature, the exception message
11773 is passed as an unbounded string argument called "message". */
11774 e_msg_val
= parse_and_eval ("message");
11775 if (e_msg_val
== NULL
)
11776 return NULL
; /* Exception message not supported. */
11778 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11779 gdb_assert (e_msg_val
!= NULL
);
11780 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11782 /* If the message string is empty, then treat it as if there was
11783 no exception message. */
11784 if (e_msg_len
<= 0)
11787 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11788 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11790 e_msg
.get ()[e_msg_len
] = '\0';
11795 /* Same as ada_exception_message_1, except that all exceptions are
11796 contained here (returning NULL instead). */
11798 static gdb::unique_xmalloc_ptr
<char>
11799 ada_exception_message (void)
11801 gdb::unique_xmalloc_ptr
<char> e_msg
;
11805 e_msg
= ada_exception_message_1 ();
11807 catch (const gdb_exception_error
&e
)
11809 e_msg
.reset (nullptr);
11815 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11816 any error that ada_exception_name_addr_1 might cause to be thrown.
11817 When an error is intercepted, a warning with the error message is printed,
11818 and zero is returned. */
11821 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11822 struct breakpoint
*b
)
11824 CORE_ADDR result
= 0;
11828 result
= ada_exception_name_addr_1 (ex
, b
);
11831 catch (const gdb_exception_error
&e
)
11833 warning (_("failed to get exception name: %s"), e
.what ());
11840 static std::string ada_exception_catchpoint_cond_string
11841 (const char *excep_string
,
11842 enum ada_exception_catchpoint_kind ex
);
11844 /* Ada catchpoints.
11846 In the case of catchpoints on Ada exceptions, the catchpoint will
11847 stop the target on every exception the program throws. When a user
11848 specifies the name of a specific exception, we translate this
11849 request into a condition expression (in text form), and then parse
11850 it into an expression stored in each of the catchpoint's locations.
11851 We then use this condition to check whether the exception that was
11852 raised is the one the user is interested in. If not, then the
11853 target is resumed again. We store the name of the requested
11854 exception, in order to be able to re-set the condition expression
11855 when symbols change. */
11857 /* An instance of this type is used to represent an Ada catchpoint
11858 breakpoint location. */
11860 class ada_catchpoint_location
: public bp_location
11863 ada_catchpoint_location (breakpoint
*owner
)
11864 : bp_location (owner
, bp_loc_software_breakpoint
)
11867 /* The condition that checks whether the exception that was raised
11868 is the specific exception the user specified on catchpoint
11870 expression_up excep_cond_expr
;
11873 /* An instance of this type is used to represent an Ada catchpoint. */
11875 struct ada_catchpoint
: public breakpoint
11877 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
11882 /* The name of the specific exception the user specified. */
11883 std::string excep_string
;
11885 /* What kind of catchpoint this is. */
11886 enum ada_exception_catchpoint_kind m_kind
;
11889 /* Parse the exception condition string in the context of each of the
11890 catchpoint's locations, and store them for later evaluation. */
11893 create_excep_cond_exprs (struct ada_catchpoint
*c
,
11894 enum ada_exception_catchpoint_kind ex
)
11896 struct bp_location
*bl
;
11898 /* Nothing to do if there's no specific exception to catch. */
11899 if (c
->excep_string
.empty ())
11902 /* Same if there are no locations... */
11903 if (c
->loc
== NULL
)
11906 /* Compute the condition expression in text form, from the specific
11907 expection we want to catch. */
11908 std::string cond_string
11909 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
11911 /* Iterate over all the catchpoint's locations, and parse an
11912 expression for each. */
11913 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
11915 struct ada_catchpoint_location
*ada_loc
11916 = (struct ada_catchpoint_location
*) bl
;
11919 if (!bl
->shlib_disabled
)
11923 s
= cond_string
.c_str ();
11926 exp
= parse_exp_1 (&s
, bl
->address
,
11927 block_for_pc (bl
->address
),
11930 catch (const gdb_exception_error
&e
)
11932 warning (_("failed to reevaluate internal exception condition "
11933 "for catchpoint %d: %s"),
11934 c
->number
, e
.what ());
11938 ada_loc
->excep_cond_expr
= std::move (exp
);
11942 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11943 structure for all exception catchpoint kinds. */
11945 static struct bp_location
*
11946 allocate_location_exception (struct breakpoint
*self
)
11948 return new ada_catchpoint_location (self
);
11951 /* Implement the RE_SET method in the breakpoint_ops structure for all
11952 exception catchpoint kinds. */
11955 re_set_exception (struct breakpoint
*b
)
11957 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11959 /* Call the base class's method. This updates the catchpoint's
11961 bkpt_breakpoint_ops
.re_set (b
);
11963 /* Reparse the exception conditional expressions. One for each
11965 create_excep_cond_exprs (c
, c
->m_kind
);
11968 /* Returns true if we should stop for this breakpoint hit. If the
11969 user specified a specific exception, we only want to cause a stop
11970 if the program thrown that exception. */
11973 should_stop_exception (const struct bp_location
*bl
)
11975 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
11976 const struct ada_catchpoint_location
*ada_loc
11977 = (const struct ada_catchpoint_location
*) bl
;
11980 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
11981 if (c
->m_kind
== ada_catch_assert
)
11982 clear_internalvar (var
);
11989 if (c
->m_kind
== ada_catch_handlers
)
11990 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
11991 ".all.occurrence.id");
11995 struct value
*exc
= parse_and_eval (expr
);
11996 set_internalvar (var
, exc
);
11998 catch (const gdb_exception_error
&ex
)
12000 clear_internalvar (var
);
12004 /* With no specific exception, should always stop. */
12005 if (c
->excep_string
.empty ())
12008 if (ada_loc
->excep_cond_expr
== NULL
)
12010 /* We will have a NULL expression if back when we were creating
12011 the expressions, this location's had failed to parse. */
12018 struct value
*mark
;
12020 mark
= value_mark ();
12021 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12022 value_free_to_mark (mark
);
12024 catch (const gdb_exception
&ex
)
12026 exception_fprintf (gdb_stderr
, ex
,
12027 _("Error in testing exception condition:\n"));
12033 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12034 for all exception catchpoint kinds. */
12037 check_status_exception (bpstat bs
)
12039 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12042 /* Implement the PRINT_IT method in the breakpoint_ops structure
12043 for all exception catchpoint kinds. */
12045 static enum print_stop_action
12046 print_it_exception (bpstat bs
)
12048 struct ui_out
*uiout
= current_uiout
;
12049 struct breakpoint
*b
= bs
->breakpoint_at
;
12051 annotate_catchpoint (b
->number
);
12053 if (uiout
->is_mi_like_p ())
12055 uiout
->field_string ("reason",
12056 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12057 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12060 uiout
->text (b
->disposition
== disp_del
12061 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12062 uiout
->field_signed ("bkptno", b
->number
);
12063 uiout
->text (", ");
12065 /* ada_exception_name_addr relies on the selected frame being the
12066 current frame. Need to do this here because this function may be
12067 called more than once when printing a stop, and below, we'll
12068 select the first frame past the Ada run-time (see
12069 ada_find_printable_frame). */
12070 select_frame (get_current_frame ());
12072 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12075 case ada_catch_exception
:
12076 case ada_catch_exception_unhandled
:
12077 case ada_catch_handlers
:
12079 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12080 char exception_name
[256];
12084 read_memory (addr
, (gdb_byte
*) exception_name
,
12085 sizeof (exception_name
) - 1);
12086 exception_name
[sizeof (exception_name
) - 1] = '\0';
12090 /* For some reason, we were unable to read the exception
12091 name. This could happen if the Runtime was compiled
12092 without debugging info, for instance. In that case,
12093 just replace the exception name by the generic string
12094 "exception" - it will read as "an exception" in the
12095 notification we are about to print. */
12096 memcpy (exception_name
, "exception", sizeof ("exception"));
12098 /* In the case of unhandled exception breakpoints, we print
12099 the exception name as "unhandled EXCEPTION_NAME", to make
12100 it clearer to the user which kind of catchpoint just got
12101 hit. We used ui_out_text to make sure that this extra
12102 info does not pollute the exception name in the MI case. */
12103 if (c
->m_kind
== ada_catch_exception_unhandled
)
12104 uiout
->text ("unhandled ");
12105 uiout
->field_string ("exception-name", exception_name
);
12108 case ada_catch_assert
:
12109 /* In this case, the name of the exception is not really
12110 important. Just print "failed assertion" to make it clearer
12111 that his program just hit an assertion-failure catchpoint.
12112 We used ui_out_text because this info does not belong in
12114 uiout
->text ("failed assertion");
12118 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12119 if (exception_message
!= NULL
)
12121 uiout
->text (" (");
12122 uiout
->field_string ("exception-message", exception_message
.get ());
12126 uiout
->text (" at ");
12127 ada_find_printable_frame (get_current_frame ());
12129 return PRINT_SRC_AND_LOC
;
12132 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12133 for all exception catchpoint kinds. */
12136 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12138 struct ui_out
*uiout
= current_uiout
;
12139 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12140 struct value_print_options opts
;
12142 get_user_print_options (&opts
);
12144 if (opts
.addressprint
)
12145 uiout
->field_skip ("addr");
12147 annotate_field (5);
12150 case ada_catch_exception
:
12151 if (!c
->excep_string
.empty ())
12153 std::string msg
= string_printf (_("`%s' Ada exception"),
12154 c
->excep_string
.c_str ());
12156 uiout
->field_string ("what", msg
);
12159 uiout
->field_string ("what", "all Ada exceptions");
12163 case ada_catch_exception_unhandled
:
12164 uiout
->field_string ("what", "unhandled Ada exceptions");
12167 case ada_catch_handlers
:
12168 if (!c
->excep_string
.empty ())
12170 uiout
->field_fmt ("what",
12171 _("`%s' Ada exception handlers"),
12172 c
->excep_string
.c_str ());
12175 uiout
->field_string ("what", "all Ada exceptions handlers");
12178 case ada_catch_assert
:
12179 uiout
->field_string ("what", "failed Ada assertions");
12183 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12188 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12189 for all exception catchpoint kinds. */
12192 print_mention_exception (struct breakpoint
*b
)
12194 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12195 struct ui_out
*uiout
= current_uiout
;
12197 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12198 : _("Catchpoint "));
12199 uiout
->field_signed ("bkptno", b
->number
);
12200 uiout
->text (": ");
12204 case ada_catch_exception
:
12205 if (!c
->excep_string
.empty ())
12207 std::string info
= string_printf (_("`%s' Ada exception"),
12208 c
->excep_string
.c_str ());
12209 uiout
->text (info
.c_str ());
12212 uiout
->text (_("all Ada exceptions"));
12215 case ada_catch_exception_unhandled
:
12216 uiout
->text (_("unhandled Ada exceptions"));
12219 case ada_catch_handlers
:
12220 if (!c
->excep_string
.empty ())
12223 = string_printf (_("`%s' Ada exception handlers"),
12224 c
->excep_string
.c_str ());
12225 uiout
->text (info
.c_str ());
12228 uiout
->text (_("all Ada exceptions handlers"));
12231 case ada_catch_assert
:
12232 uiout
->text (_("failed Ada assertions"));
12236 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12241 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12242 for all exception catchpoint kinds. */
12245 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12247 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12251 case ada_catch_exception
:
12252 fprintf_filtered (fp
, "catch exception");
12253 if (!c
->excep_string
.empty ())
12254 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12257 case ada_catch_exception_unhandled
:
12258 fprintf_filtered (fp
, "catch exception unhandled");
12261 case ada_catch_handlers
:
12262 fprintf_filtered (fp
, "catch handlers");
12265 case ada_catch_assert
:
12266 fprintf_filtered (fp
, "catch assert");
12270 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12272 print_recreate_thread (b
, fp
);
12275 /* Virtual tables for various breakpoint types. */
12276 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12277 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12278 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12279 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12281 /* See ada-lang.h. */
12284 is_ada_exception_catchpoint (breakpoint
*bp
)
12286 return (bp
->ops
== &catch_exception_breakpoint_ops
12287 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12288 || bp
->ops
== &catch_assert_breakpoint_ops
12289 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12292 /* Split the arguments specified in a "catch exception" command.
12293 Set EX to the appropriate catchpoint type.
12294 Set EXCEP_STRING to the name of the specific exception if
12295 specified by the user.
12296 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12297 "catch handlers" command. False otherwise.
12298 If a condition is found at the end of the arguments, the condition
12299 expression is stored in COND_STRING (memory must be deallocated
12300 after use). Otherwise COND_STRING is set to NULL. */
12303 catch_ada_exception_command_split (const char *args
,
12304 bool is_catch_handlers_cmd
,
12305 enum ada_exception_catchpoint_kind
*ex
,
12306 std::string
*excep_string
,
12307 std::string
*cond_string
)
12309 std::string exception_name
;
12311 exception_name
= extract_arg (&args
);
12312 if (exception_name
== "if")
12314 /* This is not an exception name; this is the start of a condition
12315 expression for a catchpoint on all exceptions. So, "un-get"
12316 this token, and set exception_name to NULL. */
12317 exception_name
.clear ();
12321 /* Check to see if we have a condition. */
12323 args
= skip_spaces (args
);
12324 if (startswith (args
, "if")
12325 && (isspace (args
[2]) || args
[2] == '\0'))
12328 args
= skip_spaces (args
);
12330 if (args
[0] == '\0')
12331 error (_("Condition missing after `if' keyword"));
12332 *cond_string
= args
;
12334 args
+= strlen (args
);
12337 /* Check that we do not have any more arguments. Anything else
12340 if (args
[0] != '\0')
12341 error (_("Junk at end of expression"));
12343 if (is_catch_handlers_cmd
)
12345 /* Catch handling of exceptions. */
12346 *ex
= ada_catch_handlers
;
12347 *excep_string
= exception_name
;
12349 else if (exception_name
.empty ())
12351 /* Catch all exceptions. */
12352 *ex
= ada_catch_exception
;
12353 excep_string
->clear ();
12355 else if (exception_name
== "unhandled")
12357 /* Catch unhandled exceptions. */
12358 *ex
= ada_catch_exception_unhandled
;
12359 excep_string
->clear ();
12363 /* Catch a specific exception. */
12364 *ex
= ada_catch_exception
;
12365 *excep_string
= exception_name
;
12369 /* Return the name of the symbol on which we should break in order to
12370 implement a catchpoint of the EX kind. */
12372 static const char *
12373 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12375 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12377 gdb_assert (data
->exception_info
!= NULL
);
12381 case ada_catch_exception
:
12382 return (data
->exception_info
->catch_exception_sym
);
12384 case ada_catch_exception_unhandled
:
12385 return (data
->exception_info
->catch_exception_unhandled_sym
);
12387 case ada_catch_assert
:
12388 return (data
->exception_info
->catch_assert_sym
);
12390 case ada_catch_handlers
:
12391 return (data
->exception_info
->catch_handlers_sym
);
12394 internal_error (__FILE__
, __LINE__
,
12395 _("unexpected catchpoint kind (%d)"), ex
);
12399 /* Return the breakpoint ops "virtual table" used for catchpoints
12402 static const struct breakpoint_ops
*
12403 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12407 case ada_catch_exception
:
12408 return (&catch_exception_breakpoint_ops
);
12410 case ada_catch_exception_unhandled
:
12411 return (&catch_exception_unhandled_breakpoint_ops
);
12413 case ada_catch_assert
:
12414 return (&catch_assert_breakpoint_ops
);
12416 case ada_catch_handlers
:
12417 return (&catch_handlers_breakpoint_ops
);
12420 internal_error (__FILE__
, __LINE__
,
12421 _("unexpected catchpoint kind (%d)"), ex
);
12425 /* Return the condition that will be used to match the current exception
12426 being raised with the exception that the user wants to catch. This
12427 assumes that this condition is used when the inferior just triggered
12428 an exception catchpoint.
12429 EX: the type of catchpoints used for catching Ada exceptions. */
12432 ada_exception_catchpoint_cond_string (const char *excep_string
,
12433 enum ada_exception_catchpoint_kind ex
)
12436 bool is_standard_exc
= false;
12437 std::string result
;
12439 if (ex
== ada_catch_handlers
)
12441 /* For exception handlers catchpoints, the condition string does
12442 not use the same parameter as for the other exceptions. */
12443 result
= ("long_integer (GNAT_GCC_exception_Access"
12444 "(gcc_exception).all.occurrence.id)");
12447 result
= "long_integer (e)";
12449 /* The standard exceptions are a special case. They are defined in
12450 runtime units that have been compiled without debugging info; if
12451 EXCEP_STRING is the not-fully-qualified name of a standard
12452 exception (e.g. "constraint_error") then, during the evaluation
12453 of the condition expression, the symbol lookup on this name would
12454 *not* return this standard exception. The catchpoint condition
12455 may then be set only on user-defined exceptions which have the
12456 same not-fully-qualified name (e.g. my_package.constraint_error).
12458 To avoid this unexcepted behavior, these standard exceptions are
12459 systematically prefixed by "standard". This means that "catch
12460 exception constraint_error" is rewritten into "catch exception
12461 standard.constraint_error".
12463 If an exception named constraint_error is defined in another package of
12464 the inferior program, then the only way to specify this exception as a
12465 breakpoint condition is to use its fully-qualified named:
12466 e.g. my_package.constraint_error. */
12468 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12470 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12472 is_standard_exc
= true;
12479 if (is_standard_exc
)
12480 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12482 string_appendf (result
, "long_integer (&%s)", excep_string
);
12487 /* Return the symtab_and_line that should be used to insert an exception
12488 catchpoint of the TYPE kind.
12490 ADDR_STRING returns the name of the function where the real
12491 breakpoint that implements the catchpoints is set, depending on the
12492 type of catchpoint we need to create. */
12494 static struct symtab_and_line
12495 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12496 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12498 const char *sym_name
;
12499 struct symbol
*sym
;
12501 /* First, find out which exception support info to use. */
12502 ada_exception_support_info_sniffer ();
12504 /* Then lookup the function on which we will break in order to catch
12505 the Ada exceptions requested by the user. */
12506 sym_name
= ada_exception_sym_name (ex
);
12507 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12510 error (_("Catchpoint symbol not found: %s"), sym_name
);
12512 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12513 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12515 /* Set ADDR_STRING. */
12516 *addr_string
= sym_name
;
12519 *ops
= ada_exception_breakpoint_ops (ex
);
12521 return find_function_start_sal (sym
, 1);
12524 /* Create an Ada exception catchpoint.
12526 EX_KIND is the kind of exception catchpoint to be created.
12528 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12529 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12530 of the exception to which this catchpoint applies.
12532 COND_STRING, if not empty, is the catchpoint condition.
12534 TEMPFLAG, if nonzero, means that the underlying breakpoint
12535 should be temporary.
12537 FROM_TTY is the usual argument passed to all commands implementations. */
12540 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12541 enum ada_exception_catchpoint_kind ex_kind
,
12542 const std::string
&excep_string
,
12543 const std::string
&cond_string
,
12548 std::string addr_string
;
12549 const struct breakpoint_ops
*ops
= NULL
;
12550 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12552 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12553 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12554 ops
, tempflag
, disabled
, from_tty
);
12555 c
->excep_string
= excep_string
;
12556 create_excep_cond_exprs (c
.get (), ex_kind
);
12557 if (!cond_string
.empty ())
12558 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12559 install_breakpoint (0, std::move (c
), 1);
12562 /* Implement the "catch exception" command. */
12565 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12566 struct cmd_list_element
*command
)
12568 const char *arg
= arg_entry
;
12569 struct gdbarch
*gdbarch
= get_current_arch ();
12571 enum ada_exception_catchpoint_kind ex_kind
;
12572 std::string excep_string
;
12573 std::string cond_string
;
12575 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12579 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12581 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12582 excep_string
, cond_string
,
12583 tempflag
, 1 /* enabled */,
12587 /* Implement the "catch handlers" command. */
12590 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12591 struct cmd_list_element
*command
)
12593 const char *arg
= arg_entry
;
12594 struct gdbarch
*gdbarch
= get_current_arch ();
12596 enum ada_exception_catchpoint_kind ex_kind
;
12597 std::string excep_string
;
12598 std::string cond_string
;
12600 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12604 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12606 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12607 excep_string
, cond_string
,
12608 tempflag
, 1 /* enabled */,
12612 /* Completion function for the Ada "catch" commands. */
12615 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12616 const char *text
, const char *word
)
12618 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12620 for (const ada_exc_info
&info
: exceptions
)
12622 if (startswith (info
.name
, word
))
12623 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12627 /* Split the arguments specified in a "catch assert" command.
12629 ARGS contains the command's arguments (or the empty string if
12630 no arguments were passed).
12632 If ARGS contains a condition, set COND_STRING to that condition
12633 (the memory needs to be deallocated after use). */
12636 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12638 args
= skip_spaces (args
);
12640 /* Check whether a condition was provided. */
12641 if (startswith (args
, "if")
12642 && (isspace (args
[2]) || args
[2] == '\0'))
12645 args
= skip_spaces (args
);
12646 if (args
[0] == '\0')
12647 error (_("condition missing after `if' keyword"));
12648 cond_string
.assign (args
);
12651 /* Otherwise, there should be no other argument at the end of
12653 else if (args
[0] != '\0')
12654 error (_("Junk at end of arguments."));
12657 /* Implement the "catch assert" command. */
12660 catch_assert_command (const char *arg_entry
, int from_tty
,
12661 struct cmd_list_element
*command
)
12663 const char *arg
= arg_entry
;
12664 struct gdbarch
*gdbarch
= get_current_arch ();
12666 std::string cond_string
;
12668 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12672 catch_ada_assert_command_split (arg
, cond_string
);
12673 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12675 tempflag
, 1 /* enabled */,
12679 /* Return non-zero if the symbol SYM is an Ada exception object. */
12682 ada_is_exception_sym (struct symbol
*sym
)
12684 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12686 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12687 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12688 && SYMBOL_CLASS (sym
) != LOC_CONST
12689 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12690 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12693 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12694 Ada exception object. This matches all exceptions except the ones
12695 defined by the Ada language. */
12698 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12702 if (!ada_is_exception_sym (sym
))
12705 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12706 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12707 return 0; /* A standard exception. */
12709 /* Numeric_Error is also a standard exception, so exclude it.
12710 See the STANDARD_EXC description for more details as to why
12711 this exception is not listed in that array. */
12712 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12718 /* A helper function for std::sort, comparing two struct ada_exc_info
12721 The comparison is determined first by exception name, and then
12722 by exception address. */
12725 ada_exc_info::operator< (const ada_exc_info
&other
) const
12729 result
= strcmp (name
, other
.name
);
12732 if (result
== 0 && addr
< other
.addr
)
12738 ada_exc_info::operator== (const ada_exc_info
&other
) const
12740 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12743 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12744 routine, but keeping the first SKIP elements untouched.
12746 All duplicates are also removed. */
12749 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12752 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12753 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12754 exceptions
->end ());
12757 /* Add all exceptions defined by the Ada standard whose name match
12758 a regular expression.
12760 If PREG is not NULL, then this regexp_t object is used to
12761 perform the symbol name matching. Otherwise, no name-based
12762 filtering is performed.
12764 EXCEPTIONS is a vector of exceptions to which matching exceptions
12768 ada_add_standard_exceptions (compiled_regex
*preg
,
12769 std::vector
<ada_exc_info
> *exceptions
)
12773 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12776 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12778 struct bound_minimal_symbol msymbol
12779 = ada_lookup_simple_minsym (standard_exc
[i
]);
12781 if (msymbol
.minsym
!= NULL
)
12783 struct ada_exc_info info
12784 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12786 exceptions
->push_back (info
);
12792 /* Add all Ada exceptions defined locally and accessible from the given
12795 If PREG is not NULL, then this regexp_t object is used to
12796 perform the symbol name matching. Otherwise, no name-based
12797 filtering is performed.
12799 EXCEPTIONS is a vector of exceptions to which matching exceptions
12803 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12804 struct frame_info
*frame
,
12805 std::vector
<ada_exc_info
> *exceptions
)
12807 const struct block
*block
= get_frame_block (frame
, 0);
12811 struct block_iterator iter
;
12812 struct symbol
*sym
;
12814 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12816 switch (SYMBOL_CLASS (sym
))
12823 if (ada_is_exception_sym (sym
))
12825 struct ada_exc_info info
= {sym
->print_name (),
12826 SYMBOL_VALUE_ADDRESS (sym
)};
12828 exceptions
->push_back (info
);
12832 if (BLOCK_FUNCTION (block
) != NULL
)
12834 block
= BLOCK_SUPERBLOCK (block
);
12838 /* Return true if NAME matches PREG or if PREG is NULL. */
12841 name_matches_regex (const char *name
, compiled_regex
*preg
)
12843 return (preg
== NULL
12844 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
12847 /* Add all exceptions defined globally whose name name match
12848 a regular expression, excluding standard exceptions.
12850 The reason we exclude standard exceptions is that they need
12851 to be handled separately: Standard exceptions are defined inside
12852 a runtime unit which is normally not compiled with debugging info,
12853 and thus usually do not show up in our symbol search. However,
12854 if the unit was in fact built with debugging info, we need to
12855 exclude them because they would duplicate the entry we found
12856 during the special loop that specifically searches for those
12857 standard exceptions.
12859 If PREG is not NULL, then this regexp_t object is used to
12860 perform the symbol name matching. Otherwise, no name-based
12861 filtering is performed.
12863 EXCEPTIONS is a vector of exceptions to which matching exceptions
12867 ada_add_global_exceptions (compiled_regex
*preg
,
12868 std::vector
<ada_exc_info
> *exceptions
)
12870 /* In Ada, the symbol "search name" is a linkage name, whereas the
12871 regular expression used to do the matching refers to the natural
12872 name. So match against the decoded name. */
12873 expand_symtabs_matching (NULL
,
12874 lookup_name_info::match_any (),
12875 [&] (const char *search_name
)
12877 std::string decoded
= ada_decode (search_name
);
12878 return name_matches_regex (decoded
.c_str (), preg
);
12883 for (objfile
*objfile
: current_program_space
->objfiles ())
12885 for (compunit_symtab
*s
: objfile
->compunits ())
12887 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
12890 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12892 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12893 struct block_iterator iter
;
12894 struct symbol
*sym
;
12896 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12897 if (ada_is_non_standard_exception_sym (sym
)
12898 && name_matches_regex (sym
->natural_name (), preg
))
12900 struct ada_exc_info info
12901 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
12903 exceptions
->push_back (info
);
12910 /* Implements ada_exceptions_list with the regular expression passed
12911 as a regex_t, rather than a string.
12913 If not NULL, PREG is used to filter out exceptions whose names
12914 do not match. Otherwise, all exceptions are listed. */
12916 static std::vector
<ada_exc_info
>
12917 ada_exceptions_list_1 (compiled_regex
*preg
)
12919 std::vector
<ada_exc_info
> result
;
12922 /* First, list the known standard exceptions. These exceptions
12923 need to be handled separately, as they are usually defined in
12924 runtime units that have been compiled without debugging info. */
12926 ada_add_standard_exceptions (preg
, &result
);
12928 /* Next, find all exceptions whose scope is local and accessible
12929 from the currently selected frame. */
12931 if (has_stack_frames ())
12933 prev_len
= result
.size ();
12934 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12936 if (result
.size () > prev_len
)
12937 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12940 /* Add all exceptions whose scope is global. */
12942 prev_len
= result
.size ();
12943 ada_add_global_exceptions (preg
, &result
);
12944 if (result
.size () > prev_len
)
12945 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12950 /* Return a vector of ada_exc_info.
12952 If REGEXP is NULL, all exceptions are included in the result.
12953 Otherwise, it should contain a valid regular expression,
12954 and only the exceptions whose names match that regular expression
12955 are included in the result.
12957 The exceptions are sorted in the following order:
12958 - Standard exceptions (defined by the Ada language), in
12959 alphabetical order;
12960 - Exceptions only visible from the current frame, in
12961 alphabetical order;
12962 - Exceptions whose scope is global, in alphabetical order. */
12964 std::vector
<ada_exc_info
>
12965 ada_exceptions_list (const char *regexp
)
12967 if (regexp
== NULL
)
12968 return ada_exceptions_list_1 (NULL
);
12970 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
12971 return ada_exceptions_list_1 (®
);
12974 /* Implement the "info exceptions" command. */
12977 info_exceptions_command (const char *regexp
, int from_tty
)
12979 struct gdbarch
*gdbarch
= get_current_arch ();
12981 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
12983 if (regexp
!= NULL
)
12985 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
12987 printf_filtered (_("All defined Ada exceptions:\n"));
12989 for (const ada_exc_info
&info
: exceptions
)
12990 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
12994 /* Information about operators given special treatment in functions
12996 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12998 #define ADA_OPERATORS \
12999 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13000 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13001 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13002 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13003 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13004 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13005 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13006 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13007 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13008 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13009 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13010 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13011 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13012 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13013 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13014 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13015 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13016 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13017 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13020 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13023 switch (exp
->elts
[pc
- 1].opcode
)
13026 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13029 #define OP_DEFN(op, len, args, binop) \
13030 case op: *oplenp = len; *argsp = args; break;
13036 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13041 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13046 /* Implementation of the exp_descriptor method operator_check. */
13049 ada_operator_check (struct expression
*exp
, int pos
,
13050 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13053 const union exp_element
*const elts
= exp
->elts
;
13054 struct type
*type
= NULL
;
13056 switch (elts
[pos
].opcode
)
13058 case UNOP_IN_RANGE
:
13060 type
= elts
[pos
+ 1].type
;
13064 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13067 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13069 if (type
!= nullptr && type
->objfile_owner () != nullptr
13070 && objfile_func (type
->objfile_owner (), data
))
13076 /* As for operator_length, but assumes PC is pointing at the first
13077 element of the operator, and gives meaningful results only for the
13078 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13081 ada_forward_operator_length (struct expression
*exp
, int pc
,
13082 int *oplenp
, int *argsp
)
13084 switch (exp
->elts
[pc
].opcode
)
13087 *oplenp
= *argsp
= 0;
13090 #define OP_DEFN(op, len, args, binop) \
13091 case op: *oplenp = len; *argsp = args; break;
13097 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13102 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13108 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13110 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13118 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13120 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13125 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13129 /* Ada attributes ('Foo). */
13132 case OP_ATR_LENGTH
:
13136 case OP_ATR_MODULUS
:
13143 case UNOP_IN_RANGE
:
13145 /* XXX: gdb_sprint_host_address, type_sprint */
13146 fprintf_filtered (stream
, _("Type @"));
13147 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13148 fprintf_filtered (stream
, " (");
13149 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13150 fprintf_filtered (stream
, ")");
13152 case BINOP_IN_BOUNDS
:
13153 fprintf_filtered (stream
, " (%d)",
13154 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13156 case TERNOP_IN_RANGE
:
13161 case OP_DISCRETE_RANGE
:
13162 case OP_POSITIONAL
:
13169 char *name
= &exp
->elts
[elt
+ 2].string
;
13170 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13172 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13177 return dump_subexp_body_standard (exp
, stream
, elt
);
13181 for (i
= 0; i
< nargs
; i
+= 1)
13182 elt
= dump_subexp (exp
, stream
, elt
);
13187 /* The Ada extension of print_subexp (q.v.). */
13190 ada_print_subexp (struct expression
*exp
, int *pos
,
13191 struct ui_file
*stream
, enum precedence prec
)
13193 int oplen
, nargs
, i
;
13195 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13197 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13204 print_subexp_standard (exp
, pos
, stream
, prec
);
13208 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13211 case BINOP_IN_BOUNDS
:
13212 /* XXX: sprint_subexp */
13213 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13214 fputs_filtered (" in ", stream
);
13215 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13216 fputs_filtered ("'range", stream
);
13217 if (exp
->elts
[pc
+ 1].longconst
> 1)
13218 fprintf_filtered (stream
, "(%ld)",
13219 (long) exp
->elts
[pc
+ 1].longconst
);
13222 case TERNOP_IN_RANGE
:
13223 if (prec
>= PREC_EQUAL
)
13224 fputs_filtered ("(", stream
);
13225 /* XXX: sprint_subexp */
13226 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13227 fputs_filtered (" in ", stream
);
13228 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13229 fputs_filtered (" .. ", stream
);
13230 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13231 if (prec
>= PREC_EQUAL
)
13232 fputs_filtered (")", stream
);
13237 case OP_ATR_LENGTH
:
13241 case OP_ATR_MODULUS
:
13246 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13248 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13249 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13250 &type_print_raw_options
);
13254 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13255 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13260 for (tem
= 1; tem
< nargs
; tem
+= 1)
13262 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13263 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13265 fputs_filtered (")", stream
);
13270 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13271 fputs_filtered ("'(", stream
);
13272 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13273 fputs_filtered (")", stream
);
13276 case UNOP_IN_RANGE
:
13277 /* XXX: sprint_subexp */
13278 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13279 fputs_filtered (" in ", stream
);
13280 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13281 &type_print_raw_options
);
13284 case OP_DISCRETE_RANGE
:
13285 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13286 fputs_filtered ("..", stream
);
13287 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13291 fputs_filtered ("others => ", stream
);
13292 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13296 for (i
= 0; i
< nargs
-1; i
+= 1)
13299 fputs_filtered ("|", stream
);
13300 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13302 fputs_filtered (" => ", stream
);
13303 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13306 case OP_POSITIONAL
:
13307 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13311 fputs_filtered ("(", stream
);
13312 for (i
= 0; i
< nargs
; i
+= 1)
13315 fputs_filtered (", ", stream
);
13316 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13318 fputs_filtered (")", stream
);
13323 /* Table mapping opcodes into strings for printing operators
13324 and precedences of the operators. */
13326 static const struct op_print ada_op_print_tab
[] = {
13327 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13328 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13329 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13330 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13331 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13332 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13333 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13334 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13335 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13336 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13337 {">", BINOP_GTR
, PREC_ORDER
, 0},
13338 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13339 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13340 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13341 {"+", BINOP_ADD
, PREC_ADD
, 0},
13342 {"-", BINOP_SUB
, PREC_ADD
, 0},
13343 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13344 {"*", BINOP_MUL
, PREC_MUL
, 0},
13345 {"/", BINOP_DIV
, PREC_MUL
, 0},
13346 {"rem", BINOP_REM
, PREC_MUL
, 0},
13347 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13348 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13349 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13350 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13351 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13352 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13353 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13354 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13355 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13356 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13357 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13358 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13361 /* Language vector */
13363 static const struct exp_descriptor ada_exp_descriptor
= {
13365 ada_operator_length
,
13366 ada_operator_check
,
13367 ada_dump_subexp_body
,
13368 ada_evaluate_subexp
13371 /* symbol_name_matcher_ftype adapter for wild_match. */
13374 do_wild_match (const char *symbol_search_name
,
13375 const lookup_name_info
&lookup_name
,
13376 completion_match_result
*comp_match_res
)
13378 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13381 /* symbol_name_matcher_ftype adapter for full_match. */
13384 do_full_match (const char *symbol_search_name
,
13385 const lookup_name_info
&lookup_name
,
13386 completion_match_result
*comp_match_res
)
13388 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13390 /* If both symbols start with "_ada_", just let the loop below
13391 handle the comparison. However, if only the symbol name starts
13392 with "_ada_", skip the prefix and let the match proceed as
13394 if (startswith (symbol_search_name
, "_ada_")
13395 && !startswith (lname
, "_ada"))
13396 symbol_search_name
+= 5;
13398 int uscore_count
= 0;
13399 while (*lname
!= '\0')
13401 if (*symbol_search_name
!= *lname
)
13403 if (*symbol_search_name
== 'B' && uscore_count
== 2
13404 && symbol_search_name
[1] == '_')
13406 symbol_search_name
+= 2;
13407 while (isdigit (*symbol_search_name
))
13408 ++symbol_search_name
;
13409 if (symbol_search_name
[0] == '_'
13410 && symbol_search_name
[1] == '_')
13412 symbol_search_name
+= 2;
13419 if (*symbol_search_name
== '_')
13424 ++symbol_search_name
;
13428 return is_name_suffix (symbol_search_name
);
13431 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13434 do_exact_match (const char *symbol_search_name
,
13435 const lookup_name_info
&lookup_name
,
13436 completion_match_result
*comp_match_res
)
13438 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13441 /* Build the Ada lookup name for LOOKUP_NAME. */
13443 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13445 gdb::string_view user_name
= lookup_name
.name ();
13447 if (!user_name
.empty () && user_name
[0] == '<')
13449 if (user_name
.back () == '>')
13451 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13454 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13455 m_encoded_p
= true;
13456 m_verbatim_p
= true;
13457 m_wild_match_p
= false;
13458 m_standard_p
= false;
13462 m_verbatim_p
= false;
13464 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13468 const char *folded
= ada_fold_name (user_name
);
13469 m_encoded_name
= ada_encode_1 (folded
, false);
13470 if (m_encoded_name
.empty ())
13471 m_encoded_name
= gdb::to_string (user_name
);
13474 m_encoded_name
= gdb::to_string (user_name
);
13476 /* Handle the 'package Standard' special case. See description
13477 of m_standard_p. */
13478 if (startswith (m_encoded_name
.c_str (), "standard__"))
13480 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13481 m_standard_p
= true;
13484 m_standard_p
= false;
13486 /* If the name contains a ".", then the user is entering a fully
13487 qualified entity name, and the match must not be done in wild
13488 mode. Similarly, if the user wants to complete what looks
13489 like an encoded name, the match must not be done in wild
13490 mode. Also, in the standard__ special case always do
13491 non-wild matching. */
13493 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13496 && user_name
.find ('.') == std::string::npos
);
13500 /* symbol_name_matcher_ftype method for Ada. This only handles
13501 completion mode. */
13504 ada_symbol_name_matches (const char *symbol_search_name
,
13505 const lookup_name_info
&lookup_name
,
13506 completion_match_result
*comp_match_res
)
13508 return lookup_name
.ada ().matches (symbol_search_name
,
13509 lookup_name
.match_type (),
13513 /* A name matcher that matches the symbol name exactly, with
13517 literal_symbol_name_matcher (const char *symbol_search_name
,
13518 const lookup_name_info
&lookup_name
,
13519 completion_match_result
*comp_match_res
)
13521 gdb::string_view name_view
= lookup_name
.name ();
13523 if (lookup_name
.completion_mode ()
13524 ? (strncmp (symbol_search_name
, name_view
.data (),
13525 name_view
.size ()) == 0)
13526 : symbol_search_name
== name_view
)
13528 if (comp_match_res
!= NULL
)
13529 comp_match_res
->set_match (symbol_search_name
);
13536 /* Implement the "get_symbol_name_matcher" language_defn method for
13539 static symbol_name_matcher_ftype
*
13540 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13542 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13543 return literal_symbol_name_matcher
;
13545 if (lookup_name
.completion_mode ())
13546 return ada_symbol_name_matches
;
13549 if (lookup_name
.ada ().wild_match_p ())
13550 return do_wild_match
;
13551 else if (lookup_name
.ada ().verbatim_p ())
13552 return do_exact_match
;
13554 return do_full_match
;
13558 /* Class representing the Ada language. */
13560 class ada_language
: public language_defn
13564 : language_defn (language_ada
)
13567 /* See language.h. */
13569 const char *name () const override
13572 /* See language.h. */
13574 const char *natural_name () const override
13577 /* See language.h. */
13579 const std::vector
<const char *> &filename_extensions () const override
13581 static const std::vector
<const char *> extensions
13582 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13586 /* Print an array element index using the Ada syntax. */
13588 void print_array_index (struct type
*index_type
,
13590 struct ui_file
*stream
,
13591 const value_print_options
*options
) const override
13593 struct value
*index_value
= val_atr (index_type
, index
);
13595 value_print (index_value
, stream
, options
);
13596 fprintf_filtered (stream
, " => ");
13599 /* Implement the "read_var_value" language_defn method for Ada. */
13601 struct value
*read_var_value (struct symbol
*var
,
13602 const struct block
*var_block
,
13603 struct frame_info
*frame
) const override
13605 /* The only case where default_read_var_value is not sufficient
13606 is when VAR is a renaming... */
13607 if (frame
!= nullptr)
13609 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13610 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13611 return ada_read_renaming_var_value (var
, frame_block
);
13614 /* This is a typical case where we expect the default_read_var_value
13615 function to work. */
13616 return language_defn::read_var_value (var
, var_block
, frame
);
13619 /* See language.h. */
13620 void language_arch_info (struct gdbarch
*gdbarch
,
13621 struct language_arch_info
*lai
) const override
13623 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13625 /* Helper function to allow shorter lines below. */
13626 auto add
= [&] (struct type
*t
)
13628 lai
->add_primitive_type (t
);
13631 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13633 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13634 0, "long_integer"));
13635 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13636 0, "short_integer"));
13637 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13639 lai
->set_string_char_type (char_type
);
13641 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13642 "float", gdbarch_float_format (gdbarch
)));
13643 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13644 "long_float", gdbarch_double_format (gdbarch
)));
13645 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13646 0, "long_long_integer"));
13647 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13649 gdbarch_long_double_format (gdbarch
)));
13650 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13652 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13654 add (builtin
->builtin_void
);
13656 struct type
*system_addr_ptr
13657 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13659 system_addr_ptr
->set_name ("system__address");
13660 add (system_addr_ptr
);
13662 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13663 type. This is a signed integral type whose size is the same as
13664 the size of addresses. */
13665 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13666 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13667 "storage_offset"));
13669 lai
->set_bool_type (builtin
->builtin_bool
);
13672 /* See language.h. */
13674 bool iterate_over_symbols
13675 (const struct block
*block
, const lookup_name_info
&name
,
13676 domain_enum domain
,
13677 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13679 std::vector
<struct block_symbol
> results
13680 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13681 for (block_symbol
&sym
: results
)
13683 if (!callback (&sym
))
13690 /* See language.h. */
13691 bool sniff_from_mangled_name (const char *mangled
,
13692 char **out
) const override
13694 std::string demangled
= ada_decode (mangled
);
13698 if (demangled
!= mangled
&& demangled
[0] != '<')
13700 /* Set the gsymbol language to Ada, but still return 0.
13701 Two reasons for that:
13703 1. For Ada, we prefer computing the symbol's decoded name
13704 on the fly rather than pre-compute it, in order to save
13705 memory (Ada projects are typically very large).
13707 2. There are some areas in the definition of the GNAT
13708 encoding where, with a bit of bad luck, we might be able
13709 to decode a non-Ada symbol, generating an incorrect
13710 demangled name (Eg: names ending with "TB" for instance
13711 are identified as task bodies and so stripped from
13712 the decoded name returned).
13714 Returning true, here, but not setting *DEMANGLED, helps us get
13715 a little bit of the best of both worlds. Because we're last,
13716 we should not affect any of the other languages that were
13717 able to demangle the symbol before us; we get to correctly
13718 tag Ada symbols as such; and even if we incorrectly tagged a
13719 non-Ada symbol, which should be rare, any routing through the
13720 Ada language should be transparent (Ada tries to behave much
13721 like C/C++ with non-Ada symbols). */
13728 /* See language.h. */
13730 char *demangle_symbol (const char *mangled
, int options
) const override
13732 return ada_la_decode (mangled
, options
);
13735 /* See language.h. */
13737 void print_type (struct type
*type
, const char *varstring
,
13738 struct ui_file
*stream
, int show
, int level
,
13739 const struct type_print_options
*flags
) const override
13741 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13744 /* See language.h. */
13746 const char *word_break_characters (void) const override
13748 return ada_completer_word_break_characters
;
13751 /* See language.h. */
13753 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13754 complete_symbol_mode mode
,
13755 symbol_name_match_type name_match_type
,
13756 const char *text
, const char *word
,
13757 enum type_code code
) const override
13759 struct symbol
*sym
;
13760 const struct block
*b
, *surrounding_static_block
= 0;
13761 struct block_iterator iter
;
13763 gdb_assert (code
== TYPE_CODE_UNDEF
);
13765 lookup_name_info
lookup_name (text
, name_match_type
, true);
13767 /* First, look at the partial symtab symbols. */
13768 expand_symtabs_matching (NULL
,
13774 /* At this point scan through the misc symbol vectors and add each
13775 symbol you find to the list. Eventually we want to ignore
13776 anything that isn't a text symbol (everything else will be
13777 handled by the psymtab code above). */
13779 for (objfile
*objfile
: current_program_space
->objfiles ())
13781 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13785 if (completion_skip_symbol (mode
, msymbol
))
13788 language symbol_language
= msymbol
->language ();
13790 /* Ada minimal symbols won't have their language set to Ada. If
13791 we let completion_list_add_name compare using the
13792 default/C-like matcher, then when completing e.g., symbols in a
13793 package named "pck", we'd match internal Ada symbols like
13794 "pckS", which are invalid in an Ada expression, unless you wrap
13795 them in '<' '>' to request a verbatim match.
13797 Unfortunately, some Ada encoded names successfully demangle as
13798 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13799 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13800 with the wrong language set. Paper over that issue here. */
13801 if (symbol_language
== language_auto
13802 || symbol_language
== language_cplus
)
13803 symbol_language
= language_ada
;
13805 completion_list_add_name (tracker
,
13807 msymbol
->linkage_name (),
13808 lookup_name
, text
, word
);
13812 /* Search upwards from currently selected frame (so that we can
13813 complete on local vars. */
13815 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13817 if (!BLOCK_SUPERBLOCK (b
))
13818 surrounding_static_block
= b
; /* For elmin of dups */
13820 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13822 if (completion_skip_symbol (mode
, sym
))
13825 completion_list_add_name (tracker
,
13827 sym
->linkage_name (),
13828 lookup_name
, text
, word
);
13832 /* Go through the symtabs and check the externs and statics for
13833 symbols which match. */
13835 for (objfile
*objfile
: current_program_space
->objfiles ())
13837 for (compunit_symtab
*s
: objfile
->compunits ())
13840 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
13841 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13843 if (completion_skip_symbol (mode
, sym
))
13846 completion_list_add_name (tracker
,
13848 sym
->linkage_name (),
13849 lookup_name
, text
, word
);
13854 for (objfile
*objfile
: current_program_space
->objfiles ())
13856 for (compunit_symtab
*s
: objfile
->compunits ())
13859 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
13860 /* Don't do this block twice. */
13861 if (b
== surrounding_static_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
);
13877 /* See language.h. */
13879 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13880 (struct type
*type
, CORE_ADDR addr
) const override
13882 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
13883 std::string name
= type_to_string (type
);
13884 return gdb::unique_xmalloc_ptr
<char>
13885 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
13888 /* See language.h. */
13890 void value_print (struct value
*val
, struct ui_file
*stream
,
13891 const struct value_print_options
*options
) const override
13893 return ada_value_print (val
, stream
, options
);
13896 /* See language.h. */
13898 void value_print_inner
13899 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13900 const struct value_print_options
*options
) const override
13902 return ada_value_print_inner (val
, stream
, recurse
, options
);
13905 /* See language.h. */
13907 struct block_symbol lookup_symbol_nonlocal
13908 (const char *name
, const struct block
*block
,
13909 const domain_enum domain
) const override
13911 struct block_symbol sym
;
13913 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13914 if (sym
.symbol
!= NULL
)
13917 /* If we haven't found a match at this point, try the primitive
13918 types. In other languages, this search is performed before
13919 searching for global symbols in order to short-circuit that
13920 global-symbol search if it happens that the name corresponds
13921 to a primitive type. But we cannot do the same in Ada, because
13922 it is perfectly legitimate for a program to declare a type which
13923 has the same name as a standard type. If looking up a type in
13924 that situation, we have traditionally ignored the primitive type
13925 in favor of user-defined types. This is why, unlike most other
13926 languages, we search the primitive types this late and only after
13927 having searched the global symbols without success. */
13929 if (domain
== VAR_DOMAIN
)
13931 struct gdbarch
*gdbarch
;
13934 gdbarch
= target_gdbarch ();
13936 gdbarch
= block_gdbarch (block
);
13938 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
13939 if (sym
.symbol
!= NULL
)
13946 /* See language.h. */
13948 int parser (struct parser_state
*ps
) const override
13950 warnings_issued
= 0;
13951 return ada_parse (ps
);
13956 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
13957 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
13958 namespace) and converts operators that are user-defined into
13959 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
13960 a preferred result type [at the moment, only type void has any
13961 effect---causing procedures to be preferred over functions in calls].
13962 A null CONTEXT_TYPE indicates that a non-void return type is
13963 preferred. May change (expand) *EXP. */
13965 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
13968 struct type
*context_type
= NULL
;
13971 if (ps
->void_context_p
)
13972 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
13974 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
13975 ps
->block_tracker
);
13978 /* See language.h. */
13980 void emitchar (int ch
, struct type
*chtype
,
13981 struct ui_file
*stream
, int quoter
) const override
13983 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
13986 /* See language.h. */
13988 void printchar (int ch
, struct type
*chtype
,
13989 struct ui_file
*stream
) const override
13991 ada_printchar (ch
, chtype
, stream
);
13994 /* See language.h. */
13996 void printstr (struct ui_file
*stream
, struct type
*elttype
,
13997 const gdb_byte
*string
, unsigned int length
,
13998 const char *encoding
, int force_ellipses
,
13999 const struct value_print_options
*options
) const override
14001 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14002 force_ellipses
, options
);
14005 /* See language.h. */
14007 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14008 struct ui_file
*stream
) const override
14010 ada_print_typedef (type
, new_symbol
, stream
);
14013 /* See language.h. */
14015 bool is_string_type_p (struct type
*type
) const override
14017 return ada_is_string_type (type
);
14020 /* See language.h. */
14022 const char *struct_too_deep_ellipsis () const override
14023 { return "(...)"; }
14025 /* See language.h. */
14027 bool c_style_arrays_p () const override
14030 /* See language.h. */
14032 bool store_sym_names_in_linkage_form_p () const override
14035 /* See language.h. */
14037 const struct lang_varobj_ops
*varobj_ops () const override
14038 { return &ada_varobj_ops
; }
14040 /* See language.h. */
14042 const struct exp_descriptor
*expression_ops () const override
14043 { return &ada_exp_descriptor
; }
14045 /* See language.h. */
14047 const struct op_print
*opcode_print_table () const override
14048 { return ada_op_print_tab
; }
14051 /* See language.h. */
14053 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14054 (const lookup_name_info
&lookup_name
) const override
14056 return ada_get_symbol_name_matcher (lookup_name
);
14060 /* Single instance of the Ada language class. */
14062 static ada_language ada_language_defn
;
14064 /* Command-list for the "set/show ada" prefix command. */
14065 static struct cmd_list_element
*set_ada_list
;
14066 static struct cmd_list_element
*show_ada_list
;
14069 initialize_ada_catchpoint_ops (void)
14071 struct breakpoint_ops
*ops
;
14073 initialize_breakpoint_ops ();
14075 ops
= &catch_exception_breakpoint_ops
;
14076 *ops
= bkpt_breakpoint_ops
;
14077 ops
->allocate_location
= allocate_location_exception
;
14078 ops
->re_set
= re_set_exception
;
14079 ops
->check_status
= check_status_exception
;
14080 ops
->print_it
= print_it_exception
;
14081 ops
->print_one
= print_one_exception
;
14082 ops
->print_mention
= print_mention_exception
;
14083 ops
->print_recreate
= print_recreate_exception
;
14085 ops
= &catch_exception_unhandled_breakpoint_ops
;
14086 *ops
= bkpt_breakpoint_ops
;
14087 ops
->allocate_location
= allocate_location_exception
;
14088 ops
->re_set
= re_set_exception
;
14089 ops
->check_status
= check_status_exception
;
14090 ops
->print_it
= print_it_exception
;
14091 ops
->print_one
= print_one_exception
;
14092 ops
->print_mention
= print_mention_exception
;
14093 ops
->print_recreate
= print_recreate_exception
;
14095 ops
= &catch_assert_breakpoint_ops
;
14096 *ops
= bkpt_breakpoint_ops
;
14097 ops
->allocate_location
= allocate_location_exception
;
14098 ops
->re_set
= re_set_exception
;
14099 ops
->check_status
= check_status_exception
;
14100 ops
->print_it
= print_it_exception
;
14101 ops
->print_one
= print_one_exception
;
14102 ops
->print_mention
= print_mention_exception
;
14103 ops
->print_recreate
= print_recreate_exception
;
14105 ops
= &catch_handlers_breakpoint_ops
;
14106 *ops
= bkpt_breakpoint_ops
;
14107 ops
->allocate_location
= allocate_location_exception
;
14108 ops
->re_set
= re_set_exception
;
14109 ops
->check_status
= check_status_exception
;
14110 ops
->print_it
= print_it_exception
;
14111 ops
->print_one
= print_one_exception
;
14112 ops
->print_mention
= print_mention_exception
;
14113 ops
->print_recreate
= print_recreate_exception
;
14116 /* This module's 'new_objfile' observer. */
14119 ada_new_objfile_observer (struct objfile
*objfile
)
14121 ada_clear_symbol_cache ();
14124 /* This module's 'free_objfile' observer. */
14127 ada_free_objfile_observer (struct objfile
*objfile
)
14129 ada_clear_symbol_cache ();
14132 void _initialize_ada_language ();
14134 _initialize_ada_language ()
14136 initialize_ada_catchpoint_ops ();
14138 add_basic_prefix_cmd ("ada", no_class
,
14139 _("Prefix command for changing Ada-specific settings."),
14140 &set_ada_list
, "set ada ", 0, &setlist
);
14142 add_show_prefix_cmd ("ada", no_class
,
14143 _("Generic command for showing Ada-specific settings."),
14144 &show_ada_list
, "show ada ", 0, &showlist
);
14146 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14147 &trust_pad_over_xvs
, _("\
14148 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14149 Show whether an optimization trusting PAD types over XVS types is activated."),
14151 This is related to the encoding used by the GNAT compiler. The debugger\n\
14152 should normally trust the contents of PAD types, but certain older versions\n\
14153 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14154 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14155 work around this bug. It is always safe to turn this option \"off\", but\n\
14156 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14157 this option to \"off\" unless necessary."),
14158 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14160 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14161 &print_signatures
, _("\
14162 Enable or disable the output of formal and return types for functions in the \
14163 overloads selection menu."), _("\
14164 Show whether the output of formal and return types for functions in the \
14165 overloads selection menu is activated."),
14166 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14168 add_catch_command ("exception", _("\
14169 Catch Ada exceptions, when raised.\n\
14170 Usage: catch exception [ARG] [if CONDITION]\n\
14171 Without any argument, stop when any Ada exception is raised.\n\
14172 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14173 being raised does not have a handler (and will therefore lead to the task's\n\
14175 Otherwise, the catchpoint only stops when the name of the exception being\n\
14176 raised is the same as ARG.\n\
14177 CONDITION is a boolean expression that is evaluated to see whether the\n\
14178 exception should cause a stop."),
14179 catch_ada_exception_command
,
14180 catch_ada_completer
,
14184 add_catch_command ("handlers", _("\
14185 Catch Ada exceptions, when handled.\n\
14186 Usage: catch handlers [ARG] [if CONDITION]\n\
14187 Without any argument, stop when any Ada exception is handled.\n\
14188 With an argument, catch only exceptions with the given name.\n\
14189 CONDITION is a boolean expression that is evaluated to see whether the\n\
14190 exception should cause a stop."),
14191 catch_ada_handlers_command
,
14192 catch_ada_completer
,
14195 add_catch_command ("assert", _("\
14196 Catch failed Ada assertions, when raised.\n\
14197 Usage: catch assert [if CONDITION]\n\
14198 CONDITION is a boolean expression that is evaluated to see whether the\n\
14199 exception should cause a stop."),
14200 catch_assert_command
,
14205 varsize_limit
= 65536;
14206 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14207 &varsize_limit
, _("\
14208 Set the maximum number of bytes allowed in a variable-size object."), _("\
14209 Show the maximum number of bytes allowed in a variable-size object."), _("\
14210 Attempts to access an object whose size is not a compile-time constant\n\
14211 and exceeds this limit will cause an error."),
14212 NULL
, NULL
, &setlist
, &showlist
);
14214 add_info ("exceptions", info_exceptions_command
,
14216 List all Ada exception names.\n\
14217 Usage: info exceptions [REGEXP]\n\
14218 If a regular expression is passed as an argument, only those matching\n\
14219 the regular expression are listed."));
14221 add_basic_prefix_cmd ("ada", class_maintenance
,
14222 _("Set Ada maintenance-related variables."),
14223 &maint_set_ada_cmdlist
, "maintenance set ada ",
14224 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14226 add_show_prefix_cmd ("ada", class_maintenance
,
14227 _("Show Ada maintenance-related variables."),
14228 &maint_show_ada_cmdlist
, "maintenance show ada ",
14229 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14231 add_setshow_boolean_cmd
14232 ("ignore-descriptive-types", class_maintenance
,
14233 &ada_ignore_descriptive_types_p
,
14234 _("Set whether descriptive types generated by GNAT should be ignored."),
14235 _("Show whether descriptive types generated by GNAT should be ignored."),
14237 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14238 DWARF attribute."),
14239 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14241 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14242 NULL
, xcalloc
, xfree
);
14244 /* The ada-lang observers. */
14245 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14246 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14247 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);