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
= to_string (name
.substr (1, name
.size () - 2));
950 fold_storage
= 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[0..NSYMS-1] 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[0..N-1]. 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 OBSTACKP, 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.
4970 Returns the number of items in the modified list. */
4973 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
4977 /* We should never be called with less than 2 symbols, as there
4978 cannot be any extra symbol in that case. But it's easy to
4979 handle, since we have nothing to do in that case. */
4980 if (syms
->size () < 2)
4984 while (i
< syms
->size ())
4988 /* If two symbols have the same name and one of them is a stub type,
4989 the get rid of the stub. */
4991 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
4992 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
4994 for (j
= 0; j
< syms
->size (); j
++)
4997 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
4998 && (*syms
)[j
].symbol
->linkage_name () != NULL
4999 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5000 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5005 /* Two symbols with the same name, same class and same address
5006 should be identical. */
5008 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5009 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5010 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5012 for (j
= 0; j
< syms
->size (); j
+= 1)
5015 && (*syms
)[j
].symbol
->linkage_name () != NULL
5016 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5017 (*syms
)[j
].symbol
->linkage_name ()) == 0
5018 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5019 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5020 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5021 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5027 syms
->erase (syms
->begin () + i
);
5032 /* If all the remaining symbols are identical enumerals, then
5033 just keep the first one and discard the rest.
5035 Unlike what we did previously, we do not discard any entry
5036 unless they are ALL identical. This is because the symbol
5037 comparison is not a strict comparison, but rather a practical
5038 comparison. If all symbols are considered identical, then
5039 we can just go ahead and use the first one and discard the rest.
5040 But if we cannot reduce the list to a single element, we have
5041 to ask the user to disambiguate anyways. And if we have to
5042 present a multiple-choice menu, it's less confusing if the list
5043 isn't missing some choices that were identical and yet distinct. */
5044 if (symbols_are_identical_enums (*syms
))
5048 /* Given a type that corresponds to a renaming entity, use the type name
5049 to extract the scope (package name or function name, fully qualified,
5050 and following the GNAT encoding convention) where this renaming has been
5054 xget_renaming_scope (struct type
*renaming_type
)
5056 /* The renaming types adhere to the following convention:
5057 <scope>__<rename>___<XR extension>.
5058 So, to extract the scope, we search for the "___XR" extension,
5059 and then backtrack until we find the first "__". */
5061 const char *name
= renaming_type
->name ();
5062 const char *suffix
= strstr (name
, "___XR");
5065 /* Now, backtrack a bit until we find the first "__". Start looking
5066 at suffix - 3, as the <rename> part is at least one character long. */
5068 for (last
= suffix
- 3; last
> name
; last
--)
5069 if (last
[0] == '_' && last
[1] == '_')
5072 /* Make a copy of scope and return it. */
5073 return std::string (name
, last
);
5076 /* Return nonzero if NAME corresponds to a package name. */
5079 is_package_name (const char *name
)
5081 /* Here, We take advantage of the fact that no symbols are generated
5082 for packages, while symbols are generated for each function.
5083 So the condition for NAME represent a package becomes equivalent
5084 to NAME not existing in our list of symbols. There is only one
5085 small complication with library-level functions (see below). */
5087 /* If it is a function that has not been defined at library level,
5088 then we should be able to look it up in the symbols. */
5089 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5092 /* Library-level function names start with "_ada_". See if function
5093 "_ada_" followed by NAME can be found. */
5095 /* Do a quick check that NAME does not contain "__", since library-level
5096 functions names cannot contain "__" in them. */
5097 if (strstr (name
, "__") != NULL
)
5100 std::string fun_name
= string_printf ("_ada_%s", name
);
5102 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5105 /* Return nonzero if SYM corresponds to a renaming entity that is
5106 not visible from FUNCTION_NAME. */
5109 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5111 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5114 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5116 /* If the rename has been defined in a package, then it is visible. */
5117 if (is_package_name (scope
.c_str ()))
5120 /* Check that the rename is in the current function scope by checking
5121 that its name starts with SCOPE. */
5123 /* If the function name starts with "_ada_", it means that it is
5124 a library-level function. Strip this prefix before doing the
5125 comparison, as the encoding for the renaming does not contain
5127 if (startswith (function_name
, "_ada_"))
5130 return !startswith (function_name
, scope
.c_str ());
5133 /* Remove entries from SYMS that corresponds to a renaming entity that
5134 is not visible from the function associated with CURRENT_BLOCK or
5135 that is superfluous due to the presence of more specific renaming
5136 information. Places surviving symbols in the initial entries of
5140 First, in cases where an object renaming is implemented as a
5141 reference variable, GNAT may produce both the actual reference
5142 variable and the renaming encoding. In this case, we discard the
5145 Second, GNAT emits a type following a specified encoding for each renaming
5146 entity. Unfortunately, STABS currently does not support the definition
5147 of types that are local to a given lexical block, so all renamings types
5148 are emitted at library level. As a consequence, if an application
5149 contains two renaming entities using the same name, and a user tries to
5150 print the value of one of these entities, the result of the ada symbol
5151 lookup will also contain the wrong renaming type.
5153 This function partially covers for this limitation by attempting to
5154 remove from the SYMS list renaming symbols that should be visible
5155 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5156 method with the current information available. The implementation
5157 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5159 - When the user tries to print a rename in a function while there
5160 is another rename entity defined in a package: Normally, the
5161 rename in the function has precedence over the rename in the
5162 package, so the latter should be removed from the list. This is
5163 currently not the case.
5165 - This function will incorrectly remove valid renames if
5166 the CURRENT_BLOCK corresponds to a function which symbol name
5167 has been changed by an "Export" pragma. As a consequence,
5168 the user will be unable to print such rename entities. */
5171 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5172 const struct block
*current_block
)
5174 struct symbol
*current_function
;
5175 const char *current_function_name
;
5177 int is_new_style_renaming
;
5179 /* If there is both a renaming foo___XR... encoded as a variable and
5180 a simple variable foo in the same block, discard the latter.
5181 First, zero out such symbols, then compress. */
5182 is_new_style_renaming
= 0;
5183 for (i
= 0; i
< syms
->size (); i
+= 1)
5185 struct symbol
*sym
= (*syms
)[i
].symbol
;
5186 const struct block
*block
= (*syms
)[i
].block
;
5190 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5192 name
= sym
->linkage_name ();
5193 suffix
= strstr (name
, "___XR");
5197 int name_len
= suffix
- name
;
5200 is_new_style_renaming
= 1;
5201 for (j
= 0; j
< syms
->size (); j
+= 1)
5202 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5203 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5205 && block
== (*syms
)[j
].block
)
5206 (*syms
)[j
].symbol
= NULL
;
5209 if (is_new_style_renaming
)
5213 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5214 if ((*syms
)[j
].symbol
!= NULL
)
5216 (*syms
)[k
] = (*syms
)[j
];
5223 /* Extract the function name associated to CURRENT_BLOCK.
5224 Abort if unable to do so. */
5226 if (current_block
== NULL
)
5229 current_function
= block_linkage_function (current_block
);
5230 if (current_function
== NULL
)
5233 current_function_name
= current_function
->linkage_name ();
5234 if (current_function_name
== NULL
)
5237 /* Check each of the symbols, and remove it from the list if it is
5238 a type corresponding to a renaming that is out of the scope of
5239 the current block. */
5242 while (i
< syms
->size ())
5244 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5245 == ADA_OBJECT_RENAMING
5246 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5247 current_function_name
))
5248 syms
->erase (syms
->begin () + i
);
5254 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5255 whose name and domain match NAME and DOMAIN respectively.
5256 If no match was found, then extend the search to "enclosing"
5257 routines (in other words, if we're inside a nested function,
5258 search the symbols defined inside the enclosing functions).
5259 If WILD_MATCH_P is nonzero, perform the naming matching in
5260 "wild" mode (see function "wild_match" for more info).
5262 Note: This function assumes that RESULT has 0 (zero) element in it. */
5265 ada_add_local_symbols (std::vector
<struct block_symbol
> &result
,
5266 const lookup_name_info
&lookup_name
,
5267 const struct block
*block
, domain_enum domain
)
5269 int block_depth
= 0;
5271 while (block
!= NULL
)
5274 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5276 /* If we found a non-function match, assume that's the one. */
5277 if (is_nonfunction (result
))
5280 block
= BLOCK_SUPERBLOCK (block
);
5283 /* If no luck so far, try to find NAME as a local symbol in some lexically
5284 enclosing subprogram. */
5285 if (result
.empty () && block_depth
> 2)
5286 add_symbols_from_enclosing_procs (result
, lookup_name
, domain
);
5289 /* An object of this type is used as the user_data argument when
5290 calling the map_matching_symbols method. */
5294 struct objfile
*objfile
;
5295 std::vector
<struct block_symbol
> *resultp
;
5296 struct symbol
*arg_sym
;
5300 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5301 to a list of symbols. DATA is a pointer to a struct match_data *
5302 containing the obstack that collects the symbol list, the file that SYM
5303 must come from, a flag indicating whether a non-argument symbol has
5304 been found in the current block, and the last argument symbol
5305 passed in SYM within the current block (if any). When SYM is null,
5306 marking the end of a block, the argument symbol is added if no
5307 other has been found. */
5310 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5311 struct match_data
*data
)
5313 const struct block
*block
= bsym
->block
;
5314 struct symbol
*sym
= bsym
->symbol
;
5318 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5319 add_defn_to_vec (*data
->resultp
,
5320 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5322 data
->found_sym
= 0;
5323 data
->arg_sym
= NULL
;
5327 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5329 else if (SYMBOL_IS_ARGUMENT (sym
))
5330 data
->arg_sym
= sym
;
5333 data
->found_sym
= 1;
5334 add_defn_to_vec (*data
->resultp
,
5335 fixup_symbol_section (sym
, data
->objfile
),
5342 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5343 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5344 symbols to OBSTACKP. Return whether we found such symbols. */
5347 ada_add_block_renamings (std::vector
<struct block_symbol
> &result
,
5348 const struct block
*block
,
5349 const lookup_name_info
&lookup_name
,
5352 struct using_direct
*renaming
;
5353 int defns_mark
= result
.size ();
5355 symbol_name_matcher_ftype
*name_match
5356 = ada_get_symbol_name_matcher (lookup_name
);
5358 for (renaming
= block_using (block
);
5360 renaming
= renaming
->next
)
5364 /* Avoid infinite recursions: skip this renaming if we are actually
5365 already traversing it.
5367 Currently, symbol lookup in Ada don't use the namespace machinery from
5368 C++/Fortran support: skip namespace imports that use them. */
5369 if (renaming
->searched
5370 || (renaming
->import_src
!= NULL
5371 && renaming
->import_src
[0] != '\0')
5372 || (renaming
->import_dest
!= NULL
5373 && renaming
->import_dest
[0] != '\0'))
5375 renaming
->searched
= 1;
5377 /* TODO: here, we perform another name-based symbol lookup, which can
5378 pull its own multiple overloads. In theory, we should be able to do
5379 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5380 not a simple name. But in order to do this, we would need to enhance
5381 the DWARF reader to associate a symbol to this renaming, instead of a
5382 name. So, for now, we do something simpler: re-use the C++/Fortran
5383 namespace machinery. */
5384 r_name
= (renaming
->alias
!= NULL
5386 : renaming
->declaration
);
5387 if (name_match (r_name
, lookup_name
, NULL
))
5389 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5390 lookup_name
.match_type ());
5391 ada_add_all_symbols (result
, block
, decl_lookup_name
, domain
,
5394 renaming
->searched
= 0;
5396 return result
.size () != defns_mark
;
5399 /* Implements compare_names, but only applying the comparision using
5400 the given CASING. */
5403 compare_names_with_case (const char *string1
, const char *string2
,
5404 enum case_sensitivity casing
)
5406 while (*string1
!= '\0' && *string2
!= '\0')
5410 if (isspace (*string1
) || isspace (*string2
))
5411 return strcmp_iw_ordered (string1
, string2
);
5413 if (casing
== case_sensitive_off
)
5415 c1
= tolower (*string1
);
5416 c2
= tolower (*string2
);
5433 return strcmp_iw_ordered (string1
, string2
);
5435 if (*string2
== '\0')
5437 if (is_name_suffix (string1
))
5444 if (*string2
== '(')
5445 return strcmp_iw_ordered (string1
, string2
);
5448 if (casing
== case_sensitive_off
)
5449 return tolower (*string1
) - tolower (*string2
);
5451 return *string1
- *string2
;
5456 /* Compare STRING1 to STRING2, with results as for strcmp.
5457 Compatible with strcmp_iw_ordered in that...
5459 strcmp_iw_ordered (STRING1, STRING2) <= 0
5463 compare_names (STRING1, STRING2) <= 0
5465 (they may differ as to what symbols compare equal). */
5468 compare_names (const char *string1
, const char *string2
)
5472 /* Similar to what strcmp_iw_ordered does, we need to perform
5473 a case-insensitive comparison first, and only resort to
5474 a second, case-sensitive, comparison if the first one was
5475 not sufficient to differentiate the two strings. */
5477 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5479 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5484 /* Convenience function to get at the Ada encoded lookup name for
5485 LOOKUP_NAME, as a C string. */
5488 ada_lookup_name (const lookup_name_info
&lookup_name
)
5490 return lookup_name
.ada ().lookup_name ().c_str ();
5493 /* Add to OBSTACKP all non-local symbols whose name and domain match
5494 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5495 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5496 symbols otherwise. */
5499 add_nonlocal_symbols (std::vector
<struct block_symbol
> &result
,
5500 const lookup_name_info
&lookup_name
,
5501 domain_enum domain
, int global
)
5503 struct match_data data
;
5505 memset (&data
, 0, sizeof data
);
5506 data
.resultp
= &result
;
5508 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5510 auto callback
= [&] (struct block_symbol
*bsym
)
5512 return aux_add_nonlocal_symbols (bsym
, &data
);
5515 for (objfile
*objfile
: current_program_space
->objfiles ())
5517 data
.objfile
= objfile
;
5519 if (objfile
->sf
!= nullptr)
5520 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5521 domain
, global
, callback
,
5523 ? NULL
: compare_names
));
5525 for (compunit_symtab
*cu
: objfile
->compunits ())
5527 const struct block
*global_block
5528 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5530 if (ada_add_block_renamings (result
, global_block
, lookup_name
,
5536 if (result
.empty () && global
&& !is_wild_match
)
5538 const char *name
= ada_lookup_name (lookup_name
);
5539 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5540 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5542 for (objfile
*objfile
: current_program_space
->objfiles ())
5544 data
.objfile
= objfile
;
5545 if (objfile
->sf
!= nullptr)
5546 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5547 domain
, global
, callback
,
5553 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5554 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5555 returning the number of matches. Add these to OBSTACKP.
5557 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5558 symbol match within the nest of blocks whose innermost member is BLOCK,
5559 is the one match returned (no other matches in that or
5560 enclosing blocks is returned). If there are any matches in or
5561 surrounding BLOCK, then these alone are returned.
5563 Names prefixed with "standard__" are handled specially:
5564 "standard__" is first stripped off (by the lookup_name
5565 constructor), and only static and global symbols are searched.
5567 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5568 to lookup global symbols. */
5571 ada_add_all_symbols (std::vector
<struct block_symbol
> &result
,
5572 const struct block
*block
,
5573 const lookup_name_info
&lookup_name
,
5576 int *made_global_lookup_p
)
5580 if (made_global_lookup_p
)
5581 *made_global_lookup_p
= 0;
5583 /* Special case: If the user specifies a symbol name inside package
5584 Standard, do a non-wild matching of the symbol name without
5585 the "standard__" prefix. This was primarily introduced in order
5586 to allow the user to specifically access the standard exceptions
5587 using, for instance, Standard.Constraint_Error when Constraint_Error
5588 is ambiguous (due to the user defining its own Constraint_Error
5589 entity inside its program). */
5590 if (lookup_name
.ada ().standard_p ())
5593 /* Check the non-global symbols. If we have ANY match, then we're done. */
5598 ada_add_local_symbols (result
, lookup_name
, block
, domain
);
5601 /* In the !full_search case we're are being called by
5602 iterate_over_symbols, and we don't want to search
5604 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5606 if (!result
.empty () || !full_search
)
5610 /* No non-global symbols found. Check our cache to see if we have
5611 already performed this search before. If we have, then return
5614 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5615 domain
, &sym
, &block
))
5618 add_defn_to_vec (result
, sym
, block
);
5622 if (made_global_lookup_p
)
5623 *made_global_lookup_p
= 1;
5625 /* Search symbols from all global blocks. */
5627 add_nonlocal_symbols (result
, lookup_name
, domain
, 1);
5629 /* Now add symbols from all per-file blocks if we've gotten no hits
5630 (not strictly correct, but perhaps better than an error). */
5632 if (result
.empty ())
5633 add_nonlocal_symbols (result
, lookup_name
, domain
, 0);
5636 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5637 is non-zero, enclosing scope and in global scopes.
5639 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5640 blocks and symbol tables (if any) in which they were found.
5642 When full_search is non-zero, any non-function/non-enumeral
5643 symbol match within the nest of blocks whose innermost member is BLOCK,
5644 is the one match returned (no other matches in that or
5645 enclosing blocks is returned). If there are any matches in or
5646 surrounding BLOCK, then these alone are returned.
5648 Names prefixed with "standard__" are handled specially: "standard__"
5649 is first stripped off, and only static and global symbols are searched. */
5651 static std::vector
<struct block_symbol
>
5652 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5653 const struct block
*block
,
5657 int syms_from_global_search
;
5658 std::vector
<struct block_symbol
> results
;
5660 ada_add_all_symbols (results
, block
, lookup_name
,
5661 domain
, full_search
, &syms_from_global_search
);
5663 remove_extra_symbols (&results
);
5665 if (results
.empty () && full_search
&& syms_from_global_search
)
5666 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5668 if (results
.size () == 1 && full_search
&& syms_from_global_search
)
5669 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5670 results
[0].symbol
, results
[0].block
);
5672 remove_irrelevant_renamings (&results
, block
);
5676 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5677 in global scopes, returning (SYM,BLOCK) tuples.
5679 See ada_lookup_symbol_list_worker for further details. */
5681 std::vector
<struct block_symbol
>
5682 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5685 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5686 lookup_name_info
lookup_name (name
, name_match_type
);
5688 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, 1);
5691 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5692 to 1, but choosing the first symbol found if there are multiple
5695 The result is stored in *INFO, which must be non-NULL.
5696 If no match is found, INFO->SYM is set to NULL. */
5699 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5701 struct block_symbol
*info
)
5703 /* Since we already have an encoded name, wrap it in '<>' to force a
5704 verbatim match. Otherwise, if the name happens to not look like
5705 an encoded name (because it doesn't include a "__"),
5706 ada_lookup_name_info would re-encode/fold it again, and that
5707 would e.g., incorrectly lowercase object renaming names like
5708 "R28b" -> "r28b". */
5709 std::string verbatim
= add_angle_brackets (name
);
5711 gdb_assert (info
!= NULL
);
5712 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5715 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5716 scope and in global scopes, or NULL if none. NAME is folded and
5717 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5718 choosing the first symbol if there are multiple choices. */
5721 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5724 std::vector
<struct block_symbol
> candidates
5725 = ada_lookup_symbol_list (name
, block0
, domain
);
5727 if (candidates
.empty ())
5730 block_symbol info
= candidates
[0];
5731 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5736 /* True iff STR is a possible encoded suffix of a normal Ada name
5737 that is to be ignored for matching purposes. Suffixes of parallel
5738 names (e.g., XVE) are not included here. Currently, the possible suffixes
5739 are given by any of the regular expressions:
5741 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5742 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5743 TKB [subprogram suffix for task bodies]
5744 _E[0-9]+[bs]$ [protected object entry suffixes]
5745 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5747 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5748 match is performed. This sequence is used to differentiate homonyms,
5749 is an optional part of a valid name suffix. */
5752 is_name_suffix (const char *str
)
5755 const char *matching
;
5756 const int len
= strlen (str
);
5758 /* Skip optional leading __[0-9]+. */
5760 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5763 while (isdigit (str
[0]))
5769 if (str
[0] == '.' || str
[0] == '$')
5772 while (isdigit (matching
[0]))
5774 if (matching
[0] == '\0')
5780 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5783 while (isdigit (matching
[0]))
5785 if (matching
[0] == '\0')
5789 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5791 if (strcmp (str
, "TKB") == 0)
5795 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5796 with a N at the end. Unfortunately, the compiler uses the same
5797 convention for other internal types it creates. So treating
5798 all entity names that end with an "N" as a name suffix causes
5799 some regressions. For instance, consider the case of an enumerated
5800 type. To support the 'Image attribute, it creates an array whose
5802 Having a single character like this as a suffix carrying some
5803 information is a bit risky. Perhaps we should change the encoding
5804 to be something like "_N" instead. In the meantime, do not do
5805 the following check. */
5806 /* Protected Object Subprograms */
5807 if (len
== 1 && str
[0] == 'N')
5812 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5815 while (isdigit (matching
[0]))
5817 if ((matching
[0] == 'b' || matching
[0] == 's')
5818 && matching
[1] == '\0')
5822 /* ??? We should not modify STR directly, as we are doing below. This
5823 is fine in this case, but may become problematic later if we find
5824 that this alternative did not work, and want to try matching
5825 another one from the begining of STR. Since we modified it, we
5826 won't be able to find the begining of the string anymore! */
5830 while (str
[0] != '_' && str
[0] != '\0')
5832 if (str
[0] != 'n' && str
[0] != 'b')
5838 if (str
[0] == '\000')
5843 if (str
[1] != '_' || str
[2] == '\000')
5847 if (strcmp (str
+ 3, "JM") == 0)
5849 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5850 the LJM suffix in favor of the JM one. But we will
5851 still accept LJM as a valid suffix for a reasonable
5852 amount of time, just to allow ourselves to debug programs
5853 compiled using an older version of GNAT. */
5854 if (strcmp (str
+ 3, "LJM") == 0)
5858 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5859 || str
[4] == 'U' || str
[4] == 'P')
5861 if (str
[4] == 'R' && str
[5] != 'T')
5865 if (!isdigit (str
[2]))
5867 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5868 if (!isdigit (str
[k
]) && str
[k
] != '_')
5872 if (str
[0] == '$' && isdigit (str
[1]))
5874 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5875 if (!isdigit (str
[k
]) && str
[k
] != '_')
5882 /* Return non-zero if the string starting at NAME and ending before
5883 NAME_END contains no capital letters. */
5886 is_valid_name_for_wild_match (const char *name0
)
5888 std::string decoded_name
= ada_decode (name0
);
5891 /* If the decoded name starts with an angle bracket, it means that
5892 NAME0 does not follow the GNAT encoding format. It should then
5893 not be allowed as a possible wild match. */
5894 if (decoded_name
[0] == '<')
5897 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5898 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5904 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5905 character which could start a simple name. Assumes that *NAMEP points
5906 somewhere inside the string beginning at NAME0. */
5909 advance_wild_match (const char **namep
, const char *name0
, char target0
)
5911 const char *name
= *namep
;
5921 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5924 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
5929 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
5930 || name
[2] == target0
))
5935 else if (t1
== '_' && name
[2] == 'B' && name
[3] == '_')
5937 /* Names like "pkg__B_N__name", where N is a number, are
5938 block-local. We can handle these by simply skipping
5945 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5955 /* Return true iff NAME encodes a name of the form prefix.PATN.
5956 Ignores any informational suffixes of NAME (i.e., for which
5957 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
5961 wild_match (const char *name
, const char *patn
)
5964 const char *name0
= name
;
5968 const char *match
= name
;
5972 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5975 if (*p
== '\0' && is_name_suffix (name
))
5976 return match
== name0
|| is_valid_name_for_wild_match (name0
);
5978 if (name
[-1] == '_')
5981 if (!advance_wild_match (&name
, name0
, *patn
))
5986 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5987 necessary). OBJFILE is the section containing BLOCK. */
5990 ada_add_block_symbols (std::vector
<struct block_symbol
> &result
,
5991 const struct block
*block
,
5992 const lookup_name_info
&lookup_name
,
5993 domain_enum domain
, struct objfile
*objfile
)
5995 struct block_iterator iter
;
5996 /* A matching argument symbol, if any. */
5997 struct symbol
*arg_sym
;
5998 /* Set true when we find a matching non-argument symbol. */
6004 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6006 sym
= block_iter_match_next (lookup_name
, &iter
))
6008 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6010 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6012 if (SYMBOL_IS_ARGUMENT (sym
))
6017 add_defn_to_vec (result
,
6018 fixup_symbol_section (sym
, objfile
),
6025 /* Handle renamings. */
6027 if (ada_add_block_renamings (result
, block
, lookup_name
, domain
))
6030 if (!found_sym
&& arg_sym
!= NULL
)
6032 add_defn_to_vec (result
,
6033 fixup_symbol_section (arg_sym
, objfile
),
6037 if (!lookup_name
.ada ().wild_match_p ())
6041 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6042 const char *name
= ada_lookup_name
.c_str ();
6043 size_t name_len
= ada_lookup_name
.size ();
6045 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6047 if (symbol_matches_domain (sym
->language (),
6048 SYMBOL_DOMAIN (sym
), domain
))
6052 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6055 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6057 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6062 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6064 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6066 if (SYMBOL_IS_ARGUMENT (sym
))
6071 add_defn_to_vec (result
,
6072 fixup_symbol_section (sym
, objfile
),
6080 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6081 They aren't parameters, right? */
6082 if (!found_sym
&& arg_sym
!= NULL
)
6084 add_defn_to_vec (result
,
6085 fixup_symbol_section (arg_sym
, objfile
),
6092 /* Symbol Completion */
6097 ada_lookup_name_info::matches
6098 (const char *sym_name
,
6099 symbol_name_match_type match_type
,
6100 completion_match_result
*comp_match_res
) const
6103 const char *text
= m_encoded_name
.c_str ();
6104 size_t text_len
= m_encoded_name
.size ();
6106 /* First, test against the fully qualified name of the symbol. */
6108 if (strncmp (sym_name
, text
, text_len
) == 0)
6111 std::string decoded_name
= ada_decode (sym_name
);
6112 if (match
&& !m_encoded_p
)
6114 /* One needed check before declaring a positive match is to verify
6115 that iff we are doing a verbatim match, the decoded version
6116 of the symbol name starts with '<'. Otherwise, this symbol name
6117 is not a suitable completion. */
6119 bool has_angle_bracket
= (decoded_name
[0] == '<');
6120 match
= (has_angle_bracket
== m_verbatim_p
);
6123 if (match
&& !m_verbatim_p
)
6125 /* When doing non-verbatim match, another check that needs to
6126 be done is to verify that the potentially matching symbol name
6127 does not include capital letters, because the ada-mode would
6128 not be able to understand these symbol names without the
6129 angle bracket notation. */
6132 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6137 /* Second: Try wild matching... */
6139 if (!match
&& m_wild_match_p
)
6141 /* Since we are doing wild matching, this means that TEXT
6142 may represent an unqualified symbol name. We therefore must
6143 also compare TEXT against the unqualified name of the symbol. */
6144 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6146 if (strncmp (sym_name
, text
, text_len
) == 0)
6150 /* Finally: If we found a match, prepare the result to return. */
6155 if (comp_match_res
!= NULL
)
6157 std::string
&match_str
= comp_match_res
->match
.storage ();
6160 match_str
= ada_decode (sym_name
);
6164 match_str
= add_angle_brackets (sym_name
);
6166 match_str
= sym_name
;
6170 comp_match_res
->set_match (match_str
.c_str ());
6178 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6179 for tagged types. */
6182 ada_is_dispatch_table_ptr_type (struct type
*type
)
6186 if (type
->code () != TYPE_CODE_PTR
)
6189 name
= TYPE_TARGET_TYPE (type
)->name ();
6193 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6196 /* Return non-zero if TYPE is an interface tag. */
6199 ada_is_interface_tag (struct type
*type
)
6201 const char *name
= type
->name ();
6206 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6209 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6210 to be invisible to users. */
6213 ada_is_ignored_field (struct type
*type
, int field_num
)
6215 if (field_num
< 0 || field_num
> type
->num_fields ())
6218 /* Check the name of that field. */
6220 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6222 /* Anonymous field names should not be printed.
6223 brobecker/2007-02-20: I don't think this can actually happen
6224 but we don't want to print the value of anonymous fields anyway. */
6228 /* Normally, fields whose name start with an underscore ("_")
6229 are fields that have been internally generated by the compiler,
6230 and thus should not be printed. The "_parent" field is special,
6231 however: This is a field internally generated by the compiler
6232 for tagged types, and it contains the components inherited from
6233 the parent type. This field should not be printed as is, but
6234 should not be ignored either. */
6235 if (name
[0] == '_' && !startswith (name
, "_parent"))
6239 /* If this is the dispatch table of a tagged type or an interface tag,
6241 if (ada_is_tagged_type (type
, 1)
6242 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6243 || ada_is_interface_tag (type
->field (field_num
).type ())))
6246 /* Not a special field, so it should not be ignored. */
6250 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6251 pointer or reference type whose ultimate target has a tag field. */
6254 ada_is_tagged_type (struct type
*type
, int refok
)
6256 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6259 /* True iff TYPE represents the type of X'Tag */
6262 ada_is_tag_type (struct type
*type
)
6264 type
= ada_check_typedef (type
);
6266 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6270 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6272 return (name
!= NULL
6273 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6277 /* The type of the tag on VAL. */
6279 static struct type
*
6280 ada_tag_type (struct value
*val
)
6282 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6285 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6286 retired at Ada 05). */
6289 is_ada95_tag (struct value
*tag
)
6291 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6294 /* The value of the tag on VAL. */
6296 static struct value
*
6297 ada_value_tag (struct value
*val
)
6299 return ada_value_struct_elt (val
, "_tag", 0);
6302 /* The value of the tag on the object of type TYPE whose contents are
6303 saved at VALADDR, if it is non-null, or is at memory address
6306 static struct value
*
6307 value_tag_from_contents_and_address (struct type
*type
,
6308 const gdb_byte
*valaddr
,
6311 int tag_byte_offset
;
6312 struct type
*tag_type
;
6314 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6317 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6319 : valaddr
+ tag_byte_offset
);
6320 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6322 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6327 static struct type
*
6328 type_from_tag (struct value
*tag
)
6330 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6332 if (type_name
!= NULL
)
6333 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6337 /* Given a value OBJ of a tagged type, return a value of this
6338 type at the base address of the object. The base address, as
6339 defined in Ada.Tags, it is the address of the primary tag of
6340 the object, and therefore where the field values of its full
6341 view can be fetched. */
6344 ada_tag_value_at_base_address (struct value
*obj
)
6347 LONGEST offset_to_top
= 0;
6348 struct type
*ptr_type
, *obj_type
;
6350 CORE_ADDR base_address
;
6352 obj_type
= value_type (obj
);
6354 /* It is the responsability of the caller to deref pointers. */
6356 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6359 tag
= ada_value_tag (obj
);
6363 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6365 if (is_ada95_tag (tag
))
6368 ptr_type
= language_lookup_primitive_type
6369 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6370 ptr_type
= lookup_pointer_type (ptr_type
);
6371 val
= value_cast (ptr_type
, tag
);
6375 /* It is perfectly possible that an exception be raised while
6376 trying to determine the base address, just like for the tag;
6377 see ada_tag_name for more details. We do not print the error
6378 message for the same reason. */
6382 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6385 catch (const gdb_exception_error
&e
)
6390 /* If offset is null, nothing to do. */
6392 if (offset_to_top
== 0)
6395 /* -1 is a special case in Ada.Tags; however, what should be done
6396 is not quite clear from the documentation. So do nothing for
6399 if (offset_to_top
== -1)
6402 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6403 from the base address. This was however incompatible with
6404 C++ dispatch table: C++ uses a *negative* value to *add*
6405 to the base address. Ada's convention has therefore been
6406 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6407 use the same convention. Here, we support both cases by
6408 checking the sign of OFFSET_TO_TOP. */
6410 if (offset_to_top
> 0)
6411 offset_to_top
= -offset_to_top
;
6413 base_address
= value_address (obj
) + offset_to_top
;
6414 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6416 /* Make sure that we have a proper tag at the new address.
6417 Otherwise, offset_to_top is bogus (which can happen when
6418 the object is not initialized yet). */
6423 obj_type
= type_from_tag (tag
);
6428 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6431 /* Return the "ada__tags__type_specific_data" type. */
6433 static struct type
*
6434 ada_get_tsd_type (struct inferior
*inf
)
6436 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6438 if (data
->tsd_type
== 0)
6439 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6440 return data
->tsd_type
;
6443 /* Return the TSD (type-specific data) associated to the given TAG.
6444 TAG is assumed to be the tag of a tagged-type entity.
6446 May return NULL if we are unable to get the TSD. */
6448 static struct value
*
6449 ada_get_tsd_from_tag (struct value
*tag
)
6454 /* First option: The TSD is simply stored as a field of our TAG.
6455 Only older versions of GNAT would use this format, but we have
6456 to test it first, because there are no visible markers for
6457 the current approach except the absence of that field. */
6459 val
= ada_value_struct_elt (tag
, "tsd", 1);
6463 /* Try the second representation for the dispatch table (in which
6464 there is no explicit 'tsd' field in the referent of the tag pointer,
6465 and instead the tsd pointer is stored just before the dispatch
6468 type
= ada_get_tsd_type (current_inferior());
6471 type
= lookup_pointer_type (lookup_pointer_type (type
));
6472 val
= value_cast (type
, tag
);
6475 return value_ind (value_ptradd (val
, -1));
6478 /* Given the TSD of a tag (type-specific data), return a string
6479 containing the name of the associated type.
6481 May return NULL if we are unable to determine the tag name. */
6483 static gdb::unique_xmalloc_ptr
<char>
6484 ada_tag_name_from_tsd (struct value
*tsd
)
6489 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6492 gdb::unique_xmalloc_ptr
<char> buffer
6493 = target_read_string (value_as_address (val
), INT_MAX
);
6494 if (buffer
== nullptr)
6497 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6506 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6509 Return NULL if the TAG is not an Ada tag, or if we were unable to
6510 determine the name of that tag. */
6512 gdb::unique_xmalloc_ptr
<char>
6513 ada_tag_name (struct value
*tag
)
6515 gdb::unique_xmalloc_ptr
<char> name
;
6517 if (!ada_is_tag_type (value_type (tag
)))
6520 /* It is perfectly possible that an exception be raised while trying
6521 to determine the TAG's name, even under normal circumstances:
6522 The associated variable may be uninitialized or corrupted, for
6523 instance. We do not let any exception propagate past this point.
6524 instead we return NULL.
6526 We also do not print the error message either (which often is very
6527 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6528 the caller print a more meaningful message if necessary. */
6531 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6534 name
= ada_tag_name_from_tsd (tsd
);
6536 catch (const gdb_exception_error
&e
)
6543 /* The parent type of TYPE, or NULL if none. */
6546 ada_parent_type (struct type
*type
)
6550 type
= ada_check_typedef (type
);
6552 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6555 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6556 if (ada_is_parent_field (type
, i
))
6558 struct type
*parent_type
= type
->field (i
).type ();
6560 /* If the _parent field is a pointer, then dereference it. */
6561 if (parent_type
->code () == TYPE_CODE_PTR
)
6562 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6563 /* If there is a parallel XVS type, get the actual base type. */
6564 parent_type
= ada_get_base_type (parent_type
);
6566 return ada_check_typedef (parent_type
);
6572 /* True iff field number FIELD_NUM of structure type TYPE contains the
6573 parent-type (inherited) fields of a derived type. Assumes TYPE is
6574 a structure type with at least FIELD_NUM+1 fields. */
6577 ada_is_parent_field (struct type
*type
, int field_num
)
6579 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6581 return (name
!= NULL
6582 && (startswith (name
, "PARENT")
6583 || startswith (name
, "_parent")));
6586 /* True iff field number FIELD_NUM of structure type TYPE is a
6587 transparent wrapper field (which should be silently traversed when doing
6588 field selection and flattened when printing). Assumes TYPE is a
6589 structure type with at least FIELD_NUM+1 fields. Such fields are always
6593 ada_is_wrapper_field (struct type
*type
, int field_num
)
6595 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6597 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6599 /* This happens in functions with "out" or "in out" parameters
6600 which are passed by copy. For such functions, GNAT describes
6601 the function's return type as being a struct where the return
6602 value is in a field called RETVAL, and where the other "out"
6603 or "in out" parameters are fields of that struct. This is not
6608 return (name
!= NULL
6609 && (startswith (name
, "PARENT")
6610 || strcmp (name
, "REP") == 0
6611 || startswith (name
, "_parent")
6612 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6615 /* True iff field number FIELD_NUM of structure or union type TYPE
6616 is a variant wrapper. Assumes TYPE is a structure type with at least
6617 FIELD_NUM+1 fields. */
6620 ada_is_variant_part (struct type
*type
, int field_num
)
6622 /* Only Ada types are eligible. */
6623 if (!ADA_TYPE_P (type
))
6626 struct type
*field_type
= type
->field (field_num
).type ();
6628 return (field_type
->code () == TYPE_CODE_UNION
6629 || (is_dynamic_field (type
, field_num
)
6630 && (TYPE_TARGET_TYPE (field_type
)->code ()
6631 == TYPE_CODE_UNION
)));
6634 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6635 whose discriminants are contained in the record type OUTER_TYPE,
6636 returns the type of the controlling discriminant for the variant.
6637 May return NULL if the type could not be found. */
6640 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6642 const char *name
= ada_variant_discrim_name (var_type
);
6644 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6647 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6648 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6649 represents a 'when others' clause; otherwise 0. */
6652 ada_is_others_clause (struct type
*type
, int field_num
)
6654 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6656 return (name
!= NULL
&& name
[0] == 'O');
6659 /* Assuming that TYPE0 is the type of the variant part of a record,
6660 returns the name of the discriminant controlling the variant.
6661 The value is valid until the next call to ada_variant_discrim_name. */
6664 ada_variant_discrim_name (struct type
*type0
)
6666 static std::string result
;
6669 const char *discrim_end
;
6670 const char *discrim_start
;
6672 if (type0
->code () == TYPE_CODE_PTR
)
6673 type
= TYPE_TARGET_TYPE (type0
);
6677 name
= ada_type_name (type
);
6679 if (name
== NULL
|| name
[0] == '\000')
6682 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6685 if (startswith (discrim_end
, "___XVN"))
6688 if (discrim_end
== name
)
6691 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6694 if (discrim_start
== name
+ 1)
6696 if ((discrim_start
> name
+ 3
6697 && startswith (discrim_start
- 3, "___"))
6698 || discrim_start
[-1] == '.')
6702 result
= std::string (discrim_start
, discrim_end
- discrim_start
);
6703 return result
.c_str ();
6706 /* Scan STR for a subtype-encoded number, beginning at position K.
6707 Put the position of the character just past the number scanned in
6708 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6709 Return 1 if there was a valid number at the given position, and 0
6710 otherwise. A "subtype-encoded" number consists of the absolute value
6711 in decimal, followed by the letter 'm' to indicate a negative number.
6712 Assumes 0m does not occur. */
6715 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6719 if (!isdigit (str
[k
]))
6722 /* Do it the hard way so as not to make any assumption about
6723 the relationship of unsigned long (%lu scan format code) and
6726 while (isdigit (str
[k
]))
6728 RU
= RU
* 10 + (str
[k
] - '0');
6735 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6741 /* NOTE on the above: Technically, C does not say what the results of
6742 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6743 number representable as a LONGEST (although either would probably work
6744 in most implementations). When RU>0, the locution in the then branch
6745 above is always equivalent to the negative of RU. */
6752 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6753 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6754 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6757 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6759 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6773 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6783 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6784 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6786 if (val
>= L
&& val
<= U
)
6798 /* FIXME: Lots of redundancy below. Try to consolidate. */
6800 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6801 ARG_TYPE, extract and return the value of one of its (non-static)
6802 fields. FIELDNO says which field. Differs from value_primitive_field
6803 only in that it can handle packed values of arbitrary type. */
6806 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6807 struct type
*arg_type
)
6811 arg_type
= ada_check_typedef (arg_type
);
6812 type
= arg_type
->field (fieldno
).type ();
6814 /* Handle packed fields. It might be that the field is not packed
6815 relative to its containing structure, but the structure itself is
6816 packed; in this case we must take the bit-field path. */
6817 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6819 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6820 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6822 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6823 offset
+ bit_pos
/ 8,
6824 bit_pos
% 8, bit_size
, type
);
6827 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6830 /* Find field with name NAME in object of type TYPE. If found,
6831 set the following for each argument that is non-null:
6832 - *FIELD_TYPE_P to the field's type;
6833 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6834 an object of that type;
6835 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6836 - *BIT_SIZE_P to its size in bits if the field is packed, and
6838 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6839 fields up to but not including the desired field, or by the total
6840 number of fields if not found. A NULL value of NAME never
6841 matches; the function just counts visible fields in this case.
6843 Notice that we need to handle when a tagged record hierarchy
6844 has some components with the same name, like in this scenario:
6846 type Top_T is tagged record
6852 type Middle_T is new Top.Top_T with record
6853 N : Character := 'a';
6857 type Bottom_T is new Middle.Middle_T with record
6859 C : Character := '5';
6861 A : Character := 'J';
6864 Let's say we now have a variable declared and initialized as follow:
6866 TC : Top_A := new Bottom_T;
6868 And then we use this variable to call this function
6870 procedure Assign (Obj: in out Top_T; TV : Integer);
6874 Assign (Top_T (B), 12);
6876 Now, we're in the debugger, and we're inside that procedure
6877 then and we want to print the value of obj.c:
6879 Usually, the tagged record or one of the parent type owns the
6880 component to print and there's no issue but in this particular
6881 case, what does it mean to ask for Obj.C? Since the actual
6882 type for object is type Bottom_T, it could mean two things: type
6883 component C from the Middle_T view, but also component C from
6884 Bottom_T. So in that "undefined" case, when the component is
6885 not found in the non-resolved type (which includes all the
6886 components of the parent type), then resolve it and see if we
6887 get better luck once expanded.
6889 In the case of homonyms in the derived tagged type, we don't
6890 guaranty anything, and pick the one that's easiest for us
6893 Returns 1 if found, 0 otherwise. */
6896 find_struct_field (const char *name
, struct type
*type
, int offset
,
6897 struct type
**field_type_p
,
6898 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6902 int parent_offset
= -1;
6904 type
= ada_check_typedef (type
);
6906 if (field_type_p
!= NULL
)
6907 *field_type_p
= NULL
;
6908 if (byte_offset_p
!= NULL
)
6910 if (bit_offset_p
!= NULL
)
6912 if (bit_size_p
!= NULL
)
6915 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6917 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6918 int fld_offset
= offset
+ bit_pos
/ 8;
6919 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6921 if (t_field_name
== NULL
)
6924 else if (ada_is_parent_field (type
, i
))
6926 /* This is a field pointing us to the parent type of a tagged
6927 type. As hinted in this function's documentation, we give
6928 preference to fields in the current record first, so what
6929 we do here is just record the index of this field before
6930 we skip it. If it turns out we couldn't find our field
6931 in the current record, then we'll get back to it and search
6932 inside it whether the field might exist in the parent. */
6938 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6940 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6942 if (field_type_p
!= NULL
)
6943 *field_type_p
= type
->field (i
).type ();
6944 if (byte_offset_p
!= NULL
)
6945 *byte_offset_p
= fld_offset
;
6946 if (bit_offset_p
!= NULL
)
6947 *bit_offset_p
= bit_pos
% 8;
6948 if (bit_size_p
!= NULL
)
6949 *bit_size_p
= bit_size
;
6952 else if (ada_is_wrapper_field (type
, i
))
6954 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
6955 field_type_p
, byte_offset_p
, bit_offset_p
,
6956 bit_size_p
, index_p
))
6959 else if (ada_is_variant_part (type
, i
))
6961 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6964 struct type
*field_type
6965 = ada_check_typedef (type
->field (i
).type ());
6967 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
6969 if (find_struct_field (name
, field_type
->field (j
).type (),
6971 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6972 field_type_p
, byte_offset_p
,
6973 bit_offset_p
, bit_size_p
, index_p
))
6977 else if (index_p
!= NULL
)
6981 /* Field not found so far. If this is a tagged type which
6982 has a parent, try finding that field in the parent now. */
6984 if (parent_offset
!= -1)
6986 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
6987 int fld_offset
= offset
+ bit_pos
/ 8;
6989 if (find_struct_field (name
, type
->field (parent_offset
).type (),
6990 fld_offset
, field_type_p
, byte_offset_p
,
6991 bit_offset_p
, bit_size_p
, index_p
))
6998 /* Number of user-visible fields in record type TYPE. */
7001 num_visible_fields (struct type
*type
)
7006 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7010 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7011 and search in it assuming it has (class) type TYPE.
7012 If found, return value, else return NULL.
7014 Searches recursively through wrapper fields (e.g., '_parent').
7016 In the case of homonyms in the tagged types, please refer to the
7017 long explanation in find_struct_field's function documentation. */
7019 static struct value
*
7020 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7024 int parent_offset
= -1;
7026 type
= ada_check_typedef (type
);
7027 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7029 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7031 if (t_field_name
== NULL
)
7034 else if (ada_is_parent_field (type
, i
))
7036 /* This is a field pointing us to the parent type of a tagged
7037 type. As hinted in this function's documentation, we give
7038 preference to fields in the current record first, so what
7039 we do here is just record the index of this field before
7040 we skip it. If it turns out we couldn't find our field
7041 in the current record, then we'll get back to it and search
7042 inside it whether the field might exist in the parent. */
7048 else if (field_name_match (t_field_name
, name
))
7049 return ada_value_primitive_field (arg
, offset
, i
, type
);
7051 else if (ada_is_wrapper_field (type
, i
))
7053 struct value
*v
= /* Do not let indent join lines here. */
7054 ada_search_struct_field (name
, arg
,
7055 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7056 type
->field (i
).type ());
7062 else if (ada_is_variant_part (type
, i
))
7064 /* PNH: Do we ever get here? See find_struct_field. */
7066 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7067 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7069 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7071 struct value
*v
= ada_search_struct_field
/* Force line
7074 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7075 field_type
->field (j
).type ());
7083 /* Field not found so far. If this is a tagged type which
7084 has a parent, try finding that field in the parent now. */
7086 if (parent_offset
!= -1)
7088 struct value
*v
= ada_search_struct_field (
7089 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7090 type
->field (parent_offset
).type ());
7099 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7100 int, struct type
*);
7103 /* Return field #INDEX in ARG, where the index is that returned by
7104 * find_struct_field through its INDEX_P argument. Adjust the address
7105 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7106 * If found, return value, else return NULL. */
7108 static struct value
*
7109 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7112 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7116 /* Auxiliary function for ada_index_struct_field. Like
7117 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7120 static struct value
*
7121 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7125 type
= ada_check_typedef (type
);
7127 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7129 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7131 else if (ada_is_wrapper_field (type
, i
))
7133 struct value
*v
= /* Do not let indent join lines here. */
7134 ada_index_struct_field_1 (index_p
, arg
,
7135 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7136 type
->field (i
).type ());
7142 else if (ada_is_variant_part (type
, i
))
7144 /* PNH: Do we ever get here? See ada_search_struct_field,
7145 find_struct_field. */
7146 error (_("Cannot assign this kind of variant record"));
7148 else if (*index_p
== 0)
7149 return ada_value_primitive_field (arg
, offset
, i
, type
);
7156 /* Return a string representation of type TYPE. */
7159 type_as_string (struct type
*type
)
7161 string_file tmp_stream
;
7163 type_print (type
, "", &tmp_stream
, -1);
7165 return std::move (tmp_stream
.string ());
7168 /* Given a type TYPE, look up the type of the component of type named NAME.
7169 If DISPP is non-null, add its byte displacement from the beginning of a
7170 structure (pointed to by a value) of type TYPE to *DISPP (does not
7171 work for packed fields).
7173 Matches any field whose name has NAME as a prefix, possibly
7176 TYPE can be either a struct or union. If REFOK, TYPE may also
7177 be a (pointer or reference)+ to a struct or union, and the
7178 ultimate target type will be searched.
7180 Looks recursively into variant clauses and parent types.
7182 In the case of homonyms in the tagged types, please refer to the
7183 long explanation in find_struct_field's function documentation.
7185 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7186 TYPE is not a type of the right kind. */
7188 static struct type
*
7189 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7193 int parent_offset
= -1;
7198 if (refok
&& type
!= NULL
)
7201 type
= ada_check_typedef (type
);
7202 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7204 type
= TYPE_TARGET_TYPE (type
);
7208 || (type
->code () != TYPE_CODE_STRUCT
7209 && type
->code () != TYPE_CODE_UNION
))
7214 error (_("Type %s is not a structure or union type"),
7215 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7218 type
= to_static_fixed_type (type
);
7220 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7222 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7225 if (t_field_name
== NULL
)
7228 else if (ada_is_parent_field (type
, i
))
7230 /* This is a field pointing us to the parent type of a tagged
7231 type. As hinted in this function's documentation, we give
7232 preference to fields in the current record first, so what
7233 we do here is just record the index of this field before
7234 we skip it. If it turns out we couldn't find our field
7235 in the current record, then we'll get back to it and search
7236 inside it whether the field might exist in the parent. */
7242 else if (field_name_match (t_field_name
, name
))
7243 return type
->field (i
).type ();
7245 else if (ada_is_wrapper_field (type
, i
))
7247 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7253 else if (ada_is_variant_part (type
, i
))
7256 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7258 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7260 /* FIXME pnh 2008/01/26: We check for a field that is
7261 NOT wrapped in a struct, since the compiler sometimes
7262 generates these for unchecked variant types. Revisit
7263 if the compiler changes this practice. */
7264 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7266 if (v_field_name
!= NULL
7267 && field_name_match (v_field_name
, name
))
7268 t
= field_type
->field (j
).type ();
7270 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7280 /* Field not found so far. If this is a tagged type which
7281 has a parent, try finding that field in the parent now. */
7283 if (parent_offset
!= -1)
7287 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7296 const char *name_str
= name
!= NULL
? name
: _("<null>");
7298 error (_("Type %s has no component named %s"),
7299 type_as_string (type
).c_str (), name_str
);
7305 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7306 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7307 represents an unchecked union (that is, the variant part of a
7308 record that is named in an Unchecked_Union pragma). */
7311 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7313 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7315 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7319 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7320 within OUTER, determine which variant clause (field number in VAR_TYPE,
7321 numbering from 0) is applicable. Returns -1 if none are. */
7324 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7328 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7329 struct value
*discrim
;
7330 LONGEST discrim_val
;
7332 /* Using plain value_from_contents_and_address here causes problems
7333 because we will end up trying to resolve a type that is currently
7334 being constructed. */
7335 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7336 if (discrim
== NULL
)
7338 discrim_val
= value_as_long (discrim
);
7341 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7343 if (ada_is_others_clause (var_type
, i
))
7345 else if (ada_in_variant (discrim_val
, var_type
, i
))
7349 return others_clause
;
7354 /* Dynamic-Sized Records */
7356 /* Strategy: The type ostensibly attached to a value with dynamic size
7357 (i.e., a size that is not statically recorded in the debugging
7358 data) does not accurately reflect the size or layout of the value.
7359 Our strategy is to convert these values to values with accurate,
7360 conventional types that are constructed on the fly. */
7362 /* There is a subtle and tricky problem here. In general, we cannot
7363 determine the size of dynamic records without its data. However,
7364 the 'struct value' data structure, which GDB uses to represent
7365 quantities in the inferior process (the target), requires the size
7366 of the type at the time of its allocation in order to reserve space
7367 for GDB's internal copy of the data. That's why the
7368 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7369 rather than struct value*s.
7371 However, GDB's internal history variables ($1, $2, etc.) are
7372 struct value*s containing internal copies of the data that are not, in
7373 general, the same as the data at their corresponding addresses in
7374 the target. Fortunately, the types we give to these values are all
7375 conventional, fixed-size types (as per the strategy described
7376 above), so that we don't usually have to perform the
7377 'to_fixed_xxx_type' conversions to look at their values.
7378 Unfortunately, there is one exception: if one of the internal
7379 history variables is an array whose elements are unconstrained
7380 records, then we will need to create distinct fixed types for each
7381 element selected. */
7383 /* The upshot of all of this is that many routines take a (type, host
7384 address, target address) triple as arguments to represent a value.
7385 The host address, if non-null, is supposed to contain an internal
7386 copy of the relevant data; otherwise, the program is to consult the
7387 target at the target address. */
7389 /* Assuming that VAL0 represents a pointer value, the result of
7390 dereferencing it. Differs from value_ind in its treatment of
7391 dynamic-sized types. */
7394 ada_value_ind (struct value
*val0
)
7396 struct value
*val
= value_ind (val0
);
7398 if (ada_is_tagged_type (value_type (val
), 0))
7399 val
= ada_tag_value_at_base_address (val
);
7401 return ada_to_fixed_value (val
);
7404 /* The value resulting from dereferencing any "reference to"
7405 qualifiers on VAL0. */
7407 static struct value
*
7408 ada_coerce_ref (struct value
*val0
)
7410 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7412 struct value
*val
= val0
;
7414 val
= coerce_ref (val
);
7416 if (ada_is_tagged_type (value_type (val
), 0))
7417 val
= ada_tag_value_at_base_address (val
);
7419 return ada_to_fixed_value (val
);
7425 /* Return the bit alignment required for field #F of template type TYPE. */
7428 field_alignment (struct type
*type
, int f
)
7430 const char *name
= TYPE_FIELD_NAME (type
, f
);
7434 /* The field name should never be null, unless the debugging information
7435 is somehow malformed. In this case, we assume the field does not
7436 require any alignment. */
7440 len
= strlen (name
);
7442 if (!isdigit (name
[len
- 1]))
7445 if (isdigit (name
[len
- 2]))
7446 align_offset
= len
- 2;
7448 align_offset
= len
- 1;
7450 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7451 return TARGET_CHAR_BIT
;
7453 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7456 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7458 static struct symbol
*
7459 ada_find_any_type_symbol (const char *name
)
7463 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7464 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7467 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7471 /* Find a type named NAME. Ignores ambiguity. This routine will look
7472 solely for types defined by debug info, it will not search the GDB
7475 static struct type
*
7476 ada_find_any_type (const char *name
)
7478 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7481 return SYMBOL_TYPE (sym
);
7486 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7487 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7488 symbol, in which case it is returned. Otherwise, this looks for
7489 symbols whose name is that of NAME_SYM suffixed with "___XR".
7490 Return symbol if found, and NULL otherwise. */
7493 ada_is_renaming_symbol (struct symbol
*name_sym
)
7495 const char *name
= name_sym
->linkage_name ();
7496 return strstr (name
, "___XR") != NULL
;
7499 /* Because of GNAT encoding conventions, several GDB symbols may match a
7500 given type name. If the type denoted by TYPE0 is to be preferred to
7501 that of TYPE1 for purposes of type printing, return non-zero;
7502 otherwise return 0. */
7505 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7509 else if (type0
== NULL
)
7511 else if (type1
->code () == TYPE_CODE_VOID
)
7513 else if (type0
->code () == TYPE_CODE_VOID
)
7515 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7517 else if (ada_is_constrained_packed_array_type (type0
))
7519 else if (ada_is_array_descriptor_type (type0
)
7520 && !ada_is_array_descriptor_type (type1
))
7524 const char *type0_name
= type0
->name ();
7525 const char *type1_name
= type1
->name ();
7527 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7528 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7534 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7538 ada_type_name (struct type
*type
)
7542 return type
->name ();
7545 /* Search the list of "descriptive" types associated to TYPE for a type
7546 whose name is NAME. */
7548 static struct type
*
7549 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7551 struct type
*result
, *tmp
;
7553 if (ada_ignore_descriptive_types_p
)
7556 /* If there no descriptive-type info, then there is no parallel type
7558 if (!HAVE_GNAT_AUX_INFO (type
))
7561 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7562 while (result
!= NULL
)
7564 const char *result_name
= ada_type_name (result
);
7566 if (result_name
== NULL
)
7568 warning (_("unexpected null name on descriptive type"));
7572 /* If the names match, stop. */
7573 if (strcmp (result_name
, name
) == 0)
7576 /* Otherwise, look at the next item on the list, if any. */
7577 if (HAVE_GNAT_AUX_INFO (result
))
7578 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7582 /* If not found either, try after having resolved the typedef. */
7587 result
= check_typedef (result
);
7588 if (HAVE_GNAT_AUX_INFO (result
))
7589 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7595 /* If we didn't find a match, see whether this is a packed array. With
7596 older compilers, the descriptive type information is either absent or
7597 irrelevant when it comes to packed arrays so the above lookup fails.
7598 Fall back to using a parallel lookup by name in this case. */
7599 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7600 return ada_find_any_type (name
);
7605 /* Find a parallel type to TYPE with the specified NAME, using the
7606 descriptive type taken from the debugging information, if available,
7607 and otherwise using the (slower) name-based method. */
7609 static struct type
*
7610 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7612 struct type
*result
= NULL
;
7614 if (HAVE_GNAT_AUX_INFO (type
))
7615 result
= find_parallel_type_by_descriptive_type (type
, name
);
7617 result
= ada_find_any_type (name
);
7622 /* Same as above, but specify the name of the parallel type by appending
7623 SUFFIX to the name of TYPE. */
7626 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7629 const char *type_name
= ada_type_name (type
);
7632 if (type_name
== NULL
)
7635 len
= strlen (type_name
);
7637 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7639 strcpy (name
, type_name
);
7640 strcpy (name
+ len
, suffix
);
7642 return ada_find_parallel_type_with_name (type
, name
);
7645 /* If TYPE is a variable-size record type, return the corresponding template
7646 type describing its fields. Otherwise, return NULL. */
7648 static struct type
*
7649 dynamic_template_type (struct type
*type
)
7651 type
= ada_check_typedef (type
);
7653 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7654 || ada_type_name (type
) == NULL
)
7658 int len
= strlen (ada_type_name (type
));
7660 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7663 return ada_find_parallel_type (type
, "___XVE");
7667 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7668 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7671 is_dynamic_field (struct type
*templ_type
, int field_num
)
7673 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7676 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7677 && strstr (name
, "___XVL") != NULL
;
7680 /* The index of the variant field of TYPE, or -1 if TYPE does not
7681 represent a variant record type. */
7684 variant_field_index (struct type
*type
)
7688 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7691 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7693 if (ada_is_variant_part (type
, f
))
7699 /* A record type with no fields. */
7701 static struct type
*
7702 empty_record (struct type
*templ
)
7704 struct type
*type
= alloc_type_copy (templ
);
7706 type
->set_code (TYPE_CODE_STRUCT
);
7707 INIT_NONE_SPECIFIC (type
);
7708 type
->set_name ("<empty>");
7709 TYPE_LENGTH (type
) = 0;
7713 /* An ordinary record type (with fixed-length fields) that describes
7714 the value of type TYPE at VALADDR or ADDRESS (see comments at
7715 the beginning of this section) VAL according to GNAT conventions.
7716 DVAL0 should describe the (portion of a) record that contains any
7717 necessary discriminants. It should be NULL if value_type (VAL) is
7718 an outer-level type (i.e., as opposed to a branch of a variant.) A
7719 variant field (unless unchecked) is replaced by a particular branch
7722 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7723 length are not statically known are discarded. As a consequence,
7724 VALADDR, ADDRESS and DVAL0 are ignored.
7726 NOTE: Limitations: For now, we assume that dynamic fields and
7727 variants occupy whole numbers of bytes. However, they need not be
7731 ada_template_to_fixed_record_type_1 (struct type
*type
,
7732 const gdb_byte
*valaddr
,
7733 CORE_ADDR address
, struct value
*dval0
,
7734 int keep_dynamic_fields
)
7736 struct value
*mark
= value_mark ();
7739 int nfields
, bit_len
;
7745 /* Compute the number of fields in this record type that are going
7746 to be processed: unless keep_dynamic_fields, this includes only
7747 fields whose position and length are static will be processed. */
7748 if (keep_dynamic_fields
)
7749 nfields
= type
->num_fields ();
7753 while (nfields
< type
->num_fields ()
7754 && !ada_is_variant_part (type
, nfields
)
7755 && !is_dynamic_field (type
, nfields
))
7759 rtype
= alloc_type_copy (type
);
7760 rtype
->set_code (TYPE_CODE_STRUCT
);
7761 INIT_NONE_SPECIFIC (rtype
);
7762 rtype
->set_num_fields (nfields
);
7764 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7765 rtype
->set_name (ada_type_name (type
));
7766 rtype
->set_is_fixed_instance (true);
7772 for (f
= 0; f
< nfields
; f
+= 1)
7774 off
= align_up (off
, field_alignment (type
, f
))
7775 + TYPE_FIELD_BITPOS (type
, f
);
7776 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7777 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7779 if (ada_is_variant_part (type
, f
))
7784 else if (is_dynamic_field (type
, f
))
7786 const gdb_byte
*field_valaddr
= valaddr
;
7787 CORE_ADDR field_address
= address
;
7788 struct type
*field_type
=
7789 TYPE_TARGET_TYPE (type
->field (f
).type ());
7793 /* rtype's length is computed based on the run-time
7794 value of discriminants. If the discriminants are not
7795 initialized, the type size may be completely bogus and
7796 GDB may fail to allocate a value for it. So check the
7797 size first before creating the value. */
7798 ada_ensure_varsize_limit (rtype
);
7799 /* Using plain value_from_contents_and_address here
7800 causes problems because we will end up trying to
7801 resolve a type that is currently being
7803 dval
= value_from_contents_and_address_unresolved (rtype
,
7806 rtype
= value_type (dval
);
7811 /* If the type referenced by this field is an aligner type, we need
7812 to unwrap that aligner type, because its size might not be set.
7813 Keeping the aligner type would cause us to compute the wrong
7814 size for this field, impacting the offset of the all the fields
7815 that follow this one. */
7816 if (ada_is_aligner_type (field_type
))
7818 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7820 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7821 field_address
= cond_offset_target (field_address
, field_offset
);
7822 field_type
= ada_aligned_type (field_type
);
7825 field_valaddr
= cond_offset_host (field_valaddr
,
7826 off
/ TARGET_CHAR_BIT
);
7827 field_address
= cond_offset_target (field_address
,
7828 off
/ TARGET_CHAR_BIT
);
7830 /* Get the fixed type of the field. Note that, in this case,
7831 we do not want to get the real type out of the tag: if
7832 the current field is the parent part of a tagged record,
7833 we will get the tag of the object. Clearly wrong: the real
7834 type of the parent is not the real type of the child. We
7835 would end up in an infinite loop. */
7836 field_type
= ada_get_base_type (field_type
);
7837 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7838 field_address
, dval
, 0);
7839 /* If the field size is already larger than the maximum
7840 object size, then the record itself will necessarily
7841 be larger than the maximum object size. We need to make
7842 this check now, because the size might be so ridiculously
7843 large (due to an uninitialized variable in the inferior)
7844 that it would cause an overflow when adding it to the
7846 ada_ensure_varsize_limit (field_type
);
7848 rtype
->field (f
).set_type (field_type
);
7849 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7850 /* The multiplication can potentially overflow. But because
7851 the field length has been size-checked just above, and
7852 assuming that the maximum size is a reasonable value,
7853 an overflow should not happen in practice. So rather than
7854 adding overflow recovery code to this already complex code,
7855 we just assume that it's not going to happen. */
7857 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7861 /* Note: If this field's type is a typedef, it is important
7862 to preserve the typedef layer.
7864 Otherwise, we might be transforming a typedef to a fat
7865 pointer (encoding a pointer to an unconstrained array),
7866 into a basic fat pointer (encoding an unconstrained
7867 array). As both types are implemented using the same
7868 structure, the typedef is the only clue which allows us
7869 to distinguish between the two options. Stripping it
7870 would prevent us from printing this field appropriately. */
7871 rtype
->field (f
).set_type (type
->field (f
).type ());
7872 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7873 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7875 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7878 struct type
*field_type
= type
->field (f
).type ();
7880 /* We need to be careful of typedefs when computing
7881 the length of our field. If this is a typedef,
7882 get the length of the target type, not the length
7884 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7885 field_type
= ada_typedef_target_type (field_type
);
7888 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7891 if (off
+ fld_bit_len
> bit_len
)
7892 bit_len
= off
+ fld_bit_len
;
7894 TYPE_LENGTH (rtype
) =
7895 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7898 /* We handle the variant part, if any, at the end because of certain
7899 odd cases in which it is re-ordered so as NOT to be the last field of
7900 the record. This can happen in the presence of representation
7902 if (variant_field
>= 0)
7904 struct type
*branch_type
;
7906 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7910 /* Using plain value_from_contents_and_address here causes
7911 problems because we will end up trying to resolve a type
7912 that is currently being constructed. */
7913 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
7915 rtype
= value_type (dval
);
7921 to_fixed_variant_branch_type
7922 (type
->field (variant_field
).type (),
7923 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7924 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7925 if (branch_type
== NULL
)
7927 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
7928 rtype
->field (f
- 1) = rtype
->field (f
);
7929 rtype
->set_num_fields (rtype
->num_fields () - 1);
7933 rtype
->field (variant_field
).set_type (branch_type
);
7934 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7936 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
7938 if (off
+ fld_bit_len
> bit_len
)
7939 bit_len
= off
+ fld_bit_len
;
7940 TYPE_LENGTH (rtype
) =
7941 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7945 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7946 should contain the alignment of that record, which should be a strictly
7947 positive value. If null or negative, then something is wrong, most
7948 probably in the debug info. In that case, we don't round up the size
7949 of the resulting type. If this record is not part of another structure,
7950 the current RTYPE length might be good enough for our purposes. */
7951 if (TYPE_LENGTH (type
) <= 0)
7954 warning (_("Invalid type size for `%s' detected: %s."),
7955 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
7957 warning (_("Invalid type size for <unnamed> detected: %s."),
7958 pulongest (TYPE_LENGTH (type
)));
7962 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
7963 TYPE_LENGTH (type
));
7966 value_free_to_mark (mark
);
7967 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7968 error (_("record type with dynamic size is larger than varsize-limit"));
7972 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7975 static struct type
*
7976 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7977 CORE_ADDR address
, struct value
*dval0
)
7979 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7983 /* An ordinary record type in which ___XVL-convention fields and
7984 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7985 static approximations, containing all possible fields. Uses
7986 no runtime values. Useless for use in values, but that's OK,
7987 since the results are used only for type determinations. Works on both
7988 structs and unions. Representation note: to save space, we memorize
7989 the result of this function in the TYPE_TARGET_TYPE of the
7992 static struct type
*
7993 template_to_static_fixed_type (struct type
*type0
)
7999 /* No need no do anything if the input type is already fixed. */
8000 if (type0
->is_fixed_instance ())
8003 /* Likewise if we already have computed the static approximation. */
8004 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8005 return TYPE_TARGET_TYPE (type0
);
8007 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8009 nfields
= type0
->num_fields ();
8011 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8012 recompute all over next time. */
8013 TYPE_TARGET_TYPE (type0
) = type
;
8015 for (f
= 0; f
< nfields
; f
+= 1)
8017 struct type
*field_type
= type0
->field (f
).type ();
8018 struct type
*new_type
;
8020 if (is_dynamic_field (type0
, f
))
8022 field_type
= ada_check_typedef (field_type
);
8023 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8026 new_type
= static_unwrap_type (field_type
);
8028 if (new_type
!= field_type
)
8030 /* Clone TYPE0 only the first time we get a new field type. */
8033 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8034 type
->set_code (type0
->code ());
8035 INIT_NONE_SPECIFIC (type
);
8036 type
->set_num_fields (nfields
);
8040 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8041 memcpy (fields
, type0
->fields (),
8042 sizeof (struct field
) * nfields
);
8043 type
->set_fields (fields
);
8045 type
->set_name (ada_type_name (type0
));
8046 type
->set_is_fixed_instance (true);
8047 TYPE_LENGTH (type
) = 0;
8049 type
->field (f
).set_type (new_type
);
8050 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8057 /* Given an object of type TYPE whose contents are at VALADDR and
8058 whose address in memory is ADDRESS, returns a revision of TYPE,
8059 which should be a non-dynamic-sized record, in which the variant
8060 part, if any, is replaced with the appropriate branch. Looks
8061 for discriminant values in DVAL0, which can be NULL if the record
8062 contains the necessary discriminant values. */
8064 static struct type
*
8065 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8066 CORE_ADDR address
, struct value
*dval0
)
8068 struct value
*mark
= value_mark ();
8071 struct type
*branch_type
;
8072 int nfields
= type
->num_fields ();
8073 int variant_field
= variant_field_index (type
);
8075 if (variant_field
== -1)
8080 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8081 type
= value_type (dval
);
8086 rtype
= alloc_type_copy (type
);
8087 rtype
->set_code (TYPE_CODE_STRUCT
);
8088 INIT_NONE_SPECIFIC (rtype
);
8089 rtype
->set_num_fields (nfields
);
8092 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8093 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8094 rtype
->set_fields (fields
);
8096 rtype
->set_name (ada_type_name (type
));
8097 rtype
->set_is_fixed_instance (true);
8098 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8100 branch_type
= to_fixed_variant_branch_type
8101 (type
->field (variant_field
).type (),
8102 cond_offset_host (valaddr
,
8103 TYPE_FIELD_BITPOS (type
, variant_field
)
8105 cond_offset_target (address
,
8106 TYPE_FIELD_BITPOS (type
, variant_field
)
8107 / TARGET_CHAR_BIT
), dval
);
8108 if (branch_type
== NULL
)
8112 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8113 rtype
->field (f
- 1) = rtype
->field (f
);
8114 rtype
->set_num_fields (rtype
->num_fields () - 1);
8118 rtype
->field (variant_field
).set_type (branch_type
);
8119 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8120 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8121 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8123 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8125 value_free_to_mark (mark
);
8129 /* An ordinary record type (with fixed-length fields) that describes
8130 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8131 beginning of this section]. Any necessary discriminants' values
8132 should be in DVAL, a record value; it may be NULL if the object
8133 at ADDR itself contains any necessary discriminant values.
8134 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8135 values from the record are needed. Except in the case that DVAL,
8136 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8137 unchecked) is replaced by a particular branch of the variant.
8139 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8140 is questionable and may be removed. It can arise during the
8141 processing of an unconstrained-array-of-record type where all the
8142 variant branches have exactly the same size. This is because in
8143 such cases, the compiler does not bother to use the XVS convention
8144 when encoding the record. I am currently dubious of this
8145 shortcut and suspect the compiler should be altered. FIXME. */
8147 static struct type
*
8148 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8149 CORE_ADDR address
, struct value
*dval
)
8151 struct type
*templ_type
;
8153 if (type0
->is_fixed_instance ())
8156 templ_type
= dynamic_template_type (type0
);
8158 if (templ_type
!= NULL
)
8159 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8160 else if (variant_field_index (type0
) >= 0)
8162 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8164 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8169 type0
->set_is_fixed_instance (true);
8175 /* An ordinary record type (with fixed-length fields) that describes
8176 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8177 union type. Any necessary discriminants' values should be in DVAL,
8178 a record value. That is, this routine selects the appropriate
8179 branch of the union at ADDR according to the discriminant value
8180 indicated in the union's type name. Returns VAR_TYPE0 itself if
8181 it represents a variant subject to a pragma Unchecked_Union. */
8183 static struct type
*
8184 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8185 CORE_ADDR address
, struct value
*dval
)
8188 struct type
*templ_type
;
8189 struct type
*var_type
;
8191 if (var_type0
->code () == TYPE_CODE_PTR
)
8192 var_type
= TYPE_TARGET_TYPE (var_type0
);
8194 var_type
= var_type0
;
8196 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8198 if (templ_type
!= NULL
)
8199 var_type
= templ_type
;
8201 if (is_unchecked_variant (var_type
, value_type (dval
)))
8203 which
= ada_which_variant_applies (var_type
, dval
);
8206 return empty_record (var_type
);
8207 else if (is_dynamic_field (var_type
, which
))
8208 return to_fixed_record_type
8209 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8210 valaddr
, address
, dval
);
8211 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8213 to_fixed_record_type
8214 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8216 return var_type
->field (which
).type ();
8219 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8220 ENCODING_TYPE, a type following the GNAT conventions for discrete
8221 type encodings, only carries redundant information. */
8224 ada_is_redundant_range_encoding (struct type
*range_type
,
8225 struct type
*encoding_type
)
8227 const char *bounds_str
;
8231 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8233 if (get_base_type (range_type
)->code ()
8234 != get_base_type (encoding_type
)->code ())
8236 /* The compiler probably used a simple base type to describe
8237 the range type instead of the range's actual base type,
8238 expecting us to get the real base type from the encoding
8239 anyway. In this situation, the encoding cannot be ignored
8244 if (is_dynamic_type (range_type
))
8247 if (encoding_type
->name () == NULL
)
8250 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8251 if (bounds_str
== NULL
)
8254 n
= 8; /* Skip "___XDLU_". */
8255 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8257 if (range_type
->bounds ()->low
.const_val () != lo
)
8260 n
+= 2; /* Skip the "__" separator between the two bounds. */
8261 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8263 if (range_type
->bounds ()->high
.const_val () != hi
)
8269 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8270 a type following the GNAT encoding for describing array type
8271 indices, only carries redundant information. */
8274 ada_is_redundant_index_type_desc (struct type
*array_type
,
8275 struct type
*desc_type
)
8277 struct type
*this_layer
= check_typedef (array_type
);
8280 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8282 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8283 desc_type
->field (i
).type ()))
8285 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8291 /* Assuming that TYPE0 is an array type describing the type of a value
8292 at ADDR, and that DVAL describes a record containing any
8293 discriminants used in TYPE0, returns a type for the value that
8294 contains no dynamic components (that is, no components whose sizes
8295 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8296 true, gives an error message if the resulting type's size is over
8299 static struct type
*
8300 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8303 struct type
*index_type_desc
;
8304 struct type
*result
;
8305 int constrained_packed_array_p
;
8306 static const char *xa_suffix
= "___XA";
8308 type0
= ada_check_typedef (type0
);
8309 if (type0
->is_fixed_instance ())
8312 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8313 if (constrained_packed_array_p
)
8315 type0
= decode_constrained_packed_array_type (type0
);
8316 if (type0
== nullptr)
8317 error (_("could not decode constrained packed array type"));
8320 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8322 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8323 encoding suffixed with 'P' may still be generated. If so,
8324 it should be used to find the XA type. */
8326 if (index_type_desc
== NULL
)
8328 const char *type_name
= ada_type_name (type0
);
8330 if (type_name
!= NULL
)
8332 const int len
= strlen (type_name
);
8333 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8335 if (type_name
[len
- 1] == 'P')
8337 strcpy (name
, type_name
);
8338 strcpy (name
+ len
- 1, xa_suffix
);
8339 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8344 ada_fixup_array_indexes_type (index_type_desc
);
8345 if (index_type_desc
!= NULL
8346 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8348 /* Ignore this ___XA parallel type, as it does not bring any
8349 useful information. This allows us to avoid creating fixed
8350 versions of the array's index types, which would be identical
8351 to the original ones. This, in turn, can also help avoid
8352 the creation of fixed versions of the array itself. */
8353 index_type_desc
= NULL
;
8356 if (index_type_desc
== NULL
)
8358 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8360 /* NOTE: elt_type---the fixed version of elt_type0---should never
8361 depend on the contents of the array in properly constructed
8363 /* Create a fixed version of the array element type.
8364 We're not providing the address of an element here,
8365 and thus the actual object value cannot be inspected to do
8366 the conversion. This should not be a problem, since arrays of
8367 unconstrained objects are not allowed. In particular, all
8368 the elements of an array of a tagged type should all be of
8369 the same type specified in the debugging info. No need to
8370 consult the object tag. */
8371 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8373 /* Make sure we always create a new array type when dealing with
8374 packed array types, since we're going to fix-up the array
8375 type length and element bitsize a little further down. */
8376 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8379 result
= create_array_type (alloc_type_copy (type0
),
8380 elt_type
, type0
->index_type ());
8385 struct type
*elt_type0
;
8388 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8389 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8391 /* NOTE: result---the fixed version of elt_type0---should never
8392 depend on the contents of the array in properly constructed
8394 /* Create a fixed version of the array element type.
8395 We're not providing the address of an element here,
8396 and thus the actual object value cannot be inspected to do
8397 the conversion. This should not be a problem, since arrays of
8398 unconstrained objects are not allowed. In particular, all
8399 the elements of an array of a tagged type should all be of
8400 the same type specified in the debugging info. No need to
8401 consult the object tag. */
8403 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8406 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8408 struct type
*range_type
=
8409 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8411 result
= create_array_type (alloc_type_copy (elt_type0
),
8412 result
, range_type
);
8413 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8415 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8416 error (_("array type with dynamic size is larger than varsize-limit"));
8419 /* We want to preserve the type name. This can be useful when
8420 trying to get the type name of a value that has already been
8421 printed (for instance, if the user did "print VAR; whatis $". */
8422 result
->set_name (type0
->name ());
8424 if (constrained_packed_array_p
)
8426 /* So far, the resulting type has been created as if the original
8427 type was a regular (non-packed) array type. As a result, the
8428 bitsize of the array elements needs to be set again, and the array
8429 length needs to be recomputed based on that bitsize. */
8430 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8431 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8433 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8434 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8435 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8436 TYPE_LENGTH (result
)++;
8439 result
->set_is_fixed_instance (true);
8444 /* A standard type (containing no dynamically sized components)
8445 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8446 DVAL describes a record containing any discriminants used in TYPE0,
8447 and may be NULL if there are none, or if the object of type TYPE at
8448 ADDRESS or in VALADDR contains these discriminants.
8450 If CHECK_TAG is not null, in the case of tagged types, this function
8451 attempts to locate the object's tag and use it to compute the actual
8452 type. However, when ADDRESS is null, we cannot use it to determine the
8453 location of the tag, and therefore compute the tagged type's actual type.
8454 So we return the tagged type without consulting the tag. */
8456 static struct type
*
8457 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8458 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8460 type
= ada_check_typedef (type
);
8462 /* Only un-fixed types need to be handled here. */
8463 if (!HAVE_GNAT_AUX_INFO (type
))
8466 switch (type
->code ())
8470 case TYPE_CODE_STRUCT
:
8472 struct type
*static_type
= to_static_fixed_type (type
);
8473 struct type
*fixed_record_type
=
8474 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8476 /* If STATIC_TYPE is a tagged type and we know the object's address,
8477 then we can determine its tag, and compute the object's actual
8478 type from there. Note that we have to use the fixed record
8479 type (the parent part of the record may have dynamic fields
8480 and the way the location of _tag is expressed may depend on
8483 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8486 value_tag_from_contents_and_address
8490 struct type
*real_type
= type_from_tag (tag
);
8492 value_from_contents_and_address (fixed_record_type
,
8495 fixed_record_type
= value_type (obj
);
8496 if (real_type
!= NULL
)
8497 return to_fixed_record_type
8499 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8502 /* Check to see if there is a parallel ___XVZ variable.
8503 If there is, then it provides the actual size of our type. */
8504 else if (ada_type_name (fixed_record_type
) != NULL
)
8506 const char *name
= ada_type_name (fixed_record_type
);
8508 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8509 bool xvz_found
= false;
8512 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8515 xvz_found
= get_int_var_value (xvz_name
, size
);
8517 catch (const gdb_exception_error
&except
)
8519 /* We found the variable, but somehow failed to read
8520 its value. Rethrow the same error, but with a little
8521 bit more information, to help the user understand
8522 what went wrong (Eg: the variable might have been
8524 throw_error (except
.error
,
8525 _("unable to read value of %s (%s)"),
8526 xvz_name
, except
.what ());
8529 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8531 fixed_record_type
= copy_type (fixed_record_type
);
8532 TYPE_LENGTH (fixed_record_type
) = size
;
8534 /* The FIXED_RECORD_TYPE may have be a stub. We have
8535 observed this when the debugging info is STABS, and
8536 apparently it is something that is hard to fix.
8538 In practice, we don't need the actual type definition
8539 at all, because the presence of the XVZ variable allows us
8540 to assume that there must be a XVS type as well, which we
8541 should be able to use later, when we need the actual type
8544 In the meantime, pretend that the "fixed" type we are
8545 returning is NOT a stub, because this can cause trouble
8546 when using this type to create new types targeting it.
8547 Indeed, the associated creation routines often check
8548 whether the target type is a stub and will try to replace
8549 it, thus using a type with the wrong size. This, in turn,
8550 might cause the new type to have the wrong size too.
8551 Consider the case of an array, for instance, where the size
8552 of the array is computed from the number of elements in
8553 our array multiplied by the size of its element. */
8554 fixed_record_type
->set_is_stub (false);
8557 return fixed_record_type
;
8559 case TYPE_CODE_ARRAY
:
8560 return to_fixed_array_type (type
, dval
, 1);
8561 case TYPE_CODE_UNION
:
8565 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8569 /* The same as ada_to_fixed_type_1, except that it preserves the type
8570 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8572 The typedef layer needs be preserved in order to differentiate between
8573 arrays and array pointers when both types are implemented using the same
8574 fat pointer. In the array pointer case, the pointer is encoded as
8575 a typedef of the pointer type. For instance, considering:
8577 type String_Access is access String;
8578 S1 : String_Access := null;
8580 To the debugger, S1 is defined as a typedef of type String. But
8581 to the user, it is a pointer. So if the user tries to print S1,
8582 we should not dereference the array, but print the array address
8585 If we didn't preserve the typedef layer, we would lose the fact that
8586 the type is to be presented as a pointer (needs de-reference before
8587 being printed). And we would also use the source-level type name. */
8590 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8591 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8594 struct type
*fixed_type
=
8595 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8597 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8598 then preserve the typedef layer.
8600 Implementation note: We can only check the main-type portion of
8601 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8602 from TYPE now returns a type that has the same instance flags
8603 as TYPE. For instance, if TYPE is a "typedef const", and its
8604 target type is a "struct", then the typedef elimination will return
8605 a "const" version of the target type. See check_typedef for more
8606 details about how the typedef layer elimination is done.
8608 brobecker/2010-11-19: It seems to me that the only case where it is
8609 useful to preserve the typedef layer is when dealing with fat pointers.
8610 Perhaps, we could add a check for that and preserve the typedef layer
8611 only in that situation. But this seems unnecessary so far, probably
8612 because we call check_typedef/ada_check_typedef pretty much everywhere.
8614 if (type
->code () == TYPE_CODE_TYPEDEF
8615 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8616 == TYPE_MAIN_TYPE (fixed_type
)))
8622 /* A standard (static-sized) type corresponding as well as possible to
8623 TYPE0, but based on no runtime data. */
8625 static struct type
*
8626 to_static_fixed_type (struct type
*type0
)
8633 if (type0
->is_fixed_instance ())
8636 type0
= ada_check_typedef (type0
);
8638 switch (type0
->code ())
8642 case TYPE_CODE_STRUCT
:
8643 type
= dynamic_template_type (type0
);
8645 return template_to_static_fixed_type (type
);
8647 return template_to_static_fixed_type (type0
);
8648 case TYPE_CODE_UNION
:
8649 type
= ada_find_parallel_type (type0
, "___XVU");
8651 return template_to_static_fixed_type (type
);
8653 return template_to_static_fixed_type (type0
);
8657 /* A static approximation of TYPE with all type wrappers removed. */
8659 static struct type
*
8660 static_unwrap_type (struct type
*type
)
8662 if (ada_is_aligner_type (type
))
8664 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8665 if (ada_type_name (type1
) == NULL
)
8666 type1
->set_name (ada_type_name (type
));
8668 return static_unwrap_type (type1
);
8672 struct type
*raw_real_type
= ada_get_base_type (type
);
8674 if (raw_real_type
== type
)
8677 return to_static_fixed_type (raw_real_type
);
8681 /* In some cases, incomplete and private types require
8682 cross-references that are not resolved as records (for example,
8684 type FooP is access Foo;
8686 type Foo is array ...;
8687 ). In these cases, since there is no mechanism for producing
8688 cross-references to such types, we instead substitute for FooP a
8689 stub enumeration type that is nowhere resolved, and whose tag is
8690 the name of the actual type. Call these types "non-record stubs". */
8692 /* A type equivalent to TYPE that is not a non-record stub, if one
8693 exists, otherwise TYPE. */
8696 ada_check_typedef (struct type
*type
)
8701 /* If our type is an access to an unconstrained array, which is encoded
8702 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8703 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8704 what allows us to distinguish between fat pointers that represent
8705 array types, and fat pointers that represent array access types
8706 (in both cases, the compiler implements them as fat pointers). */
8707 if (ada_is_access_to_unconstrained_array (type
))
8710 type
= check_typedef (type
);
8711 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8712 || !type
->is_stub ()
8713 || type
->name () == NULL
)
8717 const char *name
= type
->name ();
8718 struct type
*type1
= ada_find_any_type (name
);
8723 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8724 stubs pointing to arrays, as we don't create symbols for array
8725 types, only for the typedef-to-array types). If that's the case,
8726 strip the typedef layer. */
8727 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8728 type1
= ada_check_typedef (type1
);
8734 /* A value representing the data at VALADDR/ADDRESS as described by
8735 type TYPE0, but with a standard (static-sized) type that correctly
8736 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8737 type, then return VAL0 [this feature is simply to avoid redundant
8738 creation of struct values]. */
8740 static struct value
*
8741 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8744 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8746 if (type
== type0
&& val0
!= NULL
)
8749 if (VALUE_LVAL (val0
) != lval_memory
)
8751 /* Our value does not live in memory; it could be a convenience
8752 variable, for instance. Create a not_lval value using val0's
8754 return value_from_contents (type
, value_contents (val0
));
8757 return value_from_contents_and_address (type
, 0, address
);
8760 /* A value representing VAL, but with a standard (static-sized) type
8761 that correctly describes it. Does not necessarily create a new
8765 ada_to_fixed_value (struct value
*val
)
8767 val
= unwrap_value (val
);
8768 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8775 /* Table mapping attribute numbers to names.
8776 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8778 static const char * const attribute_names
[] = {
8796 ada_attribute_name (enum exp_opcode n
)
8798 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8799 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8801 return attribute_names
[0];
8804 /* Evaluate the 'POS attribute applied to ARG. */
8807 pos_atr (struct value
*arg
)
8809 struct value
*val
= coerce_ref (arg
);
8810 struct type
*type
= value_type (val
);
8812 if (!discrete_type_p (type
))
8813 error (_("'POS only defined on discrete types"));
8815 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8816 if (!result
.has_value ())
8817 error (_("enumeration value is invalid: can't find 'POS"));
8822 static struct value
*
8823 value_pos_atr (struct type
*type
, struct value
*arg
)
8825 return value_from_longest (type
, pos_atr (arg
));
8828 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8830 static struct value
*
8831 val_atr (struct type
*type
, LONGEST val
)
8833 gdb_assert (discrete_type_p (type
));
8834 if (type
->code () == TYPE_CODE_RANGE
)
8835 type
= TYPE_TARGET_TYPE (type
);
8836 if (type
->code () == TYPE_CODE_ENUM
)
8838 if (val
< 0 || val
>= type
->num_fields ())
8839 error (_("argument to 'VAL out of range"));
8840 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8842 return value_from_longest (type
, val
);
8845 static struct value
*
8846 value_val_atr (struct type
*type
, struct value
*arg
)
8848 if (!discrete_type_p (type
))
8849 error (_("'VAL only defined on discrete types"));
8850 if (!integer_type_p (value_type (arg
)))
8851 error (_("'VAL requires integral argument"));
8853 return val_atr (type
, value_as_long (arg
));
8859 /* True if TYPE appears to be an Ada character type.
8860 [At the moment, this is true only for Character and Wide_Character;
8861 It is a heuristic test that could stand improvement]. */
8864 ada_is_character_type (struct type
*type
)
8868 /* If the type code says it's a character, then assume it really is,
8869 and don't check any further. */
8870 if (type
->code () == TYPE_CODE_CHAR
)
8873 /* Otherwise, assume it's a character type iff it is a discrete type
8874 with a known character type name. */
8875 name
= ada_type_name (type
);
8876 return (name
!= NULL
8877 && (type
->code () == TYPE_CODE_INT
8878 || type
->code () == TYPE_CODE_RANGE
)
8879 && (strcmp (name
, "character") == 0
8880 || strcmp (name
, "wide_character") == 0
8881 || strcmp (name
, "wide_wide_character") == 0
8882 || strcmp (name
, "unsigned char") == 0));
8885 /* True if TYPE appears to be an Ada string type. */
8888 ada_is_string_type (struct type
*type
)
8890 type
= ada_check_typedef (type
);
8892 && type
->code () != TYPE_CODE_PTR
8893 && (ada_is_simple_array_type (type
)
8894 || ada_is_array_descriptor_type (type
))
8895 && ada_array_arity (type
) == 1)
8897 struct type
*elttype
= ada_array_element_type (type
, 1);
8899 return ada_is_character_type (elttype
);
8905 /* The compiler sometimes provides a parallel XVS type for a given
8906 PAD type. Normally, it is safe to follow the PAD type directly,
8907 but older versions of the compiler have a bug that causes the offset
8908 of its "F" field to be wrong. Following that field in that case
8909 would lead to incorrect results, but this can be worked around
8910 by ignoring the PAD type and using the associated XVS type instead.
8912 Set to True if the debugger should trust the contents of PAD types.
8913 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8914 static bool trust_pad_over_xvs
= true;
8916 /* True if TYPE is a struct type introduced by the compiler to force the
8917 alignment of a value. Such types have a single field with a
8918 distinctive name. */
8921 ada_is_aligner_type (struct type
*type
)
8923 type
= ada_check_typedef (type
);
8925 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
8928 return (type
->code () == TYPE_CODE_STRUCT
8929 && type
->num_fields () == 1
8930 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8933 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8934 the parallel type. */
8937 ada_get_base_type (struct type
*raw_type
)
8939 struct type
*real_type_namer
;
8940 struct type
*raw_real_type
;
8942 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
8945 if (ada_is_aligner_type (raw_type
))
8946 /* The encoding specifies that we should always use the aligner type.
8947 So, even if this aligner type has an associated XVS type, we should
8950 According to the compiler gurus, an XVS type parallel to an aligner
8951 type may exist because of a stabs limitation. In stabs, aligner
8952 types are empty because the field has a variable-sized type, and
8953 thus cannot actually be used as an aligner type. As a result,
8954 we need the associated parallel XVS type to decode the type.
8955 Since the policy in the compiler is to not change the internal
8956 representation based on the debugging info format, we sometimes
8957 end up having a redundant XVS type parallel to the aligner type. */
8960 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8961 if (real_type_namer
== NULL
8962 || real_type_namer
->code () != TYPE_CODE_STRUCT
8963 || real_type_namer
->num_fields () != 1)
8966 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
8968 /* This is an older encoding form where the base type needs to be
8969 looked up by name. We prefer the newer encoding because it is
8971 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8972 if (raw_real_type
== NULL
)
8975 return raw_real_type
;
8978 /* The field in our XVS type is a reference to the base type. */
8979 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
8982 /* The type of value designated by TYPE, with all aligners removed. */
8985 ada_aligned_type (struct type
*type
)
8987 if (ada_is_aligner_type (type
))
8988 return ada_aligned_type (type
->field (0).type ());
8990 return ada_get_base_type (type
);
8994 /* The address of the aligned value in an object at address VALADDR
8995 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8998 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9000 if (ada_is_aligner_type (type
))
9001 return ada_aligned_value_addr (type
->field (0).type (),
9003 TYPE_FIELD_BITPOS (type
,
9004 0) / TARGET_CHAR_BIT
);
9011 /* The printed representation of an enumeration literal with encoded
9012 name NAME. The value is good to the next call of ada_enum_name. */
9014 ada_enum_name (const char *name
)
9016 static std::string storage
;
9019 /* First, unqualify the enumeration name:
9020 1. Search for the last '.' character. If we find one, then skip
9021 all the preceding characters, the unqualified name starts
9022 right after that dot.
9023 2. Otherwise, we may be debugging on a target where the compiler
9024 translates dots into "__". Search forward for double underscores,
9025 but stop searching when we hit an overloading suffix, which is
9026 of the form "__" followed by digits. */
9028 tmp
= strrchr (name
, '.');
9033 while ((tmp
= strstr (name
, "__")) != NULL
)
9035 if (isdigit (tmp
[2]))
9046 if (name
[1] == 'U' || name
[1] == 'W')
9048 if (sscanf (name
+ 2, "%x", &v
) != 1)
9051 else if (((name
[1] >= '0' && name
[1] <= '9')
9052 || (name
[1] >= 'a' && name
[1] <= 'z'))
9055 storage
= string_printf ("'%c'", name
[1]);
9056 return storage
.c_str ();
9061 if (isascii (v
) && isprint (v
))
9062 storage
= string_printf ("'%c'", v
);
9063 else if (name
[1] == 'U')
9064 storage
= string_printf ("[\"%02x\"]", v
);
9066 storage
= string_printf ("[\"%04x\"]", v
);
9068 return storage
.c_str ();
9072 tmp
= strstr (name
, "__");
9074 tmp
= strstr (name
, "$");
9077 storage
= std::string (name
, tmp
- name
);
9078 return storage
.c_str ();
9085 /* Evaluate the subexpression of EXP starting at *POS as for
9086 evaluate_type, updating *POS to point just past the evaluated
9089 static struct value
*
9090 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9092 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9095 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9098 static struct value
*
9099 unwrap_value (struct value
*val
)
9101 struct type
*type
= ada_check_typedef (value_type (val
));
9103 if (ada_is_aligner_type (type
))
9105 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9106 struct type
*val_type
= ada_check_typedef (value_type (v
));
9108 if (ada_type_name (val_type
) == NULL
)
9109 val_type
->set_name (ada_type_name (type
));
9111 return unwrap_value (v
);
9115 struct type
*raw_real_type
=
9116 ada_check_typedef (ada_get_base_type (type
));
9118 /* If there is no parallel XVS or XVE type, then the value is
9119 already unwrapped. Return it without further modification. */
9120 if ((type
== raw_real_type
)
9121 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9125 coerce_unspec_val_to_type
9126 (val
, ada_to_fixed_type (raw_real_type
, 0,
9127 value_address (val
),
9132 static struct value
*
9133 cast_from_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9136 = gnat_encoded_fixed_point_scaling_factor (value_type (arg
));
9137 arg
= value_cast (value_type (scale
), arg
);
9139 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9140 return value_cast (type
, arg
);
9143 static struct value
*
9144 cast_to_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9146 if (type
== value_type (arg
))
9149 struct value
*scale
= gnat_encoded_fixed_point_scaling_factor (type
);
9150 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9151 arg
= cast_from_gnat_encoded_fixed_point_type (value_type (scale
), arg
);
9153 arg
= value_cast (value_type (scale
), arg
);
9155 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9156 return value_cast (type
, arg
);
9159 /* Given two array types T1 and T2, return nonzero iff both arrays
9160 contain the same number of elements. */
9163 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9165 LONGEST lo1
, hi1
, lo2
, hi2
;
9167 /* Get the array bounds in order to verify that the size of
9168 the two arrays match. */
9169 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9170 || !get_array_bounds (t2
, &lo2
, &hi2
))
9171 error (_("unable to determine array bounds"));
9173 /* To make things easier for size comparison, normalize a bit
9174 the case of empty arrays by making sure that the difference
9175 between upper bound and lower bound is always -1. */
9181 return (hi1
- lo1
== hi2
- lo2
);
9184 /* Assuming that VAL is an array of integrals, and TYPE represents
9185 an array with the same number of elements, but with wider integral
9186 elements, return an array "casted" to TYPE. In practice, this
9187 means that the returned array is built by casting each element
9188 of the original array into TYPE's (wider) element type. */
9190 static struct value
*
9191 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9193 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9198 /* Verify that both val and type are arrays of scalars, and
9199 that the size of val's elements is smaller than the size
9200 of type's element. */
9201 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9202 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9203 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9204 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9205 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9206 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9208 if (!get_array_bounds (type
, &lo
, &hi
))
9209 error (_("unable to determine array bounds"));
9211 res
= allocate_value (type
);
9213 /* Promote each array element. */
9214 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9216 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9218 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9219 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9225 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9226 return the converted value. */
9228 static struct value
*
9229 coerce_for_assign (struct type
*type
, struct value
*val
)
9231 struct type
*type2
= value_type (val
);
9236 type2
= ada_check_typedef (type2
);
9237 type
= ada_check_typedef (type
);
9239 if (type2
->code () == TYPE_CODE_PTR
9240 && type
->code () == TYPE_CODE_ARRAY
)
9242 val
= ada_value_ind (val
);
9243 type2
= value_type (val
);
9246 if (type2
->code () == TYPE_CODE_ARRAY
9247 && type
->code () == TYPE_CODE_ARRAY
)
9249 if (!ada_same_array_size_p (type
, type2
))
9250 error (_("cannot assign arrays of different length"));
9252 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9253 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9254 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9255 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9257 /* Allow implicit promotion of the array elements to
9259 return ada_promote_array_of_integrals (type
, val
);
9262 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9263 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9264 error (_("Incompatible types in assignment"));
9265 deprecated_set_value_type (val
, type
);
9270 static struct value
*
9271 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9274 struct type
*type1
, *type2
;
9277 arg1
= coerce_ref (arg1
);
9278 arg2
= coerce_ref (arg2
);
9279 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9280 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9282 if (type1
->code () != TYPE_CODE_INT
9283 || type2
->code () != TYPE_CODE_INT
)
9284 return value_binop (arg1
, arg2
, op
);
9293 return value_binop (arg1
, arg2
, op
);
9296 v2
= value_as_long (arg2
);
9298 error (_("second operand of %s must not be zero."), op_string (op
));
9300 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9301 return value_binop (arg1
, arg2
, op
);
9303 v1
= value_as_long (arg1
);
9308 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9309 v
+= v
> 0 ? -1 : 1;
9317 /* Should not reach this point. */
9321 val
= allocate_value (type1
);
9322 store_unsigned_integer (value_contents_raw (val
),
9323 TYPE_LENGTH (value_type (val
)),
9324 type_byte_order (type1
), v
);
9329 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9331 if (ada_is_direct_array_type (value_type (arg1
))
9332 || ada_is_direct_array_type (value_type (arg2
)))
9334 struct type
*arg1_type
, *arg2_type
;
9336 /* Automatically dereference any array reference before
9337 we attempt to perform the comparison. */
9338 arg1
= ada_coerce_ref (arg1
);
9339 arg2
= ada_coerce_ref (arg2
);
9341 arg1
= ada_coerce_to_simple_array (arg1
);
9342 arg2
= ada_coerce_to_simple_array (arg2
);
9344 arg1_type
= ada_check_typedef (value_type (arg1
));
9345 arg2_type
= ada_check_typedef (value_type (arg2
));
9347 if (arg1_type
->code () != TYPE_CODE_ARRAY
9348 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9349 error (_("Attempt to compare array with non-array"));
9350 /* FIXME: The following works only for types whose
9351 representations use all bits (no padding or undefined bits)
9352 and do not have user-defined equality. */
9353 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9354 && memcmp (value_contents (arg1
), value_contents (arg2
),
9355 TYPE_LENGTH (arg1_type
)) == 0);
9357 return value_equal (arg1
, arg2
);
9360 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9361 component of LHS (a simple array or a record), updating *POS past
9362 the expression, assuming that LHS is contained in CONTAINER. Does
9363 not modify the inferior's memory, nor does it modify LHS (unless
9364 LHS == CONTAINER). */
9367 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9368 struct expression
*exp
, int *pos
)
9370 struct value
*mark
= value_mark ();
9372 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9374 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9376 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9377 struct value
*index_val
= value_from_longest (index_type
, index
);
9379 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9383 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9384 elt
= ada_to_fixed_value (elt
);
9387 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9388 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9390 value_assign_to_component (container
, elt
,
9391 ada_evaluate_subexp (NULL
, exp
, pos
,
9394 value_free_to_mark (mark
);
9397 /* Assuming that LHS represents an lvalue having a record or array
9398 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9399 of that aggregate's value to LHS, advancing *POS past the
9400 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9401 lvalue containing LHS (possibly LHS itself). Does not modify
9402 the inferior's memory, nor does it modify the contents of
9403 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9405 static struct value
*
9406 assign_aggregate (struct value
*container
,
9407 struct value
*lhs
, struct expression
*exp
,
9408 int *pos
, enum noside noside
)
9410 struct type
*lhs_type
;
9411 int n
= exp
->elts
[*pos
+1].longconst
;
9412 LONGEST low_index
, high_index
;
9416 if (noside
!= EVAL_NORMAL
)
9418 for (i
= 0; i
< n
; i
+= 1)
9419 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9423 container
= ada_coerce_ref (container
);
9424 if (ada_is_direct_array_type (value_type (container
)))
9425 container
= ada_coerce_to_simple_array (container
);
9426 lhs
= ada_coerce_ref (lhs
);
9427 if (!deprecated_value_modifiable (lhs
))
9428 error (_("Left operand of assignment is not a modifiable lvalue."));
9430 lhs_type
= check_typedef (value_type (lhs
));
9431 if (ada_is_direct_array_type (lhs_type
))
9433 lhs
= ada_coerce_to_simple_array (lhs
);
9434 lhs_type
= check_typedef (value_type (lhs
));
9435 low_index
= lhs_type
->bounds ()->low
.const_val ();
9436 high_index
= lhs_type
->bounds ()->high
.const_val ();
9438 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9441 high_index
= num_visible_fields (lhs_type
) - 1;
9444 error (_("Left-hand side must be array or record."));
9446 std::vector
<LONGEST
> indices (4);
9447 indices
[0] = indices
[1] = low_index
- 1;
9448 indices
[2] = indices
[3] = high_index
+ 1;
9450 for (i
= 0; i
< n
; i
+= 1)
9452 switch (exp
->elts
[*pos
].opcode
)
9455 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9456 low_index
, high_index
);
9459 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9460 low_index
, high_index
);
9464 error (_("Misplaced 'others' clause"));
9465 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9466 low_index
, high_index
);
9469 error (_("Internal error: bad aggregate clause"));
9476 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9477 construct at *POS, updating *POS past the construct, given that
9478 the positions are relative to lower bound LOW, where HIGH is the
9479 upper bound. Record the position in INDICES. CONTAINER is as for
9480 assign_aggregate. */
9482 aggregate_assign_positional (struct value
*container
,
9483 struct value
*lhs
, struct expression
*exp
,
9484 int *pos
, std::vector
<LONGEST
> &indices
,
9485 LONGEST low
, LONGEST high
)
9487 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9489 if (ind
- 1 == high
)
9490 warning (_("Extra components in aggregate ignored."));
9493 add_component_interval (ind
, ind
, indices
);
9495 assign_component (container
, lhs
, ind
, exp
, pos
);
9498 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9501 /* Assign into the components of LHS indexed by the OP_CHOICES
9502 construct at *POS, updating *POS past the construct, given that
9503 the allowable indices are LOW..HIGH. Record the indices assigned
9504 to in INDICES. CONTAINER is as for assign_aggregate. */
9506 aggregate_assign_from_choices (struct value
*container
,
9507 struct value
*lhs
, struct expression
*exp
,
9508 int *pos
, std::vector
<LONGEST
> &indices
,
9509 LONGEST low
, LONGEST high
)
9512 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9513 int choice_pos
, expr_pc
;
9514 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9516 choice_pos
= *pos
+= 3;
9518 for (j
= 0; j
< n_choices
; j
+= 1)
9519 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9521 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9523 for (j
= 0; j
< n_choices
; j
+= 1)
9525 LONGEST lower
, upper
;
9526 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9528 if (op
== OP_DISCRETE_RANGE
)
9531 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9533 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9538 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9550 name
= &exp
->elts
[choice_pos
+ 2].string
;
9553 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9556 error (_("Invalid record component association."));
9558 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9560 if (! find_struct_field (name
, value_type (lhs
), 0,
9561 NULL
, NULL
, NULL
, NULL
, &ind
))
9562 error (_("Unknown component name: %s."), name
);
9563 lower
= upper
= ind
;
9566 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9567 error (_("Index in component association out of bounds."));
9569 add_component_interval (lower
, upper
, indices
);
9570 while (lower
<= upper
)
9575 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9581 /* Assign the value of the expression in the OP_OTHERS construct in
9582 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9583 have not been previously assigned. The index intervals already assigned
9584 are in INDICES. Updates *POS to after the OP_OTHERS clause.
9585 CONTAINER is as for assign_aggregate. */
9587 aggregate_assign_others (struct value
*container
,
9588 struct value
*lhs
, struct expression
*exp
,
9589 int *pos
, std::vector
<LONGEST
> &indices
,
9590 LONGEST low
, LONGEST high
)
9593 int expr_pc
= *pos
+ 1;
9595 int num_indices
= indices
.size ();
9596 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9600 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9605 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9608 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9611 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9612 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9615 add_component_interval (LONGEST low
, LONGEST high
,
9616 std::vector
<LONGEST
> &indices
)
9620 int size
= indices
.size ();
9621 for (i
= 0; i
< size
; i
+= 2) {
9622 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9626 for (kh
= i
+ 2; kh
< size
; kh
+= 2)
9627 if (high
< indices
[kh
])
9629 if (low
< indices
[i
])
9631 indices
[i
+ 1] = indices
[kh
- 1];
9632 if (high
> indices
[i
+ 1])
9633 indices
[i
+ 1] = high
;
9634 memcpy (indices
.data () + i
+ 2, indices
.data () + kh
, size
- kh
);
9635 indices
.resize (kh
- i
- 2);
9638 else if (high
< indices
[i
])
9642 indices
.resize (indices
.size () + 2);
9643 for (j
= indices
.size () - 1; j
>= i
+ 2; j
-= 1)
9644 indices
[j
] = indices
[j
- 2];
9646 indices
[i
+ 1] = high
;
9649 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9652 static struct value
*
9653 ada_value_cast (struct type
*type
, struct value
*arg2
)
9655 if (type
== ada_check_typedef (value_type (arg2
)))
9658 if (ada_is_gnat_encoded_fixed_point_type (type
))
9659 return cast_to_gnat_encoded_fixed_point_type (type
, arg2
);
9661 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9662 return cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
9664 return value_cast (type
, arg2
);
9667 /* Evaluating Ada expressions, and printing their result.
9668 ------------------------------------------------------
9673 We usually evaluate an Ada expression in order to print its value.
9674 We also evaluate an expression in order to print its type, which
9675 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9676 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9677 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9678 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9681 Evaluating expressions is a little more complicated for Ada entities
9682 than it is for entities in languages such as C. The main reason for
9683 this is that Ada provides types whose definition might be dynamic.
9684 One example of such types is variant records. Or another example
9685 would be an array whose bounds can only be known at run time.
9687 The following description is a general guide as to what should be
9688 done (and what should NOT be done) in order to evaluate an expression
9689 involving such types, and when. This does not cover how the semantic
9690 information is encoded by GNAT as this is covered separatly. For the
9691 document used as the reference for the GNAT encoding, see exp_dbug.ads
9692 in the GNAT sources.
9694 Ideally, we should embed each part of this description next to its
9695 associated code. Unfortunately, the amount of code is so vast right
9696 now that it's hard to see whether the code handling a particular
9697 situation might be duplicated or not. One day, when the code is
9698 cleaned up, this guide might become redundant with the comments
9699 inserted in the code, and we might want to remove it.
9701 2. ``Fixing'' an Entity, the Simple Case:
9702 -----------------------------------------
9704 When evaluating Ada expressions, the tricky issue is that they may
9705 reference entities whose type contents and size are not statically
9706 known. Consider for instance a variant record:
9708 type Rec (Empty : Boolean := True) is record
9711 when False => Value : Integer;
9714 Yes : Rec := (Empty => False, Value => 1);
9715 No : Rec := (empty => True);
9717 The size and contents of that record depends on the value of the
9718 descriminant (Rec.Empty). At this point, neither the debugging
9719 information nor the associated type structure in GDB are able to
9720 express such dynamic types. So what the debugger does is to create
9721 "fixed" versions of the type that applies to the specific object.
9722 We also informally refer to this operation as "fixing" an object,
9723 which means creating its associated fixed type.
9725 Example: when printing the value of variable "Yes" above, its fixed
9726 type would look like this:
9733 On the other hand, if we printed the value of "No", its fixed type
9740 Things become a little more complicated when trying to fix an entity
9741 with a dynamic type that directly contains another dynamic type,
9742 such as an array of variant records, for instance. There are
9743 two possible cases: Arrays, and records.
9745 3. ``Fixing'' Arrays:
9746 ---------------------
9748 The type structure in GDB describes an array in terms of its bounds,
9749 and the type of its elements. By design, all elements in the array
9750 have the same type and we cannot represent an array of variant elements
9751 using the current type structure in GDB. When fixing an array,
9752 we cannot fix the array element, as we would potentially need one
9753 fixed type per element of the array. As a result, the best we can do
9754 when fixing an array is to produce an array whose bounds and size
9755 are correct (allowing us to read it from memory), but without having
9756 touched its element type. Fixing each element will be done later,
9757 when (if) necessary.
9759 Arrays are a little simpler to handle than records, because the same
9760 amount of memory is allocated for each element of the array, even if
9761 the amount of space actually used by each element differs from element
9762 to element. Consider for instance the following array of type Rec:
9764 type Rec_Array is array (1 .. 2) of Rec;
9766 The actual amount of memory occupied by each element might be different
9767 from element to element, depending on the value of their discriminant.
9768 But the amount of space reserved for each element in the array remains
9769 fixed regardless. So we simply need to compute that size using
9770 the debugging information available, from which we can then determine
9771 the array size (we multiply the number of elements of the array by
9772 the size of each element).
9774 The simplest case is when we have an array of a constrained element
9775 type. For instance, consider the following type declarations:
9777 type Bounded_String (Max_Size : Integer) is
9779 Buffer : String (1 .. Max_Size);
9781 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9783 In this case, the compiler describes the array as an array of
9784 variable-size elements (identified by its XVS suffix) for which
9785 the size can be read in the parallel XVZ variable.
9787 In the case of an array of an unconstrained element type, the compiler
9788 wraps the array element inside a private PAD type. This type should not
9789 be shown to the user, and must be "unwrap"'ed before printing. Note
9790 that we also use the adjective "aligner" in our code to designate
9791 these wrapper types.
9793 In some cases, the size allocated for each element is statically
9794 known. In that case, the PAD type already has the correct size,
9795 and the array element should remain unfixed.
9797 But there are cases when this size is not statically known.
9798 For instance, assuming that "Five" is an integer variable:
9800 type Dynamic is array (1 .. Five) of Integer;
9801 type Wrapper (Has_Length : Boolean := False) is record
9804 when True => Length : Integer;
9808 type Wrapper_Array is array (1 .. 2) of Wrapper;
9810 Hello : Wrapper_Array := (others => (Has_Length => True,
9811 Data => (others => 17),
9815 The debugging info would describe variable Hello as being an
9816 array of a PAD type. The size of that PAD type is not statically
9817 known, but can be determined using a parallel XVZ variable.
9818 In that case, a copy of the PAD type with the correct size should
9819 be used for the fixed array.
9821 3. ``Fixing'' record type objects:
9822 ----------------------------------
9824 Things are slightly different from arrays in the case of dynamic
9825 record types. In this case, in order to compute the associated
9826 fixed type, we need to determine the size and offset of each of
9827 its components. This, in turn, requires us to compute the fixed
9828 type of each of these components.
9830 Consider for instance the example:
9832 type Bounded_String (Max_Size : Natural) is record
9833 Str : String (1 .. Max_Size);
9836 My_String : Bounded_String (Max_Size => 10);
9838 In that case, the position of field "Length" depends on the size
9839 of field Str, which itself depends on the value of the Max_Size
9840 discriminant. In order to fix the type of variable My_String,
9841 we need to fix the type of field Str. Therefore, fixing a variant
9842 record requires us to fix each of its components.
9844 However, if a component does not have a dynamic size, the component
9845 should not be fixed. In particular, fields that use a PAD type
9846 should not fixed. Here is an example where this might happen
9847 (assuming type Rec above):
9849 type Container (Big : Boolean) is record
9853 when True => Another : Integer;
9857 My_Container : Container := (Big => False,
9858 First => (Empty => True),
9861 In that example, the compiler creates a PAD type for component First,
9862 whose size is constant, and then positions the component After just
9863 right after it. The offset of component After is therefore constant
9866 The debugger computes the position of each field based on an algorithm
9867 that uses, among other things, the actual position and size of the field
9868 preceding it. Let's now imagine that the user is trying to print
9869 the value of My_Container. If the type fixing was recursive, we would
9870 end up computing the offset of field After based on the size of the
9871 fixed version of field First. And since in our example First has
9872 only one actual field, the size of the fixed type is actually smaller
9873 than the amount of space allocated to that field, and thus we would
9874 compute the wrong offset of field After.
9876 To make things more complicated, we need to watch out for dynamic
9877 components of variant records (identified by the ___XVL suffix in
9878 the component name). Even if the target type is a PAD type, the size
9879 of that type might not be statically known. So the PAD type needs
9880 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9881 we might end up with the wrong size for our component. This can be
9882 observed with the following type declarations:
9884 type Octal is new Integer range 0 .. 7;
9885 type Octal_Array is array (Positive range <>) of Octal;
9886 pragma Pack (Octal_Array);
9888 type Octal_Buffer (Size : Positive) is record
9889 Buffer : Octal_Array (1 .. Size);
9893 In that case, Buffer is a PAD type whose size is unset and needs
9894 to be computed by fixing the unwrapped type.
9896 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9897 ----------------------------------------------------------
9899 Lastly, when should the sub-elements of an entity that remained unfixed
9900 thus far, be actually fixed?
9902 The answer is: Only when referencing that element. For instance
9903 when selecting one component of a record, this specific component
9904 should be fixed at that point in time. Or when printing the value
9905 of a record, each component should be fixed before its value gets
9906 printed. Similarly for arrays, the element of the array should be
9907 fixed when printing each element of the array, or when extracting
9908 one element out of that array. On the other hand, fixing should
9909 not be performed on the elements when taking a slice of an array!
9911 Note that one of the side effects of miscomputing the offset and
9912 size of each field is that we end up also miscomputing the size
9913 of the containing type. This can have adverse results when computing
9914 the value of an entity. GDB fetches the value of an entity based
9915 on the size of its type, and thus a wrong size causes GDB to fetch
9916 the wrong amount of memory. In the case where the computed size is
9917 too small, GDB fetches too little data to print the value of our
9918 entity. Results in this case are unpredictable, as we usually read
9919 past the buffer containing the data =:-o. */
9921 /* Evaluate a subexpression of EXP, at index *POS, and return a value
9922 for that subexpression cast to TO_TYPE. Advance *POS over the
9926 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
9927 enum noside noside
, struct type
*to_type
)
9931 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
9932 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
9937 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
9939 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9940 return value_zero (to_type
, not_lval
);
9942 val
= evaluate_var_msym_value (noside
,
9943 exp
->elts
[pc
+ 1].objfile
,
9944 exp
->elts
[pc
+ 2].msymbol
);
9947 val
= evaluate_var_value (noside
,
9948 exp
->elts
[pc
+ 1].block
,
9949 exp
->elts
[pc
+ 2].symbol
);
9951 if (noside
== EVAL_SKIP
)
9952 return eval_skip_value (exp
);
9954 val
= ada_value_cast (to_type
, val
);
9956 /* Follow the Ada language semantics that do not allow taking
9957 an address of the result of a cast (view conversion in Ada). */
9958 if (VALUE_LVAL (val
) == lval_memory
)
9960 if (value_lazy (val
))
9961 value_fetch_lazy (val
);
9962 VALUE_LVAL (val
) = not_lval
;
9967 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
9968 if (noside
== EVAL_SKIP
)
9969 return eval_skip_value (exp
);
9970 return ada_value_cast (to_type
, val
);
9973 /* Implement the evaluate_exp routine in the exp_descriptor structure
9974 for the Ada language. */
9976 static struct value
*
9977 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
9978 int *pos
, enum noside noside
)
9984 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
9987 struct value
**argvec
;
9991 op
= exp
->elts
[pc
].opcode
;
9997 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9999 if (noside
== EVAL_NORMAL
)
10000 arg1
= unwrap_value (arg1
);
10002 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10003 then we need to perform the conversion manually, because
10004 evaluate_subexp_standard doesn't do it. This conversion is
10005 necessary in Ada because the different kinds of float/fixed
10006 types in Ada have different representations.
10008 Similarly, we need to perform the conversion from OP_LONG
10010 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10011 arg1
= ada_value_cast (expect_type
, arg1
);
10017 struct value
*result
;
10020 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10021 /* The result type will have code OP_STRING, bashed there from
10022 OP_ARRAY. Bash it back. */
10023 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10024 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10030 type
= exp
->elts
[pc
+ 1].type
;
10031 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10035 type
= exp
->elts
[pc
+ 1].type
;
10036 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10039 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10040 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10042 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10043 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10045 return ada_value_assign (arg1
, arg1
);
10047 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10048 except if the lhs of our assignment is a convenience variable.
10049 In the case of assigning to a convenience variable, the lhs
10050 should be exactly the result of the evaluation of the rhs. */
10051 type
= value_type (arg1
);
10052 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10054 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10055 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10057 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10061 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10062 arg2
= cast_to_gnat_encoded_fixed_point_type (value_type (arg1
), arg2
);
10063 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10065 (_("Fixed-point values must be assigned to fixed-point variables"));
10067 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10068 return ada_value_assign (arg1
, arg2
);
10071 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10072 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10073 if (noside
== EVAL_SKIP
)
10075 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10076 return (value_from_longest
10077 (value_type (arg1
),
10078 value_as_long (arg1
) + value_as_long (arg2
)));
10079 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10080 return (value_from_longest
10081 (value_type (arg2
),
10082 value_as_long (arg1
) + value_as_long (arg2
)));
10083 /* Preserve the original type for use by the range case below.
10084 We cannot cast the result to a reference type, so if ARG1 is
10085 a reference type, find its underlying type. */
10086 type
= value_type (arg1
);
10087 while (type
->code () == TYPE_CODE_REF
)
10088 type
= TYPE_TARGET_TYPE (type
);
10089 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10090 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10092 if (value_type (arg1
) != value_type (arg2
))
10093 error (_("Operands of fixed-point addition must have the same type"));
10096 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10097 arg1
= value_binop (arg1
, arg2
, BINOP_ADD
);
10098 /* We need to special-case the result of adding to a range.
10099 This is done for the benefit of "ptype". gdb's Ada support
10100 historically used the LHS to set the result type here, so
10101 preserve this behavior. */
10102 if (type
->code () == TYPE_CODE_RANGE
)
10103 arg1
= value_cast (type
, arg1
);
10107 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10108 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10109 if (noside
== EVAL_SKIP
)
10111 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10112 return (value_from_longest
10113 (value_type (arg1
),
10114 value_as_long (arg1
) - value_as_long (arg2
)));
10115 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10116 return (value_from_longest
10117 (value_type (arg2
),
10118 value_as_long (arg1
) - value_as_long (arg2
)));
10119 /* Preserve the original type for use by the range case below.
10120 We cannot cast the result to a reference type, so if ARG1 is
10121 a reference type, find its underlying type. */
10122 type
= value_type (arg1
);
10123 while (type
->code () == TYPE_CODE_REF
)
10124 type
= TYPE_TARGET_TYPE (type
);
10125 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10126 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10128 if (value_type (arg1
) != value_type (arg2
))
10129 error (_("Operands of fixed-point subtraction "
10130 "must have the same type"));
10133 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10134 arg1
= value_binop (arg1
, arg2
, BINOP_SUB
);
10135 /* We need to special-case the result of adding to a range.
10136 This is done for the benefit of "ptype". gdb's Ada support
10137 historically used the LHS to set the result type here, so
10138 preserve this behavior. */
10139 if (type
->code () == TYPE_CODE_RANGE
)
10140 arg1
= value_cast (type
, arg1
);
10147 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10148 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10149 if (noside
== EVAL_SKIP
)
10151 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10153 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10154 return value_zero (value_type (arg1
), not_lval
);
10158 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10159 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10160 arg1
= cast_from_gnat_encoded_fixed_point_type (type
, arg1
);
10161 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10162 arg2
= cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
10163 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10164 return ada_value_binop (arg1
, arg2
, op
);
10168 case BINOP_NOTEQUAL
:
10169 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10170 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10171 if (noside
== EVAL_SKIP
)
10173 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10177 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10178 tem
= ada_value_equal (arg1
, arg2
);
10180 if (op
== BINOP_NOTEQUAL
)
10182 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10183 return value_from_longest (type
, (LONGEST
) tem
);
10186 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10187 if (noside
== EVAL_SKIP
)
10189 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10190 return value_cast (value_type (arg1
), value_neg (arg1
));
10193 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10194 return value_neg (arg1
);
10197 case BINOP_LOGICAL_AND
:
10198 case BINOP_LOGICAL_OR
:
10199 case UNOP_LOGICAL_NOT
:
10204 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10205 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10206 return value_cast (type
, val
);
10209 case BINOP_BITWISE_AND
:
10210 case BINOP_BITWISE_IOR
:
10211 case BINOP_BITWISE_XOR
:
10215 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10217 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10219 return value_cast (value_type (arg1
), val
);
10225 if (noside
== EVAL_SKIP
)
10231 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10232 /* Only encountered when an unresolved symbol occurs in a
10233 context other than a function call, in which case, it is
10235 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10236 exp
->elts
[pc
+ 2].symbol
->print_name ());
10238 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10240 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10241 /* Check to see if this is a tagged type. We also need to handle
10242 the case where the type is a reference to a tagged type, but
10243 we have to be careful to exclude pointers to tagged types.
10244 The latter should be shown as usual (as a pointer), whereas
10245 a reference should mostly be transparent to the user. */
10246 if (ada_is_tagged_type (type
, 0)
10247 || (type
->code () == TYPE_CODE_REF
10248 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10250 /* Tagged types are a little special in the fact that the real
10251 type is dynamic and can only be determined by inspecting the
10252 object's tag. This means that we need to get the object's
10253 value first (EVAL_NORMAL) and then extract the actual object
10256 Note that we cannot skip the final step where we extract
10257 the object type from its tag, because the EVAL_NORMAL phase
10258 results in dynamic components being resolved into fixed ones.
10259 This can cause problems when trying to print the type
10260 description of tagged types whose parent has a dynamic size:
10261 We use the type name of the "_parent" component in order
10262 to print the name of the ancestor type in the type description.
10263 If that component had a dynamic size, the resolution into
10264 a fixed type would result in the loss of that type name,
10265 thus preventing us from printing the name of the ancestor
10266 type in the type description. */
10267 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10269 if (type
->code () != TYPE_CODE_REF
)
10271 struct type
*actual_type
;
10273 actual_type
= type_from_tag (ada_value_tag (arg1
));
10274 if (actual_type
== NULL
)
10275 /* If, for some reason, we were unable to determine
10276 the actual type from the tag, then use the static
10277 approximation that we just computed as a fallback.
10278 This can happen if the debugging information is
10279 incomplete, for instance. */
10280 actual_type
= type
;
10281 return value_zero (actual_type
, not_lval
);
10285 /* In the case of a ref, ada_coerce_ref takes care
10286 of determining the actual type. But the evaluation
10287 should return a ref as it should be valid to ask
10288 for its address; so rebuild a ref after coerce. */
10289 arg1
= ada_coerce_ref (arg1
);
10290 return value_ref (arg1
, TYPE_CODE_REF
);
10294 /* Records and unions for which GNAT encodings have been
10295 generated need to be statically fixed as well.
10296 Otherwise, non-static fixing produces a type where
10297 all dynamic properties are removed, which prevents "ptype"
10298 from being able to completely describe the type.
10299 For instance, a case statement in a variant record would be
10300 replaced by the relevant components based on the actual
10301 value of the discriminants. */
10302 if ((type
->code () == TYPE_CODE_STRUCT
10303 && dynamic_template_type (type
) != NULL
)
10304 || (type
->code () == TYPE_CODE_UNION
10305 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10308 return value_zero (to_static_fixed_type (type
), not_lval
);
10312 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10313 return ada_to_fixed_value (arg1
);
10318 /* Allocate arg vector, including space for the function to be
10319 called in argvec[0] and a terminating NULL. */
10320 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10321 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10323 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10324 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10325 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10326 exp
->elts
[pc
+ 5].symbol
->print_name ());
10329 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10330 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10333 if (noside
== EVAL_SKIP
)
10337 if (ada_is_constrained_packed_array_type
10338 (desc_base_type (value_type (argvec
[0]))))
10339 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10340 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10341 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10342 /* This is a packed array that has already been fixed, and
10343 therefore already coerced to a simple array. Nothing further
10346 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10348 /* Make sure we dereference references so that all the code below
10349 feels like it's really handling the referenced value. Wrapping
10350 types (for alignment) may be there, so make sure we strip them as
10352 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10354 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10355 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10356 argvec
[0] = value_addr (argvec
[0]);
10358 type
= ada_check_typedef (value_type (argvec
[0]));
10360 /* Ada allows us to implicitly dereference arrays when subscripting
10361 them. So, if this is an array typedef (encoding use for array
10362 access types encoded as fat pointers), strip it now. */
10363 if (type
->code () == TYPE_CODE_TYPEDEF
)
10364 type
= ada_typedef_target_type (type
);
10366 if (type
->code () == TYPE_CODE_PTR
)
10368 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10370 case TYPE_CODE_FUNC
:
10371 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10373 case TYPE_CODE_ARRAY
:
10375 case TYPE_CODE_STRUCT
:
10376 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10377 argvec
[0] = ada_value_ind (argvec
[0]);
10378 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10381 error (_("cannot subscript or call something of type `%s'"),
10382 ada_type_name (value_type (argvec
[0])));
10387 switch (type
->code ())
10389 case TYPE_CODE_FUNC
:
10390 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10392 if (TYPE_TARGET_TYPE (type
) == NULL
)
10393 error_call_unknown_return_type (NULL
);
10394 return allocate_value (TYPE_TARGET_TYPE (type
));
10396 return call_function_by_hand (argvec
[0], NULL
,
10397 gdb::make_array_view (argvec
+ 1,
10399 case TYPE_CODE_INTERNAL_FUNCTION
:
10400 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10401 /* We don't know anything about what the internal
10402 function might return, but we have to return
10404 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10407 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10408 argvec
[0], nargs
, argvec
+ 1);
10410 case TYPE_CODE_STRUCT
:
10414 arity
= ada_array_arity (type
);
10415 type
= ada_array_element_type (type
, nargs
);
10417 error (_("cannot subscript or call a record"));
10418 if (arity
!= nargs
)
10419 error (_("wrong number of subscripts; expecting %d"), arity
);
10420 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10421 return value_zero (ada_aligned_type (type
), lval_memory
);
10423 unwrap_value (ada_value_subscript
10424 (argvec
[0], nargs
, argvec
+ 1));
10426 case TYPE_CODE_ARRAY
:
10427 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10429 type
= ada_array_element_type (type
, nargs
);
10431 error (_("element type of array unknown"));
10433 return value_zero (ada_aligned_type (type
), lval_memory
);
10436 unwrap_value (ada_value_subscript
10437 (ada_coerce_to_simple_array (argvec
[0]),
10438 nargs
, argvec
+ 1));
10439 case TYPE_CODE_PTR
: /* Pointer to array */
10440 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10442 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10443 type
= ada_array_element_type (type
, nargs
);
10445 error (_("element type of array unknown"));
10447 return value_zero (ada_aligned_type (type
), lval_memory
);
10450 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10451 nargs
, argvec
+ 1));
10454 error (_("Attempt to index or call something other than an "
10455 "array or function"));
10460 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10461 struct value
*low_bound_val
10462 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10463 struct value
*high_bound_val
10464 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10466 LONGEST high_bound
;
10468 low_bound_val
= coerce_ref (low_bound_val
);
10469 high_bound_val
= coerce_ref (high_bound_val
);
10470 low_bound
= value_as_long (low_bound_val
);
10471 high_bound
= value_as_long (high_bound_val
);
10473 if (noside
== EVAL_SKIP
)
10476 /* If this is a reference to an aligner type, then remove all
10478 if (value_type (array
)->code () == TYPE_CODE_REF
10479 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10480 TYPE_TARGET_TYPE (value_type (array
)) =
10481 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10483 if (ada_is_any_packed_array_type (value_type (array
)))
10484 error (_("cannot slice a packed array"));
10486 /* If this is a reference to an array or an array lvalue,
10487 convert to a pointer. */
10488 if (value_type (array
)->code () == TYPE_CODE_REF
10489 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10490 && VALUE_LVAL (array
) == lval_memory
))
10491 array
= value_addr (array
);
10493 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10494 && ada_is_array_descriptor_type (ada_check_typedef
10495 (value_type (array
))))
10496 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10499 array
= ada_coerce_to_simple_array_ptr (array
);
10501 /* If we have more than one level of pointer indirection,
10502 dereference the value until we get only one level. */
10503 while (value_type (array
)->code () == TYPE_CODE_PTR
10504 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10506 array
= value_ind (array
);
10508 /* Make sure we really do have an array type before going further,
10509 to avoid a SEGV when trying to get the index type or the target
10510 type later down the road if the debug info generated by
10511 the compiler is incorrect or incomplete. */
10512 if (!ada_is_simple_array_type (value_type (array
)))
10513 error (_("cannot take slice of non-array"));
10515 if (ada_check_typedef (value_type (array
))->code ()
10518 struct type
*type0
= ada_check_typedef (value_type (array
));
10520 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10521 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10524 struct type
*arr_type0
=
10525 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10527 return ada_value_slice_from_ptr (array
, arr_type0
,
10528 longest_to_int (low_bound
),
10529 longest_to_int (high_bound
));
10532 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10534 else if (high_bound
< low_bound
)
10535 return empty_array (value_type (array
), low_bound
, high_bound
);
10537 return ada_value_slice (array
, longest_to_int (low_bound
),
10538 longest_to_int (high_bound
));
10541 case UNOP_IN_RANGE
:
10543 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10544 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10546 if (noside
== EVAL_SKIP
)
10549 switch (type
->code ())
10552 lim_warning (_("Membership test incompletely implemented; "
10553 "always returns true"));
10554 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10555 return value_from_longest (type
, (LONGEST
) 1);
10557 case TYPE_CODE_RANGE
:
10558 arg2
= value_from_longest (type
,
10559 type
->bounds ()->low
.const_val ());
10560 arg3
= value_from_longest (type
,
10561 type
->bounds ()->high
.const_val ());
10562 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10563 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10564 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10566 value_from_longest (type
,
10567 (value_less (arg1
, arg3
)
10568 || value_equal (arg1
, arg3
))
10569 && (value_less (arg2
, arg1
)
10570 || value_equal (arg2
, arg1
)));
10573 case BINOP_IN_BOUNDS
:
10575 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10576 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10578 if (noside
== EVAL_SKIP
)
10581 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10583 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10584 return value_zero (type
, not_lval
);
10587 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10589 type
= ada_index_type (value_type (arg2
), tem
, "range");
10591 type
= value_type (arg1
);
10593 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10594 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10596 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10597 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10598 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10600 value_from_longest (type
,
10601 (value_less (arg1
, arg3
)
10602 || value_equal (arg1
, arg3
))
10603 && (value_less (arg2
, arg1
)
10604 || value_equal (arg2
, arg1
)));
10606 case TERNOP_IN_RANGE
:
10607 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10608 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10609 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10611 if (noside
== EVAL_SKIP
)
10614 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10615 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10616 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10618 value_from_longest (type
,
10619 (value_less (arg1
, arg3
)
10620 || value_equal (arg1
, arg3
))
10621 && (value_less (arg2
, arg1
)
10622 || value_equal (arg2
, arg1
)));
10626 case OP_ATR_LENGTH
:
10628 struct type
*type_arg
;
10630 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10632 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10634 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10638 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10642 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10643 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10644 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10647 if (noside
== EVAL_SKIP
)
10649 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10651 if (type_arg
== NULL
)
10652 type_arg
= value_type (arg1
);
10654 if (ada_is_constrained_packed_array_type (type_arg
))
10655 type_arg
= decode_constrained_packed_array_type (type_arg
);
10657 if (!discrete_type_p (type_arg
))
10661 default: /* Should never happen. */
10662 error (_("unexpected attribute encountered"));
10665 type_arg
= ada_index_type (type_arg
, tem
,
10666 ada_attribute_name (op
));
10668 case OP_ATR_LENGTH
:
10669 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10674 return value_zero (type_arg
, not_lval
);
10676 else if (type_arg
== NULL
)
10678 arg1
= ada_coerce_ref (arg1
);
10680 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10681 arg1
= ada_coerce_to_simple_array (arg1
);
10683 if (op
== OP_ATR_LENGTH
)
10684 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10687 type
= ada_index_type (value_type (arg1
), tem
,
10688 ada_attribute_name (op
));
10690 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10695 default: /* Should never happen. */
10696 error (_("unexpected attribute encountered"));
10698 return value_from_longest
10699 (type
, ada_array_bound (arg1
, tem
, 0));
10701 return value_from_longest
10702 (type
, ada_array_bound (arg1
, tem
, 1));
10703 case OP_ATR_LENGTH
:
10704 return value_from_longest
10705 (type
, ada_array_length (arg1
, tem
));
10708 else if (discrete_type_p (type_arg
))
10710 struct type
*range_type
;
10711 const char *name
= ada_type_name (type_arg
);
10714 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10715 range_type
= to_fixed_range_type (type_arg
, NULL
);
10716 if (range_type
== NULL
)
10717 range_type
= type_arg
;
10721 error (_("unexpected attribute encountered"));
10723 return value_from_longest
10724 (range_type
, ada_discrete_type_low_bound (range_type
));
10726 return value_from_longest
10727 (range_type
, ada_discrete_type_high_bound (range_type
));
10728 case OP_ATR_LENGTH
:
10729 error (_("the 'length attribute applies only to array types"));
10732 else if (type_arg
->code () == TYPE_CODE_FLT
)
10733 error (_("unimplemented type attribute"));
10738 if (ada_is_constrained_packed_array_type (type_arg
))
10739 type_arg
= decode_constrained_packed_array_type (type_arg
);
10741 if (op
== OP_ATR_LENGTH
)
10742 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10745 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10747 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10753 error (_("unexpected attribute encountered"));
10755 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10756 return value_from_longest (type
, low
);
10758 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10759 return value_from_longest (type
, high
);
10760 case OP_ATR_LENGTH
:
10761 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10762 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10763 return value_from_longest (type
, high
- low
+ 1);
10769 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10770 if (noside
== EVAL_SKIP
)
10773 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10774 return value_zero (ada_tag_type (arg1
), not_lval
);
10776 return ada_value_tag (arg1
);
10780 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10781 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10782 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10783 if (noside
== EVAL_SKIP
)
10785 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10786 return value_zero (value_type (arg1
), not_lval
);
10789 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10790 return value_binop (arg1
, arg2
,
10791 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10794 case OP_ATR_MODULUS
:
10796 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10798 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10799 if (noside
== EVAL_SKIP
)
10802 if (!ada_is_modular_type (type_arg
))
10803 error (_("'modulus must be applied to modular type"));
10805 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10806 ada_modulus (type_arg
));
10811 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10812 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10813 if (noside
== EVAL_SKIP
)
10815 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10816 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10817 return value_zero (type
, not_lval
);
10819 return value_pos_atr (type
, arg1
);
10822 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10823 type
= value_type (arg1
);
10825 /* If the argument is a reference, then dereference its type, since
10826 the user is really asking for the size of the actual object,
10827 not the size of the pointer. */
10828 if (type
->code () == TYPE_CODE_REF
)
10829 type
= TYPE_TARGET_TYPE (type
);
10831 if (noside
== EVAL_SKIP
)
10833 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10834 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10836 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10837 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10840 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10841 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10842 type
= exp
->elts
[pc
+ 2].type
;
10843 if (noside
== EVAL_SKIP
)
10845 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10846 return value_zero (type
, not_lval
);
10848 return value_val_atr (type
, arg1
);
10851 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10852 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10853 if (noside
== EVAL_SKIP
)
10855 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10856 return value_zero (value_type (arg1
), not_lval
);
10859 /* For integer exponentiation operations,
10860 only promote the first argument. */
10861 if (is_integral_type (value_type (arg2
)))
10862 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10864 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10866 return value_binop (arg1
, arg2
, op
);
10870 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10871 if (noside
== EVAL_SKIP
)
10877 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10878 if (noside
== EVAL_SKIP
)
10880 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10881 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10882 return value_neg (arg1
);
10887 preeval_pos
= *pos
;
10888 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10889 if (noside
== EVAL_SKIP
)
10891 type
= ada_check_typedef (value_type (arg1
));
10892 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10894 if (ada_is_array_descriptor_type (type
))
10895 /* GDB allows dereferencing GNAT array descriptors. */
10897 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10899 if (arrType
== NULL
)
10900 error (_("Attempt to dereference null array pointer."));
10901 return value_at_lazy (arrType
, 0);
10903 else if (type
->code () == TYPE_CODE_PTR
10904 || type
->code () == TYPE_CODE_REF
10905 /* In C you can dereference an array to get the 1st elt. */
10906 || type
->code () == TYPE_CODE_ARRAY
)
10908 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10909 only be determined by inspecting the object's tag.
10910 This means that we need to evaluate completely the
10911 expression in order to get its type. */
10913 if ((type
->code () == TYPE_CODE_REF
10914 || type
->code () == TYPE_CODE_PTR
)
10915 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10918 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10919 type
= value_type (ada_value_ind (arg1
));
10923 type
= to_static_fixed_type
10925 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10927 ada_ensure_varsize_limit (type
);
10928 return value_zero (type
, lval_memory
);
10930 else if (type
->code () == TYPE_CODE_INT
)
10932 /* GDB allows dereferencing an int. */
10933 if (expect_type
== NULL
)
10934 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10939 to_static_fixed_type (ada_aligned_type (expect_type
));
10940 return value_zero (expect_type
, lval_memory
);
10944 error (_("Attempt to take contents of a non-pointer value."));
10946 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10947 type
= ada_check_typedef (value_type (arg1
));
10949 if (type
->code () == TYPE_CODE_INT
)
10950 /* GDB allows dereferencing an int. If we were given
10951 the expect_type, then use that as the target type.
10952 Otherwise, assume that the target type is an int. */
10954 if (expect_type
!= NULL
)
10955 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
10958 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
10959 (CORE_ADDR
) value_as_address (arg1
));
10962 if (ada_is_array_descriptor_type (type
))
10963 /* GDB allows dereferencing GNAT array descriptors. */
10964 return ada_coerce_to_simple_array (arg1
);
10966 return ada_value_ind (arg1
);
10968 case STRUCTOP_STRUCT
:
10969 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10970 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
10971 preeval_pos
= *pos
;
10972 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10973 if (noside
== EVAL_SKIP
)
10975 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10977 struct type
*type1
= value_type (arg1
);
10979 if (ada_is_tagged_type (type1
, 1))
10981 type
= ada_lookup_struct_elt_type (type1
,
10982 &exp
->elts
[pc
+ 2].string
,
10985 /* If the field is not found, check if it exists in the
10986 extension of this object's type. This means that we
10987 need to evaluate completely the expression. */
10992 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
10993 arg1
= ada_value_struct_elt (arg1
,
10994 &exp
->elts
[pc
+ 2].string
,
10996 arg1
= unwrap_value (arg1
);
10997 type
= value_type (ada_to_fixed_value (arg1
));
11002 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11005 return value_zero (ada_aligned_type (type
), lval_memory
);
11009 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11010 arg1
= unwrap_value (arg1
);
11011 return ada_to_fixed_value (arg1
);
11015 /* The value is not supposed to be used. This is here to make it
11016 easier to accommodate expressions that contain types. */
11018 if (noside
== EVAL_SKIP
)
11020 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11021 return allocate_value (exp
->elts
[pc
+ 1].type
);
11023 error (_("Attempt to use a type name as an expression"));
11028 case OP_DISCRETE_RANGE
:
11029 case OP_POSITIONAL
:
11031 if (noside
== EVAL_NORMAL
)
11035 error (_("Undefined name, ambiguous name, or renaming used in "
11036 "component association: %s."), &exp
->elts
[pc
+2].string
);
11038 error (_("Aggregates only allowed on the right of an assignment"));
11040 internal_error (__FILE__
, __LINE__
,
11041 _("aggregate apparently mangled"));
11044 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11046 for (tem
= 0; tem
< nargs
; tem
+= 1)
11047 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11052 return eval_skip_value (exp
);
11058 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11059 type name that encodes the 'small and 'delta information.
11060 Otherwise, return NULL. */
11062 static const char *
11063 gnat_encoded_fixed_point_type_info (struct type
*type
)
11065 const char *name
= ada_type_name (type
);
11066 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11068 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11070 const char *tail
= strstr (name
, "___XF_");
11077 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11078 return gnat_encoded_fixed_point_type_info (TYPE_TARGET_TYPE (type
));
11083 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11086 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11088 return gnat_encoded_fixed_point_type_info (type
) != NULL
;
11091 /* Return non-zero iff TYPE represents a System.Address type. */
11094 ada_is_system_address_type (struct type
*type
)
11096 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11099 /* Assuming that TYPE is the representation of an Ada fixed-point
11100 type, return the target floating-point type to be used to represent
11101 of this type during internal computation. */
11103 static struct type
*
11104 ada_scaling_type (struct type
*type
)
11106 return builtin_type (type
->arch ())->builtin_long_double
;
11109 /* Assuming that TYPE is the representation of an Ada fixed-point
11110 type, return its delta, or NULL if the type is malformed and the
11111 delta cannot be determined. */
11114 gnat_encoded_fixed_point_delta (struct type
*type
)
11116 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11117 struct type
*scale_type
= ada_scaling_type (type
);
11119 long long num
, den
;
11121 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11124 return value_binop (value_from_longest (scale_type
, num
),
11125 value_from_longest (scale_type
, den
), BINOP_DIV
);
11128 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11129 the scaling factor ('SMALL value) associated with the type. */
11132 gnat_encoded_fixed_point_scaling_factor (struct type
*type
)
11134 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11135 struct type
*scale_type
= ada_scaling_type (type
);
11137 long long num0
, den0
, num1
, den1
;
11140 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11141 &num0
, &den0
, &num1
, &den1
);
11144 return value_from_longest (scale_type
, 1);
11146 return value_binop (value_from_longest (scale_type
, num1
),
11147 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11149 return value_binop (value_from_longest (scale_type
, num0
),
11150 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11157 /* Scan STR beginning at position K for a discriminant name, and
11158 return the value of that discriminant field of DVAL in *PX. If
11159 PNEW_K is not null, put the position of the character beyond the
11160 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11161 not alter *PX and *PNEW_K if unsuccessful. */
11164 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11167 static std::string storage
;
11168 const char *pstart
, *pend
, *bound
;
11169 struct value
*bound_val
;
11171 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11175 pend
= strstr (pstart
, "__");
11179 k
+= strlen (bound
);
11183 int len
= pend
- pstart
;
11185 /* Strip __ and beyond. */
11186 storage
= std::string (pstart
, len
);
11187 bound
= storage
.c_str ();
11191 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11192 if (bound_val
== NULL
)
11195 *px
= value_as_long (bound_val
);
11196 if (pnew_k
!= NULL
)
11201 /* Value of variable named NAME. Only exact matches are considered.
11202 If no such variable found, then if ERR_MSG is null, returns 0, and
11203 otherwise causes an error with message ERR_MSG. */
11205 static struct value
*
11206 get_var_value (const char *name
, const char *err_msg
)
11208 std::string quoted_name
= add_angle_brackets (name
);
11210 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11212 std::vector
<struct block_symbol
> syms
11213 = ada_lookup_symbol_list_worker (lookup_name
,
11214 get_selected_block (0),
11217 if (syms
.size () != 1)
11219 if (err_msg
== NULL
)
11222 error (("%s"), err_msg
);
11225 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11228 /* Value of integer variable named NAME in the current environment.
11229 If no such variable is found, returns false. Otherwise, sets VALUE
11230 to the variable's value and returns true. */
11233 get_int_var_value (const char *name
, LONGEST
&value
)
11235 struct value
*var_val
= get_var_value (name
, 0);
11240 value
= value_as_long (var_val
);
11245 /* Return a range type whose base type is that of the range type named
11246 NAME in the current environment, and whose bounds are calculated
11247 from NAME according to the GNAT range encoding conventions.
11248 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11249 corresponding range type from debug information; fall back to using it
11250 if symbol lookup fails. If a new type must be created, allocate it
11251 like ORIG_TYPE was. The bounds information, in general, is encoded
11252 in NAME, the base type given in the named range type. */
11254 static struct type
*
11255 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11258 struct type
*base_type
;
11259 const char *subtype_info
;
11261 gdb_assert (raw_type
!= NULL
);
11262 gdb_assert (raw_type
->name () != NULL
);
11264 if (raw_type
->code () == TYPE_CODE_RANGE
)
11265 base_type
= TYPE_TARGET_TYPE (raw_type
);
11267 base_type
= raw_type
;
11269 name
= raw_type
->name ();
11270 subtype_info
= strstr (name
, "___XD");
11271 if (subtype_info
== NULL
)
11273 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11274 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11276 if (L
< INT_MIN
|| U
> INT_MAX
)
11279 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11284 int prefix_len
= subtype_info
- name
;
11287 const char *bounds_str
;
11291 bounds_str
= strchr (subtype_info
, '_');
11294 if (*subtype_info
== 'L')
11296 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11297 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11299 if (bounds_str
[n
] == '_')
11301 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11307 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11308 if (!get_int_var_value (name_buf
.c_str (), L
))
11310 lim_warning (_("Unknown lower bound, using 1."));
11315 if (*subtype_info
== 'U')
11317 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11318 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11323 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11324 if (!get_int_var_value (name_buf
.c_str (), U
))
11326 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11331 type
= create_static_range_type (alloc_type_copy (raw_type
),
11333 /* create_static_range_type alters the resulting type's length
11334 to match the size of the base_type, which is not what we want.
11335 Set it back to the original range type's length. */
11336 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11337 type
->set_name (name
);
11342 /* True iff NAME is the name of a range type. */
11345 ada_is_range_type_name (const char *name
)
11347 return (name
!= NULL
&& strstr (name
, "___XD"));
11351 /* Modular types */
11353 /* True iff TYPE is an Ada modular type. */
11356 ada_is_modular_type (struct type
*type
)
11358 struct type
*subranged_type
= get_base_type (type
);
11360 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11361 && subranged_type
->code () == TYPE_CODE_INT
11362 && subranged_type
->is_unsigned ());
11365 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11368 ada_modulus (struct type
*type
)
11370 const dynamic_prop
&high
= type
->bounds ()->high
;
11372 if (high
.kind () == PROP_CONST
)
11373 return (ULONGEST
) high
.const_val () + 1;
11375 /* If TYPE is unresolved, the high bound might be a location list. Return
11376 0, for lack of a better value to return. */
11381 /* Ada exception catchpoint support:
11382 ---------------------------------
11384 We support 3 kinds of exception catchpoints:
11385 . catchpoints on Ada exceptions
11386 . catchpoints on unhandled Ada exceptions
11387 . catchpoints on failed assertions
11389 Exceptions raised during failed assertions, or unhandled exceptions
11390 could perfectly be caught with the general catchpoint on Ada exceptions.
11391 However, we can easily differentiate these two special cases, and having
11392 the option to distinguish these two cases from the rest can be useful
11393 to zero-in on certain situations.
11395 Exception catchpoints are a specialized form of breakpoint,
11396 since they rely on inserting breakpoints inside known routines
11397 of the GNAT runtime. The implementation therefore uses a standard
11398 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11401 Support in the runtime for exception catchpoints have been changed
11402 a few times already, and these changes affect the implementation
11403 of these catchpoints. In order to be able to support several
11404 variants of the runtime, we use a sniffer that will determine
11405 the runtime variant used by the program being debugged. */
11407 /* Ada's standard exceptions.
11409 The Ada 83 standard also defined Numeric_Error. But there so many
11410 situations where it was unclear from the Ada 83 Reference Manual
11411 (RM) whether Constraint_Error or Numeric_Error should be raised,
11412 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11413 Interpretation saying that anytime the RM says that Numeric_Error
11414 should be raised, the implementation may raise Constraint_Error.
11415 Ada 95 went one step further and pretty much removed Numeric_Error
11416 from the list of standard exceptions (it made it a renaming of
11417 Constraint_Error, to help preserve compatibility when compiling
11418 an Ada83 compiler). As such, we do not include Numeric_Error from
11419 this list of standard exceptions. */
11421 static const char * const standard_exc
[] = {
11422 "constraint_error",
11428 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11430 /* A structure that describes how to support exception catchpoints
11431 for a given executable. */
11433 struct exception_support_info
11435 /* The name of the symbol to break on in order to insert
11436 a catchpoint on exceptions. */
11437 const char *catch_exception_sym
;
11439 /* The name of the symbol to break on in order to insert
11440 a catchpoint on unhandled exceptions. */
11441 const char *catch_exception_unhandled_sym
;
11443 /* The name of the symbol to break on in order to insert
11444 a catchpoint on failed assertions. */
11445 const char *catch_assert_sym
;
11447 /* The name of the symbol to break on in order to insert
11448 a catchpoint on exception handling. */
11449 const char *catch_handlers_sym
;
11451 /* Assuming that the inferior just triggered an unhandled exception
11452 catchpoint, this function is responsible for returning the address
11453 in inferior memory where the name of that exception is stored.
11454 Return zero if the address could not be computed. */
11455 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11458 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11459 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11461 /* The following exception support info structure describes how to
11462 implement exception catchpoints with the latest version of the
11463 Ada runtime (as of 2019-08-??). */
11465 static const struct exception_support_info default_exception_support_info
=
11467 "__gnat_debug_raise_exception", /* catch_exception_sym */
11468 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11469 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11470 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11471 ada_unhandled_exception_name_addr
11474 /* The following exception support info structure describes how to
11475 implement exception catchpoints with an earlier version of the
11476 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11478 static const struct exception_support_info exception_support_info_v0
=
11480 "__gnat_debug_raise_exception", /* catch_exception_sym */
11481 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11482 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11483 "__gnat_begin_handler", /* catch_handlers_sym */
11484 ada_unhandled_exception_name_addr
11487 /* The following exception support info structure describes how to
11488 implement exception catchpoints with a slightly older version
11489 of the Ada runtime. */
11491 static const struct exception_support_info exception_support_info_fallback
=
11493 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11494 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11495 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11496 "__gnat_begin_handler", /* catch_handlers_sym */
11497 ada_unhandled_exception_name_addr_from_raise
11500 /* Return nonzero if we can detect the exception support routines
11501 described in EINFO.
11503 This function errors out if an abnormal situation is detected
11504 (for instance, if we find the exception support routines, but
11505 that support is found to be incomplete). */
11508 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11510 struct symbol
*sym
;
11512 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11513 that should be compiled with debugging information. As a result, we
11514 expect to find that symbol in the symtabs. */
11516 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11519 /* Perhaps we did not find our symbol because the Ada runtime was
11520 compiled without debugging info, or simply stripped of it.
11521 It happens on some GNU/Linux distributions for instance, where
11522 users have to install a separate debug package in order to get
11523 the runtime's debugging info. In that situation, let the user
11524 know why we cannot insert an Ada exception catchpoint.
11526 Note: Just for the purpose of inserting our Ada exception
11527 catchpoint, we could rely purely on the associated minimal symbol.
11528 But we would be operating in degraded mode anyway, since we are
11529 still lacking the debugging info needed later on to extract
11530 the name of the exception being raised (this name is printed in
11531 the catchpoint message, and is also used when trying to catch
11532 a specific exception). We do not handle this case for now. */
11533 struct bound_minimal_symbol msym
11534 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11536 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11537 error (_("Your Ada runtime appears to be missing some debugging "
11538 "information.\nCannot insert Ada exception catchpoint "
11539 "in this configuration."));
11544 /* Make sure that the symbol we found corresponds to a function. */
11546 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11548 error (_("Symbol \"%s\" is not a function (class = %d)"),
11549 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11553 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11556 struct bound_minimal_symbol msym
11557 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11559 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11560 error (_("Your Ada runtime appears to be missing some debugging "
11561 "information.\nCannot insert Ada exception catchpoint "
11562 "in this configuration."));
11567 /* Make sure that the symbol we found corresponds to a function. */
11569 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11571 error (_("Symbol \"%s\" is not a function (class = %d)"),
11572 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11579 /* Inspect the Ada runtime and determine which exception info structure
11580 should be used to provide support for exception catchpoints.
11582 This function will always set the per-inferior exception_info,
11583 or raise an error. */
11586 ada_exception_support_info_sniffer (void)
11588 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11590 /* If the exception info is already known, then no need to recompute it. */
11591 if (data
->exception_info
!= NULL
)
11594 /* Check the latest (default) exception support info. */
11595 if (ada_has_this_exception_support (&default_exception_support_info
))
11597 data
->exception_info
= &default_exception_support_info
;
11601 /* Try the v0 exception suport info. */
11602 if (ada_has_this_exception_support (&exception_support_info_v0
))
11604 data
->exception_info
= &exception_support_info_v0
;
11608 /* Try our fallback exception suport info. */
11609 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11611 data
->exception_info
= &exception_support_info_fallback
;
11615 /* Sometimes, it is normal for us to not be able to find the routine
11616 we are looking for. This happens when the program is linked with
11617 the shared version of the GNAT runtime, and the program has not been
11618 started yet. Inform the user of these two possible causes if
11621 if (ada_update_initial_language (language_unknown
) != language_ada
)
11622 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11624 /* If the symbol does not exist, then check that the program is
11625 already started, to make sure that shared libraries have been
11626 loaded. If it is not started, this may mean that the symbol is
11627 in a shared library. */
11629 if (inferior_ptid
.pid () == 0)
11630 error (_("Unable to insert catchpoint. Try to start the program first."));
11632 /* At this point, we know that we are debugging an Ada program and
11633 that the inferior has been started, but we still are not able to
11634 find the run-time symbols. That can mean that we are in
11635 configurable run time mode, or that a-except as been optimized
11636 out by the linker... In any case, at this point it is not worth
11637 supporting this feature. */
11639 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11642 /* True iff FRAME is very likely to be that of a function that is
11643 part of the runtime system. This is all very heuristic, but is
11644 intended to be used as advice as to what frames are uninteresting
11648 is_known_support_routine (struct frame_info
*frame
)
11650 enum language func_lang
;
11652 const char *fullname
;
11654 /* If this code does not have any debugging information (no symtab),
11655 This cannot be any user code. */
11657 symtab_and_line sal
= find_frame_sal (frame
);
11658 if (sal
.symtab
== NULL
)
11661 /* If there is a symtab, but the associated source file cannot be
11662 located, then assume this is not user code: Selecting a frame
11663 for which we cannot display the code would not be very helpful
11664 for the user. This should also take care of case such as VxWorks
11665 where the kernel has some debugging info provided for a few units. */
11667 fullname
= symtab_to_fullname (sal
.symtab
);
11668 if (access (fullname
, R_OK
) != 0)
11671 /* Check the unit filename against the Ada runtime file naming.
11672 We also check the name of the objfile against the name of some
11673 known system libraries that sometimes come with debugging info
11676 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11678 re_comp (known_runtime_file_name_patterns
[i
]);
11679 if (re_exec (lbasename (sal
.symtab
->filename
)))
11681 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11682 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11686 /* Check whether the function is a GNAT-generated entity. */
11688 gdb::unique_xmalloc_ptr
<char> func_name
11689 = find_frame_funname (frame
, &func_lang
, NULL
);
11690 if (func_name
== NULL
)
11693 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11695 re_comp (known_auxiliary_function_name_patterns
[i
]);
11696 if (re_exec (func_name
.get ()))
11703 /* Find the first frame that contains debugging information and that is not
11704 part of the Ada run-time, starting from FI and moving upward. */
11707 ada_find_printable_frame (struct frame_info
*fi
)
11709 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11711 if (!is_known_support_routine (fi
))
11720 /* Assuming that the inferior just triggered an unhandled exception
11721 catchpoint, return the address in inferior memory where the name
11722 of the exception is stored.
11724 Return zero if the address could not be computed. */
11727 ada_unhandled_exception_name_addr (void)
11729 return parse_and_eval_address ("e.full_name");
11732 /* Same as ada_unhandled_exception_name_addr, except that this function
11733 should be used when the inferior uses an older version of the runtime,
11734 where the exception name needs to be extracted from a specific frame
11735 several frames up in the callstack. */
11738 ada_unhandled_exception_name_addr_from_raise (void)
11741 struct frame_info
*fi
;
11742 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11744 /* To determine the name of this exception, we need to select
11745 the frame corresponding to RAISE_SYM_NAME. This frame is
11746 at least 3 levels up, so we simply skip the first 3 frames
11747 without checking the name of their associated function. */
11748 fi
= get_current_frame ();
11749 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11751 fi
= get_prev_frame (fi
);
11755 enum language func_lang
;
11757 gdb::unique_xmalloc_ptr
<char> func_name
11758 = find_frame_funname (fi
, &func_lang
, NULL
);
11759 if (func_name
!= NULL
)
11761 if (strcmp (func_name
.get (),
11762 data
->exception_info
->catch_exception_sym
) == 0)
11763 break; /* We found the frame we were looking for... */
11765 fi
= get_prev_frame (fi
);
11772 return parse_and_eval_address ("id.full_name");
11775 /* Assuming the inferior just triggered an Ada exception catchpoint
11776 (of any type), return the address in inferior memory where the name
11777 of the exception is stored, if applicable.
11779 Assumes the selected frame is the current frame.
11781 Return zero if the address could not be computed, or if not relevant. */
11784 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11785 struct breakpoint
*b
)
11787 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11791 case ada_catch_exception
:
11792 return (parse_and_eval_address ("e.full_name"));
11795 case ada_catch_exception_unhandled
:
11796 return data
->exception_info
->unhandled_exception_name_addr ();
11799 case ada_catch_handlers
:
11800 return 0; /* The runtimes does not provide access to the exception
11804 case ada_catch_assert
:
11805 return 0; /* Exception name is not relevant in this case. */
11809 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11813 return 0; /* Should never be reached. */
11816 /* Assuming the inferior is stopped at an exception catchpoint,
11817 return the message which was associated to the exception, if
11818 available. Return NULL if the message could not be retrieved.
11820 Note: The exception message can be associated to an exception
11821 either through the use of the Raise_Exception function, or
11822 more simply (Ada 2005 and later), via:
11824 raise Exception_Name with "exception message";
11828 static gdb::unique_xmalloc_ptr
<char>
11829 ada_exception_message_1 (void)
11831 struct value
*e_msg_val
;
11834 /* For runtimes that support this feature, the exception message
11835 is passed as an unbounded string argument called "message". */
11836 e_msg_val
= parse_and_eval ("message");
11837 if (e_msg_val
== NULL
)
11838 return NULL
; /* Exception message not supported. */
11840 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11841 gdb_assert (e_msg_val
!= NULL
);
11842 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11844 /* If the message string is empty, then treat it as if there was
11845 no exception message. */
11846 if (e_msg_len
<= 0)
11849 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11850 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11852 e_msg
.get ()[e_msg_len
] = '\0';
11857 /* Same as ada_exception_message_1, except that all exceptions are
11858 contained here (returning NULL instead). */
11860 static gdb::unique_xmalloc_ptr
<char>
11861 ada_exception_message (void)
11863 gdb::unique_xmalloc_ptr
<char> e_msg
;
11867 e_msg
= ada_exception_message_1 ();
11869 catch (const gdb_exception_error
&e
)
11871 e_msg
.reset (nullptr);
11877 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11878 any error that ada_exception_name_addr_1 might cause to be thrown.
11879 When an error is intercepted, a warning with the error message is printed,
11880 and zero is returned. */
11883 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11884 struct breakpoint
*b
)
11886 CORE_ADDR result
= 0;
11890 result
= ada_exception_name_addr_1 (ex
, b
);
11893 catch (const gdb_exception_error
&e
)
11895 warning (_("failed to get exception name: %s"), e
.what ());
11902 static std::string ada_exception_catchpoint_cond_string
11903 (const char *excep_string
,
11904 enum ada_exception_catchpoint_kind ex
);
11906 /* Ada catchpoints.
11908 In the case of catchpoints on Ada exceptions, the catchpoint will
11909 stop the target on every exception the program throws. When a user
11910 specifies the name of a specific exception, we translate this
11911 request into a condition expression (in text form), and then parse
11912 it into an expression stored in each of the catchpoint's locations.
11913 We then use this condition to check whether the exception that was
11914 raised is the one the user is interested in. If not, then the
11915 target is resumed again. We store the name of the requested
11916 exception, in order to be able to re-set the condition expression
11917 when symbols change. */
11919 /* An instance of this type is used to represent an Ada catchpoint
11920 breakpoint location. */
11922 class ada_catchpoint_location
: public bp_location
11925 ada_catchpoint_location (breakpoint
*owner
)
11926 : bp_location (owner
, bp_loc_software_breakpoint
)
11929 /* The condition that checks whether the exception that was raised
11930 is the specific exception the user specified on catchpoint
11932 expression_up excep_cond_expr
;
11935 /* An instance of this type is used to represent an Ada catchpoint. */
11937 struct ada_catchpoint
: public breakpoint
11939 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
11944 /* The name of the specific exception the user specified. */
11945 std::string excep_string
;
11947 /* What kind of catchpoint this is. */
11948 enum ada_exception_catchpoint_kind m_kind
;
11951 /* Parse the exception condition string in the context of each of the
11952 catchpoint's locations, and store them for later evaluation. */
11955 create_excep_cond_exprs (struct ada_catchpoint
*c
,
11956 enum ada_exception_catchpoint_kind ex
)
11958 struct bp_location
*bl
;
11960 /* Nothing to do if there's no specific exception to catch. */
11961 if (c
->excep_string
.empty ())
11964 /* Same if there are no locations... */
11965 if (c
->loc
== NULL
)
11968 /* Compute the condition expression in text form, from the specific
11969 expection we want to catch. */
11970 std::string cond_string
11971 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
11973 /* Iterate over all the catchpoint's locations, and parse an
11974 expression for each. */
11975 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
11977 struct ada_catchpoint_location
*ada_loc
11978 = (struct ada_catchpoint_location
*) bl
;
11981 if (!bl
->shlib_disabled
)
11985 s
= cond_string
.c_str ();
11988 exp
= parse_exp_1 (&s
, bl
->address
,
11989 block_for_pc (bl
->address
),
11992 catch (const gdb_exception_error
&e
)
11994 warning (_("failed to reevaluate internal exception condition "
11995 "for catchpoint %d: %s"),
11996 c
->number
, e
.what ());
12000 ada_loc
->excep_cond_expr
= std::move (exp
);
12004 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12005 structure for all exception catchpoint kinds. */
12007 static struct bp_location
*
12008 allocate_location_exception (struct breakpoint
*self
)
12010 return new ada_catchpoint_location (self
);
12013 /* Implement the RE_SET method in the breakpoint_ops structure for all
12014 exception catchpoint kinds. */
12017 re_set_exception (struct breakpoint
*b
)
12019 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12021 /* Call the base class's method. This updates the catchpoint's
12023 bkpt_breakpoint_ops
.re_set (b
);
12025 /* Reparse the exception conditional expressions. One for each
12027 create_excep_cond_exprs (c
, c
->m_kind
);
12030 /* Returns true if we should stop for this breakpoint hit. If the
12031 user specified a specific exception, we only want to cause a stop
12032 if the program thrown that exception. */
12035 should_stop_exception (const struct bp_location
*bl
)
12037 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12038 const struct ada_catchpoint_location
*ada_loc
12039 = (const struct ada_catchpoint_location
*) bl
;
12042 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12043 if (c
->m_kind
== ada_catch_assert
)
12044 clear_internalvar (var
);
12051 if (c
->m_kind
== ada_catch_handlers
)
12052 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12053 ".all.occurrence.id");
12057 struct value
*exc
= parse_and_eval (expr
);
12058 set_internalvar (var
, exc
);
12060 catch (const gdb_exception_error
&ex
)
12062 clear_internalvar (var
);
12066 /* With no specific exception, should always stop. */
12067 if (c
->excep_string
.empty ())
12070 if (ada_loc
->excep_cond_expr
== NULL
)
12072 /* We will have a NULL expression if back when we were creating
12073 the expressions, this location's had failed to parse. */
12080 struct value
*mark
;
12082 mark
= value_mark ();
12083 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12084 value_free_to_mark (mark
);
12086 catch (const gdb_exception
&ex
)
12088 exception_fprintf (gdb_stderr
, ex
,
12089 _("Error in testing exception condition:\n"));
12095 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12096 for all exception catchpoint kinds. */
12099 check_status_exception (bpstat bs
)
12101 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12104 /* Implement the PRINT_IT method in the breakpoint_ops structure
12105 for all exception catchpoint kinds. */
12107 static enum print_stop_action
12108 print_it_exception (bpstat bs
)
12110 struct ui_out
*uiout
= current_uiout
;
12111 struct breakpoint
*b
= bs
->breakpoint_at
;
12113 annotate_catchpoint (b
->number
);
12115 if (uiout
->is_mi_like_p ())
12117 uiout
->field_string ("reason",
12118 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12119 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12122 uiout
->text (b
->disposition
== disp_del
12123 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12124 uiout
->field_signed ("bkptno", b
->number
);
12125 uiout
->text (", ");
12127 /* ada_exception_name_addr relies on the selected frame being the
12128 current frame. Need to do this here because this function may be
12129 called more than once when printing a stop, and below, we'll
12130 select the first frame past the Ada run-time (see
12131 ada_find_printable_frame). */
12132 select_frame (get_current_frame ());
12134 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12137 case ada_catch_exception
:
12138 case ada_catch_exception_unhandled
:
12139 case ada_catch_handlers
:
12141 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12142 char exception_name
[256];
12146 read_memory (addr
, (gdb_byte
*) exception_name
,
12147 sizeof (exception_name
) - 1);
12148 exception_name
[sizeof (exception_name
) - 1] = '\0';
12152 /* For some reason, we were unable to read the exception
12153 name. This could happen if the Runtime was compiled
12154 without debugging info, for instance. In that case,
12155 just replace the exception name by the generic string
12156 "exception" - it will read as "an exception" in the
12157 notification we are about to print. */
12158 memcpy (exception_name
, "exception", sizeof ("exception"));
12160 /* In the case of unhandled exception breakpoints, we print
12161 the exception name as "unhandled EXCEPTION_NAME", to make
12162 it clearer to the user which kind of catchpoint just got
12163 hit. We used ui_out_text to make sure that this extra
12164 info does not pollute the exception name in the MI case. */
12165 if (c
->m_kind
== ada_catch_exception_unhandled
)
12166 uiout
->text ("unhandled ");
12167 uiout
->field_string ("exception-name", exception_name
);
12170 case ada_catch_assert
:
12171 /* In this case, the name of the exception is not really
12172 important. Just print "failed assertion" to make it clearer
12173 that his program just hit an assertion-failure catchpoint.
12174 We used ui_out_text because this info does not belong in
12176 uiout
->text ("failed assertion");
12180 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12181 if (exception_message
!= NULL
)
12183 uiout
->text (" (");
12184 uiout
->field_string ("exception-message", exception_message
.get ());
12188 uiout
->text (" at ");
12189 ada_find_printable_frame (get_current_frame ());
12191 return PRINT_SRC_AND_LOC
;
12194 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12195 for all exception catchpoint kinds. */
12198 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12200 struct ui_out
*uiout
= current_uiout
;
12201 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12202 struct value_print_options opts
;
12204 get_user_print_options (&opts
);
12206 if (opts
.addressprint
)
12207 uiout
->field_skip ("addr");
12209 annotate_field (5);
12212 case ada_catch_exception
:
12213 if (!c
->excep_string
.empty ())
12215 std::string msg
= string_printf (_("`%s' Ada exception"),
12216 c
->excep_string
.c_str ());
12218 uiout
->field_string ("what", msg
);
12221 uiout
->field_string ("what", "all Ada exceptions");
12225 case ada_catch_exception_unhandled
:
12226 uiout
->field_string ("what", "unhandled Ada exceptions");
12229 case ada_catch_handlers
:
12230 if (!c
->excep_string
.empty ())
12232 uiout
->field_fmt ("what",
12233 _("`%s' Ada exception handlers"),
12234 c
->excep_string
.c_str ());
12237 uiout
->field_string ("what", "all Ada exceptions handlers");
12240 case ada_catch_assert
:
12241 uiout
->field_string ("what", "failed Ada assertions");
12245 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12250 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12251 for all exception catchpoint kinds. */
12254 print_mention_exception (struct breakpoint
*b
)
12256 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12257 struct ui_out
*uiout
= current_uiout
;
12259 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12260 : _("Catchpoint "));
12261 uiout
->field_signed ("bkptno", b
->number
);
12262 uiout
->text (": ");
12266 case ada_catch_exception
:
12267 if (!c
->excep_string
.empty ())
12269 std::string info
= string_printf (_("`%s' Ada exception"),
12270 c
->excep_string
.c_str ());
12271 uiout
->text (info
.c_str ());
12274 uiout
->text (_("all Ada exceptions"));
12277 case ada_catch_exception_unhandled
:
12278 uiout
->text (_("unhandled Ada exceptions"));
12281 case ada_catch_handlers
:
12282 if (!c
->excep_string
.empty ())
12285 = string_printf (_("`%s' Ada exception handlers"),
12286 c
->excep_string
.c_str ());
12287 uiout
->text (info
.c_str ());
12290 uiout
->text (_("all Ada exceptions handlers"));
12293 case ada_catch_assert
:
12294 uiout
->text (_("failed Ada assertions"));
12298 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12303 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12304 for all exception catchpoint kinds. */
12307 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12309 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12313 case ada_catch_exception
:
12314 fprintf_filtered (fp
, "catch exception");
12315 if (!c
->excep_string
.empty ())
12316 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12319 case ada_catch_exception_unhandled
:
12320 fprintf_filtered (fp
, "catch exception unhandled");
12323 case ada_catch_handlers
:
12324 fprintf_filtered (fp
, "catch handlers");
12327 case ada_catch_assert
:
12328 fprintf_filtered (fp
, "catch assert");
12332 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12334 print_recreate_thread (b
, fp
);
12337 /* Virtual tables for various breakpoint types. */
12338 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12339 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12340 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12341 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12343 /* See ada-lang.h. */
12346 is_ada_exception_catchpoint (breakpoint
*bp
)
12348 return (bp
->ops
== &catch_exception_breakpoint_ops
12349 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12350 || bp
->ops
== &catch_assert_breakpoint_ops
12351 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12354 /* Split the arguments specified in a "catch exception" command.
12355 Set EX to the appropriate catchpoint type.
12356 Set EXCEP_STRING to the name of the specific exception if
12357 specified by the user.
12358 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12359 "catch handlers" command. False otherwise.
12360 If a condition is found at the end of the arguments, the condition
12361 expression is stored in COND_STRING (memory must be deallocated
12362 after use). Otherwise COND_STRING is set to NULL. */
12365 catch_ada_exception_command_split (const char *args
,
12366 bool is_catch_handlers_cmd
,
12367 enum ada_exception_catchpoint_kind
*ex
,
12368 std::string
*excep_string
,
12369 std::string
*cond_string
)
12371 std::string exception_name
;
12373 exception_name
= extract_arg (&args
);
12374 if (exception_name
== "if")
12376 /* This is not an exception name; this is the start of a condition
12377 expression for a catchpoint on all exceptions. So, "un-get"
12378 this token, and set exception_name to NULL. */
12379 exception_name
.clear ();
12383 /* Check to see if we have a condition. */
12385 args
= skip_spaces (args
);
12386 if (startswith (args
, "if")
12387 && (isspace (args
[2]) || args
[2] == '\0'))
12390 args
= skip_spaces (args
);
12392 if (args
[0] == '\0')
12393 error (_("Condition missing after `if' keyword"));
12394 *cond_string
= args
;
12396 args
+= strlen (args
);
12399 /* Check that we do not have any more arguments. Anything else
12402 if (args
[0] != '\0')
12403 error (_("Junk at end of expression"));
12405 if (is_catch_handlers_cmd
)
12407 /* Catch handling of exceptions. */
12408 *ex
= ada_catch_handlers
;
12409 *excep_string
= exception_name
;
12411 else if (exception_name
.empty ())
12413 /* Catch all exceptions. */
12414 *ex
= ada_catch_exception
;
12415 excep_string
->clear ();
12417 else if (exception_name
== "unhandled")
12419 /* Catch unhandled exceptions. */
12420 *ex
= ada_catch_exception_unhandled
;
12421 excep_string
->clear ();
12425 /* Catch a specific exception. */
12426 *ex
= ada_catch_exception
;
12427 *excep_string
= exception_name
;
12431 /* Return the name of the symbol on which we should break in order to
12432 implement a catchpoint of the EX kind. */
12434 static const char *
12435 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12437 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12439 gdb_assert (data
->exception_info
!= NULL
);
12443 case ada_catch_exception
:
12444 return (data
->exception_info
->catch_exception_sym
);
12446 case ada_catch_exception_unhandled
:
12447 return (data
->exception_info
->catch_exception_unhandled_sym
);
12449 case ada_catch_assert
:
12450 return (data
->exception_info
->catch_assert_sym
);
12452 case ada_catch_handlers
:
12453 return (data
->exception_info
->catch_handlers_sym
);
12456 internal_error (__FILE__
, __LINE__
,
12457 _("unexpected catchpoint kind (%d)"), ex
);
12461 /* Return the breakpoint ops "virtual table" used for catchpoints
12464 static const struct breakpoint_ops
*
12465 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12469 case ada_catch_exception
:
12470 return (&catch_exception_breakpoint_ops
);
12472 case ada_catch_exception_unhandled
:
12473 return (&catch_exception_unhandled_breakpoint_ops
);
12475 case ada_catch_assert
:
12476 return (&catch_assert_breakpoint_ops
);
12478 case ada_catch_handlers
:
12479 return (&catch_handlers_breakpoint_ops
);
12482 internal_error (__FILE__
, __LINE__
,
12483 _("unexpected catchpoint kind (%d)"), ex
);
12487 /* Return the condition that will be used to match the current exception
12488 being raised with the exception that the user wants to catch. This
12489 assumes that this condition is used when the inferior just triggered
12490 an exception catchpoint.
12491 EX: the type of catchpoints used for catching Ada exceptions. */
12494 ada_exception_catchpoint_cond_string (const char *excep_string
,
12495 enum ada_exception_catchpoint_kind ex
)
12498 bool is_standard_exc
= false;
12499 std::string result
;
12501 if (ex
== ada_catch_handlers
)
12503 /* For exception handlers catchpoints, the condition string does
12504 not use the same parameter as for the other exceptions. */
12505 result
= ("long_integer (GNAT_GCC_exception_Access"
12506 "(gcc_exception).all.occurrence.id)");
12509 result
= "long_integer (e)";
12511 /* The standard exceptions are a special case. They are defined in
12512 runtime units that have been compiled without debugging info; if
12513 EXCEP_STRING is the not-fully-qualified name of a standard
12514 exception (e.g. "constraint_error") then, during the evaluation
12515 of the condition expression, the symbol lookup on this name would
12516 *not* return this standard exception. The catchpoint condition
12517 may then be set only on user-defined exceptions which have the
12518 same not-fully-qualified name (e.g. my_package.constraint_error).
12520 To avoid this unexcepted behavior, these standard exceptions are
12521 systematically prefixed by "standard". This means that "catch
12522 exception constraint_error" is rewritten into "catch exception
12523 standard.constraint_error".
12525 If an exception named constraint_error is defined in another package of
12526 the inferior program, then the only way to specify this exception as a
12527 breakpoint condition is to use its fully-qualified named:
12528 e.g. my_package.constraint_error. */
12530 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12532 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12534 is_standard_exc
= true;
12541 if (is_standard_exc
)
12542 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12544 string_appendf (result
, "long_integer (&%s)", excep_string
);
12549 /* Return the symtab_and_line that should be used to insert an exception
12550 catchpoint of the TYPE kind.
12552 ADDR_STRING returns the name of the function where the real
12553 breakpoint that implements the catchpoints is set, depending on the
12554 type of catchpoint we need to create. */
12556 static struct symtab_and_line
12557 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12558 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12560 const char *sym_name
;
12561 struct symbol
*sym
;
12563 /* First, find out which exception support info to use. */
12564 ada_exception_support_info_sniffer ();
12566 /* Then lookup the function on which we will break in order to catch
12567 the Ada exceptions requested by the user. */
12568 sym_name
= ada_exception_sym_name (ex
);
12569 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12572 error (_("Catchpoint symbol not found: %s"), sym_name
);
12574 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12575 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12577 /* Set ADDR_STRING. */
12578 *addr_string
= sym_name
;
12581 *ops
= ada_exception_breakpoint_ops (ex
);
12583 return find_function_start_sal (sym
, 1);
12586 /* Create an Ada exception catchpoint.
12588 EX_KIND is the kind of exception catchpoint to be created.
12590 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12591 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12592 of the exception to which this catchpoint applies.
12594 COND_STRING, if not empty, is the catchpoint condition.
12596 TEMPFLAG, if nonzero, means that the underlying breakpoint
12597 should be temporary.
12599 FROM_TTY is the usual argument passed to all commands implementations. */
12602 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12603 enum ada_exception_catchpoint_kind ex_kind
,
12604 const std::string
&excep_string
,
12605 const std::string
&cond_string
,
12610 std::string addr_string
;
12611 const struct breakpoint_ops
*ops
= NULL
;
12612 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12614 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12615 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12616 ops
, tempflag
, disabled
, from_tty
);
12617 c
->excep_string
= excep_string
;
12618 create_excep_cond_exprs (c
.get (), ex_kind
);
12619 if (!cond_string
.empty ())
12620 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12621 install_breakpoint (0, std::move (c
), 1);
12624 /* Implement the "catch exception" command. */
12627 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12628 struct cmd_list_element
*command
)
12630 const char *arg
= arg_entry
;
12631 struct gdbarch
*gdbarch
= get_current_arch ();
12633 enum ada_exception_catchpoint_kind ex_kind
;
12634 std::string excep_string
;
12635 std::string cond_string
;
12637 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12641 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12643 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12644 excep_string
, cond_string
,
12645 tempflag
, 1 /* enabled */,
12649 /* Implement the "catch handlers" command. */
12652 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12653 struct cmd_list_element
*command
)
12655 const char *arg
= arg_entry
;
12656 struct gdbarch
*gdbarch
= get_current_arch ();
12658 enum ada_exception_catchpoint_kind ex_kind
;
12659 std::string excep_string
;
12660 std::string cond_string
;
12662 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12666 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12668 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12669 excep_string
, cond_string
,
12670 tempflag
, 1 /* enabled */,
12674 /* Completion function for the Ada "catch" commands. */
12677 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12678 const char *text
, const char *word
)
12680 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12682 for (const ada_exc_info
&info
: exceptions
)
12684 if (startswith (info
.name
, word
))
12685 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12689 /* Split the arguments specified in a "catch assert" command.
12691 ARGS contains the command's arguments (or the empty string if
12692 no arguments were passed).
12694 If ARGS contains a condition, set COND_STRING to that condition
12695 (the memory needs to be deallocated after use). */
12698 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12700 args
= skip_spaces (args
);
12702 /* Check whether a condition was provided. */
12703 if (startswith (args
, "if")
12704 && (isspace (args
[2]) || args
[2] == '\0'))
12707 args
= skip_spaces (args
);
12708 if (args
[0] == '\0')
12709 error (_("condition missing after `if' keyword"));
12710 cond_string
.assign (args
);
12713 /* Otherwise, there should be no other argument at the end of
12715 else if (args
[0] != '\0')
12716 error (_("Junk at end of arguments."));
12719 /* Implement the "catch assert" command. */
12722 catch_assert_command (const char *arg_entry
, int from_tty
,
12723 struct cmd_list_element
*command
)
12725 const char *arg
= arg_entry
;
12726 struct gdbarch
*gdbarch
= get_current_arch ();
12728 std::string cond_string
;
12730 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12734 catch_ada_assert_command_split (arg
, cond_string
);
12735 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12737 tempflag
, 1 /* enabled */,
12741 /* Return non-zero if the symbol SYM is an Ada exception object. */
12744 ada_is_exception_sym (struct symbol
*sym
)
12746 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12748 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12749 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12750 && SYMBOL_CLASS (sym
) != LOC_CONST
12751 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12752 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12755 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12756 Ada exception object. This matches all exceptions except the ones
12757 defined by the Ada language. */
12760 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12764 if (!ada_is_exception_sym (sym
))
12767 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12768 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12769 return 0; /* A standard exception. */
12771 /* Numeric_Error is also a standard exception, so exclude it.
12772 See the STANDARD_EXC description for more details as to why
12773 this exception is not listed in that array. */
12774 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12780 /* A helper function for std::sort, comparing two struct ada_exc_info
12783 The comparison is determined first by exception name, and then
12784 by exception address. */
12787 ada_exc_info::operator< (const ada_exc_info
&other
) const
12791 result
= strcmp (name
, other
.name
);
12794 if (result
== 0 && addr
< other
.addr
)
12800 ada_exc_info::operator== (const ada_exc_info
&other
) const
12802 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12805 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12806 routine, but keeping the first SKIP elements untouched.
12808 All duplicates are also removed. */
12811 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12814 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12815 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12816 exceptions
->end ());
12819 /* Add all exceptions defined by the Ada standard whose name match
12820 a regular expression.
12822 If PREG is not NULL, then this regexp_t object is used to
12823 perform the symbol name matching. Otherwise, no name-based
12824 filtering is performed.
12826 EXCEPTIONS is a vector of exceptions to which matching exceptions
12830 ada_add_standard_exceptions (compiled_regex
*preg
,
12831 std::vector
<ada_exc_info
> *exceptions
)
12835 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12838 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12840 struct bound_minimal_symbol msymbol
12841 = ada_lookup_simple_minsym (standard_exc
[i
]);
12843 if (msymbol
.minsym
!= NULL
)
12845 struct ada_exc_info info
12846 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12848 exceptions
->push_back (info
);
12854 /* Add all Ada exceptions defined locally and accessible from the given
12857 If PREG is not NULL, then this regexp_t object is used to
12858 perform the symbol name matching. Otherwise, no name-based
12859 filtering is performed.
12861 EXCEPTIONS is a vector of exceptions to which matching exceptions
12865 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12866 struct frame_info
*frame
,
12867 std::vector
<ada_exc_info
> *exceptions
)
12869 const struct block
*block
= get_frame_block (frame
, 0);
12873 struct block_iterator iter
;
12874 struct symbol
*sym
;
12876 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12878 switch (SYMBOL_CLASS (sym
))
12885 if (ada_is_exception_sym (sym
))
12887 struct ada_exc_info info
= {sym
->print_name (),
12888 SYMBOL_VALUE_ADDRESS (sym
)};
12890 exceptions
->push_back (info
);
12894 if (BLOCK_FUNCTION (block
) != NULL
)
12896 block
= BLOCK_SUPERBLOCK (block
);
12900 /* Return true if NAME matches PREG or if PREG is NULL. */
12903 name_matches_regex (const char *name
, compiled_regex
*preg
)
12905 return (preg
== NULL
12906 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
12909 /* Add all exceptions defined globally whose name name match
12910 a regular expression, excluding standard exceptions.
12912 The reason we exclude standard exceptions is that they need
12913 to be handled separately: Standard exceptions are defined inside
12914 a runtime unit which is normally not compiled with debugging info,
12915 and thus usually do not show up in our symbol search. However,
12916 if the unit was in fact built with debugging info, we need to
12917 exclude them because they would duplicate the entry we found
12918 during the special loop that specifically searches for those
12919 standard exceptions.
12921 If PREG is not NULL, then this regexp_t object is used to
12922 perform the symbol name matching. Otherwise, no name-based
12923 filtering is performed.
12925 EXCEPTIONS is a vector of exceptions to which matching exceptions
12929 ada_add_global_exceptions (compiled_regex
*preg
,
12930 std::vector
<ada_exc_info
> *exceptions
)
12932 /* In Ada, the symbol "search name" is a linkage name, whereas the
12933 regular expression used to do the matching refers to the natural
12934 name. So match against the decoded name. */
12935 expand_symtabs_matching (NULL
,
12936 lookup_name_info::match_any (),
12937 [&] (const char *search_name
)
12939 std::string decoded
= ada_decode (search_name
);
12940 return name_matches_regex (decoded
.c_str (), preg
);
12945 for (objfile
*objfile
: current_program_space
->objfiles ())
12947 for (compunit_symtab
*s
: objfile
->compunits ())
12949 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
12952 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12954 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12955 struct block_iterator iter
;
12956 struct symbol
*sym
;
12958 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12959 if (ada_is_non_standard_exception_sym (sym
)
12960 && name_matches_regex (sym
->natural_name (), preg
))
12962 struct ada_exc_info info
12963 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
12965 exceptions
->push_back (info
);
12972 /* Implements ada_exceptions_list with the regular expression passed
12973 as a regex_t, rather than a string.
12975 If not NULL, PREG is used to filter out exceptions whose names
12976 do not match. Otherwise, all exceptions are listed. */
12978 static std::vector
<ada_exc_info
>
12979 ada_exceptions_list_1 (compiled_regex
*preg
)
12981 std::vector
<ada_exc_info
> result
;
12984 /* First, list the known standard exceptions. These exceptions
12985 need to be handled separately, as they are usually defined in
12986 runtime units that have been compiled without debugging info. */
12988 ada_add_standard_exceptions (preg
, &result
);
12990 /* Next, find all exceptions whose scope is local and accessible
12991 from the currently selected frame. */
12993 if (has_stack_frames ())
12995 prev_len
= result
.size ();
12996 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12998 if (result
.size () > prev_len
)
12999 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13002 /* Add all exceptions whose scope is global. */
13004 prev_len
= result
.size ();
13005 ada_add_global_exceptions (preg
, &result
);
13006 if (result
.size () > prev_len
)
13007 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13012 /* Return a vector of ada_exc_info.
13014 If REGEXP is NULL, all exceptions are included in the result.
13015 Otherwise, it should contain a valid regular expression,
13016 and only the exceptions whose names match that regular expression
13017 are included in the result.
13019 The exceptions are sorted in the following order:
13020 - Standard exceptions (defined by the Ada language), in
13021 alphabetical order;
13022 - Exceptions only visible from the current frame, in
13023 alphabetical order;
13024 - Exceptions whose scope is global, in alphabetical order. */
13026 std::vector
<ada_exc_info
>
13027 ada_exceptions_list (const char *regexp
)
13029 if (regexp
== NULL
)
13030 return ada_exceptions_list_1 (NULL
);
13032 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13033 return ada_exceptions_list_1 (®
);
13036 /* Implement the "info exceptions" command. */
13039 info_exceptions_command (const char *regexp
, int from_tty
)
13041 struct gdbarch
*gdbarch
= get_current_arch ();
13043 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13045 if (regexp
!= NULL
)
13047 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13049 printf_filtered (_("All defined Ada exceptions:\n"));
13051 for (const ada_exc_info
&info
: exceptions
)
13052 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13056 /* Information about operators given special treatment in functions
13058 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13060 #define ADA_OPERATORS \
13061 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13062 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13063 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13064 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13065 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13066 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13067 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13068 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13069 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13070 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13071 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13072 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13073 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13074 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13075 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13076 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13077 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13078 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13079 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13082 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13085 switch (exp
->elts
[pc
- 1].opcode
)
13088 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13091 #define OP_DEFN(op, len, args, binop) \
13092 case op: *oplenp = len; *argsp = args; break;
13098 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13103 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13108 /* Implementation of the exp_descriptor method operator_check. */
13111 ada_operator_check (struct expression
*exp
, int pos
,
13112 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13115 const union exp_element
*const elts
= exp
->elts
;
13116 struct type
*type
= NULL
;
13118 switch (elts
[pos
].opcode
)
13120 case UNOP_IN_RANGE
:
13122 type
= elts
[pos
+ 1].type
;
13126 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13129 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13131 if (type
!= nullptr && type
->objfile_owner () != nullptr
13132 && objfile_func (type
->objfile_owner (), data
))
13138 /* As for operator_length, but assumes PC is pointing at the first
13139 element of the operator, and gives meaningful results only for the
13140 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13143 ada_forward_operator_length (struct expression
*exp
, int pc
,
13144 int *oplenp
, int *argsp
)
13146 switch (exp
->elts
[pc
].opcode
)
13149 *oplenp
= *argsp
= 0;
13152 #define OP_DEFN(op, len, args, binop) \
13153 case op: *oplenp = len; *argsp = args; break;
13159 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13164 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13170 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13172 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13180 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13182 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13187 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13191 /* Ada attributes ('Foo). */
13194 case OP_ATR_LENGTH
:
13198 case OP_ATR_MODULUS
:
13205 case UNOP_IN_RANGE
:
13207 /* XXX: gdb_sprint_host_address, type_sprint */
13208 fprintf_filtered (stream
, _("Type @"));
13209 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13210 fprintf_filtered (stream
, " (");
13211 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13212 fprintf_filtered (stream
, ")");
13214 case BINOP_IN_BOUNDS
:
13215 fprintf_filtered (stream
, " (%d)",
13216 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13218 case TERNOP_IN_RANGE
:
13223 case OP_DISCRETE_RANGE
:
13224 case OP_POSITIONAL
:
13231 char *name
= &exp
->elts
[elt
+ 2].string
;
13232 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13234 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13239 return dump_subexp_body_standard (exp
, stream
, elt
);
13243 for (i
= 0; i
< nargs
; i
+= 1)
13244 elt
= dump_subexp (exp
, stream
, elt
);
13249 /* The Ada extension of print_subexp (q.v.). */
13252 ada_print_subexp (struct expression
*exp
, int *pos
,
13253 struct ui_file
*stream
, enum precedence prec
)
13255 int oplen
, nargs
, i
;
13257 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13259 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13266 print_subexp_standard (exp
, pos
, stream
, prec
);
13270 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13273 case BINOP_IN_BOUNDS
:
13274 /* XXX: sprint_subexp */
13275 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13276 fputs_filtered (" in ", stream
);
13277 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13278 fputs_filtered ("'range", stream
);
13279 if (exp
->elts
[pc
+ 1].longconst
> 1)
13280 fprintf_filtered (stream
, "(%ld)",
13281 (long) exp
->elts
[pc
+ 1].longconst
);
13284 case TERNOP_IN_RANGE
:
13285 if (prec
>= PREC_EQUAL
)
13286 fputs_filtered ("(", stream
);
13287 /* XXX: sprint_subexp */
13288 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13289 fputs_filtered (" in ", stream
);
13290 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13291 fputs_filtered (" .. ", stream
);
13292 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13293 if (prec
>= PREC_EQUAL
)
13294 fputs_filtered (")", stream
);
13299 case OP_ATR_LENGTH
:
13303 case OP_ATR_MODULUS
:
13308 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13310 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13311 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13312 &type_print_raw_options
);
13316 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13317 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13322 for (tem
= 1; tem
< nargs
; tem
+= 1)
13324 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13325 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13327 fputs_filtered (")", stream
);
13332 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13333 fputs_filtered ("'(", stream
);
13334 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13335 fputs_filtered (")", stream
);
13338 case UNOP_IN_RANGE
:
13339 /* XXX: sprint_subexp */
13340 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13341 fputs_filtered (" in ", stream
);
13342 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13343 &type_print_raw_options
);
13346 case OP_DISCRETE_RANGE
:
13347 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13348 fputs_filtered ("..", stream
);
13349 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13353 fputs_filtered ("others => ", stream
);
13354 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13358 for (i
= 0; i
< nargs
-1; i
+= 1)
13361 fputs_filtered ("|", stream
);
13362 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13364 fputs_filtered (" => ", stream
);
13365 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13368 case OP_POSITIONAL
:
13369 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13373 fputs_filtered ("(", stream
);
13374 for (i
= 0; i
< nargs
; i
+= 1)
13377 fputs_filtered (", ", stream
);
13378 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13380 fputs_filtered (")", stream
);
13385 /* Table mapping opcodes into strings for printing operators
13386 and precedences of the operators. */
13388 static const struct op_print ada_op_print_tab
[] = {
13389 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13390 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13391 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13392 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13393 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13394 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13395 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13396 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13397 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13398 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13399 {">", BINOP_GTR
, PREC_ORDER
, 0},
13400 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13401 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13402 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13403 {"+", BINOP_ADD
, PREC_ADD
, 0},
13404 {"-", BINOP_SUB
, PREC_ADD
, 0},
13405 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13406 {"*", BINOP_MUL
, PREC_MUL
, 0},
13407 {"/", BINOP_DIV
, PREC_MUL
, 0},
13408 {"rem", BINOP_REM
, PREC_MUL
, 0},
13409 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13410 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13411 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13412 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13413 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13414 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13415 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13416 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13417 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13418 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13419 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13420 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13423 /* Language vector */
13425 static const struct exp_descriptor ada_exp_descriptor
= {
13427 ada_operator_length
,
13428 ada_operator_check
,
13429 ada_dump_subexp_body
,
13430 ada_evaluate_subexp
13433 /* symbol_name_matcher_ftype adapter for wild_match. */
13436 do_wild_match (const char *symbol_search_name
,
13437 const lookup_name_info
&lookup_name
,
13438 completion_match_result
*comp_match_res
)
13440 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13443 /* symbol_name_matcher_ftype adapter for full_match. */
13446 do_full_match (const char *symbol_search_name
,
13447 const lookup_name_info
&lookup_name
,
13448 completion_match_result
*comp_match_res
)
13450 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13452 /* If both symbols start with "_ada_", just let the loop below
13453 handle the comparison. However, if only the symbol name starts
13454 with "_ada_", skip the prefix and let the match proceed as
13456 if (startswith (symbol_search_name
, "_ada_")
13457 && !startswith (lname
, "_ada"))
13458 symbol_search_name
+= 5;
13460 int uscore_count
= 0;
13461 while (*lname
!= '\0')
13463 if (*symbol_search_name
!= *lname
)
13465 if (*symbol_search_name
== 'B' && uscore_count
== 2
13466 && symbol_search_name
[1] == '_')
13468 symbol_search_name
+= 2;
13469 while (isdigit (*symbol_search_name
))
13470 ++symbol_search_name
;
13471 if (symbol_search_name
[0] == '_'
13472 && symbol_search_name
[1] == '_')
13474 symbol_search_name
+= 2;
13481 if (*symbol_search_name
== '_')
13486 ++symbol_search_name
;
13490 return is_name_suffix (symbol_search_name
);
13493 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13496 do_exact_match (const char *symbol_search_name
,
13497 const lookup_name_info
&lookup_name
,
13498 completion_match_result
*comp_match_res
)
13500 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13503 /* Build the Ada lookup name for LOOKUP_NAME. */
13505 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13507 gdb::string_view user_name
= lookup_name
.name ();
13509 if (!user_name
.empty () && user_name
[0] == '<')
13511 if (user_name
.back () == '>')
13513 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13516 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13517 m_encoded_p
= true;
13518 m_verbatim_p
= true;
13519 m_wild_match_p
= false;
13520 m_standard_p
= false;
13524 m_verbatim_p
= false;
13526 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13530 const char *folded
= ada_fold_name (user_name
);
13531 m_encoded_name
= ada_encode_1 (folded
, false);
13532 if (m_encoded_name
.empty ())
13533 m_encoded_name
= gdb::to_string (user_name
);
13536 m_encoded_name
= gdb::to_string (user_name
);
13538 /* Handle the 'package Standard' special case. See description
13539 of m_standard_p. */
13540 if (startswith (m_encoded_name
.c_str (), "standard__"))
13542 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13543 m_standard_p
= true;
13546 m_standard_p
= false;
13548 /* If the name contains a ".", then the user is entering a fully
13549 qualified entity name, and the match must not be done in wild
13550 mode. Similarly, if the user wants to complete what looks
13551 like an encoded name, the match must not be done in wild
13552 mode. Also, in the standard__ special case always do
13553 non-wild matching. */
13555 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13558 && user_name
.find ('.') == std::string::npos
);
13562 /* symbol_name_matcher_ftype method for Ada. This only handles
13563 completion mode. */
13566 ada_symbol_name_matches (const char *symbol_search_name
,
13567 const lookup_name_info
&lookup_name
,
13568 completion_match_result
*comp_match_res
)
13570 return lookup_name
.ada ().matches (symbol_search_name
,
13571 lookup_name
.match_type (),
13575 /* A name matcher that matches the symbol name exactly, with
13579 literal_symbol_name_matcher (const char *symbol_search_name
,
13580 const lookup_name_info
&lookup_name
,
13581 completion_match_result
*comp_match_res
)
13583 gdb::string_view name_view
= lookup_name
.name ();
13585 if (lookup_name
.completion_mode ()
13586 ? (strncmp (symbol_search_name
, name_view
.data (),
13587 name_view
.size ()) == 0)
13588 : symbol_search_name
== name_view
)
13590 if (comp_match_res
!= NULL
)
13591 comp_match_res
->set_match (symbol_search_name
);
13598 /* Implement the "get_symbol_name_matcher" language_defn method for
13601 static symbol_name_matcher_ftype
*
13602 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13604 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13605 return literal_symbol_name_matcher
;
13607 if (lookup_name
.completion_mode ())
13608 return ada_symbol_name_matches
;
13611 if (lookup_name
.ada ().wild_match_p ())
13612 return do_wild_match
;
13613 else if (lookup_name
.ada ().verbatim_p ())
13614 return do_exact_match
;
13616 return do_full_match
;
13620 /* Class representing the Ada language. */
13622 class ada_language
: public language_defn
13626 : language_defn (language_ada
)
13629 /* See language.h. */
13631 const char *name () const override
13634 /* See language.h. */
13636 const char *natural_name () const override
13639 /* See language.h. */
13641 const std::vector
<const char *> &filename_extensions () const override
13643 static const std::vector
<const char *> extensions
13644 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13648 /* Print an array element index using the Ada syntax. */
13650 void print_array_index (struct type
*index_type
,
13652 struct ui_file
*stream
,
13653 const value_print_options
*options
) const override
13655 struct value
*index_value
= val_atr (index_type
, index
);
13657 value_print (index_value
, stream
, options
);
13658 fprintf_filtered (stream
, " => ");
13661 /* Implement the "read_var_value" language_defn method for Ada. */
13663 struct value
*read_var_value (struct symbol
*var
,
13664 const struct block
*var_block
,
13665 struct frame_info
*frame
) const override
13667 /* The only case where default_read_var_value is not sufficient
13668 is when VAR is a renaming... */
13669 if (frame
!= nullptr)
13671 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13672 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13673 return ada_read_renaming_var_value (var
, frame_block
);
13676 /* This is a typical case where we expect the default_read_var_value
13677 function to work. */
13678 return language_defn::read_var_value (var
, var_block
, frame
);
13681 /* See language.h. */
13682 void language_arch_info (struct gdbarch
*gdbarch
,
13683 struct language_arch_info
*lai
) const override
13685 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13687 /* Helper function to allow shorter lines below. */
13688 auto add
= [&] (struct type
*t
)
13690 lai
->add_primitive_type (t
);
13693 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13695 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13696 0, "long_integer"));
13697 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13698 0, "short_integer"));
13699 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13701 lai
->set_string_char_type (char_type
);
13703 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13704 "float", gdbarch_float_format (gdbarch
)));
13705 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13706 "long_float", gdbarch_double_format (gdbarch
)));
13707 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13708 0, "long_long_integer"));
13709 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13711 gdbarch_long_double_format (gdbarch
)));
13712 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13714 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13716 add (builtin
->builtin_void
);
13718 struct type
*system_addr_ptr
13719 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13721 system_addr_ptr
->set_name ("system__address");
13722 add (system_addr_ptr
);
13724 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13725 type. This is a signed integral type whose size is the same as
13726 the size of addresses. */
13727 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13728 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13729 "storage_offset"));
13731 lai
->set_bool_type (builtin
->builtin_bool
);
13734 /* See language.h. */
13736 bool iterate_over_symbols
13737 (const struct block
*block
, const lookup_name_info
&name
,
13738 domain_enum domain
,
13739 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13741 std::vector
<struct block_symbol
> results
13742 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13743 for (block_symbol
&sym
: results
)
13745 if (!callback (&sym
))
13752 /* See language.h. */
13753 bool sniff_from_mangled_name (const char *mangled
,
13754 char **out
) const override
13756 std::string demangled
= ada_decode (mangled
);
13760 if (demangled
!= mangled
&& demangled
[0] != '<')
13762 /* Set the gsymbol language to Ada, but still return 0.
13763 Two reasons for that:
13765 1. For Ada, we prefer computing the symbol's decoded name
13766 on the fly rather than pre-compute it, in order to save
13767 memory (Ada projects are typically very large).
13769 2. There are some areas in the definition of the GNAT
13770 encoding where, with a bit of bad luck, we might be able
13771 to decode a non-Ada symbol, generating an incorrect
13772 demangled name (Eg: names ending with "TB" for instance
13773 are identified as task bodies and so stripped from
13774 the decoded name returned).
13776 Returning true, here, but not setting *DEMANGLED, helps us get
13777 a little bit of the best of both worlds. Because we're last,
13778 we should not affect any of the other languages that were
13779 able to demangle the symbol before us; we get to correctly
13780 tag Ada symbols as such; and even if we incorrectly tagged a
13781 non-Ada symbol, which should be rare, any routing through the
13782 Ada language should be transparent (Ada tries to behave much
13783 like C/C++ with non-Ada symbols). */
13790 /* See language.h. */
13792 char *demangle_symbol (const char *mangled
, int options
) const override
13794 return ada_la_decode (mangled
, options
);
13797 /* See language.h. */
13799 void print_type (struct type
*type
, const char *varstring
,
13800 struct ui_file
*stream
, int show
, int level
,
13801 const struct type_print_options
*flags
) const override
13803 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13806 /* See language.h. */
13808 const char *word_break_characters (void) const override
13810 return ada_completer_word_break_characters
;
13813 /* See language.h. */
13815 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13816 complete_symbol_mode mode
,
13817 symbol_name_match_type name_match_type
,
13818 const char *text
, const char *word
,
13819 enum type_code code
) const override
13821 struct symbol
*sym
;
13822 const struct block
*b
, *surrounding_static_block
= 0;
13823 struct block_iterator iter
;
13825 gdb_assert (code
== TYPE_CODE_UNDEF
);
13827 lookup_name_info
lookup_name (text
, name_match_type
, true);
13829 /* First, look at the partial symtab symbols. */
13830 expand_symtabs_matching (NULL
,
13836 /* At this point scan through the misc symbol vectors and add each
13837 symbol you find to the list. Eventually we want to ignore
13838 anything that isn't a text symbol (everything else will be
13839 handled by the psymtab code above). */
13841 for (objfile
*objfile
: current_program_space
->objfiles ())
13843 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13847 if (completion_skip_symbol (mode
, msymbol
))
13850 language symbol_language
= msymbol
->language ();
13852 /* Ada minimal symbols won't have their language set to Ada. If
13853 we let completion_list_add_name compare using the
13854 default/C-like matcher, then when completing e.g., symbols in a
13855 package named "pck", we'd match internal Ada symbols like
13856 "pckS", which are invalid in an Ada expression, unless you wrap
13857 them in '<' '>' to request a verbatim match.
13859 Unfortunately, some Ada encoded names successfully demangle as
13860 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13861 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13862 with the wrong language set. Paper over that issue here. */
13863 if (symbol_language
== language_auto
13864 || symbol_language
== language_cplus
)
13865 symbol_language
= language_ada
;
13867 completion_list_add_name (tracker
,
13869 msymbol
->linkage_name (),
13870 lookup_name
, text
, word
);
13874 /* Search upwards from currently selected frame (so that we can
13875 complete on local vars. */
13877 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13879 if (!BLOCK_SUPERBLOCK (b
))
13880 surrounding_static_block
= b
; /* For elmin of dups */
13882 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13884 if (completion_skip_symbol (mode
, sym
))
13887 completion_list_add_name (tracker
,
13889 sym
->linkage_name (),
13890 lookup_name
, text
, word
);
13894 /* Go through the symtabs and check the externs and statics for
13895 symbols which match. */
13897 for (objfile
*objfile
: current_program_space
->objfiles ())
13899 for (compunit_symtab
*s
: objfile
->compunits ())
13902 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
13903 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13905 if (completion_skip_symbol (mode
, sym
))
13908 completion_list_add_name (tracker
,
13910 sym
->linkage_name (),
13911 lookup_name
, text
, word
);
13916 for (objfile
*objfile
: current_program_space
->objfiles ())
13918 for (compunit_symtab
*s
: objfile
->compunits ())
13921 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
13922 /* Don't do this block twice. */
13923 if (b
== surrounding_static_block
)
13925 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13927 if (completion_skip_symbol (mode
, sym
))
13930 completion_list_add_name (tracker
,
13932 sym
->linkage_name (),
13933 lookup_name
, text
, word
);
13939 /* See language.h. */
13941 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13942 (struct type
*type
, CORE_ADDR addr
) const override
13944 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
13945 std::string name
= type_to_string (type
);
13946 return gdb::unique_xmalloc_ptr
<char>
13947 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
13950 /* See language.h. */
13952 void value_print (struct value
*val
, struct ui_file
*stream
,
13953 const struct value_print_options
*options
) const override
13955 return ada_value_print (val
, stream
, options
);
13958 /* See language.h. */
13960 void value_print_inner
13961 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13962 const struct value_print_options
*options
) const override
13964 return ada_value_print_inner (val
, stream
, recurse
, options
);
13967 /* See language.h. */
13969 struct block_symbol lookup_symbol_nonlocal
13970 (const char *name
, const struct block
*block
,
13971 const domain_enum domain
) const override
13973 struct block_symbol sym
;
13975 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13976 if (sym
.symbol
!= NULL
)
13979 /* If we haven't found a match at this point, try the primitive
13980 types. In other languages, this search is performed before
13981 searching for global symbols in order to short-circuit that
13982 global-symbol search if it happens that the name corresponds
13983 to a primitive type. But we cannot do the same in Ada, because
13984 it is perfectly legitimate for a program to declare a type which
13985 has the same name as a standard type. If looking up a type in
13986 that situation, we have traditionally ignored the primitive type
13987 in favor of user-defined types. This is why, unlike most other
13988 languages, we search the primitive types this late and only after
13989 having searched the global symbols without success. */
13991 if (domain
== VAR_DOMAIN
)
13993 struct gdbarch
*gdbarch
;
13996 gdbarch
= target_gdbarch ();
13998 gdbarch
= block_gdbarch (block
);
14000 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
14001 if (sym
.symbol
!= NULL
)
14008 /* See language.h. */
14010 int parser (struct parser_state
*ps
) const override
14012 warnings_issued
= 0;
14013 return ada_parse (ps
);
14018 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
14019 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
14020 namespace) and converts operators that are user-defined into
14021 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
14022 a preferred result type [at the moment, only type void has any
14023 effect---causing procedures to be preferred over functions in calls].
14024 A null CONTEXT_TYPE indicates that a non-void return type is
14025 preferred. May change (expand) *EXP. */
14027 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
14030 struct type
*context_type
= NULL
;
14033 if (ps
->void_context_p
)
14034 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14036 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
14037 ps
->block_tracker
);
14040 /* See language.h. */
14042 void emitchar (int ch
, struct type
*chtype
,
14043 struct ui_file
*stream
, int quoter
) const override
14045 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14048 /* See language.h. */
14050 void printchar (int ch
, struct type
*chtype
,
14051 struct ui_file
*stream
) const override
14053 ada_printchar (ch
, chtype
, stream
);
14056 /* See language.h. */
14058 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14059 const gdb_byte
*string
, unsigned int length
,
14060 const char *encoding
, int force_ellipses
,
14061 const struct value_print_options
*options
) const override
14063 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14064 force_ellipses
, options
);
14067 /* See language.h. */
14069 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14070 struct ui_file
*stream
) const override
14072 ada_print_typedef (type
, new_symbol
, stream
);
14075 /* See language.h. */
14077 bool is_string_type_p (struct type
*type
) const override
14079 return ada_is_string_type (type
);
14082 /* See language.h. */
14084 const char *struct_too_deep_ellipsis () const override
14085 { return "(...)"; }
14087 /* See language.h. */
14089 bool c_style_arrays_p () const override
14092 /* See language.h. */
14094 bool store_sym_names_in_linkage_form_p () const override
14097 /* See language.h. */
14099 const struct lang_varobj_ops
*varobj_ops () const override
14100 { return &ada_varobj_ops
; }
14102 /* See language.h. */
14104 const struct exp_descriptor
*expression_ops () const override
14105 { return &ada_exp_descriptor
; }
14107 /* See language.h. */
14109 const struct op_print
*opcode_print_table () const override
14110 { return ada_op_print_tab
; }
14113 /* See language.h. */
14115 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14116 (const lookup_name_info
&lookup_name
) const override
14118 return ada_get_symbol_name_matcher (lookup_name
);
14122 /* Single instance of the Ada language class. */
14124 static ada_language ada_language_defn
;
14126 /* Command-list for the "set/show ada" prefix command. */
14127 static struct cmd_list_element
*set_ada_list
;
14128 static struct cmd_list_element
*show_ada_list
;
14131 initialize_ada_catchpoint_ops (void)
14133 struct breakpoint_ops
*ops
;
14135 initialize_breakpoint_ops ();
14137 ops
= &catch_exception_breakpoint_ops
;
14138 *ops
= bkpt_breakpoint_ops
;
14139 ops
->allocate_location
= allocate_location_exception
;
14140 ops
->re_set
= re_set_exception
;
14141 ops
->check_status
= check_status_exception
;
14142 ops
->print_it
= print_it_exception
;
14143 ops
->print_one
= print_one_exception
;
14144 ops
->print_mention
= print_mention_exception
;
14145 ops
->print_recreate
= print_recreate_exception
;
14147 ops
= &catch_exception_unhandled_breakpoint_ops
;
14148 *ops
= bkpt_breakpoint_ops
;
14149 ops
->allocate_location
= allocate_location_exception
;
14150 ops
->re_set
= re_set_exception
;
14151 ops
->check_status
= check_status_exception
;
14152 ops
->print_it
= print_it_exception
;
14153 ops
->print_one
= print_one_exception
;
14154 ops
->print_mention
= print_mention_exception
;
14155 ops
->print_recreate
= print_recreate_exception
;
14157 ops
= &catch_assert_breakpoint_ops
;
14158 *ops
= bkpt_breakpoint_ops
;
14159 ops
->allocate_location
= allocate_location_exception
;
14160 ops
->re_set
= re_set_exception
;
14161 ops
->check_status
= check_status_exception
;
14162 ops
->print_it
= print_it_exception
;
14163 ops
->print_one
= print_one_exception
;
14164 ops
->print_mention
= print_mention_exception
;
14165 ops
->print_recreate
= print_recreate_exception
;
14167 ops
= &catch_handlers_breakpoint_ops
;
14168 *ops
= bkpt_breakpoint_ops
;
14169 ops
->allocate_location
= allocate_location_exception
;
14170 ops
->re_set
= re_set_exception
;
14171 ops
->check_status
= check_status_exception
;
14172 ops
->print_it
= print_it_exception
;
14173 ops
->print_one
= print_one_exception
;
14174 ops
->print_mention
= print_mention_exception
;
14175 ops
->print_recreate
= print_recreate_exception
;
14178 /* This module's 'new_objfile' observer. */
14181 ada_new_objfile_observer (struct objfile
*objfile
)
14183 ada_clear_symbol_cache ();
14186 /* This module's 'free_objfile' observer. */
14189 ada_free_objfile_observer (struct objfile
*objfile
)
14191 ada_clear_symbol_cache ();
14194 void _initialize_ada_language ();
14196 _initialize_ada_language ()
14198 initialize_ada_catchpoint_ops ();
14200 add_basic_prefix_cmd ("ada", no_class
,
14201 _("Prefix command for changing Ada-specific settings."),
14202 &set_ada_list
, "set ada ", 0, &setlist
);
14204 add_show_prefix_cmd ("ada", no_class
,
14205 _("Generic command for showing Ada-specific settings."),
14206 &show_ada_list
, "show ada ", 0, &showlist
);
14208 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14209 &trust_pad_over_xvs
, _("\
14210 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14211 Show whether an optimization trusting PAD types over XVS types is activated."),
14213 This is related to the encoding used by the GNAT compiler. The debugger\n\
14214 should normally trust the contents of PAD types, but certain older versions\n\
14215 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14216 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14217 work around this bug. It is always safe to turn this option \"off\", but\n\
14218 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14219 this option to \"off\" unless necessary."),
14220 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14222 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14223 &print_signatures
, _("\
14224 Enable or disable the output of formal and return types for functions in the \
14225 overloads selection menu."), _("\
14226 Show whether the output of formal and return types for functions in the \
14227 overloads selection menu is activated."),
14228 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14230 add_catch_command ("exception", _("\
14231 Catch Ada exceptions, when raised.\n\
14232 Usage: catch exception [ARG] [if CONDITION]\n\
14233 Without any argument, stop when any Ada exception is raised.\n\
14234 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14235 being raised does not have a handler (and will therefore lead to the task's\n\
14237 Otherwise, the catchpoint only stops when the name of the exception being\n\
14238 raised is the same as ARG.\n\
14239 CONDITION is a boolean expression that is evaluated to see whether the\n\
14240 exception should cause a stop."),
14241 catch_ada_exception_command
,
14242 catch_ada_completer
,
14246 add_catch_command ("handlers", _("\
14247 Catch Ada exceptions, when handled.\n\
14248 Usage: catch handlers [ARG] [if CONDITION]\n\
14249 Without any argument, stop when any Ada exception is handled.\n\
14250 With an argument, catch only exceptions with the given name.\n\
14251 CONDITION is a boolean expression that is evaluated to see whether the\n\
14252 exception should cause a stop."),
14253 catch_ada_handlers_command
,
14254 catch_ada_completer
,
14257 add_catch_command ("assert", _("\
14258 Catch failed Ada assertions, when raised.\n\
14259 Usage: catch assert [if CONDITION]\n\
14260 CONDITION is a boolean expression that is evaluated to see whether the\n\
14261 exception should cause a stop."),
14262 catch_assert_command
,
14267 varsize_limit
= 65536;
14268 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14269 &varsize_limit
, _("\
14270 Set the maximum number of bytes allowed in a variable-size object."), _("\
14271 Show the maximum number of bytes allowed in a variable-size object."), _("\
14272 Attempts to access an object whose size is not a compile-time constant\n\
14273 and exceeds this limit will cause an error."),
14274 NULL
, NULL
, &setlist
, &showlist
);
14276 add_info ("exceptions", info_exceptions_command
,
14278 List all Ada exception names.\n\
14279 Usage: info exceptions [REGEXP]\n\
14280 If a regular expression is passed as an argument, only those matching\n\
14281 the regular expression are listed."));
14283 add_basic_prefix_cmd ("ada", class_maintenance
,
14284 _("Set Ada maintenance-related variables."),
14285 &maint_set_ada_cmdlist
, "maintenance set ada ",
14286 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14288 add_show_prefix_cmd ("ada", class_maintenance
,
14289 _("Show Ada maintenance-related variables."),
14290 &maint_show_ada_cmdlist
, "maintenance show ada ",
14291 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14293 add_setshow_boolean_cmd
14294 ("ignore-descriptive-types", class_maintenance
,
14295 &ada_ignore_descriptive_types_p
,
14296 _("Set whether descriptive types generated by GNAT should be ignored."),
14297 _("Show whether descriptive types generated by GNAT should be ignored."),
14299 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14300 DWARF attribute."),
14301 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14303 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14304 NULL
, xcalloc
, xfree
);
14306 /* The ada-lang observers. */
14307 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14308 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14309 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);