1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2020 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 (struct obstack
*,
104 const struct block
*,
105 const lookup_name_info
&lookup_name
,
106 domain_enum
, struct objfile
*);
108 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
109 const lookup_name_info
&lookup_name
,
110 domain_enum
, int, int *);
112 static int is_nonfunction (struct block_symbol
*, int);
114 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
115 const struct block
*);
117 static int num_defns_collected (struct obstack
*);
119 static struct block_symbol
*defns_collected (struct obstack
*, int);
121 static struct value
*resolve_subexp (expression_up
*, int *, int,
123 innermost_block_tracker
*);
125 static void replace_operator_with_call (expression_up
*, int, int, int,
126 struct symbol
*, const struct block
*);
128 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
130 static const char *ada_decoded_op_name (enum exp_opcode
);
132 static int numeric_type_p (struct type
*);
134 static int integer_type_p (struct type
*);
136 static int scalar_type_p (struct type
*);
138 static int discrete_type_p (struct type
*);
140 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
143 static struct value
*evaluate_subexp_type (struct expression
*, int *);
145 static struct type
*ada_find_parallel_type_with_name (struct type
*,
148 static int is_dynamic_field (struct type
*, int);
150 static struct type
*to_fixed_variant_branch_type (struct type
*,
152 CORE_ADDR
, struct value
*);
154 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
156 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
158 static struct type
*to_static_fixed_type (struct type
*);
159 static struct type
*static_unwrap_type (struct type
*type
);
161 static struct value
*unwrap_value (struct value
*);
163 static struct type
*constrained_packed_array_type (struct type
*, long *);
165 static struct type
*decode_constrained_packed_array_type (struct type
*);
167 static long decode_packed_array_bitsize (struct type
*);
169 static struct value
*decode_constrained_packed_array (struct value
*);
171 static int ada_is_unconstrained_packed_array_type (struct type
*);
173 static struct value
*value_subscript_packed (struct value
*, int,
176 static struct value
*coerce_unspec_val_to_type (struct value
*,
179 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
181 static int equiv_types (struct type
*, struct type
*);
183 static int is_name_suffix (const char *);
185 static int advance_wild_match (const char **, const char *, char);
187 static bool wild_match (const char *name
, const char *patn
);
189 static struct value
*ada_coerce_ref (struct value
*);
191 static LONGEST
pos_atr (struct value
*);
193 static struct value
*value_pos_atr (struct type
*, struct value
*);
195 static struct value
*val_atr (struct type
*, LONGEST
);
197 static struct value
*value_val_atr (struct type
*, struct value
*);
199 static struct symbol
*standard_lookup (const char *, const struct block
*,
202 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
205 static int find_struct_field (const char *, struct type
*, int,
206 struct type
**, int *, int *, int *, int *);
208 static int ada_resolve_function (struct block_symbol
*, int,
209 struct value
**, int, const char *,
212 static int ada_is_direct_array_type (struct type
*);
214 static struct value
*ada_index_struct_field (int, struct value
*, int,
217 static struct value
*assign_aggregate (struct value
*, struct value
*,
221 static void aggregate_assign_from_choices (struct value
*, struct value
*,
223 int *, LONGEST
*, int *,
224 int, LONGEST
, LONGEST
);
226 static void aggregate_assign_positional (struct value
*, struct value
*,
228 int *, LONGEST
*, int *, int,
232 static void aggregate_assign_others (struct value
*, struct value
*,
234 int *, LONGEST
*, int, LONGEST
, LONGEST
);
237 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
240 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
243 static void ada_forward_operator_length (struct expression
*, int, int *,
246 static struct type
*ada_find_any_type (const char *name
);
248 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
249 (const lookup_name_info
&lookup_name
);
253 /* The result of a symbol lookup to be stored in our symbol cache. */
257 /* The name used to perform the lookup. */
259 /* The namespace used during the lookup. */
261 /* The symbol returned by the lookup, or NULL if no matching symbol
264 /* The block where the symbol was found, or NULL if no matching
266 const struct block
*block
;
267 /* A pointer to the next entry with the same hash. */
268 struct cache_entry
*next
;
271 /* The Ada symbol cache, used to store the result of Ada-mode symbol
272 lookups in the course of executing the user's commands.
274 The cache is implemented using a simple, fixed-sized hash.
275 The size is fixed on the grounds that there are not likely to be
276 all that many symbols looked up during any given session, regardless
277 of the size of the symbol table. If we decide to go to a resizable
278 table, let's just use the stuff from libiberty instead. */
280 #define HASH_SIZE 1009
282 struct ada_symbol_cache
284 /* An obstack used to store the entries in our cache. */
285 struct obstack cache_space
;
287 /* The root of the hash table used to implement our symbol cache. */
288 struct cache_entry
*root
[HASH_SIZE
];
291 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
293 /* Maximum-sized dynamic type. */
294 static unsigned int varsize_limit
;
296 static const char ada_completer_word_break_characters
[] =
298 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
300 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
303 /* The name of the symbol to use to get the name of the main subprogram. */
304 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
305 = "__gnat_ada_main_program_name";
307 /* Limit on the number of warnings to raise per expression evaluation. */
308 static int warning_limit
= 2;
310 /* Number of warning messages issued; reset to 0 by cleanups after
311 expression evaluation. */
312 static int warnings_issued
= 0;
314 static const char * const known_runtime_file_name_patterns
[] = {
315 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
318 static const char * const known_auxiliary_function_name_patterns
[] = {
319 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
322 /* Maintenance-related settings for this module. */
324 static struct cmd_list_element
*maint_set_ada_cmdlist
;
325 static struct cmd_list_element
*maint_show_ada_cmdlist
;
327 /* The "maintenance ada set/show ignore-descriptive-type" value. */
329 static bool ada_ignore_descriptive_types_p
= false;
331 /* Inferior-specific data. */
333 /* Per-inferior data for this module. */
335 struct ada_inferior_data
337 /* The ada__tags__type_specific_data type, which is used when decoding
338 tagged types. With older versions of GNAT, this type was directly
339 accessible through a component ("tsd") in the object tag. But this
340 is no longer the case, so we cache it for each inferior. */
341 struct type
*tsd_type
= nullptr;
343 /* The exception_support_info data. This data is used to determine
344 how to implement support for Ada exception catchpoints in a given
346 const struct exception_support_info
*exception_info
= nullptr;
349 /* Our key to this module's inferior data. */
350 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
352 /* Return our inferior data for the given inferior (INF).
354 This function always returns a valid pointer to an allocated
355 ada_inferior_data structure. If INF's inferior data has not
356 been previously set, this functions creates a new one with all
357 fields set to zero, sets INF's inferior to it, and then returns
358 a pointer to that newly allocated ada_inferior_data. */
360 static struct ada_inferior_data
*
361 get_ada_inferior_data (struct inferior
*inf
)
363 struct ada_inferior_data
*data
;
365 data
= ada_inferior_data
.get (inf
);
367 data
= ada_inferior_data
.emplace (inf
);
372 /* Perform all necessary cleanups regarding our module's inferior data
373 that is required after the inferior INF just exited. */
376 ada_inferior_exit (struct inferior
*inf
)
378 ada_inferior_data
.clear (inf
);
382 /* program-space-specific data. */
384 /* This module's per-program-space data. */
385 struct ada_pspace_data
389 if (sym_cache
!= NULL
)
390 ada_free_symbol_cache (sym_cache
);
393 /* The Ada symbol cache. */
394 struct ada_symbol_cache
*sym_cache
= nullptr;
397 /* Key to our per-program-space data. */
398 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
400 /* Return this module's data for the given program space (PSPACE).
401 If not is found, add a zero'ed one now.
403 This function always returns a valid object. */
405 static struct ada_pspace_data
*
406 get_ada_pspace_data (struct program_space
*pspace
)
408 struct ada_pspace_data
*data
;
410 data
= ada_pspace_data_handle
.get (pspace
);
412 data
= ada_pspace_data_handle
.emplace (pspace
);
419 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
420 all typedef layers have been peeled. Otherwise, return TYPE.
422 Normally, we really expect a typedef type to only have 1 typedef layer.
423 In other words, we really expect the target type of a typedef type to be
424 a non-typedef type. This is particularly true for Ada units, because
425 the language does not have a typedef vs not-typedef distinction.
426 In that respect, the Ada compiler has been trying to eliminate as many
427 typedef definitions in the debugging information, since they generally
428 do not bring any extra information (we still use typedef under certain
429 circumstances related mostly to the GNAT encoding).
431 Unfortunately, we have seen situations where the debugging information
432 generated by the compiler leads to such multiple typedef layers. For
433 instance, consider the following example with stabs:
435 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
436 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
438 This is an error in the debugging information which causes type
439 pck__float_array___XUP to be defined twice, and the second time,
440 it is defined as a typedef of a typedef.
442 This is on the fringe of legality as far as debugging information is
443 concerned, and certainly unexpected. But it is easy to handle these
444 situations correctly, so we can afford to be lenient in this case. */
447 ada_typedef_target_type (struct type
*type
)
449 while (type
->code () == TYPE_CODE_TYPEDEF
)
450 type
= TYPE_TARGET_TYPE (type
);
454 /* Given DECODED_NAME a string holding a symbol name in its
455 decoded form (ie using the Ada dotted notation), returns
456 its unqualified name. */
459 ada_unqualified_name (const char *decoded_name
)
463 /* If the decoded name starts with '<', it means that the encoded
464 name does not follow standard naming conventions, and thus that
465 it is not your typical Ada symbol name. Trying to unqualify it
466 is therefore pointless and possibly erroneous. */
467 if (decoded_name
[0] == '<')
470 result
= strrchr (decoded_name
, '.');
472 result
++; /* Skip the dot... */
474 result
= decoded_name
;
479 /* Return a string starting with '<', followed by STR, and '>'. */
482 add_angle_brackets (const char *str
)
484 return string_printf ("<%s>", str
);
487 /* Assuming V points to an array of S objects, make sure that it contains at
488 least M objects, updating V and S as necessary. */
490 #define GROW_VECT(v, s, m) \
491 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
493 /* Assuming VECT points to an array of *SIZE objects of size
494 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
495 updating *SIZE as necessary and returning the (new) array. */
498 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
500 if (*size
< min_size
)
503 if (*size
< min_size
)
505 vect
= xrealloc (vect
, *size
* element_size
);
510 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
511 suffix of FIELD_NAME beginning "___". */
514 field_name_match (const char *field_name
, const char *target
)
516 int len
= strlen (target
);
519 (strncmp (field_name
, target
, len
) == 0
520 && (field_name
[len
] == '\0'
521 || (startswith (field_name
+ len
, "___")
522 && strcmp (field_name
+ strlen (field_name
) - 6,
527 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
528 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
529 and return its index. This function also handles fields whose name
530 have ___ suffixes because the compiler sometimes alters their name
531 by adding such a suffix to represent fields with certain constraints.
532 If the field could not be found, return a negative number if
533 MAYBE_MISSING is set. Otherwise raise an error. */
536 ada_get_field_index (const struct type
*type
, const char *field_name
,
540 struct type
*struct_type
= check_typedef ((struct type
*) type
);
542 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
543 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
547 error (_("Unable to find field %s in struct %s. Aborting"),
548 field_name
, struct_type
->name ());
553 /* The length of the prefix of NAME prior to any "___" suffix. */
556 ada_name_prefix_len (const char *name
)
562 const char *p
= strstr (name
, "___");
565 return strlen (name
);
571 /* Return non-zero if SUFFIX is a suffix of STR.
572 Return zero if STR is null. */
575 is_suffix (const char *str
, const char *suffix
)
582 len2
= strlen (suffix
);
583 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
586 /* The contents of value VAL, treated as a value of type TYPE. The
587 result is an lval in memory if VAL is. */
589 static struct value
*
590 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
592 type
= ada_check_typedef (type
);
593 if (value_type (val
) == type
)
597 struct value
*result
;
599 /* Make sure that the object size is not unreasonable before
600 trying to allocate some memory for it. */
601 ada_ensure_varsize_limit (type
);
604 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
605 result
= allocate_value_lazy (type
);
608 result
= allocate_value (type
);
609 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
611 set_value_component_location (result
, val
);
612 set_value_bitsize (result
, value_bitsize (val
));
613 set_value_bitpos (result
, value_bitpos (val
));
614 if (VALUE_LVAL (result
) == lval_memory
)
615 set_value_address (result
, value_address (val
));
620 static const gdb_byte
*
621 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
626 return valaddr
+ offset
;
630 cond_offset_target (CORE_ADDR address
, long offset
)
635 return address
+ offset
;
638 /* Issue a warning (as for the definition of warning in utils.c, but
639 with exactly one argument rather than ...), unless the limit on the
640 number of warnings has passed during the evaluation of the current
643 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
644 provided by "complaint". */
645 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
648 lim_warning (const char *format
, ...)
652 va_start (args
, format
);
653 warnings_issued
+= 1;
654 if (warnings_issued
<= warning_limit
)
655 vwarning (format
, args
);
660 /* Issue an error if the size of an object of type T is unreasonable,
661 i.e. if it would be a bad idea to allocate a value of this type in
665 ada_ensure_varsize_limit (const struct type
*type
)
667 if (TYPE_LENGTH (type
) > varsize_limit
)
668 error (_("object size is larger than varsize-limit"));
671 /* Maximum value of a SIZE-byte signed integer type. */
673 max_of_size (int size
)
675 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
677 return top_bit
| (top_bit
- 1);
680 /* Minimum value of a SIZE-byte signed integer type. */
682 min_of_size (int size
)
684 return -max_of_size (size
) - 1;
687 /* Maximum value of a SIZE-byte unsigned integer type. */
689 umax_of_size (int size
)
691 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
693 return top_bit
| (top_bit
- 1);
696 /* Maximum value of integral type T, as a signed quantity. */
698 max_of_type (struct type
*t
)
700 if (t
->is_unsigned ())
701 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
703 return max_of_size (TYPE_LENGTH (t
));
706 /* Minimum value of integral type T, as a signed quantity. */
708 min_of_type (struct type
*t
)
710 if (t
->is_unsigned ())
713 return min_of_size (TYPE_LENGTH (t
));
716 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
718 ada_discrete_type_high_bound (struct type
*type
)
720 type
= resolve_dynamic_type (type
, {}, 0);
721 switch (type
->code ())
723 case TYPE_CODE_RANGE
:
725 const dynamic_prop
&high
= type
->bounds ()->high
;
727 if (high
.kind () == PROP_CONST
)
728 return high
.const_val ();
731 gdb_assert (high
.kind () == PROP_UNDEFINED
);
733 /* This happens when trying to evaluate a type's dynamic bound
734 without a live target. There is nothing relevant for us to
735 return here, so return 0. */
740 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
745 return max_of_type (type
);
747 error (_("Unexpected type in ada_discrete_type_high_bound."));
751 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
753 ada_discrete_type_low_bound (struct type
*type
)
755 type
= resolve_dynamic_type (type
, {}, 0);
756 switch (type
->code ())
758 case TYPE_CODE_RANGE
:
760 const dynamic_prop
&low
= type
->bounds ()->low
;
762 if (low
.kind () == PROP_CONST
)
763 return low
.const_val ();
766 gdb_assert (low
.kind () == PROP_UNDEFINED
);
768 /* This happens when trying to evaluate a type's dynamic bound
769 without a live target. There is nothing relevant for us to
770 return here, so return 0. */
775 return TYPE_FIELD_ENUMVAL (type
, 0);
780 return min_of_type (type
);
782 error (_("Unexpected type in ada_discrete_type_low_bound."));
786 /* The identity on non-range types. For range types, the underlying
787 non-range scalar type. */
790 get_base_type (struct type
*type
)
792 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
794 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
796 type
= TYPE_TARGET_TYPE (type
);
801 /* Return a decoded version of the given VALUE. This means returning
802 a value whose type is obtained by applying all the GNAT-specific
803 encodings, making the resulting type a static but standard description
804 of the initial type. */
807 ada_get_decoded_value (struct value
*value
)
809 struct type
*type
= ada_check_typedef (value_type (value
));
811 if (ada_is_array_descriptor_type (type
)
812 || (ada_is_constrained_packed_array_type (type
)
813 && type
->code () != TYPE_CODE_PTR
))
815 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
816 value
= ada_coerce_to_simple_array_ptr (value
);
818 value
= ada_coerce_to_simple_array (value
);
821 value
= ada_to_fixed_value (value
);
826 /* Same as ada_get_decoded_value, but with the given TYPE.
827 Because there is no associated actual value for this type,
828 the resulting type might be a best-effort approximation in
829 the case of dynamic types. */
832 ada_get_decoded_type (struct type
*type
)
834 type
= to_static_fixed_type (type
);
835 if (ada_is_constrained_packed_array_type (type
))
836 type
= ada_coerce_to_simple_array_type (type
);
842 /* Language Selection */
844 /* If the main program is in Ada, return language_ada, otherwise return LANG
845 (the main program is in Ada iif the adainit symbol is found). */
848 ada_update_initial_language (enum language lang
)
850 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
856 /* If the main procedure is written in Ada, then return its name.
857 The result is good until the next call. Return NULL if the main
858 procedure doesn't appear to be in Ada. */
863 struct bound_minimal_symbol msym
;
864 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
866 /* For Ada, the name of the main procedure is stored in a specific
867 string constant, generated by the binder. Look for that symbol,
868 extract its address, and then read that string. If we didn't find
869 that string, then most probably the main procedure is not written
871 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
873 if (msym
.minsym
!= NULL
)
875 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
876 if (main_program_name_addr
== 0)
877 error (_("Invalid address for Ada main program name."));
879 main_program_name
= target_read_string (main_program_name_addr
, 1024);
880 return main_program_name
.get ();
883 /* The main procedure doesn't seem to be in Ada. */
889 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
892 const struct ada_opname_map ada_opname_table
[] = {
893 {"Oadd", "\"+\"", BINOP_ADD
},
894 {"Osubtract", "\"-\"", BINOP_SUB
},
895 {"Omultiply", "\"*\"", BINOP_MUL
},
896 {"Odivide", "\"/\"", BINOP_DIV
},
897 {"Omod", "\"mod\"", BINOP_MOD
},
898 {"Orem", "\"rem\"", BINOP_REM
},
899 {"Oexpon", "\"**\"", BINOP_EXP
},
900 {"Olt", "\"<\"", BINOP_LESS
},
901 {"Ole", "\"<=\"", BINOP_LEQ
},
902 {"Ogt", "\">\"", BINOP_GTR
},
903 {"Oge", "\">=\"", BINOP_GEQ
},
904 {"Oeq", "\"=\"", BINOP_EQUAL
},
905 {"One", "\"/=\"", BINOP_NOTEQUAL
},
906 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
907 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
908 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
909 {"Oconcat", "\"&\"", BINOP_CONCAT
},
910 {"Oabs", "\"abs\"", UNOP_ABS
},
911 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
912 {"Oadd", "\"+\"", UNOP_PLUS
},
913 {"Osubtract", "\"-\"", UNOP_NEG
},
917 /* The "encoded" form of DECODED, according to GNAT conventions. If
918 THROW_ERRORS, throw an error if invalid operator name is found.
919 Otherwise, return the empty string in that case. */
922 ada_encode_1 (const char *decoded
, bool throw_errors
)
927 std::string encoding_buffer
;
928 for (const char *p
= decoded
; *p
!= '\0'; p
+= 1)
931 encoding_buffer
.append ("__");
934 const struct ada_opname_map
*mapping
;
936 for (mapping
= ada_opname_table
;
937 mapping
->encoded
!= NULL
938 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
940 if (mapping
->encoded
== NULL
)
943 error (_("invalid Ada operator name: %s"), p
);
947 encoding_buffer
.append (mapping
->encoded
);
951 encoding_buffer
.push_back (*p
);
954 return encoding_buffer
;
957 /* The "encoded" form of DECODED, according to GNAT conventions. */
960 ada_encode (const char *decoded
)
962 return ada_encode_1 (decoded
, true);
965 /* Return NAME folded to lower case, or, if surrounded by single
966 quotes, unfolded, but with the quotes stripped away. Result good
970 ada_fold_name (gdb::string_view name
)
972 static char *fold_buffer
= NULL
;
973 static size_t fold_buffer_size
= 0;
975 int len
= name
.size ();
976 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
980 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
981 fold_buffer
[len
- 2] = '\000';
987 for (i
= 0; i
<= len
; i
+= 1)
988 fold_buffer
[i
] = tolower (name
[i
]);
994 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
997 is_lower_alphanum (const char c
)
999 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1002 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1003 This function saves in LEN the length of that same symbol name but
1004 without either of these suffixes:
1010 These are suffixes introduced by the compiler for entities such as
1011 nested subprogram for instance, in order to avoid name clashes.
1012 They do not serve any purpose for the debugger. */
1015 ada_remove_trailing_digits (const char *encoded
, int *len
)
1017 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1021 while (i
> 0 && isdigit (encoded
[i
]))
1023 if (i
>= 0 && encoded
[i
] == '.')
1025 else if (i
>= 0 && encoded
[i
] == '$')
1027 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1029 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1034 /* Remove the suffix introduced by the compiler for protected object
1038 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1040 /* Remove trailing N. */
1042 /* Protected entry subprograms are broken into two
1043 separate subprograms: The first one is unprotected, and has
1044 a 'N' suffix; the second is the protected version, and has
1045 the 'P' suffix. The second calls the first one after handling
1046 the protection. Since the P subprograms are internally generated,
1047 we leave these names undecoded, giving the user a clue that this
1048 entity is internal. */
1051 && encoded
[*len
- 1] == 'N'
1052 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1056 /* If ENCODED follows the GNAT entity encoding conventions, then return
1057 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1058 replaced by ENCODED. */
1061 ada_decode (const char *encoded
)
1067 std::string decoded
;
1069 /* With function descriptors on PPC64, the value of a symbol named
1070 ".FN", if it exists, is the entry point of the function "FN". */
1071 if (encoded
[0] == '.')
1074 /* The name of the Ada main procedure starts with "_ada_".
1075 This prefix is not part of the decoded name, so skip this part
1076 if we see this prefix. */
1077 if (startswith (encoded
, "_ada_"))
1080 /* If the name starts with '_', then it is not a properly encoded
1081 name, so do not attempt to decode it. Similarly, if the name
1082 starts with '<', the name should not be decoded. */
1083 if (encoded
[0] == '_' || encoded
[0] == '<')
1086 len0
= strlen (encoded
);
1088 ada_remove_trailing_digits (encoded
, &len0
);
1089 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1091 /* Remove the ___X.* suffix if present. Do not forget to verify that
1092 the suffix is located before the current "end" of ENCODED. We want
1093 to avoid re-matching parts of ENCODED that have previously been
1094 marked as discarded (by decrementing LEN0). */
1095 p
= strstr (encoded
, "___");
1096 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1104 /* Remove any trailing TKB suffix. It tells us that this symbol
1105 is for the body of a task, but that information does not actually
1106 appear in the decoded name. */
1108 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1111 /* Remove any trailing TB suffix. The TB suffix is slightly different
1112 from the TKB suffix because it is used for non-anonymous task
1115 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1118 /* Remove trailing "B" suffixes. */
1119 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1121 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1124 /* Make decoded big enough for possible expansion by operator name. */
1126 decoded
.resize (2 * len0
+ 1, 'X');
1128 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1130 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1133 while ((i
>= 0 && isdigit (encoded
[i
]))
1134 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1136 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1138 else if (encoded
[i
] == '$')
1142 /* The first few characters that are not alphabetic are not part
1143 of any encoding we use, so we can copy them over verbatim. */
1145 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1146 decoded
[j
] = encoded
[i
];
1151 /* Is this a symbol function? */
1152 if (at_start_name
&& encoded
[i
] == 'O')
1156 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1158 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1159 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1161 && !isalnum (encoded
[i
+ op_len
]))
1163 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1166 j
+= strlen (ada_opname_table
[k
].decoded
);
1170 if (ada_opname_table
[k
].encoded
!= NULL
)
1175 /* Replace "TK__" with "__", which will eventually be translated
1176 into "." (just below). */
1178 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1181 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1182 be translated into "." (just below). These are internal names
1183 generated for anonymous blocks inside which our symbol is nested. */
1185 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1186 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1187 && isdigit (encoded
[i
+4]))
1191 while (k
< len0
&& isdigit (encoded
[k
]))
1192 k
++; /* Skip any extra digit. */
1194 /* Double-check that the "__B_{DIGITS}+" sequence we found
1195 is indeed followed by "__". */
1196 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1200 /* Remove _E{DIGITS}+[sb] */
1202 /* Just as for protected object subprograms, there are 2 categories
1203 of subprograms created by the compiler for each entry. The first
1204 one implements the actual entry code, and has a suffix following
1205 the convention above; the second one implements the barrier and
1206 uses the same convention as above, except that the 'E' is replaced
1209 Just as above, we do not decode the name of barrier functions
1210 to give the user a clue that the code he is debugging has been
1211 internally generated. */
1213 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1214 && isdigit (encoded
[i
+2]))
1218 while (k
< len0
&& isdigit (encoded
[k
]))
1222 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1225 /* Just as an extra precaution, make sure that if this
1226 suffix is followed by anything else, it is a '_'.
1227 Otherwise, we matched this sequence by accident. */
1229 || (k
< len0
&& encoded
[k
] == '_'))
1234 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1235 the GNAT front-end in protected object subprograms. */
1238 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1240 /* Backtrack a bit up until we reach either the begining of
1241 the encoded name, or "__". Make sure that we only find
1242 digits or lowercase characters. */
1243 const char *ptr
= encoded
+ i
- 1;
1245 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1248 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1252 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1254 /* This is a X[bn]* sequence not separated from the previous
1255 part of the name with a non-alpha-numeric character (in other
1256 words, immediately following an alpha-numeric character), then
1257 verify that it is placed at the end of the encoded name. If
1258 not, then the encoding is not valid and we should abort the
1259 decoding. Otherwise, just skip it, it is used in body-nested
1263 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1267 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1269 /* Replace '__' by '.'. */
1277 /* It's a character part of the decoded name, so just copy it
1279 decoded
[j
] = encoded
[i
];
1286 /* Decoded names should never contain any uppercase character.
1287 Double-check this, and abort the decoding if we find one. */
1289 for (i
= 0; i
< decoded
.length(); ++i
)
1290 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1296 if (encoded
[0] == '<')
1299 decoded
= '<' + std::string(encoded
) + '>';
1304 /* Table for keeping permanent unique copies of decoded names. Once
1305 allocated, names in this table are never released. While this is a
1306 storage leak, it should not be significant unless there are massive
1307 changes in the set of decoded names in successive versions of a
1308 symbol table loaded during a single session. */
1309 static struct htab
*decoded_names_store
;
1311 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1312 in the language-specific part of GSYMBOL, if it has not been
1313 previously computed. Tries to save the decoded name in the same
1314 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1315 in any case, the decoded symbol has a lifetime at least that of
1317 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1318 const, but nevertheless modified to a semantically equivalent form
1319 when a decoded name is cached in it. */
1322 ada_decode_symbol (const struct general_symbol_info
*arg
)
1324 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1325 const char **resultp
=
1326 &gsymbol
->language_specific
.demangled_name
;
1328 if (!gsymbol
->ada_mangled
)
1330 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1331 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1333 gsymbol
->ada_mangled
= 1;
1335 if (obstack
!= NULL
)
1336 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1339 /* Sometimes, we can't find a corresponding objfile, in
1340 which case, we put the result on the heap. Since we only
1341 decode when needed, we hope this usually does not cause a
1342 significant memory leak (FIXME). */
1344 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1345 decoded
.c_str (), INSERT
);
1348 *slot
= xstrdup (decoded
.c_str ());
1357 ada_la_decode (const char *encoded
, int options
)
1359 return xstrdup (ada_decode (encoded
).c_str ());
1366 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1367 generated by the GNAT compiler to describe the index type used
1368 for each dimension of an array, check whether it follows the latest
1369 known encoding. If not, fix it up to conform to the latest encoding.
1370 Otherwise, do nothing. This function also does nothing if
1371 INDEX_DESC_TYPE is NULL.
1373 The GNAT encoding used to describe the array index type evolved a bit.
1374 Initially, the information would be provided through the name of each
1375 field of the structure type only, while the type of these fields was
1376 described as unspecified and irrelevant. The debugger was then expected
1377 to perform a global type lookup using the name of that field in order
1378 to get access to the full index type description. Because these global
1379 lookups can be very expensive, the encoding was later enhanced to make
1380 the global lookup unnecessary by defining the field type as being
1381 the full index type description.
1383 The purpose of this routine is to allow us to support older versions
1384 of the compiler by detecting the use of the older encoding, and by
1385 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1386 we essentially replace each field's meaningless type by the associated
1390 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1394 if (index_desc_type
== NULL
)
1396 gdb_assert (index_desc_type
->num_fields () > 0);
1398 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1399 to check one field only, no need to check them all). If not, return
1402 If our INDEX_DESC_TYPE was generated using the older encoding,
1403 the field type should be a meaningless integer type whose name
1404 is not equal to the field name. */
1405 if (index_desc_type
->field (0).type ()->name () != NULL
1406 && strcmp (index_desc_type
->field (0).type ()->name (),
1407 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1410 /* Fixup each field of INDEX_DESC_TYPE. */
1411 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1413 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1414 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1417 index_desc_type
->field (i
).set_type (raw_type
);
1421 /* The desc_* routines return primitive portions of array descriptors
1424 /* The descriptor or array type, if any, indicated by TYPE; removes
1425 level of indirection, if needed. */
1427 static struct type
*
1428 desc_base_type (struct type
*type
)
1432 type
= ada_check_typedef (type
);
1433 if (type
->code () == TYPE_CODE_TYPEDEF
)
1434 type
= ada_typedef_target_type (type
);
1437 && (type
->code () == TYPE_CODE_PTR
1438 || type
->code () == TYPE_CODE_REF
))
1439 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1444 /* True iff TYPE indicates a "thin" array pointer type. */
1447 is_thin_pntr (struct type
*type
)
1450 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1451 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1454 /* The descriptor type for thin pointer type TYPE. */
1456 static struct type
*
1457 thin_descriptor_type (struct type
*type
)
1459 struct type
*base_type
= desc_base_type (type
);
1461 if (base_type
== NULL
)
1463 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1467 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1469 if (alt_type
== NULL
)
1476 /* A pointer to the array data for thin-pointer value VAL. */
1478 static struct value
*
1479 thin_data_pntr (struct value
*val
)
1481 struct type
*type
= ada_check_typedef (value_type (val
));
1482 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1484 data_type
= lookup_pointer_type (data_type
);
1486 if (type
->code () == TYPE_CODE_PTR
)
1487 return value_cast (data_type
, value_copy (val
));
1489 return value_from_longest (data_type
, value_address (val
));
1492 /* True iff TYPE indicates a "thick" array pointer type. */
1495 is_thick_pntr (struct type
*type
)
1497 type
= desc_base_type (type
);
1498 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1499 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1502 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1503 pointer to one, the type of its bounds data; otherwise, NULL. */
1505 static struct type
*
1506 desc_bounds_type (struct type
*type
)
1510 type
= desc_base_type (type
);
1514 else if (is_thin_pntr (type
))
1516 type
= thin_descriptor_type (type
);
1519 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1521 return ada_check_typedef (r
);
1523 else if (type
->code () == TYPE_CODE_STRUCT
)
1525 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1527 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1532 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1533 one, a pointer to its bounds data. Otherwise NULL. */
1535 static struct value
*
1536 desc_bounds (struct value
*arr
)
1538 struct type
*type
= ada_check_typedef (value_type (arr
));
1540 if (is_thin_pntr (type
))
1542 struct type
*bounds_type
=
1543 desc_bounds_type (thin_descriptor_type (type
));
1546 if (bounds_type
== NULL
)
1547 error (_("Bad GNAT array descriptor"));
1549 /* NOTE: The following calculation is not really kosher, but
1550 since desc_type is an XVE-encoded type (and shouldn't be),
1551 the correct calculation is a real pain. FIXME (and fix GCC). */
1552 if (type
->code () == TYPE_CODE_PTR
)
1553 addr
= value_as_long (arr
);
1555 addr
= value_address (arr
);
1558 value_from_longest (lookup_pointer_type (bounds_type
),
1559 addr
- TYPE_LENGTH (bounds_type
));
1562 else if (is_thick_pntr (type
))
1564 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1565 _("Bad GNAT array descriptor"));
1566 struct type
*p_bounds_type
= value_type (p_bounds
);
1569 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1571 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1573 if (target_type
->is_stub ())
1574 p_bounds
= value_cast (lookup_pointer_type
1575 (ada_check_typedef (target_type
)),
1579 error (_("Bad GNAT array descriptor"));
1587 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1588 position of the field containing the address of the bounds data. */
1591 fat_pntr_bounds_bitpos (struct type
*type
)
1593 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1596 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1597 size of the field containing the address of the bounds data. */
1600 fat_pntr_bounds_bitsize (struct type
*type
)
1602 type
= desc_base_type (type
);
1604 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1605 return TYPE_FIELD_BITSIZE (type
, 1);
1607 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1610 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1611 pointer to one, the type of its array data (a array-with-no-bounds type);
1612 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1615 static struct type
*
1616 desc_data_target_type (struct type
*type
)
1618 type
= desc_base_type (type
);
1620 /* NOTE: The following is bogus; see comment in desc_bounds. */
1621 if (is_thin_pntr (type
))
1622 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1623 else if (is_thick_pntr (type
))
1625 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1628 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1629 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1635 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1638 static struct value
*
1639 desc_data (struct value
*arr
)
1641 struct type
*type
= value_type (arr
);
1643 if (is_thin_pntr (type
))
1644 return thin_data_pntr (arr
);
1645 else if (is_thick_pntr (type
))
1646 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1647 _("Bad GNAT array descriptor"));
1653 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1654 position of the field containing the address of the data. */
1657 fat_pntr_data_bitpos (struct type
*type
)
1659 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1662 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1663 size of the field containing the address of the data. */
1666 fat_pntr_data_bitsize (struct type
*type
)
1668 type
= desc_base_type (type
);
1670 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1671 return TYPE_FIELD_BITSIZE (type
, 0);
1673 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1676 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1677 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1678 bound, if WHICH is 1. The first bound is I=1. */
1680 static struct value
*
1681 desc_one_bound (struct value
*bounds
, int i
, int which
)
1683 char bound_name
[20];
1684 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1685 which
? 'U' : 'L', i
- 1);
1686 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1687 _("Bad GNAT array descriptor bounds"));
1690 /* If BOUNDS is an array-bounds structure type, return the bit position
1691 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1692 bound, if WHICH is 1. The first bound is I=1. */
1695 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1697 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1700 /* If BOUNDS is an array-bounds structure type, return the bit field size
1701 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1702 bound, if WHICH is 1. The first bound is I=1. */
1705 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1707 type
= desc_base_type (type
);
1709 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1710 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1712 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1715 /* If TYPE is the type of an array-bounds structure, the type of its
1716 Ith bound (numbering from 1). Otherwise, NULL. */
1718 static struct type
*
1719 desc_index_type (struct type
*type
, int i
)
1721 type
= desc_base_type (type
);
1723 if (type
->code () == TYPE_CODE_STRUCT
)
1725 char bound_name
[20];
1726 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1727 return lookup_struct_elt_type (type
, bound_name
, 1);
1733 /* The number of index positions in the array-bounds type TYPE.
1734 Return 0 if TYPE is NULL. */
1737 desc_arity (struct type
*type
)
1739 type
= desc_base_type (type
);
1742 return type
->num_fields () / 2;
1746 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1747 an array descriptor type (representing an unconstrained array
1751 ada_is_direct_array_type (struct type
*type
)
1755 type
= ada_check_typedef (type
);
1756 return (type
->code () == TYPE_CODE_ARRAY
1757 || ada_is_array_descriptor_type (type
));
1760 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1764 ada_is_array_type (struct type
*type
)
1767 && (type
->code () == TYPE_CODE_PTR
1768 || type
->code () == TYPE_CODE_REF
))
1769 type
= TYPE_TARGET_TYPE (type
);
1770 return ada_is_direct_array_type (type
);
1773 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1776 ada_is_simple_array_type (struct type
*type
)
1780 type
= ada_check_typedef (type
);
1781 return (type
->code () == TYPE_CODE_ARRAY
1782 || (type
->code () == TYPE_CODE_PTR
1783 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1784 == TYPE_CODE_ARRAY
)));
1787 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1790 ada_is_array_descriptor_type (struct type
*type
)
1792 struct type
*data_type
= desc_data_target_type (type
);
1796 type
= ada_check_typedef (type
);
1797 return (data_type
!= NULL
1798 && data_type
->code () == TYPE_CODE_ARRAY
1799 && desc_arity (desc_bounds_type (type
)) > 0);
1802 /* Non-zero iff type is a partially mal-formed GNAT array
1803 descriptor. FIXME: This is to compensate for some problems with
1804 debugging output from GNAT. Re-examine periodically to see if it
1808 ada_is_bogus_array_descriptor (struct type
*type
)
1812 && type
->code () == TYPE_CODE_STRUCT
1813 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1814 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1815 && !ada_is_array_descriptor_type (type
);
1819 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1820 (fat pointer) returns the type of the array data described---specifically,
1821 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1822 in from the descriptor; otherwise, they are left unspecified. If
1823 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1824 returns NULL. The result is simply the type of ARR if ARR is not
1827 static struct type
*
1828 ada_type_of_array (struct value
*arr
, int bounds
)
1830 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1831 return decode_constrained_packed_array_type (value_type (arr
));
1833 if (!ada_is_array_descriptor_type (value_type (arr
)))
1834 return value_type (arr
);
1838 struct type
*array_type
=
1839 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1841 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1842 TYPE_FIELD_BITSIZE (array_type
, 0) =
1843 decode_packed_array_bitsize (value_type (arr
));
1849 struct type
*elt_type
;
1851 struct value
*descriptor
;
1853 elt_type
= ada_array_element_type (value_type (arr
), -1);
1854 arity
= ada_array_arity (value_type (arr
));
1856 if (elt_type
== NULL
|| arity
== 0)
1857 return ada_check_typedef (value_type (arr
));
1859 descriptor
= desc_bounds (arr
);
1860 if (value_as_long (descriptor
) == 0)
1864 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1865 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1866 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1867 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1870 create_static_range_type (range_type
, value_type (low
),
1871 longest_to_int (value_as_long (low
)),
1872 longest_to_int (value_as_long (high
)));
1873 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1875 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1877 /* We need to store the element packed bitsize, as well as
1878 recompute the array size, because it was previously
1879 computed based on the unpacked element size. */
1880 LONGEST lo
= value_as_long (low
);
1881 LONGEST hi
= value_as_long (high
);
1883 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1884 decode_packed_array_bitsize (value_type (arr
));
1885 /* If the array has no element, then the size is already
1886 zero, and does not need to be recomputed. */
1890 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1892 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1897 return lookup_pointer_type (elt_type
);
1901 /* If ARR does not represent an array, returns ARR unchanged.
1902 Otherwise, returns either a standard GDB array with bounds set
1903 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1904 GDB array. Returns NULL if ARR is a null fat pointer. */
1907 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1909 if (ada_is_array_descriptor_type (value_type (arr
)))
1911 struct type
*arrType
= ada_type_of_array (arr
, 1);
1913 if (arrType
== NULL
)
1915 return value_cast (arrType
, value_copy (desc_data (arr
)));
1917 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1918 return decode_constrained_packed_array (arr
);
1923 /* If ARR does not represent an array, returns ARR unchanged.
1924 Otherwise, returns a standard GDB array describing ARR (which may
1925 be ARR itself if it already is in the proper form). */
1928 ada_coerce_to_simple_array (struct value
*arr
)
1930 if (ada_is_array_descriptor_type (value_type (arr
)))
1932 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1935 error (_("Bounds unavailable for null array pointer."));
1936 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1937 return value_ind (arrVal
);
1939 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1940 return decode_constrained_packed_array (arr
);
1945 /* If TYPE represents a GNAT array type, return it translated to an
1946 ordinary GDB array type (possibly with BITSIZE fields indicating
1947 packing). For other types, is the identity. */
1950 ada_coerce_to_simple_array_type (struct type
*type
)
1952 if (ada_is_constrained_packed_array_type (type
))
1953 return decode_constrained_packed_array_type (type
);
1955 if (ada_is_array_descriptor_type (type
))
1956 return ada_check_typedef (desc_data_target_type (type
));
1961 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1964 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
1968 type
= desc_base_type (type
);
1969 type
= ada_check_typedef (type
);
1971 ada_type_name (type
) != NULL
1972 && strstr (ada_type_name (type
), "___XP") != NULL
;
1975 /* Non-zero iff TYPE represents a standard GNAT constrained
1976 packed-array type. */
1979 ada_is_constrained_packed_array_type (struct type
*type
)
1981 return ada_is_gnat_encoded_packed_array_type (type
)
1982 && !ada_is_array_descriptor_type (type
);
1985 /* Non-zero iff TYPE represents an array descriptor for a
1986 unconstrained packed-array type. */
1989 ada_is_unconstrained_packed_array_type (struct type
*type
)
1991 if (!ada_is_array_descriptor_type (type
))
1994 if (ada_is_gnat_encoded_packed_array_type (type
))
1997 /* If we saw GNAT encodings, then the above code is sufficient.
1998 However, with minimal encodings, we will just have a thick
2000 if (is_thick_pntr (type
))
2002 type
= desc_base_type (type
);
2003 /* The structure's first field is a pointer to an array, so this
2004 fetches the array type. */
2005 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2006 /* Now we can see if the array elements are packed. */
2007 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
2013 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2014 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2017 ada_is_any_packed_array_type (struct type
*type
)
2019 return (ada_is_constrained_packed_array_type (type
)
2020 || (type
->code () == TYPE_CODE_ARRAY
2021 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
2024 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2025 return the size of its elements in bits. */
2028 decode_packed_array_bitsize (struct type
*type
)
2030 const char *raw_name
;
2034 /* Access to arrays implemented as fat pointers are encoded as a typedef
2035 of the fat pointer type. We need the name of the fat pointer type
2036 to do the decoding, so strip the typedef layer. */
2037 if (type
->code () == TYPE_CODE_TYPEDEF
)
2038 type
= ada_typedef_target_type (type
);
2040 raw_name
= ada_type_name (ada_check_typedef (type
));
2042 raw_name
= ada_type_name (desc_base_type (type
));
2047 tail
= strstr (raw_name
, "___XP");
2048 if (tail
== nullptr)
2050 gdb_assert (is_thick_pntr (type
));
2051 /* The structure's first field is a pointer to an array, so this
2052 fetches the array type. */
2053 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2054 /* Now we can see if the array elements are packed. */
2055 return TYPE_FIELD_BITSIZE (type
, 0);
2058 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2061 (_("could not understand bit size information on packed array"));
2068 /* Given that TYPE is a standard GDB array type with all bounds filled
2069 in, and that the element size of its ultimate scalar constituents
2070 (that is, either its elements, or, if it is an array of arrays, its
2071 elements' elements, etc.) is *ELT_BITS, return an identical type,
2072 but with the bit sizes of its elements (and those of any
2073 constituent arrays) recorded in the BITSIZE components of its
2074 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2077 Note that, for arrays whose index type has an XA encoding where
2078 a bound references a record discriminant, getting that discriminant,
2079 and therefore the actual value of that bound, is not possible
2080 because none of the given parameters gives us access to the record.
2081 This function assumes that it is OK in the context where it is being
2082 used to return an array whose bounds are still dynamic and where
2083 the length is arbitrary. */
2085 static struct type
*
2086 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2088 struct type
*new_elt_type
;
2089 struct type
*new_type
;
2090 struct type
*index_type_desc
;
2091 struct type
*index_type
;
2092 LONGEST low_bound
, high_bound
;
2094 type
= ada_check_typedef (type
);
2095 if (type
->code () != TYPE_CODE_ARRAY
)
2098 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2099 if (index_type_desc
)
2100 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2103 index_type
= type
->index_type ();
2105 new_type
= alloc_type_copy (type
);
2107 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2109 create_array_type (new_type
, new_elt_type
, index_type
);
2110 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2111 new_type
->set_name (ada_type_name (type
));
2113 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2114 && is_dynamic_type (check_typedef (index_type
)))
2115 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2116 low_bound
= high_bound
= 0;
2117 if (high_bound
< low_bound
)
2118 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2121 *elt_bits
*= (high_bound
- low_bound
+ 1);
2122 TYPE_LENGTH (new_type
) =
2123 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2126 new_type
->set_is_fixed_instance (true);
2130 /* The array type encoded by TYPE, where
2131 ada_is_constrained_packed_array_type (TYPE). */
2133 static struct type
*
2134 decode_constrained_packed_array_type (struct type
*type
)
2136 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2139 struct type
*shadow_type
;
2143 raw_name
= ada_type_name (desc_base_type (type
));
2148 name
= (char *) alloca (strlen (raw_name
) + 1);
2149 tail
= strstr (raw_name
, "___XP");
2150 type
= desc_base_type (type
);
2152 memcpy (name
, raw_name
, tail
- raw_name
);
2153 name
[tail
- raw_name
] = '\000';
2155 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2157 if (shadow_type
== NULL
)
2159 lim_warning (_("could not find bounds information on packed array"));
2162 shadow_type
= check_typedef (shadow_type
);
2164 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2166 lim_warning (_("could not understand bounds "
2167 "information on packed array"));
2171 bits
= decode_packed_array_bitsize (type
);
2172 return constrained_packed_array_type (shadow_type
, &bits
);
2175 /* Helper function for decode_constrained_packed_array. Set the field
2176 bitsize on a series of packed arrays. Returns the number of
2177 elements in TYPE. */
2180 recursively_update_array_bitsize (struct type
*type
)
2182 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2185 if (get_discrete_bounds (type
->index_type (), &low
, &high
) < 0
2188 LONGEST our_len
= high
- low
+ 1;
2190 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
2191 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2193 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2194 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2195 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2197 TYPE_LENGTH (type
) = ((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2204 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2205 array, returns a simple array that denotes that array. Its type is a
2206 standard GDB array type except that the BITSIZEs of the array
2207 target types are set to the number of bits in each element, and the
2208 type length is set appropriately. */
2210 static struct value
*
2211 decode_constrained_packed_array (struct value
*arr
)
2215 /* If our value is a pointer, then dereference it. Likewise if
2216 the value is a reference. Make sure that this operation does not
2217 cause the target type to be fixed, as this would indirectly cause
2218 this array to be decoded. The rest of the routine assumes that
2219 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2220 and "value_ind" routines to perform the dereferencing, as opposed
2221 to using "ada_coerce_ref" or "ada_value_ind". */
2222 arr
= coerce_ref (arr
);
2223 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2224 arr
= value_ind (arr
);
2226 type
= decode_constrained_packed_array_type (value_type (arr
));
2229 error (_("can't unpack array"));
2233 /* Decoding the packed array type could not correctly set the field
2234 bitsizes for any dimension except the innermost, because the
2235 bounds may be variable and were not passed to that function. So,
2236 we further resolve the array bounds here and then update the
2238 const gdb_byte
*valaddr
= value_contents_for_printing (arr
);
2239 CORE_ADDR address
= value_address (arr
);
2240 gdb::array_view
<const gdb_byte
> view
2241 = gdb::make_array_view (valaddr
, TYPE_LENGTH (type
));
2242 type
= resolve_dynamic_type (type
, view
, address
);
2243 recursively_update_array_bitsize (type
);
2245 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2246 && ada_is_modular_type (value_type (arr
)))
2248 /* This is a (right-justified) modular type representing a packed
2249 array with no wrapper. In order to interpret the value through
2250 the (left-justified) packed array type we just built, we must
2251 first left-justify it. */
2252 int bit_size
, bit_pos
;
2255 mod
= ada_modulus (value_type (arr
)) - 1;
2262 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2263 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2264 bit_pos
/ HOST_CHAR_BIT
,
2265 bit_pos
% HOST_CHAR_BIT
,
2270 return coerce_unspec_val_to_type (arr
, type
);
2274 /* The value of the element of packed array ARR at the ARITY indices
2275 given in IND. ARR must be a simple array. */
2277 static struct value
*
2278 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2281 int bits
, elt_off
, bit_off
;
2282 long elt_total_bit_offset
;
2283 struct type
*elt_type
;
2287 elt_total_bit_offset
= 0;
2288 elt_type
= ada_check_typedef (value_type (arr
));
2289 for (i
= 0; i
< arity
; i
+= 1)
2291 if (elt_type
->code () != TYPE_CODE_ARRAY
2292 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2294 (_("attempt to do packed indexing of "
2295 "something other than a packed array"));
2298 struct type
*range_type
= elt_type
->index_type ();
2299 LONGEST lowerbound
, upperbound
;
2302 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2304 lim_warning (_("don't know bounds of array"));
2305 lowerbound
= upperbound
= 0;
2308 idx
= pos_atr (ind
[i
]);
2309 if (idx
< lowerbound
|| idx
> upperbound
)
2310 lim_warning (_("packed array index %ld out of bounds"),
2312 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2313 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2314 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2317 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2318 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2320 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2325 /* Non-zero iff TYPE includes negative integer values. */
2328 has_negatives (struct type
*type
)
2330 switch (type
->code ())
2335 return !type
->is_unsigned ();
2336 case TYPE_CODE_RANGE
:
2337 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2341 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2342 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2343 the unpacked buffer.
2345 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2346 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2348 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2351 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2353 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2356 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2357 gdb_byte
*unpacked
, int unpacked_len
,
2358 int is_big_endian
, int is_signed_type
,
2361 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2362 int src_idx
; /* Index into the source area */
2363 int src_bytes_left
; /* Number of source bytes left to process. */
2364 int srcBitsLeft
; /* Number of source bits left to move */
2365 int unusedLS
; /* Number of bits in next significant
2366 byte of source that are unused */
2368 int unpacked_idx
; /* Index into the unpacked buffer */
2369 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2371 unsigned long accum
; /* Staging area for bits being transferred */
2372 int accumSize
; /* Number of meaningful bits in accum */
2375 /* Transmit bytes from least to most significant; delta is the direction
2376 the indices move. */
2377 int delta
= is_big_endian
? -1 : 1;
2379 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2381 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2382 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2383 bit_size
, unpacked_len
);
2385 srcBitsLeft
= bit_size
;
2386 src_bytes_left
= src_len
;
2387 unpacked_bytes_left
= unpacked_len
;
2392 src_idx
= src_len
- 1;
2394 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2398 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2404 unpacked_idx
= unpacked_len
- 1;
2408 /* Non-scalar values must be aligned at a byte boundary... */
2410 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2411 /* ... And are placed at the beginning (most-significant) bytes
2413 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2414 unpacked_bytes_left
= unpacked_idx
+ 1;
2419 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2421 src_idx
= unpacked_idx
= 0;
2422 unusedLS
= bit_offset
;
2425 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2430 while (src_bytes_left
> 0)
2432 /* Mask for removing bits of the next source byte that are not
2433 part of the value. */
2434 unsigned int unusedMSMask
=
2435 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2437 /* Sign-extend bits for this byte. */
2438 unsigned int signMask
= sign
& ~unusedMSMask
;
2441 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2442 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2443 if (accumSize
>= HOST_CHAR_BIT
)
2445 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2446 accumSize
-= HOST_CHAR_BIT
;
2447 accum
>>= HOST_CHAR_BIT
;
2448 unpacked_bytes_left
-= 1;
2449 unpacked_idx
+= delta
;
2451 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2453 src_bytes_left
-= 1;
2456 while (unpacked_bytes_left
> 0)
2458 accum
|= sign
<< accumSize
;
2459 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2460 accumSize
-= HOST_CHAR_BIT
;
2463 accum
>>= HOST_CHAR_BIT
;
2464 unpacked_bytes_left
-= 1;
2465 unpacked_idx
+= delta
;
2469 /* Create a new value of type TYPE from the contents of OBJ starting
2470 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2471 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2472 assigning through the result will set the field fetched from.
2473 VALADDR is ignored unless OBJ is NULL, in which case,
2474 VALADDR+OFFSET must address the start of storage containing the
2475 packed value. The value returned in this case is never an lval.
2476 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2479 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2480 long offset
, int bit_offset
, int bit_size
,
2484 const gdb_byte
*src
; /* First byte containing data to unpack */
2486 const int is_scalar
= is_scalar_type (type
);
2487 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2488 gdb::byte_vector staging
;
2490 type
= ada_check_typedef (type
);
2493 src
= valaddr
+ offset
;
2495 src
= value_contents (obj
) + offset
;
2497 if (is_dynamic_type (type
))
2499 /* The length of TYPE might by dynamic, so we need to resolve
2500 TYPE in order to know its actual size, which we then use
2501 to create the contents buffer of the value we return.
2502 The difficulty is that the data containing our object is
2503 packed, and therefore maybe not at a byte boundary. So, what
2504 we do, is unpack the data into a byte-aligned buffer, and then
2505 use that buffer as our object's value for resolving the type. */
2506 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2507 staging
.resize (staging_len
);
2509 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2510 staging
.data (), staging
.size (),
2511 is_big_endian
, has_negatives (type
),
2513 type
= resolve_dynamic_type (type
, staging
, 0);
2514 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2516 /* This happens when the length of the object is dynamic,
2517 and is actually smaller than the space reserved for it.
2518 For instance, in an array of variant records, the bit_size
2519 we're given is the array stride, which is constant and
2520 normally equal to the maximum size of its element.
2521 But, in reality, each element only actually spans a portion
2523 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2529 v
= allocate_value (type
);
2530 src
= valaddr
+ offset
;
2532 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2534 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2537 v
= value_at (type
, value_address (obj
) + offset
);
2538 buf
= (gdb_byte
*) alloca (src_len
);
2539 read_memory (value_address (v
), buf
, src_len
);
2544 v
= allocate_value (type
);
2545 src
= value_contents (obj
) + offset
;
2550 long new_offset
= offset
;
2552 set_value_component_location (v
, obj
);
2553 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2554 set_value_bitsize (v
, bit_size
);
2555 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2558 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2560 set_value_offset (v
, new_offset
);
2562 /* Also set the parent value. This is needed when trying to
2563 assign a new value (in inferior memory). */
2564 set_value_parent (v
, obj
);
2567 set_value_bitsize (v
, bit_size
);
2568 unpacked
= value_contents_writeable (v
);
2572 memset (unpacked
, 0, TYPE_LENGTH (type
));
2576 if (staging
.size () == TYPE_LENGTH (type
))
2578 /* Small short-cut: If we've unpacked the data into a buffer
2579 of the same size as TYPE's length, then we can reuse that,
2580 instead of doing the unpacking again. */
2581 memcpy (unpacked
, staging
.data (), staging
.size ());
2584 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2585 unpacked
, TYPE_LENGTH (type
),
2586 is_big_endian
, has_negatives (type
), is_scalar
);
2591 /* Store the contents of FROMVAL into the location of TOVAL.
2592 Return a new value with the location of TOVAL and contents of
2593 FROMVAL. Handles assignment into packed fields that have
2594 floating-point or non-scalar types. */
2596 static struct value
*
2597 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2599 struct type
*type
= value_type (toval
);
2600 int bits
= value_bitsize (toval
);
2602 toval
= ada_coerce_ref (toval
);
2603 fromval
= ada_coerce_ref (fromval
);
2605 if (ada_is_direct_array_type (value_type (toval
)))
2606 toval
= ada_coerce_to_simple_array (toval
);
2607 if (ada_is_direct_array_type (value_type (fromval
)))
2608 fromval
= ada_coerce_to_simple_array (fromval
);
2610 if (!deprecated_value_modifiable (toval
))
2611 error (_("Left operand of assignment is not a modifiable lvalue."));
2613 if (VALUE_LVAL (toval
) == lval_memory
2615 && (type
->code () == TYPE_CODE_FLT
2616 || type
->code () == TYPE_CODE_STRUCT
))
2618 int len
= (value_bitpos (toval
)
2619 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2621 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2623 CORE_ADDR to_addr
= value_address (toval
);
2625 if (type
->code () == TYPE_CODE_FLT
)
2626 fromval
= value_cast (type
, fromval
);
2628 read_memory (to_addr
, buffer
, len
);
2629 from_size
= value_bitsize (fromval
);
2631 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2633 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2634 ULONGEST from_offset
= 0;
2635 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2636 from_offset
= from_size
- bits
;
2637 copy_bitwise (buffer
, value_bitpos (toval
),
2638 value_contents (fromval
), from_offset
,
2639 bits
, is_big_endian
);
2640 write_memory_with_notification (to_addr
, buffer
, len
);
2642 val
= value_copy (toval
);
2643 memcpy (value_contents_raw (val
), value_contents (fromval
),
2644 TYPE_LENGTH (type
));
2645 deprecated_set_value_type (val
, type
);
2650 return value_assign (toval
, fromval
);
2654 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2655 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2656 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2657 COMPONENT, and not the inferior's memory. The current contents
2658 of COMPONENT are ignored.
2660 Although not part of the initial design, this function also works
2661 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2662 had a null address, and COMPONENT had an address which is equal to
2663 its offset inside CONTAINER. */
2666 value_assign_to_component (struct value
*container
, struct value
*component
,
2669 LONGEST offset_in_container
=
2670 (LONGEST
) (value_address (component
) - value_address (container
));
2671 int bit_offset_in_container
=
2672 value_bitpos (component
) - value_bitpos (container
);
2675 val
= value_cast (value_type (component
), val
);
2677 if (value_bitsize (component
) == 0)
2678 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2680 bits
= value_bitsize (component
);
2682 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2686 if (is_scalar_type (check_typedef (value_type (component
))))
2688 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2691 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2692 value_bitpos (container
) + bit_offset_in_container
,
2693 value_contents (val
), src_offset
, bits
, 1);
2696 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2697 value_bitpos (container
) + bit_offset_in_container
,
2698 value_contents (val
), 0, bits
, 0);
2701 /* Determine if TYPE is an access to an unconstrained array. */
2704 ada_is_access_to_unconstrained_array (struct type
*type
)
2706 return (type
->code () == TYPE_CODE_TYPEDEF
2707 && is_thick_pntr (ada_typedef_target_type (type
)));
2710 /* The value of the element of array ARR at the ARITY indices given in IND.
2711 ARR may be either a simple array, GNAT array descriptor, or pointer
2715 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2719 struct type
*elt_type
;
2721 elt
= ada_coerce_to_simple_array (arr
);
2723 elt_type
= ada_check_typedef (value_type (elt
));
2724 if (elt_type
->code () == TYPE_CODE_ARRAY
2725 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2726 return value_subscript_packed (elt
, arity
, ind
);
2728 for (k
= 0; k
< arity
; k
+= 1)
2730 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2732 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2733 error (_("too many subscripts (%d expected)"), k
);
2735 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2737 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2738 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2740 /* The element is a typedef to an unconstrained array,
2741 except that the value_subscript call stripped the
2742 typedef layer. The typedef layer is GNAT's way to
2743 specify that the element is, at the source level, an
2744 access to the unconstrained array, rather than the
2745 unconstrained array. So, we need to restore that
2746 typedef layer, which we can do by forcing the element's
2747 type back to its original type. Otherwise, the returned
2748 value is going to be printed as the array, rather
2749 than as an access. Another symptom of the same issue
2750 would be that an expression trying to dereference the
2751 element would also be improperly rejected. */
2752 deprecated_set_value_type (elt
, saved_elt_type
);
2755 elt_type
= ada_check_typedef (value_type (elt
));
2761 /* Assuming ARR is a pointer to a GDB array, the value of the element
2762 of *ARR at the ARITY indices given in IND.
2763 Does not read the entire array into memory.
2765 Note: Unlike what one would expect, this function is used instead of
2766 ada_value_subscript for basically all non-packed array types. The reason
2767 for this is that a side effect of doing our own pointer arithmetics instead
2768 of relying on value_subscript is that there is no implicit typedef peeling.
2769 This is important for arrays of array accesses, where it allows us to
2770 preserve the fact that the array's element is an array access, where the
2771 access part os encoded in a typedef layer. */
2773 static struct value
*
2774 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2777 struct value
*array_ind
= ada_value_ind (arr
);
2779 = check_typedef (value_enclosing_type (array_ind
));
2781 if (type
->code () == TYPE_CODE_ARRAY
2782 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2783 return value_subscript_packed (array_ind
, arity
, ind
);
2785 for (k
= 0; k
< arity
; k
+= 1)
2789 if (type
->code () != TYPE_CODE_ARRAY
)
2790 error (_("too many subscripts (%d expected)"), k
);
2791 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2793 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2794 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2795 type
= TYPE_TARGET_TYPE (type
);
2798 return value_ind (arr
);
2801 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2802 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2803 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2804 this array is LOW, as per Ada rules. */
2805 static struct value
*
2806 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2809 struct type
*type0
= ada_check_typedef (type
);
2810 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2811 struct type
*index_type
2812 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2813 struct type
*slice_type
= create_array_type_with_stride
2814 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2815 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2816 TYPE_FIELD_BITSIZE (type0
, 0));
2817 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2818 LONGEST base_low_pos
, low_pos
;
2821 if (!discrete_position (base_index_type
, low
, &low_pos
)
2822 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2824 warning (_("unable to get positions in slice, use bounds instead"));
2826 base_low_pos
= base_low
;
2829 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
2831 stride
= TYPE_LENGTH (TYPE_TARGET_TYPE (type0
));
2833 base
= value_as_address (array_ptr
) + (low_pos
- base_low_pos
) * stride
;
2834 return value_at_lazy (slice_type
, base
);
2838 static struct value
*
2839 ada_value_slice (struct value
*array
, int low
, int high
)
2841 struct type
*type
= ada_check_typedef (value_type (array
));
2842 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2843 struct type
*index_type
2844 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2845 struct type
*slice_type
= create_array_type_with_stride
2846 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2847 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2848 TYPE_FIELD_BITSIZE (type
, 0));
2849 LONGEST low_pos
, high_pos
;
2851 if (!discrete_position (base_index_type
, low
, &low_pos
)
2852 || !discrete_position (base_index_type
, high
, &high_pos
))
2854 warning (_("unable to get positions in slice, use bounds instead"));
2859 return value_cast (slice_type
,
2860 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2863 /* If type is a record type in the form of a standard GNAT array
2864 descriptor, returns the number of dimensions for type. If arr is a
2865 simple array, returns the number of "array of"s that prefix its
2866 type designation. Otherwise, returns 0. */
2869 ada_array_arity (struct type
*type
)
2876 type
= desc_base_type (type
);
2879 if (type
->code () == TYPE_CODE_STRUCT
)
2880 return desc_arity (desc_bounds_type (type
));
2882 while (type
->code () == TYPE_CODE_ARRAY
)
2885 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2891 /* If TYPE is a record type in the form of a standard GNAT array
2892 descriptor or a simple array type, returns the element type for
2893 TYPE after indexing by NINDICES indices, or by all indices if
2894 NINDICES is -1. Otherwise, returns NULL. */
2897 ada_array_element_type (struct type
*type
, int nindices
)
2899 type
= desc_base_type (type
);
2901 if (type
->code () == TYPE_CODE_STRUCT
)
2904 struct type
*p_array_type
;
2906 p_array_type
= desc_data_target_type (type
);
2908 k
= ada_array_arity (type
);
2912 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2913 if (nindices
>= 0 && k
> nindices
)
2915 while (k
> 0 && p_array_type
!= NULL
)
2917 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2920 return p_array_type
;
2922 else if (type
->code () == TYPE_CODE_ARRAY
)
2924 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2926 type
= TYPE_TARGET_TYPE (type
);
2935 /* The type of nth index in arrays of given type (n numbering from 1).
2936 Does not examine memory. Throws an error if N is invalid or TYPE
2937 is not an array type. NAME is the name of the Ada attribute being
2938 evaluated ('range, 'first, 'last, or 'length); it is used in building
2939 the error message. */
2941 static struct type
*
2942 ada_index_type (struct type
*type
, int n
, const char *name
)
2944 struct type
*result_type
;
2946 type
= desc_base_type (type
);
2948 if (n
< 0 || n
> ada_array_arity (type
))
2949 error (_("invalid dimension number to '%s"), name
);
2951 if (ada_is_simple_array_type (type
))
2955 for (i
= 1; i
< n
; i
+= 1)
2956 type
= TYPE_TARGET_TYPE (type
);
2957 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2958 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2959 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2960 perhaps stabsread.c would make more sense. */
2961 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2966 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2967 if (result_type
== NULL
)
2968 error (_("attempt to take bound of something that is not an array"));
2974 /* Given that arr is an array type, returns the lower bound of the
2975 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2976 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2977 array-descriptor type. It works for other arrays with bounds supplied
2978 by run-time quantities other than discriminants. */
2981 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2983 struct type
*type
, *index_type_desc
, *index_type
;
2986 gdb_assert (which
== 0 || which
== 1);
2988 if (ada_is_constrained_packed_array_type (arr_type
))
2989 arr_type
= decode_constrained_packed_array_type (arr_type
);
2991 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2992 return (LONGEST
) - which
;
2994 if (arr_type
->code () == TYPE_CODE_PTR
)
2995 type
= TYPE_TARGET_TYPE (arr_type
);
2999 if (type
->is_fixed_instance ())
3001 /* The array has already been fixed, so we do not need to
3002 check the parallel ___XA type again. That encoding has
3003 already been applied, so ignore it now. */
3004 index_type_desc
= NULL
;
3008 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3009 ada_fixup_array_indexes_type (index_type_desc
);
3012 if (index_type_desc
!= NULL
)
3013 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
3017 struct type
*elt_type
= check_typedef (type
);
3019 for (i
= 1; i
< n
; i
++)
3020 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3022 index_type
= elt_type
->index_type ();
3026 (LONGEST
) (which
== 0
3027 ? ada_discrete_type_low_bound (index_type
)
3028 : ada_discrete_type_high_bound (index_type
));
3031 /* Given that arr is an array value, returns the lower bound of the
3032 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3033 WHICH is 1. This routine will also work for arrays with bounds
3034 supplied by run-time quantities other than discriminants. */
3037 ada_array_bound (struct value
*arr
, int n
, int which
)
3039 struct type
*arr_type
;
3041 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3042 arr
= value_ind (arr
);
3043 arr_type
= value_enclosing_type (arr
);
3045 if (ada_is_constrained_packed_array_type (arr_type
))
3046 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3047 else if (ada_is_simple_array_type (arr_type
))
3048 return ada_array_bound_from_type (arr_type
, n
, which
);
3050 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3053 /* Given that arr is an array value, returns the length of the
3054 nth index. This routine will also work for arrays with bounds
3055 supplied by run-time quantities other than discriminants.
3056 Does not work for arrays indexed by enumeration types with representation
3057 clauses at the moment. */
3060 ada_array_length (struct value
*arr
, int n
)
3062 struct type
*arr_type
, *index_type
;
3065 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3066 arr
= value_ind (arr
);
3067 arr_type
= value_enclosing_type (arr
);
3069 if (ada_is_constrained_packed_array_type (arr_type
))
3070 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3072 if (ada_is_simple_array_type (arr_type
))
3074 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3075 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3079 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3080 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3083 arr_type
= check_typedef (arr_type
);
3084 index_type
= ada_index_type (arr_type
, n
, "length");
3085 if (index_type
!= NULL
)
3087 struct type
*base_type
;
3088 if (index_type
->code () == TYPE_CODE_RANGE
)
3089 base_type
= TYPE_TARGET_TYPE (index_type
);
3091 base_type
= index_type
;
3093 low
= pos_atr (value_from_longest (base_type
, low
));
3094 high
= pos_atr (value_from_longest (base_type
, high
));
3096 return high
- low
+ 1;
3099 /* An array whose type is that of ARR_TYPE (an array type), with
3100 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3101 less than LOW, then LOW-1 is used. */
3103 static struct value
*
3104 empty_array (struct type
*arr_type
, int low
, int high
)
3106 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3107 struct type
*index_type
3108 = create_static_range_type
3109 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3110 high
< low
? low
- 1 : high
);
3111 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3113 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3117 /* Name resolution */
3119 /* The "decoded" name for the user-definable Ada operator corresponding
3123 ada_decoded_op_name (enum exp_opcode op
)
3127 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3129 if (ada_opname_table
[i
].op
== op
)
3130 return ada_opname_table
[i
].decoded
;
3132 error (_("Could not find operator name for opcode"));
3135 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3136 in a listing of choices during disambiguation (see sort_choices, below).
3137 The idea is that overloadings of a subprogram name from the
3138 same package should sort in their source order. We settle for ordering
3139 such symbols by their trailing number (__N or $N). */
3142 encoded_ordered_before (const char *N0
, const char *N1
)
3146 else if (N0
== NULL
)
3152 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3154 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3156 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3157 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3162 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3165 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3167 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3168 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3170 return (strcmp (N0
, N1
) < 0);
3174 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3178 sort_choices (struct block_symbol syms
[], int nsyms
)
3182 for (i
= 1; i
< nsyms
; i
+= 1)
3184 struct block_symbol sym
= syms
[i
];
3187 for (j
= i
- 1; j
>= 0; j
-= 1)
3189 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3190 sym
.symbol
->linkage_name ()))
3192 syms
[j
+ 1] = syms
[j
];
3198 /* Whether GDB should display formals and return types for functions in the
3199 overloads selection menu. */
3200 static bool print_signatures
= true;
3202 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3203 all but functions, the signature is just the name of the symbol. For
3204 functions, this is the name of the function, the list of types for formals
3205 and the return type (if any). */
3208 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3209 const struct type_print_options
*flags
)
3211 struct type
*type
= SYMBOL_TYPE (sym
);
3213 fprintf_filtered (stream
, "%s", sym
->print_name ());
3214 if (!print_signatures
3216 || type
->code () != TYPE_CODE_FUNC
)
3219 if (type
->num_fields () > 0)
3223 fprintf_filtered (stream
, " (");
3224 for (i
= 0; i
< type
->num_fields (); ++i
)
3227 fprintf_filtered (stream
, "; ");
3228 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3231 fprintf_filtered (stream
, ")");
3233 if (TYPE_TARGET_TYPE (type
) != NULL
3234 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3236 fprintf_filtered (stream
, " return ");
3237 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3241 /* Read and validate a set of numeric choices from the user in the
3242 range 0 .. N_CHOICES-1. Place the results in increasing
3243 order in CHOICES[0 .. N-1], and return N.
3245 The user types choices as a sequence of numbers on one line
3246 separated by blanks, encoding them as follows:
3248 + A choice of 0 means to cancel the selection, throwing an error.
3249 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3250 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3252 The user is not allowed to choose more than MAX_RESULTS values.
3254 ANNOTATION_SUFFIX, if present, is used to annotate the input
3255 prompts (for use with the -f switch). */
3258 get_selections (int *choices
, int n_choices
, int max_results
,
3259 int is_all_choice
, const char *annotation_suffix
)
3264 int first_choice
= is_all_choice
? 2 : 1;
3266 prompt
= getenv ("PS2");
3270 args
= command_line_input (prompt
, annotation_suffix
);
3273 error_no_arg (_("one or more choice numbers"));
3277 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3278 order, as given in args. Choices are validated. */
3284 args
= skip_spaces (args
);
3285 if (*args
== '\0' && n_chosen
== 0)
3286 error_no_arg (_("one or more choice numbers"));
3287 else if (*args
== '\0')
3290 choice
= strtol (args
, &args2
, 10);
3291 if (args
== args2
|| choice
< 0
3292 || choice
> n_choices
+ first_choice
- 1)
3293 error (_("Argument must be choice number"));
3297 error (_("cancelled"));
3299 if (choice
< first_choice
)
3301 n_chosen
= n_choices
;
3302 for (j
= 0; j
< n_choices
; j
+= 1)
3306 choice
-= first_choice
;
3308 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3312 if (j
< 0 || choice
!= choices
[j
])
3316 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3317 choices
[k
+ 1] = choices
[k
];
3318 choices
[j
+ 1] = choice
;
3323 if (n_chosen
> max_results
)
3324 error (_("Select no more than %d of the above"), max_results
);
3329 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3330 by asking the user (if necessary), returning the number selected,
3331 and setting the first elements of SYMS items. Error if no symbols
3334 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3335 to be re-integrated one of these days. */
3338 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3341 int *chosen
= XALLOCAVEC (int , nsyms
);
3343 int first_choice
= (max_results
== 1) ? 1 : 2;
3344 const char *select_mode
= multiple_symbols_select_mode ();
3346 if (max_results
< 1)
3347 error (_("Request to select 0 symbols!"));
3351 if (select_mode
== multiple_symbols_cancel
)
3353 canceled because the command is ambiguous\n\
3354 See set/show multiple-symbol."));
3356 /* If select_mode is "all", then return all possible symbols.
3357 Only do that if more than one symbol can be selected, of course.
3358 Otherwise, display the menu as usual. */
3359 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3362 printf_filtered (_("[0] cancel\n"));
3363 if (max_results
> 1)
3364 printf_filtered (_("[1] all\n"));
3366 sort_choices (syms
, nsyms
);
3368 for (i
= 0; i
< nsyms
; i
+= 1)
3370 if (syms
[i
].symbol
== NULL
)
3373 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3375 struct symtab_and_line sal
=
3376 find_function_start_sal (syms
[i
].symbol
, 1);
3378 printf_filtered ("[%d] ", i
+ first_choice
);
3379 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3380 &type_print_raw_options
);
3381 if (sal
.symtab
== NULL
)
3382 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3383 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3387 styled_string (file_name_style
.style (),
3388 symtab_to_filename_for_display (sal
.symtab
)),
3395 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3396 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3397 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3398 struct symtab
*symtab
= NULL
;
3400 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3401 symtab
= symbol_symtab (syms
[i
].symbol
);
3403 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3405 printf_filtered ("[%d] ", i
+ first_choice
);
3406 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3407 &type_print_raw_options
);
3408 printf_filtered (_(" at %s:%d\n"),
3409 symtab_to_filename_for_display (symtab
),
3410 SYMBOL_LINE (syms
[i
].symbol
));
3412 else if (is_enumeral
3413 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3415 printf_filtered (("[%d] "), i
+ first_choice
);
3416 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3417 gdb_stdout
, -1, 0, &type_print_raw_options
);
3418 printf_filtered (_("'(%s) (enumeral)\n"),
3419 syms
[i
].symbol
->print_name ());
3423 printf_filtered ("[%d] ", i
+ first_choice
);
3424 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3425 &type_print_raw_options
);
3428 printf_filtered (is_enumeral
3429 ? _(" in %s (enumeral)\n")
3431 symtab_to_filename_for_display (symtab
));
3433 printf_filtered (is_enumeral
3434 ? _(" (enumeral)\n")
3440 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3443 for (i
= 0; i
< n_chosen
; i
+= 1)
3444 syms
[i
] = syms
[chosen
[i
]];
3449 /* Resolve the operator of the subexpression beginning at
3450 position *POS of *EXPP. "Resolving" consists of replacing
3451 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3452 with their resolutions, replacing built-in operators with
3453 function calls to user-defined operators, where appropriate, and,
3454 when DEPROCEDURE_P is non-zero, converting function-valued variables
3455 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3456 are as in ada_resolve, above. */
3458 static struct value
*
3459 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3460 struct type
*context_type
, int parse_completion
,
3461 innermost_block_tracker
*tracker
)
3465 struct expression
*exp
; /* Convenience: == *expp. */
3466 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3467 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3468 int nargs
; /* Number of operands. */
3475 /* Pass one: resolve operands, saving their types and updating *pos,
3480 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3481 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3486 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3488 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3493 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3498 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3499 parse_completion
, tracker
);
3502 case OP_ATR_MODULUS
:
3512 case TERNOP_IN_RANGE
:
3513 case BINOP_IN_BOUNDS
:
3519 case OP_DISCRETE_RANGE
:
3521 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3530 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3532 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3534 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3552 case BINOP_LOGICAL_AND
:
3553 case BINOP_LOGICAL_OR
:
3554 case BINOP_BITWISE_AND
:
3555 case BINOP_BITWISE_IOR
:
3556 case BINOP_BITWISE_XOR
:
3559 case BINOP_NOTEQUAL
:
3566 case BINOP_SUBSCRIPT
:
3574 case UNOP_LOGICAL_NOT
:
3584 case OP_VAR_MSYM_VALUE
:
3591 case OP_INTERNALVAR
:
3601 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3604 case STRUCTOP_STRUCT
:
3605 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3618 error (_("Unexpected operator during name resolution"));
3621 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3622 for (i
= 0; i
< nargs
; i
+= 1)
3623 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3628 /* Pass two: perform any resolution on principal operator. */
3635 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3637 std::vector
<struct block_symbol
> candidates
;
3641 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3642 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3645 if (n_candidates
> 1)
3647 /* Types tend to get re-introduced locally, so if there
3648 are any local symbols that are not types, first filter
3651 for (j
= 0; j
< n_candidates
; j
+= 1)
3652 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3657 case LOC_REGPARM_ADDR
:
3665 if (j
< n_candidates
)
3668 while (j
< n_candidates
)
3670 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3672 candidates
[j
] = candidates
[n_candidates
- 1];
3681 if (n_candidates
== 0)
3682 error (_("No definition found for %s"),
3683 exp
->elts
[pc
+ 2].symbol
->print_name ());
3684 else if (n_candidates
== 1)
3686 else if (deprocedure_p
3687 && !is_nonfunction (candidates
.data (), n_candidates
))
3689 i
= ada_resolve_function
3690 (candidates
.data (), n_candidates
, NULL
, 0,
3691 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3692 context_type
, parse_completion
);
3694 error (_("Could not find a match for %s"),
3695 exp
->elts
[pc
+ 2].symbol
->print_name ());
3699 printf_filtered (_("Multiple matches for %s\n"),
3700 exp
->elts
[pc
+ 2].symbol
->print_name ());
3701 user_select_syms (candidates
.data (), n_candidates
, 1);
3705 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3706 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3707 tracker
->update (candidates
[i
]);
3711 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3714 replace_operator_with_call (expp
, pc
, 0, 4,
3715 exp
->elts
[pc
+ 2].symbol
,
3716 exp
->elts
[pc
+ 1].block
);
3723 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3724 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3726 std::vector
<struct block_symbol
> candidates
;
3730 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3731 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3734 if (n_candidates
== 1)
3738 i
= ada_resolve_function
3739 (candidates
.data (), n_candidates
,
3741 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3742 context_type
, parse_completion
);
3744 error (_("Could not find a match for %s"),
3745 exp
->elts
[pc
+ 5].symbol
->print_name ());
3748 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3749 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3750 tracker
->update (candidates
[i
]);
3761 case BINOP_BITWISE_AND
:
3762 case BINOP_BITWISE_IOR
:
3763 case BINOP_BITWISE_XOR
:
3765 case BINOP_NOTEQUAL
:
3773 case UNOP_LOGICAL_NOT
:
3775 if (possible_user_operator_p (op
, argvec
))
3777 std::vector
<struct block_symbol
> candidates
;
3781 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3785 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3786 nargs
, ada_decoded_op_name (op
), NULL
,
3791 replace_operator_with_call (expp
, pc
, nargs
, 1,
3792 candidates
[i
].symbol
,
3793 candidates
[i
].block
);
3804 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3805 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3806 exp
->elts
[pc
+ 1].objfile
,
3807 exp
->elts
[pc
+ 2].msymbol
);
3809 return evaluate_subexp_type (exp
, pos
);
3812 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3813 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3815 /* The term "match" here is rather loose. The match is heuristic and
3819 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3821 ftype
= ada_check_typedef (ftype
);
3822 atype
= ada_check_typedef (atype
);
3824 if (ftype
->code () == TYPE_CODE_REF
)
3825 ftype
= TYPE_TARGET_TYPE (ftype
);
3826 if (atype
->code () == TYPE_CODE_REF
)
3827 atype
= TYPE_TARGET_TYPE (atype
);
3829 switch (ftype
->code ())
3832 return ftype
->code () == atype
->code ();
3834 if (atype
->code () == TYPE_CODE_PTR
)
3835 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3836 TYPE_TARGET_TYPE (atype
), 0);
3839 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3841 case TYPE_CODE_ENUM
:
3842 case TYPE_CODE_RANGE
:
3843 switch (atype
->code ())
3846 case TYPE_CODE_ENUM
:
3847 case TYPE_CODE_RANGE
:
3853 case TYPE_CODE_ARRAY
:
3854 return (atype
->code () == TYPE_CODE_ARRAY
3855 || ada_is_array_descriptor_type (atype
));
3857 case TYPE_CODE_STRUCT
:
3858 if (ada_is_array_descriptor_type (ftype
))
3859 return (atype
->code () == TYPE_CODE_ARRAY
3860 || ada_is_array_descriptor_type (atype
));
3862 return (atype
->code () == TYPE_CODE_STRUCT
3863 && !ada_is_array_descriptor_type (atype
));
3865 case TYPE_CODE_UNION
:
3867 return (atype
->code () == ftype
->code ());
3871 /* Return non-zero if the formals of FUNC "sufficiently match" the
3872 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3873 may also be an enumeral, in which case it is treated as a 0-
3874 argument function. */
3877 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3880 struct type
*func_type
= SYMBOL_TYPE (func
);
3882 if (SYMBOL_CLASS (func
) == LOC_CONST
3883 && func_type
->code () == TYPE_CODE_ENUM
)
3884 return (n_actuals
== 0);
3885 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3888 if (func_type
->num_fields () != n_actuals
)
3891 for (i
= 0; i
< n_actuals
; i
+= 1)
3893 if (actuals
[i
] == NULL
)
3897 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3898 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3900 if (!ada_type_match (ftype
, atype
, 1))
3907 /* False iff function type FUNC_TYPE definitely does not produce a value
3908 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3909 FUNC_TYPE is not a valid function type with a non-null return type
3910 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3913 return_match (struct type
*func_type
, struct type
*context_type
)
3915 struct type
*return_type
;
3917 if (func_type
== NULL
)
3920 if (func_type
->code () == TYPE_CODE_FUNC
)
3921 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3923 return_type
= get_base_type (func_type
);
3924 if (return_type
== NULL
)
3927 context_type
= get_base_type (context_type
);
3929 if (return_type
->code () == TYPE_CODE_ENUM
)
3930 return context_type
== NULL
|| return_type
== context_type
;
3931 else if (context_type
== NULL
)
3932 return return_type
->code () != TYPE_CODE_VOID
;
3934 return return_type
->code () == context_type
->code ();
3938 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3939 function (if any) that matches the types of the NARGS arguments in
3940 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3941 that returns that type, then eliminate matches that don't. If
3942 CONTEXT_TYPE is void and there is at least one match that does not
3943 return void, eliminate all matches that do.
3945 Asks the user if there is more than one match remaining. Returns -1
3946 if there is no such symbol or none is selected. NAME is used
3947 solely for messages. May re-arrange and modify SYMS in
3948 the process; the index returned is for the modified vector. */
3951 ada_resolve_function (struct block_symbol syms
[],
3952 int nsyms
, struct value
**args
, int nargs
,
3953 const char *name
, struct type
*context_type
,
3954 int parse_completion
)
3958 int m
; /* Number of hits */
3961 /* In the first pass of the loop, we only accept functions matching
3962 context_type. If none are found, we add a second pass of the loop
3963 where every function is accepted. */
3964 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3966 for (k
= 0; k
< nsyms
; k
+= 1)
3968 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3970 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3971 && (fallback
|| return_match (type
, context_type
)))
3979 /* If we got multiple matches, ask the user which one to use. Don't do this
3980 interactive thing during completion, though, as the purpose of the
3981 completion is providing a list of all possible matches. Prompting the
3982 user to filter it down would be completely unexpected in this case. */
3985 else if (m
> 1 && !parse_completion
)
3987 printf_filtered (_("Multiple matches for %s\n"), name
);
3988 user_select_syms (syms
, m
, 1);
3994 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3995 on the function identified by SYM and BLOCK, and taking NARGS
3996 arguments. Update *EXPP as needed to hold more space. */
3999 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4000 int oplen
, struct symbol
*sym
,
4001 const struct block
*block
)
4003 /* We want to add 6 more elements (3 for funcall, 4 for function
4004 symbol, -OPLEN for operator being replaced) to the
4006 struct expression
*exp
= expp
->get ();
4007 int save_nelts
= exp
->nelts
;
4008 int extra_elts
= 7 - oplen
;
4009 exp
->nelts
+= extra_elts
;
4012 exp
->resize (exp
->nelts
);
4013 memmove (exp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4014 EXP_ELEM_TO_BYTES (save_nelts
- pc
- oplen
));
4016 exp
->resize (exp
->nelts
);
4018 exp
->elts
[pc
].opcode
= exp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4019 exp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4021 exp
->elts
[pc
+ 3].opcode
= exp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4022 exp
->elts
[pc
+ 4].block
= block
;
4023 exp
->elts
[pc
+ 5].symbol
= sym
;
4026 /* Type-class predicates */
4028 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4032 numeric_type_p (struct type
*type
)
4038 switch (type
->code ())
4043 case TYPE_CODE_RANGE
:
4044 return (type
== TYPE_TARGET_TYPE (type
)
4045 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4052 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4055 integer_type_p (struct type
*type
)
4061 switch (type
->code ())
4065 case TYPE_CODE_RANGE
:
4066 return (type
== TYPE_TARGET_TYPE (type
)
4067 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4074 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4077 scalar_type_p (struct type
*type
)
4083 switch (type
->code ())
4086 case TYPE_CODE_RANGE
:
4087 case TYPE_CODE_ENUM
:
4096 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4099 discrete_type_p (struct type
*type
)
4105 switch (type
->code ())
4108 case TYPE_CODE_RANGE
:
4109 case TYPE_CODE_ENUM
:
4110 case TYPE_CODE_BOOL
:
4118 /* Returns non-zero if OP with operands in the vector ARGS could be
4119 a user-defined function. Errs on the side of pre-defined operators
4120 (i.e., result 0). */
4123 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4125 struct type
*type0
=
4126 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4127 struct type
*type1
=
4128 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4142 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4146 case BINOP_BITWISE_AND
:
4147 case BINOP_BITWISE_IOR
:
4148 case BINOP_BITWISE_XOR
:
4149 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4152 case BINOP_NOTEQUAL
:
4157 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4160 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4163 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4167 case UNOP_LOGICAL_NOT
:
4169 return (!numeric_type_p (type0
));
4178 1. In the following, we assume that a renaming type's name may
4179 have an ___XD suffix. It would be nice if this went away at some
4181 2. We handle both the (old) purely type-based representation of
4182 renamings and the (new) variable-based encoding. At some point,
4183 it is devoutly to be hoped that the former goes away
4184 (FIXME: hilfinger-2007-07-09).
4185 3. Subprogram renamings are not implemented, although the XRS
4186 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4188 /* If SYM encodes a renaming,
4190 <renaming> renames <renamed entity>,
4192 sets *LEN to the length of the renamed entity's name,
4193 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4194 the string describing the subcomponent selected from the renamed
4195 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4196 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4197 are undefined). Otherwise, returns a value indicating the category
4198 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4199 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4200 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4201 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4202 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4203 may be NULL, in which case they are not assigned.
4205 [Currently, however, GCC does not generate subprogram renamings.] */
4207 enum ada_renaming_category
4208 ada_parse_renaming (struct symbol
*sym
,
4209 const char **renamed_entity
, int *len
,
4210 const char **renaming_expr
)
4212 enum ada_renaming_category kind
;
4217 return ADA_NOT_RENAMING
;
4218 switch (SYMBOL_CLASS (sym
))
4221 return ADA_NOT_RENAMING
;
4225 case LOC_OPTIMIZED_OUT
:
4226 info
= strstr (sym
->linkage_name (), "___XR");
4228 return ADA_NOT_RENAMING
;
4232 kind
= ADA_OBJECT_RENAMING
;
4236 kind
= ADA_EXCEPTION_RENAMING
;
4240 kind
= ADA_PACKAGE_RENAMING
;
4244 kind
= ADA_SUBPROGRAM_RENAMING
;
4248 return ADA_NOT_RENAMING
;
4252 if (renamed_entity
!= NULL
)
4253 *renamed_entity
= info
;
4254 suffix
= strstr (info
, "___XE");
4255 if (suffix
== NULL
|| suffix
== info
)
4256 return ADA_NOT_RENAMING
;
4258 *len
= strlen (info
) - strlen (suffix
);
4260 if (renaming_expr
!= NULL
)
4261 *renaming_expr
= suffix
;
4265 /* Compute the value of the given RENAMING_SYM, which is expected to
4266 be a symbol encoding a renaming expression. BLOCK is the block
4267 used to evaluate the renaming. */
4269 static struct value
*
4270 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4271 const struct block
*block
)
4273 const char *sym_name
;
4275 sym_name
= renaming_sym
->linkage_name ();
4276 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4277 return evaluate_expression (expr
.get ());
4281 /* Evaluation: Function Calls */
4283 /* Return an lvalue containing the value VAL. This is the identity on
4284 lvalues, and otherwise has the side-effect of allocating memory
4285 in the inferior where a copy of the value contents is copied. */
4287 static struct value
*
4288 ensure_lval (struct value
*val
)
4290 if (VALUE_LVAL (val
) == not_lval
4291 || VALUE_LVAL (val
) == lval_internalvar
)
4293 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4294 const CORE_ADDR addr
=
4295 value_as_long (value_allocate_space_in_inferior (len
));
4297 VALUE_LVAL (val
) = lval_memory
;
4298 set_value_address (val
, addr
);
4299 write_memory (addr
, value_contents (val
), len
);
4305 /* Given ARG, a value of type (pointer or reference to a)*
4306 structure/union, extract the component named NAME from the ultimate
4307 target structure/union and return it as a value with its
4310 The routine searches for NAME among all members of the structure itself
4311 and (recursively) among all members of any wrapper members
4314 If NO_ERR, then simply return NULL in case of error, rather than
4317 static struct value
*
4318 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4320 struct type
*t
, *t1
;
4325 t1
= t
= ada_check_typedef (value_type (arg
));
4326 if (t
->code () == TYPE_CODE_REF
)
4328 t1
= TYPE_TARGET_TYPE (t
);
4331 t1
= ada_check_typedef (t1
);
4332 if (t1
->code () == TYPE_CODE_PTR
)
4334 arg
= coerce_ref (arg
);
4339 while (t
->code () == TYPE_CODE_PTR
)
4341 t1
= TYPE_TARGET_TYPE (t
);
4344 t1
= ada_check_typedef (t1
);
4345 if (t1
->code () == TYPE_CODE_PTR
)
4347 arg
= value_ind (arg
);
4354 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4358 v
= ada_search_struct_field (name
, arg
, 0, t
);
4361 int bit_offset
, bit_size
, byte_offset
;
4362 struct type
*field_type
;
4365 if (t
->code () == TYPE_CODE_PTR
)
4366 address
= value_address (ada_value_ind (arg
));
4368 address
= value_address (ada_coerce_ref (arg
));
4370 /* Check to see if this is a tagged type. We also need to handle
4371 the case where the type is a reference to a tagged type, but
4372 we have to be careful to exclude pointers to tagged types.
4373 The latter should be shown as usual (as a pointer), whereas
4374 a reference should mostly be transparent to the user. */
4376 if (ada_is_tagged_type (t1
, 0)
4377 || (t1
->code () == TYPE_CODE_REF
4378 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4380 /* We first try to find the searched field in the current type.
4381 If not found then let's look in the fixed type. */
4383 if (!find_struct_field (name
, t1
, 0,
4384 &field_type
, &byte_offset
, &bit_offset
,
4393 /* Convert to fixed type in all cases, so that we have proper
4394 offsets to each field in unconstrained record types. */
4395 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4396 address
, NULL
, check_tag
);
4398 /* Resolve the dynamic type as well. */
4399 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4400 t1
= value_type (arg
);
4402 if (find_struct_field (name
, t1
, 0,
4403 &field_type
, &byte_offset
, &bit_offset
,
4408 if (t
->code () == TYPE_CODE_REF
)
4409 arg
= ada_coerce_ref (arg
);
4411 arg
= ada_value_ind (arg
);
4412 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4413 bit_offset
, bit_size
,
4417 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4421 if (v
!= NULL
|| no_err
)
4424 error (_("There is no member named %s."), name
);
4430 error (_("Attempt to extract a component of "
4431 "a value that is not a record."));
4434 /* Return the value ACTUAL, converted to be an appropriate value for a
4435 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4436 allocating any necessary descriptors (fat pointers), or copies of
4437 values not residing in memory, updating it as needed. */
4440 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4442 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4443 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4444 struct type
*formal_target
=
4445 formal_type
->code () == TYPE_CODE_PTR
4446 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4447 struct type
*actual_target
=
4448 actual_type
->code () == TYPE_CODE_PTR
4449 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4451 if (ada_is_array_descriptor_type (formal_target
)
4452 && actual_target
->code () == TYPE_CODE_ARRAY
)
4453 return make_array_descriptor (formal_type
, actual
);
4454 else if (formal_type
->code () == TYPE_CODE_PTR
4455 || formal_type
->code () == TYPE_CODE_REF
)
4457 struct value
*result
;
4459 if (formal_target
->code () == TYPE_CODE_ARRAY
4460 && ada_is_array_descriptor_type (actual_target
))
4461 result
= desc_data (actual
);
4462 else if (formal_type
->code () != TYPE_CODE_PTR
)
4464 if (VALUE_LVAL (actual
) != lval_memory
)
4468 actual_type
= ada_check_typedef (value_type (actual
));
4469 val
= allocate_value (actual_type
);
4470 memcpy ((char *) value_contents_raw (val
),
4471 (char *) value_contents (actual
),
4472 TYPE_LENGTH (actual_type
));
4473 actual
= ensure_lval (val
);
4475 result
= value_addr (actual
);
4479 return value_cast_pointers (formal_type
, result
, 0);
4481 else if (actual_type
->code () == TYPE_CODE_PTR
)
4482 return ada_value_ind (actual
);
4483 else if (ada_is_aligner_type (formal_type
))
4485 /* We need to turn this parameter into an aligner type
4487 struct value
*aligner
= allocate_value (formal_type
);
4488 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4490 value_assign_to_component (aligner
, component
, actual
);
4497 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4498 type TYPE. This is usually an inefficient no-op except on some targets
4499 (such as AVR) where the representation of a pointer and an address
4503 value_pointer (struct value
*value
, struct type
*type
)
4505 struct gdbarch
*gdbarch
= get_type_arch (type
);
4506 unsigned len
= TYPE_LENGTH (type
);
4507 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4510 addr
= value_address (value
);
4511 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4512 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4517 /* Push a descriptor of type TYPE for array value ARR on the stack at
4518 *SP, updating *SP to reflect the new descriptor. Return either
4519 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4520 to-descriptor type rather than a descriptor type), a struct value *
4521 representing a pointer to this descriptor. */
4523 static struct value
*
4524 make_array_descriptor (struct type
*type
, struct value
*arr
)
4526 struct type
*bounds_type
= desc_bounds_type (type
);
4527 struct type
*desc_type
= desc_base_type (type
);
4528 struct value
*descriptor
= allocate_value (desc_type
);
4529 struct value
*bounds
= allocate_value (bounds_type
);
4532 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4535 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4536 ada_array_bound (arr
, i
, 0),
4537 desc_bound_bitpos (bounds_type
, i
, 0),
4538 desc_bound_bitsize (bounds_type
, i
, 0));
4539 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4540 ada_array_bound (arr
, i
, 1),
4541 desc_bound_bitpos (bounds_type
, i
, 1),
4542 desc_bound_bitsize (bounds_type
, i
, 1));
4545 bounds
= ensure_lval (bounds
);
4547 modify_field (value_type (descriptor
),
4548 value_contents_writeable (descriptor
),
4549 value_pointer (ensure_lval (arr
),
4550 desc_type
->field (0).type ()),
4551 fat_pntr_data_bitpos (desc_type
),
4552 fat_pntr_data_bitsize (desc_type
));
4554 modify_field (value_type (descriptor
),
4555 value_contents_writeable (descriptor
),
4556 value_pointer (bounds
,
4557 desc_type
->field (1).type ()),
4558 fat_pntr_bounds_bitpos (desc_type
),
4559 fat_pntr_bounds_bitsize (desc_type
));
4561 descriptor
= ensure_lval (descriptor
);
4563 if (type
->code () == TYPE_CODE_PTR
)
4564 return value_addr (descriptor
);
4569 /* Symbol Cache Module */
4571 /* Performance measurements made as of 2010-01-15 indicate that
4572 this cache does bring some noticeable improvements. Depending
4573 on the type of entity being printed, the cache can make it as much
4574 as an order of magnitude faster than without it.
4576 The descriptive type DWARF extension has significantly reduced
4577 the need for this cache, at least when DWARF is being used. However,
4578 even in this case, some expensive name-based symbol searches are still
4579 sometimes necessary - to find an XVZ variable, mostly. */
4581 /* Initialize the contents of SYM_CACHE. */
4584 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4586 obstack_init (&sym_cache
->cache_space
);
4587 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4590 /* Free the memory used by SYM_CACHE. */
4593 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4595 obstack_free (&sym_cache
->cache_space
, NULL
);
4599 /* Return the symbol cache associated to the given program space PSPACE.
4600 If not allocated for this PSPACE yet, allocate and initialize one. */
4602 static struct ada_symbol_cache
*
4603 ada_get_symbol_cache (struct program_space
*pspace
)
4605 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4607 if (pspace_data
->sym_cache
== NULL
)
4609 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4610 ada_init_symbol_cache (pspace_data
->sym_cache
);
4613 return pspace_data
->sym_cache
;
4616 /* Clear all entries from the symbol cache. */
4619 ada_clear_symbol_cache (void)
4621 struct ada_symbol_cache
*sym_cache
4622 = ada_get_symbol_cache (current_program_space
);
4624 obstack_free (&sym_cache
->cache_space
, NULL
);
4625 ada_init_symbol_cache (sym_cache
);
4628 /* Search our cache for an entry matching NAME and DOMAIN.
4629 Return it if found, or NULL otherwise. */
4631 static struct cache_entry
**
4632 find_entry (const char *name
, domain_enum domain
)
4634 struct ada_symbol_cache
*sym_cache
4635 = ada_get_symbol_cache (current_program_space
);
4636 int h
= msymbol_hash (name
) % HASH_SIZE
;
4637 struct cache_entry
**e
;
4639 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4641 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4647 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4648 Return 1 if found, 0 otherwise.
4650 If an entry was found and SYM is not NULL, set *SYM to the entry's
4651 SYM. Same principle for BLOCK if not NULL. */
4654 lookup_cached_symbol (const char *name
, domain_enum domain
,
4655 struct symbol
**sym
, const struct block
**block
)
4657 struct cache_entry
**e
= find_entry (name
, domain
);
4664 *block
= (*e
)->block
;
4668 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4669 in domain DOMAIN, save this result in our symbol cache. */
4672 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4673 const struct block
*block
)
4675 struct ada_symbol_cache
*sym_cache
4676 = ada_get_symbol_cache (current_program_space
);
4678 struct cache_entry
*e
;
4680 /* Symbols for builtin types don't have a block.
4681 For now don't cache such symbols. */
4682 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4685 /* If the symbol is a local symbol, then do not cache it, as a search
4686 for that symbol depends on the context. To determine whether
4687 the symbol is local or not, we check the block where we found it
4688 against the global and static blocks of its associated symtab. */
4690 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4691 GLOBAL_BLOCK
) != block
4692 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4693 STATIC_BLOCK
) != block
)
4696 h
= msymbol_hash (name
) % HASH_SIZE
;
4697 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4698 e
->next
= sym_cache
->root
[h
];
4699 sym_cache
->root
[h
] = e
;
4700 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4708 /* Return the symbol name match type that should be used used when
4709 searching for all symbols matching LOOKUP_NAME.
4711 LOOKUP_NAME is expected to be a symbol name after transformation
4714 static symbol_name_match_type
4715 name_match_type_from_name (const char *lookup_name
)
4717 return (strstr (lookup_name
, "__") == NULL
4718 ? symbol_name_match_type::WILD
4719 : symbol_name_match_type::FULL
);
4722 /* Return the result of a standard (literal, C-like) lookup of NAME in
4723 given DOMAIN, visible from lexical block BLOCK. */
4725 static struct symbol
*
4726 standard_lookup (const char *name
, const struct block
*block
,
4729 /* Initialize it just to avoid a GCC false warning. */
4730 struct block_symbol sym
= {};
4732 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4734 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4735 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4740 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4741 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4742 since they contend in overloading in the same way. */
4744 is_nonfunction (struct block_symbol syms
[], int n
)
4748 for (i
= 0; i
< n
; i
+= 1)
4749 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4750 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4751 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4757 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4758 struct types. Otherwise, they may not. */
4761 equiv_types (struct type
*type0
, struct type
*type1
)
4765 if (type0
== NULL
|| type1
== NULL
4766 || type0
->code () != type1
->code ())
4768 if ((type0
->code () == TYPE_CODE_STRUCT
4769 || type0
->code () == TYPE_CODE_ENUM
)
4770 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4771 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4777 /* True iff SYM0 represents the same entity as SYM1, or one that is
4778 no more defined than that of SYM1. */
4781 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4785 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4786 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4789 switch (SYMBOL_CLASS (sym0
))
4795 struct type
*type0
= SYMBOL_TYPE (sym0
);
4796 struct type
*type1
= SYMBOL_TYPE (sym1
);
4797 const char *name0
= sym0
->linkage_name ();
4798 const char *name1
= sym1
->linkage_name ();
4799 int len0
= strlen (name0
);
4802 type0
->code () == type1
->code ()
4803 && (equiv_types (type0
, type1
)
4804 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4805 && startswith (name1
+ len0
, "___XV")));
4808 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4809 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4813 const char *name0
= sym0
->linkage_name ();
4814 const char *name1
= sym1
->linkage_name ();
4815 return (strcmp (name0
, name1
) == 0
4816 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4824 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4825 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4828 add_defn_to_vec (struct obstack
*obstackp
,
4830 const struct block
*block
)
4833 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4835 /* Do not try to complete stub types, as the debugger is probably
4836 already scanning all symbols matching a certain name at the
4837 time when this function is called. Trying to replace the stub
4838 type by its associated full type will cause us to restart a scan
4839 which may lead to an infinite recursion. Instead, the client
4840 collecting the matching symbols will end up collecting several
4841 matches, with at least one of them complete. It can then filter
4842 out the stub ones if needed. */
4844 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4846 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4848 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4850 prevDefns
[i
].symbol
= sym
;
4851 prevDefns
[i
].block
= block
;
4857 struct block_symbol info
;
4861 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4865 /* Number of block_symbol structures currently collected in current vector in
4869 num_defns_collected (struct obstack
*obstackp
)
4871 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4874 /* Vector of block_symbol structures currently collected in current vector in
4875 OBSTACKP. If FINISH, close off the vector and return its final address. */
4877 static struct block_symbol
*
4878 defns_collected (struct obstack
*obstackp
, int finish
)
4881 return (struct block_symbol
*) obstack_finish (obstackp
);
4883 return (struct block_symbol
*) obstack_base (obstackp
);
4886 /* Return a bound minimal symbol matching NAME according to Ada
4887 decoding rules. Returns an invalid symbol if there is no such
4888 minimal symbol. Names prefixed with "standard__" are handled
4889 specially: "standard__" is first stripped off, and only static and
4890 global symbols are searched. */
4892 struct bound_minimal_symbol
4893 ada_lookup_simple_minsym (const char *name
)
4895 struct bound_minimal_symbol result
;
4897 memset (&result
, 0, sizeof (result
));
4899 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4900 lookup_name_info
lookup_name (name
, match_type
);
4902 symbol_name_matcher_ftype
*match_name
4903 = ada_get_symbol_name_matcher (lookup_name
);
4905 for (objfile
*objfile
: current_program_space
->objfiles ())
4907 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4909 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4910 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4912 result
.minsym
= msymbol
;
4913 result
.objfile
= objfile
;
4922 /* For all subprograms that statically enclose the subprogram of the
4923 selected frame, add symbols matching identifier NAME in DOMAIN
4924 and their blocks to the list of data in OBSTACKP, as for
4925 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4926 with a wildcard prefix. */
4929 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4930 const lookup_name_info
&lookup_name
,
4935 /* True if TYPE is definitely an artificial type supplied to a symbol
4936 for which no debugging information was given in the symbol file. */
4939 is_nondebugging_type (struct type
*type
)
4941 const char *name
= ada_type_name (type
);
4943 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4946 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4947 that are deemed "identical" for practical purposes.
4949 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4950 types and that their number of enumerals is identical (in other
4951 words, type1->num_fields () == type2->num_fields ()). */
4954 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4958 /* The heuristic we use here is fairly conservative. We consider
4959 that 2 enumerate types are identical if they have the same
4960 number of enumerals and that all enumerals have the same
4961 underlying value and name. */
4963 /* All enums in the type should have an identical underlying value. */
4964 for (i
= 0; i
< type1
->num_fields (); i
++)
4965 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4968 /* All enumerals should also have the same name (modulo any numerical
4970 for (i
= 0; i
< type1
->num_fields (); i
++)
4972 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4973 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4974 int len_1
= strlen (name_1
);
4975 int len_2
= strlen (name_2
);
4977 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4978 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4980 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4981 TYPE_FIELD_NAME (type2
, i
),
4989 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4990 that are deemed "identical" for practical purposes. Sometimes,
4991 enumerals are not strictly identical, but their types are so similar
4992 that they can be considered identical.
4994 For instance, consider the following code:
4996 type Color is (Black, Red, Green, Blue, White);
4997 type RGB_Color is new Color range Red .. Blue;
4999 Type RGB_Color is a subrange of an implicit type which is a copy
5000 of type Color. If we call that implicit type RGB_ColorB ("B" is
5001 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5002 As a result, when an expression references any of the enumeral
5003 by name (Eg. "print green"), the expression is technically
5004 ambiguous and the user should be asked to disambiguate. But
5005 doing so would only hinder the user, since it wouldn't matter
5006 what choice he makes, the outcome would always be the same.
5007 So, for practical purposes, we consider them as the same. */
5010 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5014 /* Before performing a thorough comparison check of each type,
5015 we perform a series of inexpensive checks. We expect that these
5016 checks will quickly fail in the vast majority of cases, and thus
5017 help prevent the unnecessary use of a more expensive comparison.
5018 Said comparison also expects us to make some of these checks
5019 (see ada_identical_enum_types_p). */
5021 /* Quick check: All symbols should have an enum type. */
5022 for (i
= 0; i
< syms
.size (); i
++)
5023 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
5026 /* Quick check: They should all have the same value. */
5027 for (i
= 1; i
< syms
.size (); i
++)
5028 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5031 /* Quick check: They should all have the same number of enumerals. */
5032 for (i
= 1; i
< syms
.size (); i
++)
5033 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
5034 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
5037 /* All the sanity checks passed, so we might have a set of
5038 identical enumeration types. Perform a more complete
5039 comparison of the type of each symbol. */
5040 for (i
= 1; i
< syms
.size (); i
++)
5041 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5042 SYMBOL_TYPE (syms
[0].symbol
)))
5048 /* Remove any non-debugging symbols in SYMS that definitely
5049 duplicate other symbols in the list (The only case I know of where
5050 this happens is when object files containing stabs-in-ecoff are
5051 linked with files containing ordinary ecoff debugging symbols (or no
5052 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5053 Returns the number of items in the modified list. */
5056 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5060 /* We should never be called with less than 2 symbols, as there
5061 cannot be any extra symbol in that case. But it's easy to
5062 handle, since we have nothing to do in that case. */
5063 if (syms
->size () < 2)
5064 return syms
->size ();
5067 while (i
< syms
->size ())
5071 /* If two symbols have the same name and one of them is a stub type,
5072 the get rid of the stub. */
5074 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
5075 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5077 for (j
= 0; j
< syms
->size (); j
++)
5080 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
5081 && (*syms
)[j
].symbol
->linkage_name () != NULL
5082 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5083 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5088 /* Two symbols with the same name, same class and same address
5089 should be identical. */
5091 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5092 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5093 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5095 for (j
= 0; j
< syms
->size (); j
+= 1)
5098 && (*syms
)[j
].symbol
->linkage_name () != NULL
5099 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5100 (*syms
)[j
].symbol
->linkage_name ()) == 0
5101 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5102 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5103 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5104 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5110 syms
->erase (syms
->begin () + i
);
5115 /* If all the remaining symbols are identical enumerals, then
5116 just keep the first one and discard the rest.
5118 Unlike what we did previously, we do not discard any entry
5119 unless they are ALL identical. This is because the symbol
5120 comparison is not a strict comparison, but rather a practical
5121 comparison. If all symbols are considered identical, then
5122 we can just go ahead and use the first one and discard the rest.
5123 But if we cannot reduce the list to a single element, we have
5124 to ask the user to disambiguate anyways. And if we have to
5125 present a multiple-choice menu, it's less confusing if the list
5126 isn't missing some choices that were identical and yet distinct. */
5127 if (symbols_are_identical_enums (*syms
))
5130 return syms
->size ();
5133 /* Given a type that corresponds to a renaming entity, use the type name
5134 to extract the scope (package name or function name, fully qualified,
5135 and following the GNAT encoding convention) where this renaming has been
5139 xget_renaming_scope (struct type
*renaming_type
)
5141 /* The renaming types adhere to the following convention:
5142 <scope>__<rename>___<XR extension>.
5143 So, to extract the scope, we search for the "___XR" extension,
5144 and then backtrack until we find the first "__". */
5146 const char *name
= renaming_type
->name ();
5147 const char *suffix
= strstr (name
, "___XR");
5150 /* Now, backtrack a bit until we find the first "__". Start looking
5151 at suffix - 3, as the <rename> part is at least one character long. */
5153 for (last
= suffix
- 3; last
> name
; last
--)
5154 if (last
[0] == '_' && last
[1] == '_')
5157 /* Make a copy of scope and return it. */
5158 return std::string (name
, last
);
5161 /* Return nonzero if NAME corresponds to a package name. */
5164 is_package_name (const char *name
)
5166 /* Here, We take advantage of the fact that no symbols are generated
5167 for packages, while symbols are generated for each function.
5168 So the condition for NAME represent a package becomes equivalent
5169 to NAME not existing in our list of symbols. There is only one
5170 small complication with library-level functions (see below). */
5172 /* If it is a function that has not been defined at library level,
5173 then we should be able to look it up in the symbols. */
5174 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5177 /* Library-level function names start with "_ada_". See if function
5178 "_ada_" followed by NAME can be found. */
5180 /* Do a quick check that NAME does not contain "__", since library-level
5181 functions names cannot contain "__" in them. */
5182 if (strstr (name
, "__") != NULL
)
5185 std::string fun_name
= string_printf ("_ada_%s", name
);
5187 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5190 /* Return nonzero if SYM corresponds to a renaming entity that is
5191 not visible from FUNCTION_NAME. */
5194 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5196 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5199 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5201 /* If the rename has been defined in a package, then it is visible. */
5202 if (is_package_name (scope
.c_str ()))
5205 /* Check that the rename is in the current function scope by checking
5206 that its name starts with SCOPE. */
5208 /* If the function name starts with "_ada_", it means that it is
5209 a library-level function. Strip this prefix before doing the
5210 comparison, as the encoding for the renaming does not contain
5212 if (startswith (function_name
, "_ada_"))
5215 return !startswith (function_name
, scope
.c_str ());
5218 /* Remove entries from SYMS that corresponds to a renaming entity that
5219 is not visible from the function associated with CURRENT_BLOCK or
5220 that is superfluous due to the presence of more specific renaming
5221 information. Places surviving symbols in the initial entries of
5222 SYMS and returns the number of surviving symbols.
5225 First, in cases where an object renaming is implemented as a
5226 reference variable, GNAT may produce both the actual reference
5227 variable and the renaming encoding. In this case, we discard the
5230 Second, GNAT emits a type following a specified encoding for each renaming
5231 entity. Unfortunately, STABS currently does not support the definition
5232 of types that are local to a given lexical block, so all renamings types
5233 are emitted at library level. As a consequence, if an application
5234 contains two renaming entities using the same name, and a user tries to
5235 print the value of one of these entities, the result of the ada symbol
5236 lookup will also contain the wrong renaming type.
5238 This function partially covers for this limitation by attempting to
5239 remove from the SYMS list renaming symbols that should be visible
5240 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5241 method with the current information available. The implementation
5242 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5244 - When the user tries to print a rename in a function while there
5245 is another rename entity defined in a package: Normally, the
5246 rename in the function has precedence over the rename in the
5247 package, so the latter should be removed from the list. This is
5248 currently not the case.
5250 - This function will incorrectly remove valid renames if
5251 the CURRENT_BLOCK corresponds to a function which symbol name
5252 has been changed by an "Export" pragma. As a consequence,
5253 the user will be unable to print such rename entities. */
5256 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5257 const struct block
*current_block
)
5259 struct symbol
*current_function
;
5260 const char *current_function_name
;
5262 int is_new_style_renaming
;
5264 /* If there is both a renaming foo___XR... encoded as a variable and
5265 a simple variable foo in the same block, discard the latter.
5266 First, zero out such symbols, then compress. */
5267 is_new_style_renaming
= 0;
5268 for (i
= 0; i
< syms
->size (); i
+= 1)
5270 struct symbol
*sym
= (*syms
)[i
].symbol
;
5271 const struct block
*block
= (*syms
)[i
].block
;
5275 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5277 name
= sym
->linkage_name ();
5278 suffix
= strstr (name
, "___XR");
5282 int name_len
= suffix
- name
;
5285 is_new_style_renaming
= 1;
5286 for (j
= 0; j
< syms
->size (); j
+= 1)
5287 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5288 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5290 && block
== (*syms
)[j
].block
)
5291 (*syms
)[j
].symbol
= NULL
;
5294 if (is_new_style_renaming
)
5298 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5299 if ((*syms
)[j
].symbol
!= NULL
)
5301 (*syms
)[k
] = (*syms
)[j
];
5307 /* Extract the function name associated to CURRENT_BLOCK.
5308 Abort if unable to do so. */
5310 if (current_block
== NULL
)
5311 return syms
->size ();
5313 current_function
= block_linkage_function (current_block
);
5314 if (current_function
== NULL
)
5315 return syms
->size ();
5317 current_function_name
= current_function
->linkage_name ();
5318 if (current_function_name
== NULL
)
5319 return syms
->size ();
5321 /* Check each of the symbols, and remove it from the list if it is
5322 a type corresponding to a renaming that is out of the scope of
5323 the current block. */
5326 while (i
< syms
->size ())
5328 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5329 == ADA_OBJECT_RENAMING
5330 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5331 current_function_name
))
5332 syms
->erase (syms
->begin () + i
);
5337 return syms
->size ();
5340 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5341 whose name and domain match NAME and DOMAIN respectively.
5342 If no match was found, then extend the search to "enclosing"
5343 routines (in other words, if we're inside a nested function,
5344 search the symbols defined inside the enclosing functions).
5345 If WILD_MATCH_P is nonzero, perform the naming matching in
5346 "wild" mode (see function "wild_match" for more info).
5348 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5351 ada_add_local_symbols (struct obstack
*obstackp
,
5352 const lookup_name_info
&lookup_name
,
5353 const struct block
*block
, domain_enum domain
)
5355 int block_depth
= 0;
5357 while (block
!= NULL
)
5360 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5362 /* If we found a non-function match, assume that's the one. */
5363 if (is_nonfunction (defns_collected (obstackp
, 0),
5364 num_defns_collected (obstackp
)))
5367 block
= BLOCK_SUPERBLOCK (block
);
5370 /* If no luck so far, try to find NAME as a local symbol in some lexically
5371 enclosing subprogram. */
5372 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5373 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5376 /* An object of this type is used as the user_data argument when
5377 calling the map_matching_symbols method. */
5381 struct objfile
*objfile
;
5382 struct obstack
*obstackp
;
5383 struct symbol
*arg_sym
;
5387 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5388 to a list of symbols. DATA is a pointer to a struct match_data *
5389 containing the obstack that collects the symbol list, the file that SYM
5390 must come from, a flag indicating whether a non-argument symbol has
5391 been found in the current block, and the last argument symbol
5392 passed in SYM within the current block (if any). When SYM is null,
5393 marking the end of a block, the argument symbol is added if no
5394 other has been found. */
5397 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5398 struct match_data
*data
)
5400 const struct block
*block
= bsym
->block
;
5401 struct symbol
*sym
= bsym
->symbol
;
5405 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5406 add_defn_to_vec (data
->obstackp
,
5407 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5409 data
->found_sym
= 0;
5410 data
->arg_sym
= NULL
;
5414 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5416 else if (SYMBOL_IS_ARGUMENT (sym
))
5417 data
->arg_sym
= sym
;
5420 data
->found_sym
= 1;
5421 add_defn_to_vec (data
->obstackp
,
5422 fixup_symbol_section (sym
, data
->objfile
),
5429 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5430 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5431 symbols to OBSTACKP. Return whether we found such symbols. */
5434 ada_add_block_renamings (struct obstack
*obstackp
,
5435 const struct block
*block
,
5436 const lookup_name_info
&lookup_name
,
5439 struct using_direct
*renaming
;
5440 int defns_mark
= num_defns_collected (obstackp
);
5442 symbol_name_matcher_ftype
*name_match
5443 = ada_get_symbol_name_matcher (lookup_name
);
5445 for (renaming
= block_using (block
);
5447 renaming
= renaming
->next
)
5451 /* Avoid infinite recursions: skip this renaming if we are actually
5452 already traversing it.
5454 Currently, symbol lookup in Ada don't use the namespace machinery from
5455 C++/Fortran support: skip namespace imports that use them. */
5456 if (renaming
->searched
5457 || (renaming
->import_src
!= NULL
5458 && renaming
->import_src
[0] != '\0')
5459 || (renaming
->import_dest
!= NULL
5460 && renaming
->import_dest
[0] != '\0'))
5462 renaming
->searched
= 1;
5464 /* TODO: here, we perform another name-based symbol lookup, which can
5465 pull its own multiple overloads. In theory, we should be able to do
5466 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5467 not a simple name. But in order to do this, we would need to enhance
5468 the DWARF reader to associate a symbol to this renaming, instead of a
5469 name. So, for now, we do something simpler: re-use the C++/Fortran
5470 namespace machinery. */
5471 r_name
= (renaming
->alias
!= NULL
5473 : renaming
->declaration
);
5474 if (name_match (r_name
, lookup_name
, NULL
))
5476 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5477 lookup_name
.match_type ());
5478 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5481 renaming
->searched
= 0;
5483 return num_defns_collected (obstackp
) != defns_mark
;
5486 /* Implements compare_names, but only applying the comparision using
5487 the given CASING. */
5490 compare_names_with_case (const char *string1
, const char *string2
,
5491 enum case_sensitivity casing
)
5493 while (*string1
!= '\0' && *string2
!= '\0')
5497 if (isspace (*string1
) || isspace (*string2
))
5498 return strcmp_iw_ordered (string1
, string2
);
5500 if (casing
== case_sensitive_off
)
5502 c1
= tolower (*string1
);
5503 c2
= tolower (*string2
);
5520 return strcmp_iw_ordered (string1
, string2
);
5522 if (*string2
== '\0')
5524 if (is_name_suffix (string1
))
5531 if (*string2
== '(')
5532 return strcmp_iw_ordered (string1
, string2
);
5535 if (casing
== case_sensitive_off
)
5536 return tolower (*string1
) - tolower (*string2
);
5538 return *string1
- *string2
;
5543 /* Compare STRING1 to STRING2, with results as for strcmp.
5544 Compatible with strcmp_iw_ordered in that...
5546 strcmp_iw_ordered (STRING1, STRING2) <= 0
5550 compare_names (STRING1, STRING2) <= 0
5552 (they may differ as to what symbols compare equal). */
5555 compare_names (const char *string1
, const char *string2
)
5559 /* Similar to what strcmp_iw_ordered does, we need to perform
5560 a case-insensitive comparison first, and only resort to
5561 a second, case-sensitive, comparison if the first one was
5562 not sufficient to differentiate the two strings. */
5564 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5566 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5571 /* Convenience function to get at the Ada encoded lookup name for
5572 LOOKUP_NAME, as a C string. */
5575 ada_lookup_name (const lookup_name_info
&lookup_name
)
5577 return lookup_name
.ada ().lookup_name ().c_str ();
5580 /* Add to OBSTACKP all non-local symbols whose name and domain match
5581 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5582 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5583 symbols otherwise. */
5586 add_nonlocal_symbols (struct obstack
*obstackp
,
5587 const lookup_name_info
&lookup_name
,
5588 domain_enum domain
, int global
)
5590 struct match_data data
;
5592 memset (&data
, 0, sizeof data
);
5593 data
.obstackp
= obstackp
;
5595 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5597 auto callback
= [&] (struct block_symbol
*bsym
)
5599 return aux_add_nonlocal_symbols (bsym
, &data
);
5602 for (objfile
*objfile
: current_program_space
->objfiles ())
5604 data
.objfile
= objfile
;
5606 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5607 domain
, global
, callback
,
5609 ? NULL
: compare_names
));
5611 for (compunit_symtab
*cu
: objfile
->compunits ())
5613 const struct block
*global_block
5614 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5616 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5622 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5624 const char *name
= ada_lookup_name (lookup_name
);
5625 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5626 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5628 for (objfile
*objfile
: current_program_space
->objfiles ())
5630 data
.objfile
= objfile
;
5631 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5632 domain
, global
, callback
,
5638 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5639 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5640 returning the number of matches. Add these to OBSTACKP.
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:
5649 "standard__" is first stripped off (by the lookup_name
5650 constructor), and only static and global symbols are searched.
5652 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5653 to lookup global symbols. */
5656 ada_add_all_symbols (struct obstack
*obstackp
,
5657 const struct block
*block
,
5658 const lookup_name_info
&lookup_name
,
5661 int *made_global_lookup_p
)
5665 if (made_global_lookup_p
)
5666 *made_global_lookup_p
= 0;
5668 /* Special case: If the user specifies a symbol name inside package
5669 Standard, do a non-wild matching of the symbol name without
5670 the "standard__" prefix. This was primarily introduced in order
5671 to allow the user to specifically access the standard exceptions
5672 using, for instance, Standard.Constraint_Error when Constraint_Error
5673 is ambiguous (due to the user defining its own Constraint_Error
5674 entity inside its program). */
5675 if (lookup_name
.ada ().standard_p ())
5678 /* Check the non-global symbols. If we have ANY match, then we're done. */
5683 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5686 /* In the !full_search case we're are being called by
5687 iterate_over_symbols, and we don't want to search
5689 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5691 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5695 /* No non-global symbols found. Check our cache to see if we have
5696 already performed this search before. If we have, then return
5699 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5700 domain
, &sym
, &block
))
5703 add_defn_to_vec (obstackp
, sym
, block
);
5707 if (made_global_lookup_p
)
5708 *made_global_lookup_p
= 1;
5710 /* Search symbols from all global blocks. */
5712 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5714 /* Now add symbols from all per-file blocks if we've gotten no hits
5715 (not strictly correct, but perhaps better than an error). */
5717 if (num_defns_collected (obstackp
) == 0)
5718 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5721 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5722 is non-zero, enclosing scope and in global scopes, returning the number of
5724 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5725 found and the blocks and symbol tables (if any) in which they were
5728 When full_search is non-zero, any non-function/non-enumeral
5729 symbol match within the nest of blocks whose innermost member is BLOCK,
5730 is the one match returned (no other matches in that or
5731 enclosing blocks is returned). If there are any matches in or
5732 surrounding BLOCK, then these alone are returned.
5734 Names prefixed with "standard__" are handled specially: "standard__"
5735 is first stripped off, and only static and global symbols are searched. */
5738 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5739 const struct block
*block
,
5741 std::vector
<struct block_symbol
> *results
,
5744 int syms_from_global_search
;
5746 auto_obstack obstack
;
5748 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5749 domain
, full_search
, &syms_from_global_search
);
5751 ndefns
= num_defns_collected (&obstack
);
5753 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5754 for (int i
= 0; i
< ndefns
; ++i
)
5755 results
->push_back (base
[i
]);
5757 ndefns
= remove_extra_symbols (results
);
5759 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5760 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5762 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5763 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5764 (*results
)[0].symbol
, (*results
)[0].block
);
5766 ndefns
= remove_irrelevant_renamings (results
, block
);
5771 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5772 in global scopes, returning the number of matches, and filling *RESULTS
5773 with (SYM,BLOCK) tuples.
5775 See ada_lookup_symbol_list_worker for further details. */
5778 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5780 std::vector
<struct block_symbol
> *results
)
5782 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5783 lookup_name_info
lookup_name (name
, name_match_type
);
5785 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5788 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5789 to 1, but choosing the first symbol found if there are multiple
5792 The result is stored in *INFO, which must be non-NULL.
5793 If no match is found, INFO->SYM is set to NULL. */
5796 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5798 struct block_symbol
*info
)
5800 /* Since we already have an encoded name, wrap it in '<>' to force a
5801 verbatim match. Otherwise, if the name happens to not look like
5802 an encoded name (because it doesn't include a "__"),
5803 ada_lookup_name_info would re-encode/fold it again, and that
5804 would e.g., incorrectly lowercase object renaming names like
5805 "R28b" -> "r28b". */
5806 std::string verbatim
= std::string ("<") + name
+ '>';
5808 gdb_assert (info
!= NULL
);
5809 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5812 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5813 scope and in global scopes, or NULL if none. NAME is folded and
5814 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5815 choosing the first symbol if there are multiple choices. */
5818 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5821 std::vector
<struct block_symbol
> candidates
;
5824 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5826 if (n_candidates
== 0)
5829 block_symbol info
= candidates
[0];
5830 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5835 /* True iff STR is a possible encoded suffix of a normal Ada name
5836 that is to be ignored for matching purposes. Suffixes of parallel
5837 names (e.g., XVE) are not included here. Currently, the possible suffixes
5838 are given by any of the regular expressions:
5840 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5841 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5842 TKB [subprogram suffix for task bodies]
5843 _E[0-9]+[bs]$ [protected object entry suffixes]
5844 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5846 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5847 match is performed. This sequence is used to differentiate homonyms,
5848 is an optional part of a valid name suffix. */
5851 is_name_suffix (const char *str
)
5854 const char *matching
;
5855 const int len
= strlen (str
);
5857 /* Skip optional leading __[0-9]+. */
5859 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5862 while (isdigit (str
[0]))
5868 if (str
[0] == '.' || str
[0] == '$')
5871 while (isdigit (matching
[0]))
5873 if (matching
[0] == '\0')
5879 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5882 while (isdigit (matching
[0]))
5884 if (matching
[0] == '\0')
5888 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5890 if (strcmp (str
, "TKB") == 0)
5894 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5895 with a N at the end. Unfortunately, the compiler uses the same
5896 convention for other internal types it creates. So treating
5897 all entity names that end with an "N" as a name suffix causes
5898 some regressions. For instance, consider the case of an enumerated
5899 type. To support the 'Image attribute, it creates an array whose
5901 Having a single character like this as a suffix carrying some
5902 information is a bit risky. Perhaps we should change the encoding
5903 to be something like "_N" instead. In the meantime, do not do
5904 the following check. */
5905 /* Protected Object Subprograms */
5906 if (len
== 1 && str
[0] == 'N')
5911 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5914 while (isdigit (matching
[0]))
5916 if ((matching
[0] == 'b' || matching
[0] == 's')
5917 && matching
[1] == '\0')
5921 /* ??? We should not modify STR directly, as we are doing below. This
5922 is fine in this case, but may become problematic later if we find
5923 that this alternative did not work, and want to try matching
5924 another one from the begining of STR. Since we modified it, we
5925 won't be able to find the begining of the string anymore! */
5929 while (str
[0] != '_' && str
[0] != '\0')
5931 if (str
[0] != 'n' && str
[0] != 'b')
5937 if (str
[0] == '\000')
5942 if (str
[1] != '_' || str
[2] == '\000')
5946 if (strcmp (str
+ 3, "JM") == 0)
5948 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5949 the LJM suffix in favor of the JM one. But we will
5950 still accept LJM as a valid suffix for a reasonable
5951 amount of time, just to allow ourselves to debug programs
5952 compiled using an older version of GNAT. */
5953 if (strcmp (str
+ 3, "LJM") == 0)
5957 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5958 || str
[4] == 'U' || str
[4] == 'P')
5960 if (str
[4] == 'R' && str
[5] != 'T')
5964 if (!isdigit (str
[2]))
5966 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5967 if (!isdigit (str
[k
]) && str
[k
] != '_')
5971 if (str
[0] == '$' && isdigit (str
[1]))
5973 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5974 if (!isdigit (str
[k
]) && str
[k
] != '_')
5981 /* Return non-zero if the string starting at NAME and ending before
5982 NAME_END contains no capital letters. */
5985 is_valid_name_for_wild_match (const char *name0
)
5987 std::string decoded_name
= ada_decode (name0
);
5990 /* If the decoded name starts with an angle bracket, it means that
5991 NAME0 does not follow the GNAT encoding format. It should then
5992 not be allowed as a possible wild match. */
5993 if (decoded_name
[0] == '<')
5996 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5997 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6003 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
6004 character which could start a simple name. Assumes that *NAMEP points
6005 somewhere inside the string beginning at NAME0. */
6008 advance_wild_match (const char **namep
, const char *name0
, char target0
)
6010 const char *name
= *namep
;
6020 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6023 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6028 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6029 || name
[2] == target0
))
6037 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6047 /* Return true iff NAME encodes a name of the form prefix.PATN.
6048 Ignores any informational suffixes of NAME (i.e., for which
6049 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6053 wild_match (const char *name
, const char *patn
)
6056 const char *name0
= name
;
6060 const char *match
= name
;
6064 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6067 if (*p
== '\0' && is_name_suffix (name
))
6068 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6070 if (name
[-1] == '_')
6073 if (!advance_wild_match (&name
, name0
, *patn
))
6078 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6079 any trailing suffixes that encode debugging information or leading
6080 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6081 information that is ignored). */
6084 full_match (const char *sym_name
, const char *search_name
)
6086 size_t search_name_len
= strlen (search_name
);
6088 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6089 && is_name_suffix (sym_name
+ search_name_len
))
6092 if (startswith (sym_name
, "_ada_")
6093 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6094 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6100 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6101 *defn_symbols, updating the list of symbols in OBSTACKP (if
6102 necessary). OBJFILE is the section containing BLOCK. */
6105 ada_add_block_symbols (struct obstack
*obstackp
,
6106 const struct block
*block
,
6107 const lookup_name_info
&lookup_name
,
6108 domain_enum domain
, struct objfile
*objfile
)
6110 struct block_iterator iter
;
6111 /* A matching argument symbol, if any. */
6112 struct symbol
*arg_sym
;
6113 /* Set true when we find a matching non-argument symbol. */
6119 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6121 sym
= block_iter_match_next (lookup_name
, &iter
))
6123 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6125 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6127 if (SYMBOL_IS_ARGUMENT (sym
))
6132 add_defn_to_vec (obstackp
,
6133 fixup_symbol_section (sym
, objfile
),
6140 /* Handle renamings. */
6142 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6145 if (!found_sym
&& arg_sym
!= NULL
)
6147 add_defn_to_vec (obstackp
,
6148 fixup_symbol_section (arg_sym
, objfile
),
6152 if (!lookup_name
.ada ().wild_match_p ())
6156 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6157 const char *name
= ada_lookup_name
.c_str ();
6158 size_t name_len
= ada_lookup_name
.size ();
6160 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6162 if (symbol_matches_domain (sym
->language (),
6163 SYMBOL_DOMAIN (sym
), domain
))
6167 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6170 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6172 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6177 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6179 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6181 if (SYMBOL_IS_ARGUMENT (sym
))
6186 add_defn_to_vec (obstackp
,
6187 fixup_symbol_section (sym
, objfile
),
6195 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6196 They aren't parameters, right? */
6197 if (!found_sym
&& arg_sym
!= NULL
)
6199 add_defn_to_vec (obstackp
,
6200 fixup_symbol_section (arg_sym
, objfile
),
6207 /* Symbol Completion */
6212 ada_lookup_name_info::matches
6213 (const char *sym_name
,
6214 symbol_name_match_type match_type
,
6215 completion_match_result
*comp_match_res
) const
6218 const char *text
= m_encoded_name
.c_str ();
6219 size_t text_len
= m_encoded_name
.size ();
6221 /* First, test against the fully qualified name of the symbol. */
6223 if (strncmp (sym_name
, text
, text_len
) == 0)
6226 std::string decoded_name
= ada_decode (sym_name
);
6227 if (match
&& !m_encoded_p
)
6229 /* One needed check before declaring a positive match is to verify
6230 that iff we are doing a verbatim match, the decoded version
6231 of the symbol name starts with '<'. Otherwise, this symbol name
6232 is not a suitable completion. */
6234 bool has_angle_bracket
= (decoded_name
[0] == '<');
6235 match
= (has_angle_bracket
== m_verbatim_p
);
6238 if (match
&& !m_verbatim_p
)
6240 /* When doing non-verbatim match, another check that needs to
6241 be done is to verify that the potentially matching symbol name
6242 does not include capital letters, because the ada-mode would
6243 not be able to understand these symbol names without the
6244 angle bracket notation. */
6247 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6252 /* Second: Try wild matching... */
6254 if (!match
&& m_wild_match_p
)
6256 /* Since we are doing wild matching, this means that TEXT
6257 may represent an unqualified symbol name. We therefore must
6258 also compare TEXT against the unqualified name of the symbol. */
6259 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6261 if (strncmp (sym_name
, text
, text_len
) == 0)
6265 /* Finally: If we found a match, prepare the result to return. */
6270 if (comp_match_res
!= NULL
)
6272 std::string
&match_str
= comp_match_res
->match
.storage ();
6275 match_str
= ada_decode (sym_name
);
6279 match_str
= add_angle_brackets (sym_name
);
6281 match_str
= sym_name
;
6285 comp_match_res
->set_match (match_str
.c_str ());
6293 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6294 for tagged types. */
6297 ada_is_dispatch_table_ptr_type (struct type
*type
)
6301 if (type
->code () != TYPE_CODE_PTR
)
6304 name
= TYPE_TARGET_TYPE (type
)->name ();
6308 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6311 /* Return non-zero if TYPE is an interface tag. */
6314 ada_is_interface_tag (struct type
*type
)
6316 const char *name
= type
->name ();
6321 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6324 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6325 to be invisible to users. */
6328 ada_is_ignored_field (struct type
*type
, int field_num
)
6330 if (field_num
< 0 || field_num
> type
->num_fields ())
6333 /* Check the name of that field. */
6335 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6337 /* Anonymous field names should not be printed.
6338 brobecker/2007-02-20: I don't think this can actually happen
6339 but we don't want to print the value of anonymous fields anyway. */
6343 /* Normally, fields whose name start with an underscore ("_")
6344 are fields that have been internally generated by the compiler,
6345 and thus should not be printed. The "_parent" field is special,
6346 however: This is a field internally generated by the compiler
6347 for tagged types, and it contains the components inherited from
6348 the parent type. This field should not be printed as is, but
6349 should not be ignored either. */
6350 if (name
[0] == '_' && !startswith (name
, "_parent"))
6354 /* If this is the dispatch table of a tagged type or an interface tag,
6356 if (ada_is_tagged_type (type
, 1)
6357 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6358 || ada_is_interface_tag (type
->field (field_num
).type ())))
6361 /* Not a special field, so it should not be ignored. */
6365 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6366 pointer or reference type whose ultimate target has a tag field. */
6369 ada_is_tagged_type (struct type
*type
, int refok
)
6371 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6374 /* True iff TYPE represents the type of X'Tag */
6377 ada_is_tag_type (struct type
*type
)
6379 type
= ada_check_typedef (type
);
6381 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6385 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6387 return (name
!= NULL
6388 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6392 /* The type of the tag on VAL. */
6394 static struct type
*
6395 ada_tag_type (struct value
*val
)
6397 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6400 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6401 retired at Ada 05). */
6404 is_ada95_tag (struct value
*tag
)
6406 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6409 /* The value of the tag on VAL. */
6411 static struct value
*
6412 ada_value_tag (struct value
*val
)
6414 return ada_value_struct_elt (val
, "_tag", 0);
6417 /* The value of the tag on the object of type TYPE whose contents are
6418 saved at VALADDR, if it is non-null, or is at memory address
6421 static struct value
*
6422 value_tag_from_contents_and_address (struct type
*type
,
6423 const gdb_byte
*valaddr
,
6426 int tag_byte_offset
;
6427 struct type
*tag_type
;
6429 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6432 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6434 : valaddr
+ tag_byte_offset
);
6435 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6437 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6442 static struct type
*
6443 type_from_tag (struct value
*tag
)
6445 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6447 if (type_name
!= NULL
)
6448 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6452 /* Given a value OBJ of a tagged type, return a value of this
6453 type at the base address of the object. The base address, as
6454 defined in Ada.Tags, it is the address of the primary tag of
6455 the object, and therefore where the field values of its full
6456 view can be fetched. */
6459 ada_tag_value_at_base_address (struct value
*obj
)
6462 LONGEST offset_to_top
= 0;
6463 struct type
*ptr_type
, *obj_type
;
6465 CORE_ADDR base_address
;
6467 obj_type
= value_type (obj
);
6469 /* It is the responsability of the caller to deref pointers. */
6471 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6474 tag
= ada_value_tag (obj
);
6478 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6480 if (is_ada95_tag (tag
))
6483 ptr_type
= language_lookup_primitive_type
6484 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6485 ptr_type
= lookup_pointer_type (ptr_type
);
6486 val
= value_cast (ptr_type
, tag
);
6490 /* It is perfectly possible that an exception be raised while
6491 trying to determine the base address, just like for the tag;
6492 see ada_tag_name for more details. We do not print the error
6493 message for the same reason. */
6497 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6500 catch (const gdb_exception_error
&e
)
6505 /* If offset is null, nothing to do. */
6507 if (offset_to_top
== 0)
6510 /* -1 is a special case in Ada.Tags; however, what should be done
6511 is not quite clear from the documentation. So do nothing for
6514 if (offset_to_top
== -1)
6517 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6518 from the base address. This was however incompatible with
6519 C++ dispatch table: C++ uses a *negative* value to *add*
6520 to the base address. Ada's convention has therefore been
6521 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6522 use the same convention. Here, we support both cases by
6523 checking the sign of OFFSET_TO_TOP. */
6525 if (offset_to_top
> 0)
6526 offset_to_top
= -offset_to_top
;
6528 base_address
= value_address (obj
) + offset_to_top
;
6529 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6531 /* Make sure that we have a proper tag at the new address.
6532 Otherwise, offset_to_top is bogus (which can happen when
6533 the object is not initialized yet). */
6538 obj_type
= type_from_tag (tag
);
6543 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6546 /* Return the "ada__tags__type_specific_data" type. */
6548 static struct type
*
6549 ada_get_tsd_type (struct inferior
*inf
)
6551 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6553 if (data
->tsd_type
== 0)
6554 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6555 return data
->tsd_type
;
6558 /* Return the TSD (type-specific data) associated to the given TAG.
6559 TAG is assumed to be the tag of a tagged-type entity.
6561 May return NULL if we are unable to get the TSD. */
6563 static struct value
*
6564 ada_get_tsd_from_tag (struct value
*tag
)
6569 /* First option: The TSD is simply stored as a field of our TAG.
6570 Only older versions of GNAT would use this format, but we have
6571 to test it first, because there are no visible markers for
6572 the current approach except the absence of that field. */
6574 val
= ada_value_struct_elt (tag
, "tsd", 1);
6578 /* Try the second representation for the dispatch table (in which
6579 there is no explicit 'tsd' field in the referent of the tag pointer,
6580 and instead the tsd pointer is stored just before the dispatch
6583 type
= ada_get_tsd_type (current_inferior());
6586 type
= lookup_pointer_type (lookup_pointer_type (type
));
6587 val
= value_cast (type
, tag
);
6590 return value_ind (value_ptradd (val
, -1));
6593 /* Given the TSD of a tag (type-specific data), return a string
6594 containing the name of the associated type.
6596 May return NULL if we are unable to determine the tag name. */
6598 static gdb::unique_xmalloc_ptr
<char>
6599 ada_tag_name_from_tsd (struct value
*tsd
)
6604 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6607 gdb::unique_xmalloc_ptr
<char> buffer
6608 = target_read_string (value_as_address (val
), INT_MAX
);
6609 if (buffer
== nullptr)
6612 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6621 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6624 Return NULL if the TAG is not an Ada tag, or if we were unable to
6625 determine the name of that tag. */
6627 gdb::unique_xmalloc_ptr
<char>
6628 ada_tag_name (struct value
*tag
)
6630 gdb::unique_xmalloc_ptr
<char> name
;
6632 if (!ada_is_tag_type (value_type (tag
)))
6635 /* It is perfectly possible that an exception be raised while trying
6636 to determine the TAG's name, even under normal circumstances:
6637 The associated variable may be uninitialized or corrupted, for
6638 instance. We do not let any exception propagate past this point.
6639 instead we return NULL.
6641 We also do not print the error message either (which often is very
6642 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6643 the caller print a more meaningful message if necessary. */
6646 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6649 name
= ada_tag_name_from_tsd (tsd
);
6651 catch (const gdb_exception_error
&e
)
6658 /* The parent type of TYPE, or NULL if none. */
6661 ada_parent_type (struct type
*type
)
6665 type
= ada_check_typedef (type
);
6667 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6670 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6671 if (ada_is_parent_field (type
, i
))
6673 struct type
*parent_type
= type
->field (i
).type ();
6675 /* If the _parent field is a pointer, then dereference it. */
6676 if (parent_type
->code () == TYPE_CODE_PTR
)
6677 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6678 /* If there is a parallel XVS type, get the actual base type. */
6679 parent_type
= ada_get_base_type (parent_type
);
6681 return ada_check_typedef (parent_type
);
6687 /* True iff field number FIELD_NUM of structure type TYPE contains the
6688 parent-type (inherited) fields of a derived type. Assumes TYPE is
6689 a structure type with at least FIELD_NUM+1 fields. */
6692 ada_is_parent_field (struct type
*type
, int field_num
)
6694 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6696 return (name
!= NULL
6697 && (startswith (name
, "PARENT")
6698 || startswith (name
, "_parent")));
6701 /* True iff field number FIELD_NUM of structure type TYPE is a
6702 transparent wrapper field (which should be silently traversed when doing
6703 field selection and flattened when printing). Assumes TYPE is a
6704 structure type with at least FIELD_NUM+1 fields. Such fields are always
6708 ada_is_wrapper_field (struct type
*type
, int field_num
)
6710 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6712 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6714 /* This happens in functions with "out" or "in out" parameters
6715 which are passed by copy. For such functions, GNAT describes
6716 the function's return type as being a struct where the return
6717 value is in a field called RETVAL, and where the other "out"
6718 or "in out" parameters are fields of that struct. This is not
6723 return (name
!= NULL
6724 && (startswith (name
, "PARENT")
6725 || strcmp (name
, "REP") == 0
6726 || startswith (name
, "_parent")
6727 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6730 /* True iff field number FIELD_NUM of structure or union type TYPE
6731 is a variant wrapper. Assumes TYPE is a structure type with at least
6732 FIELD_NUM+1 fields. */
6735 ada_is_variant_part (struct type
*type
, int field_num
)
6737 /* Only Ada types are eligible. */
6738 if (!ADA_TYPE_P (type
))
6741 struct type
*field_type
= type
->field (field_num
).type ();
6743 return (field_type
->code () == TYPE_CODE_UNION
6744 || (is_dynamic_field (type
, field_num
)
6745 && (TYPE_TARGET_TYPE (field_type
)->code ()
6746 == TYPE_CODE_UNION
)));
6749 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6750 whose discriminants are contained in the record type OUTER_TYPE,
6751 returns the type of the controlling discriminant for the variant.
6752 May return NULL if the type could not be found. */
6755 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6757 const char *name
= ada_variant_discrim_name (var_type
);
6759 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6762 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6763 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6764 represents a 'when others' clause; otherwise 0. */
6767 ada_is_others_clause (struct type
*type
, int field_num
)
6769 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6771 return (name
!= NULL
&& name
[0] == 'O');
6774 /* Assuming that TYPE0 is the type of the variant part of a record,
6775 returns the name of the discriminant controlling the variant.
6776 The value is valid until the next call to ada_variant_discrim_name. */
6779 ada_variant_discrim_name (struct type
*type0
)
6781 static char *result
= NULL
;
6782 static size_t result_len
= 0;
6785 const char *discrim_end
;
6786 const char *discrim_start
;
6788 if (type0
->code () == TYPE_CODE_PTR
)
6789 type
= TYPE_TARGET_TYPE (type0
);
6793 name
= ada_type_name (type
);
6795 if (name
== NULL
|| name
[0] == '\000')
6798 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6801 if (startswith (discrim_end
, "___XVN"))
6804 if (discrim_end
== name
)
6807 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6810 if (discrim_start
== name
+ 1)
6812 if ((discrim_start
> name
+ 3
6813 && startswith (discrim_start
- 3, "___"))
6814 || discrim_start
[-1] == '.')
6818 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6819 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6820 result
[discrim_end
- discrim_start
] = '\0';
6824 /* Scan STR for a subtype-encoded number, beginning at position K.
6825 Put the position of the character just past the number scanned in
6826 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6827 Return 1 if there was a valid number at the given position, and 0
6828 otherwise. A "subtype-encoded" number consists of the absolute value
6829 in decimal, followed by the letter 'm' to indicate a negative number.
6830 Assumes 0m does not occur. */
6833 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6837 if (!isdigit (str
[k
]))
6840 /* Do it the hard way so as not to make any assumption about
6841 the relationship of unsigned long (%lu scan format code) and
6844 while (isdigit (str
[k
]))
6846 RU
= RU
* 10 + (str
[k
] - '0');
6853 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6859 /* NOTE on the above: Technically, C does not say what the results of
6860 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6861 number representable as a LONGEST (although either would probably work
6862 in most implementations). When RU>0, the locution in the then branch
6863 above is always equivalent to the negative of RU. */
6870 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6871 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6872 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6875 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6877 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6891 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6901 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6902 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6904 if (val
>= L
&& val
<= U
)
6916 /* FIXME: Lots of redundancy below. Try to consolidate. */
6918 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6919 ARG_TYPE, extract and return the value of one of its (non-static)
6920 fields. FIELDNO says which field. Differs from value_primitive_field
6921 only in that it can handle packed values of arbitrary type. */
6924 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6925 struct type
*arg_type
)
6929 arg_type
= ada_check_typedef (arg_type
);
6930 type
= arg_type
->field (fieldno
).type ();
6932 /* Handle packed fields. It might be that the field is not packed
6933 relative to its containing structure, but the structure itself is
6934 packed; in this case we must take the bit-field path. */
6935 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6937 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6938 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6940 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6941 offset
+ bit_pos
/ 8,
6942 bit_pos
% 8, bit_size
, type
);
6945 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6948 /* Find field with name NAME in object of type TYPE. If found,
6949 set the following for each argument that is non-null:
6950 - *FIELD_TYPE_P to the field's type;
6951 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6952 an object of that type;
6953 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6954 - *BIT_SIZE_P to its size in bits if the field is packed, and
6956 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6957 fields up to but not including the desired field, or by the total
6958 number of fields if not found. A NULL value of NAME never
6959 matches; the function just counts visible fields in this case.
6961 Notice that we need to handle when a tagged record hierarchy
6962 has some components with the same name, like in this scenario:
6964 type Top_T is tagged record
6970 type Middle_T is new Top.Top_T with record
6971 N : Character := 'a';
6975 type Bottom_T is new Middle.Middle_T with record
6977 C : Character := '5';
6979 A : Character := 'J';
6982 Let's say we now have a variable declared and initialized as follow:
6984 TC : Top_A := new Bottom_T;
6986 And then we use this variable to call this function
6988 procedure Assign (Obj: in out Top_T; TV : Integer);
6992 Assign (Top_T (B), 12);
6994 Now, we're in the debugger, and we're inside that procedure
6995 then and we want to print the value of obj.c:
6997 Usually, the tagged record or one of the parent type owns the
6998 component to print and there's no issue but in this particular
6999 case, what does it mean to ask for Obj.C? Since the actual
7000 type for object is type Bottom_T, it could mean two things: type
7001 component C from the Middle_T view, but also component C from
7002 Bottom_T. So in that "undefined" case, when the component is
7003 not found in the non-resolved type (which includes all the
7004 components of the parent type), then resolve it and see if we
7005 get better luck once expanded.
7007 In the case of homonyms in the derived tagged type, we don't
7008 guaranty anything, and pick the one that's easiest for us
7011 Returns 1 if found, 0 otherwise. */
7014 find_struct_field (const char *name
, struct type
*type
, int offset
,
7015 struct type
**field_type_p
,
7016 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7020 int parent_offset
= -1;
7022 type
= ada_check_typedef (type
);
7024 if (field_type_p
!= NULL
)
7025 *field_type_p
= NULL
;
7026 if (byte_offset_p
!= NULL
)
7028 if (bit_offset_p
!= NULL
)
7030 if (bit_size_p
!= NULL
)
7033 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7035 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7036 int fld_offset
= offset
+ bit_pos
/ 8;
7037 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7039 if (t_field_name
== NULL
)
7042 else if (ada_is_parent_field (type
, i
))
7044 /* This is a field pointing us to the parent type of a tagged
7045 type. As hinted in this function's documentation, we give
7046 preference to fields in the current record first, so what
7047 we do here is just record the index of this field before
7048 we skip it. If it turns out we couldn't find our field
7049 in the current record, then we'll get back to it and search
7050 inside it whether the field might exist in the parent. */
7056 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7058 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7060 if (field_type_p
!= NULL
)
7061 *field_type_p
= type
->field (i
).type ();
7062 if (byte_offset_p
!= NULL
)
7063 *byte_offset_p
= fld_offset
;
7064 if (bit_offset_p
!= NULL
)
7065 *bit_offset_p
= bit_pos
% 8;
7066 if (bit_size_p
!= NULL
)
7067 *bit_size_p
= bit_size
;
7070 else if (ada_is_wrapper_field (type
, i
))
7072 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7073 field_type_p
, byte_offset_p
, bit_offset_p
,
7074 bit_size_p
, index_p
))
7077 else if (ada_is_variant_part (type
, i
))
7079 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7082 struct type
*field_type
7083 = ada_check_typedef (type
->field (i
).type ());
7085 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7087 if (find_struct_field (name
, field_type
->field (j
).type (),
7089 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7090 field_type_p
, byte_offset_p
,
7091 bit_offset_p
, bit_size_p
, index_p
))
7095 else if (index_p
!= NULL
)
7099 /* Field not found so far. If this is a tagged type which
7100 has a parent, try finding that field in the parent now. */
7102 if (parent_offset
!= -1)
7104 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7105 int fld_offset
= offset
+ bit_pos
/ 8;
7107 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7108 fld_offset
, field_type_p
, byte_offset_p
,
7109 bit_offset_p
, bit_size_p
, index_p
))
7116 /* Number of user-visible fields in record type TYPE. */
7119 num_visible_fields (struct type
*type
)
7124 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7128 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7129 and search in it assuming it has (class) type TYPE.
7130 If found, return value, else return NULL.
7132 Searches recursively through wrapper fields (e.g., '_parent').
7134 In the case of homonyms in the tagged types, please refer to the
7135 long explanation in find_struct_field's function documentation. */
7137 static struct value
*
7138 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7142 int parent_offset
= -1;
7144 type
= ada_check_typedef (type
);
7145 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7147 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7149 if (t_field_name
== NULL
)
7152 else if (ada_is_parent_field (type
, i
))
7154 /* This is a field pointing us to the parent type of a tagged
7155 type. As hinted in this function's documentation, we give
7156 preference to fields in the current record first, so what
7157 we do here is just record the index of this field before
7158 we skip it. If it turns out we couldn't find our field
7159 in the current record, then we'll get back to it and search
7160 inside it whether the field might exist in the parent. */
7166 else if (field_name_match (t_field_name
, name
))
7167 return ada_value_primitive_field (arg
, offset
, i
, type
);
7169 else if (ada_is_wrapper_field (type
, i
))
7171 struct value
*v
= /* Do not let indent join lines here. */
7172 ada_search_struct_field (name
, arg
,
7173 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7174 type
->field (i
).type ());
7180 else if (ada_is_variant_part (type
, i
))
7182 /* PNH: Do we ever get here? See find_struct_field. */
7184 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7185 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7187 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7189 struct value
*v
= ada_search_struct_field
/* Force line
7192 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7193 field_type
->field (j
).type ());
7201 /* Field not found so far. If this is a tagged type which
7202 has a parent, try finding that field in the parent now. */
7204 if (parent_offset
!= -1)
7206 struct value
*v
= ada_search_struct_field (
7207 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7208 type
->field (parent_offset
).type ());
7217 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7218 int, struct type
*);
7221 /* Return field #INDEX in ARG, where the index is that returned by
7222 * find_struct_field through its INDEX_P argument. Adjust the address
7223 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7224 * If found, return value, else return NULL. */
7226 static struct value
*
7227 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7230 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7234 /* Auxiliary function for ada_index_struct_field. Like
7235 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7238 static struct value
*
7239 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7243 type
= ada_check_typedef (type
);
7245 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7247 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7249 else if (ada_is_wrapper_field (type
, i
))
7251 struct value
*v
= /* Do not let indent join lines here. */
7252 ada_index_struct_field_1 (index_p
, arg
,
7253 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7254 type
->field (i
).type ());
7260 else if (ada_is_variant_part (type
, i
))
7262 /* PNH: Do we ever get here? See ada_search_struct_field,
7263 find_struct_field. */
7264 error (_("Cannot assign this kind of variant record"));
7266 else if (*index_p
== 0)
7267 return ada_value_primitive_field (arg
, offset
, i
, type
);
7274 /* Return a string representation of type TYPE. */
7277 type_as_string (struct type
*type
)
7279 string_file tmp_stream
;
7281 type_print (type
, "", &tmp_stream
, -1);
7283 return std::move (tmp_stream
.string ());
7286 /* Given a type TYPE, look up the type of the component of type named NAME.
7287 If DISPP is non-null, add its byte displacement from the beginning of a
7288 structure (pointed to by a value) of type TYPE to *DISPP (does not
7289 work for packed fields).
7291 Matches any field whose name has NAME as a prefix, possibly
7294 TYPE can be either a struct or union. If REFOK, TYPE may also
7295 be a (pointer or reference)+ to a struct or union, and the
7296 ultimate target type will be searched.
7298 Looks recursively into variant clauses and parent types.
7300 In the case of homonyms in the tagged types, please refer to the
7301 long explanation in find_struct_field's function documentation.
7303 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7304 TYPE is not a type of the right kind. */
7306 static struct type
*
7307 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7311 int parent_offset
= -1;
7316 if (refok
&& type
!= NULL
)
7319 type
= ada_check_typedef (type
);
7320 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7322 type
= TYPE_TARGET_TYPE (type
);
7326 || (type
->code () != TYPE_CODE_STRUCT
7327 && type
->code () != TYPE_CODE_UNION
))
7332 error (_("Type %s is not a structure or union type"),
7333 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7336 type
= to_static_fixed_type (type
);
7338 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7340 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7343 if (t_field_name
== NULL
)
7346 else if (ada_is_parent_field (type
, i
))
7348 /* This is a field pointing us to the parent type of a tagged
7349 type. As hinted in this function's documentation, we give
7350 preference to fields in the current record first, so what
7351 we do here is just record the index of this field before
7352 we skip it. If it turns out we couldn't find our field
7353 in the current record, then we'll get back to it and search
7354 inside it whether the field might exist in the parent. */
7360 else if (field_name_match (t_field_name
, name
))
7361 return type
->field (i
).type ();
7363 else if (ada_is_wrapper_field (type
, i
))
7365 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7371 else if (ada_is_variant_part (type
, i
))
7374 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7376 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7378 /* FIXME pnh 2008/01/26: We check for a field that is
7379 NOT wrapped in a struct, since the compiler sometimes
7380 generates these for unchecked variant types. Revisit
7381 if the compiler changes this practice. */
7382 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7384 if (v_field_name
!= NULL
7385 && field_name_match (v_field_name
, name
))
7386 t
= field_type
->field (j
).type ();
7388 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7398 /* Field not found so far. If this is a tagged type which
7399 has a parent, try finding that field in the parent now. */
7401 if (parent_offset
!= -1)
7405 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7414 const char *name_str
= name
!= NULL
? name
: _("<null>");
7416 error (_("Type %s has no component named %s"),
7417 type_as_string (type
).c_str (), name_str
);
7423 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7424 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7425 represents an unchecked union (that is, the variant part of a
7426 record that is named in an Unchecked_Union pragma). */
7429 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7431 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7433 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7437 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7438 within OUTER, determine which variant clause (field number in VAR_TYPE,
7439 numbering from 0) is applicable. Returns -1 if none are. */
7442 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7446 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7447 struct value
*discrim
;
7448 LONGEST discrim_val
;
7450 /* Using plain value_from_contents_and_address here causes problems
7451 because we will end up trying to resolve a type that is currently
7452 being constructed. */
7453 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7454 if (discrim
== NULL
)
7456 discrim_val
= value_as_long (discrim
);
7459 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7461 if (ada_is_others_clause (var_type
, i
))
7463 else if (ada_in_variant (discrim_val
, var_type
, i
))
7467 return others_clause
;
7472 /* Dynamic-Sized Records */
7474 /* Strategy: The type ostensibly attached to a value with dynamic size
7475 (i.e., a size that is not statically recorded in the debugging
7476 data) does not accurately reflect the size or layout of the value.
7477 Our strategy is to convert these values to values with accurate,
7478 conventional types that are constructed on the fly. */
7480 /* There is a subtle and tricky problem here. In general, we cannot
7481 determine the size of dynamic records without its data. However,
7482 the 'struct value' data structure, which GDB uses to represent
7483 quantities in the inferior process (the target), requires the size
7484 of the type at the time of its allocation in order to reserve space
7485 for GDB's internal copy of the data. That's why the
7486 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7487 rather than struct value*s.
7489 However, GDB's internal history variables ($1, $2, etc.) are
7490 struct value*s containing internal copies of the data that are not, in
7491 general, the same as the data at their corresponding addresses in
7492 the target. Fortunately, the types we give to these values are all
7493 conventional, fixed-size types (as per the strategy described
7494 above), so that we don't usually have to perform the
7495 'to_fixed_xxx_type' conversions to look at their values.
7496 Unfortunately, there is one exception: if one of the internal
7497 history variables is an array whose elements are unconstrained
7498 records, then we will need to create distinct fixed types for each
7499 element selected. */
7501 /* The upshot of all of this is that many routines take a (type, host
7502 address, target address) triple as arguments to represent a value.
7503 The host address, if non-null, is supposed to contain an internal
7504 copy of the relevant data; otherwise, the program is to consult the
7505 target at the target address. */
7507 /* Assuming that VAL0 represents a pointer value, the result of
7508 dereferencing it. Differs from value_ind in its treatment of
7509 dynamic-sized types. */
7512 ada_value_ind (struct value
*val0
)
7514 struct value
*val
= value_ind (val0
);
7516 if (ada_is_tagged_type (value_type (val
), 0))
7517 val
= ada_tag_value_at_base_address (val
);
7519 return ada_to_fixed_value (val
);
7522 /* The value resulting from dereferencing any "reference to"
7523 qualifiers on VAL0. */
7525 static struct value
*
7526 ada_coerce_ref (struct value
*val0
)
7528 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7530 struct value
*val
= val0
;
7532 val
= coerce_ref (val
);
7534 if (ada_is_tagged_type (value_type (val
), 0))
7535 val
= ada_tag_value_at_base_address (val
);
7537 return ada_to_fixed_value (val
);
7543 /* Return the bit alignment required for field #F of template type TYPE. */
7546 field_alignment (struct type
*type
, int f
)
7548 const char *name
= TYPE_FIELD_NAME (type
, f
);
7552 /* The field name should never be null, unless the debugging information
7553 is somehow malformed. In this case, we assume the field does not
7554 require any alignment. */
7558 len
= strlen (name
);
7560 if (!isdigit (name
[len
- 1]))
7563 if (isdigit (name
[len
- 2]))
7564 align_offset
= len
- 2;
7566 align_offset
= len
- 1;
7568 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7569 return TARGET_CHAR_BIT
;
7571 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7574 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7576 static struct symbol
*
7577 ada_find_any_type_symbol (const char *name
)
7581 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7582 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7585 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7589 /* Find a type named NAME. Ignores ambiguity. This routine will look
7590 solely for types defined by debug info, it will not search the GDB
7593 static struct type
*
7594 ada_find_any_type (const char *name
)
7596 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7599 return SYMBOL_TYPE (sym
);
7604 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7605 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7606 symbol, in which case it is returned. Otherwise, this looks for
7607 symbols whose name is that of NAME_SYM suffixed with "___XR".
7608 Return symbol if found, and NULL otherwise. */
7611 ada_is_renaming_symbol (struct symbol
*name_sym
)
7613 const char *name
= name_sym
->linkage_name ();
7614 return strstr (name
, "___XR") != NULL
;
7617 /* Because of GNAT encoding conventions, several GDB symbols may match a
7618 given type name. If the type denoted by TYPE0 is to be preferred to
7619 that of TYPE1 for purposes of type printing, return non-zero;
7620 otherwise return 0. */
7623 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7627 else if (type0
== NULL
)
7629 else if (type1
->code () == TYPE_CODE_VOID
)
7631 else if (type0
->code () == TYPE_CODE_VOID
)
7633 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7635 else if (ada_is_constrained_packed_array_type (type0
))
7637 else if (ada_is_array_descriptor_type (type0
)
7638 && !ada_is_array_descriptor_type (type1
))
7642 const char *type0_name
= type0
->name ();
7643 const char *type1_name
= type1
->name ();
7645 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7646 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7652 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7656 ada_type_name (struct type
*type
)
7660 return type
->name ();
7663 /* Search the list of "descriptive" types associated to TYPE for a type
7664 whose name is NAME. */
7666 static struct type
*
7667 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7669 struct type
*result
, *tmp
;
7671 if (ada_ignore_descriptive_types_p
)
7674 /* If there no descriptive-type info, then there is no parallel type
7676 if (!HAVE_GNAT_AUX_INFO (type
))
7679 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7680 while (result
!= NULL
)
7682 const char *result_name
= ada_type_name (result
);
7684 if (result_name
== NULL
)
7686 warning (_("unexpected null name on descriptive type"));
7690 /* If the names match, stop. */
7691 if (strcmp (result_name
, name
) == 0)
7694 /* Otherwise, look at the next item on the list, if any. */
7695 if (HAVE_GNAT_AUX_INFO (result
))
7696 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7700 /* If not found either, try after having resolved the typedef. */
7705 result
= check_typedef (result
);
7706 if (HAVE_GNAT_AUX_INFO (result
))
7707 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7713 /* If we didn't find a match, see whether this is a packed array. With
7714 older compilers, the descriptive type information is either absent or
7715 irrelevant when it comes to packed arrays so the above lookup fails.
7716 Fall back to using a parallel lookup by name in this case. */
7717 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7718 return ada_find_any_type (name
);
7723 /* Find a parallel type to TYPE with the specified NAME, using the
7724 descriptive type taken from the debugging information, if available,
7725 and otherwise using the (slower) name-based method. */
7727 static struct type
*
7728 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7730 struct type
*result
= NULL
;
7732 if (HAVE_GNAT_AUX_INFO (type
))
7733 result
= find_parallel_type_by_descriptive_type (type
, name
);
7735 result
= ada_find_any_type (name
);
7740 /* Same as above, but specify the name of the parallel type by appending
7741 SUFFIX to the name of TYPE. */
7744 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7747 const char *type_name
= ada_type_name (type
);
7750 if (type_name
== NULL
)
7753 len
= strlen (type_name
);
7755 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7757 strcpy (name
, type_name
);
7758 strcpy (name
+ len
, suffix
);
7760 return ada_find_parallel_type_with_name (type
, name
);
7763 /* If TYPE is a variable-size record type, return the corresponding template
7764 type describing its fields. Otherwise, return NULL. */
7766 static struct type
*
7767 dynamic_template_type (struct type
*type
)
7769 type
= ada_check_typedef (type
);
7771 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7772 || ada_type_name (type
) == NULL
)
7776 int len
= strlen (ada_type_name (type
));
7778 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7781 return ada_find_parallel_type (type
, "___XVE");
7785 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7786 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7789 is_dynamic_field (struct type
*templ_type
, int field_num
)
7791 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7794 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7795 && strstr (name
, "___XVL") != NULL
;
7798 /* The index of the variant field of TYPE, or -1 if TYPE does not
7799 represent a variant record type. */
7802 variant_field_index (struct type
*type
)
7806 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7809 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7811 if (ada_is_variant_part (type
, f
))
7817 /* A record type with no fields. */
7819 static struct type
*
7820 empty_record (struct type
*templ
)
7822 struct type
*type
= alloc_type_copy (templ
);
7824 type
->set_code (TYPE_CODE_STRUCT
);
7825 INIT_NONE_SPECIFIC (type
);
7826 type
->set_name ("<empty>");
7827 TYPE_LENGTH (type
) = 0;
7831 /* An ordinary record type (with fixed-length fields) that describes
7832 the value of type TYPE at VALADDR or ADDRESS (see comments at
7833 the beginning of this section) VAL according to GNAT conventions.
7834 DVAL0 should describe the (portion of a) record that contains any
7835 necessary discriminants. It should be NULL if value_type (VAL) is
7836 an outer-level type (i.e., as opposed to a branch of a variant.) A
7837 variant field (unless unchecked) is replaced by a particular branch
7840 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7841 length are not statically known are discarded. As a consequence,
7842 VALADDR, ADDRESS and DVAL0 are ignored.
7844 NOTE: Limitations: For now, we assume that dynamic fields and
7845 variants occupy whole numbers of bytes. However, they need not be
7849 ada_template_to_fixed_record_type_1 (struct type
*type
,
7850 const gdb_byte
*valaddr
,
7851 CORE_ADDR address
, struct value
*dval0
,
7852 int keep_dynamic_fields
)
7854 struct value
*mark
= value_mark ();
7857 int nfields
, bit_len
;
7863 /* Compute the number of fields in this record type that are going
7864 to be processed: unless keep_dynamic_fields, this includes only
7865 fields whose position and length are static will be processed. */
7866 if (keep_dynamic_fields
)
7867 nfields
= type
->num_fields ();
7871 while (nfields
< type
->num_fields ()
7872 && !ada_is_variant_part (type
, nfields
)
7873 && !is_dynamic_field (type
, nfields
))
7877 rtype
= alloc_type_copy (type
);
7878 rtype
->set_code (TYPE_CODE_STRUCT
);
7879 INIT_NONE_SPECIFIC (rtype
);
7880 rtype
->set_num_fields (nfields
);
7882 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7883 rtype
->set_name (ada_type_name (type
));
7884 rtype
->set_is_fixed_instance (true);
7890 for (f
= 0; f
< nfields
; f
+= 1)
7892 off
= align_up (off
, field_alignment (type
, f
))
7893 + TYPE_FIELD_BITPOS (type
, f
);
7894 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7895 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7897 if (ada_is_variant_part (type
, f
))
7902 else if (is_dynamic_field (type
, f
))
7904 const gdb_byte
*field_valaddr
= valaddr
;
7905 CORE_ADDR field_address
= address
;
7906 struct type
*field_type
=
7907 TYPE_TARGET_TYPE (type
->field (f
).type ());
7911 /* rtype's length is computed based on the run-time
7912 value of discriminants. If the discriminants are not
7913 initialized, the type size may be completely bogus and
7914 GDB may fail to allocate a value for it. So check the
7915 size first before creating the value. */
7916 ada_ensure_varsize_limit (rtype
);
7917 /* Using plain value_from_contents_and_address here
7918 causes problems because we will end up trying to
7919 resolve a type that is currently being
7921 dval
= value_from_contents_and_address_unresolved (rtype
,
7924 rtype
= value_type (dval
);
7929 /* If the type referenced by this field is an aligner type, we need
7930 to unwrap that aligner type, because its size might not be set.
7931 Keeping the aligner type would cause us to compute the wrong
7932 size for this field, impacting the offset of the all the fields
7933 that follow this one. */
7934 if (ada_is_aligner_type (field_type
))
7936 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7938 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7939 field_address
= cond_offset_target (field_address
, field_offset
);
7940 field_type
= ada_aligned_type (field_type
);
7943 field_valaddr
= cond_offset_host (field_valaddr
,
7944 off
/ TARGET_CHAR_BIT
);
7945 field_address
= cond_offset_target (field_address
,
7946 off
/ TARGET_CHAR_BIT
);
7948 /* Get the fixed type of the field. Note that, in this case,
7949 we do not want to get the real type out of the tag: if
7950 the current field is the parent part of a tagged record,
7951 we will get the tag of the object. Clearly wrong: the real
7952 type of the parent is not the real type of the child. We
7953 would end up in an infinite loop. */
7954 field_type
= ada_get_base_type (field_type
);
7955 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7956 field_address
, dval
, 0);
7957 /* If the field size is already larger than the maximum
7958 object size, then the record itself will necessarily
7959 be larger than the maximum object size. We need to make
7960 this check now, because the size might be so ridiculously
7961 large (due to an uninitialized variable in the inferior)
7962 that it would cause an overflow when adding it to the
7964 ada_ensure_varsize_limit (field_type
);
7966 rtype
->field (f
).set_type (field_type
);
7967 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7968 /* The multiplication can potentially overflow. But because
7969 the field length has been size-checked just above, and
7970 assuming that the maximum size is a reasonable value,
7971 an overflow should not happen in practice. So rather than
7972 adding overflow recovery code to this already complex code,
7973 we just assume that it's not going to happen. */
7975 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7979 /* Note: If this field's type is a typedef, it is important
7980 to preserve the typedef layer.
7982 Otherwise, we might be transforming a typedef to a fat
7983 pointer (encoding a pointer to an unconstrained array),
7984 into a basic fat pointer (encoding an unconstrained
7985 array). As both types are implemented using the same
7986 structure, the typedef is the only clue which allows us
7987 to distinguish between the two options. Stripping it
7988 would prevent us from printing this field appropriately. */
7989 rtype
->field (f
).set_type (type
->field (f
).type ());
7990 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7991 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7993 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7996 struct type
*field_type
= type
->field (f
).type ();
7998 /* We need to be careful of typedefs when computing
7999 the length of our field. If this is a typedef,
8000 get the length of the target type, not the length
8002 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
8003 field_type
= ada_typedef_target_type (field_type
);
8006 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8009 if (off
+ fld_bit_len
> bit_len
)
8010 bit_len
= off
+ fld_bit_len
;
8012 TYPE_LENGTH (rtype
) =
8013 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8016 /* We handle the variant part, if any, at the end because of certain
8017 odd cases in which it is re-ordered so as NOT to be the last field of
8018 the record. This can happen in the presence of representation
8020 if (variant_field
>= 0)
8022 struct type
*branch_type
;
8024 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8028 /* Using plain value_from_contents_and_address here causes
8029 problems because we will end up trying to resolve a type
8030 that is currently being constructed. */
8031 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8033 rtype
= value_type (dval
);
8039 to_fixed_variant_branch_type
8040 (type
->field (variant_field
).type (),
8041 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8042 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8043 if (branch_type
== NULL
)
8045 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8046 rtype
->field (f
- 1) = rtype
->field (f
);
8047 rtype
->set_num_fields (rtype
->num_fields () - 1);
8051 rtype
->field (variant_field
).set_type (branch_type
);
8052 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8054 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8056 if (off
+ fld_bit_len
> bit_len
)
8057 bit_len
= off
+ fld_bit_len
;
8058 TYPE_LENGTH (rtype
) =
8059 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8063 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8064 should contain the alignment of that record, which should be a strictly
8065 positive value. If null or negative, then something is wrong, most
8066 probably in the debug info. In that case, we don't round up the size
8067 of the resulting type. If this record is not part of another structure,
8068 the current RTYPE length might be good enough for our purposes. */
8069 if (TYPE_LENGTH (type
) <= 0)
8072 warning (_("Invalid type size for `%s' detected: %s."),
8073 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8075 warning (_("Invalid type size for <unnamed> detected: %s."),
8076 pulongest (TYPE_LENGTH (type
)));
8080 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8081 TYPE_LENGTH (type
));
8084 value_free_to_mark (mark
);
8085 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8086 error (_("record type with dynamic size is larger than varsize-limit"));
8090 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8093 static struct type
*
8094 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8095 CORE_ADDR address
, struct value
*dval0
)
8097 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8101 /* An ordinary record type in which ___XVL-convention fields and
8102 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8103 static approximations, containing all possible fields. Uses
8104 no runtime values. Useless for use in values, but that's OK,
8105 since the results are used only for type determinations. Works on both
8106 structs and unions. Representation note: to save space, we memorize
8107 the result of this function in the TYPE_TARGET_TYPE of the
8110 static struct type
*
8111 template_to_static_fixed_type (struct type
*type0
)
8117 /* No need no do anything if the input type is already fixed. */
8118 if (type0
->is_fixed_instance ())
8121 /* Likewise if we already have computed the static approximation. */
8122 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8123 return TYPE_TARGET_TYPE (type0
);
8125 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8127 nfields
= type0
->num_fields ();
8129 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8130 recompute all over next time. */
8131 TYPE_TARGET_TYPE (type0
) = type
;
8133 for (f
= 0; f
< nfields
; f
+= 1)
8135 struct type
*field_type
= type0
->field (f
).type ();
8136 struct type
*new_type
;
8138 if (is_dynamic_field (type0
, f
))
8140 field_type
= ada_check_typedef (field_type
);
8141 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8144 new_type
= static_unwrap_type (field_type
);
8146 if (new_type
!= field_type
)
8148 /* Clone TYPE0 only the first time we get a new field type. */
8151 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8152 type
->set_code (type0
->code ());
8153 INIT_NONE_SPECIFIC (type
);
8154 type
->set_num_fields (nfields
);
8158 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8159 memcpy (fields
, type0
->fields (),
8160 sizeof (struct field
) * nfields
);
8161 type
->set_fields (fields
);
8163 type
->set_name (ada_type_name (type0
));
8164 type
->set_is_fixed_instance (true);
8165 TYPE_LENGTH (type
) = 0;
8167 type
->field (f
).set_type (new_type
);
8168 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8175 /* Given an object of type TYPE whose contents are at VALADDR and
8176 whose address in memory is ADDRESS, returns a revision of TYPE,
8177 which should be a non-dynamic-sized record, in which the variant
8178 part, if any, is replaced with the appropriate branch. Looks
8179 for discriminant values in DVAL0, which can be NULL if the record
8180 contains the necessary discriminant values. */
8182 static struct type
*
8183 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8184 CORE_ADDR address
, struct value
*dval0
)
8186 struct value
*mark
= value_mark ();
8189 struct type
*branch_type
;
8190 int nfields
= type
->num_fields ();
8191 int variant_field
= variant_field_index (type
);
8193 if (variant_field
== -1)
8198 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8199 type
= value_type (dval
);
8204 rtype
= alloc_type_copy (type
);
8205 rtype
->set_code (TYPE_CODE_STRUCT
);
8206 INIT_NONE_SPECIFIC (rtype
);
8207 rtype
->set_num_fields (nfields
);
8210 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8211 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8212 rtype
->set_fields (fields
);
8214 rtype
->set_name (ada_type_name (type
));
8215 rtype
->set_is_fixed_instance (true);
8216 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8218 branch_type
= to_fixed_variant_branch_type
8219 (type
->field (variant_field
).type (),
8220 cond_offset_host (valaddr
,
8221 TYPE_FIELD_BITPOS (type
, variant_field
)
8223 cond_offset_target (address
,
8224 TYPE_FIELD_BITPOS (type
, variant_field
)
8225 / TARGET_CHAR_BIT
), dval
);
8226 if (branch_type
== NULL
)
8230 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8231 rtype
->field (f
- 1) = rtype
->field (f
);
8232 rtype
->set_num_fields (rtype
->num_fields () - 1);
8236 rtype
->field (variant_field
).set_type (branch_type
);
8237 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8238 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8239 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8241 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8243 value_free_to_mark (mark
);
8247 /* An ordinary record type (with fixed-length fields) that describes
8248 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8249 beginning of this section]. Any necessary discriminants' values
8250 should be in DVAL, a record value; it may be NULL if the object
8251 at ADDR itself contains any necessary discriminant values.
8252 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8253 values from the record are needed. Except in the case that DVAL,
8254 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8255 unchecked) is replaced by a particular branch of the variant.
8257 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8258 is questionable and may be removed. It can arise during the
8259 processing of an unconstrained-array-of-record type where all the
8260 variant branches have exactly the same size. This is because in
8261 such cases, the compiler does not bother to use the XVS convention
8262 when encoding the record. I am currently dubious of this
8263 shortcut and suspect the compiler should be altered. FIXME. */
8265 static struct type
*
8266 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8267 CORE_ADDR address
, struct value
*dval
)
8269 struct type
*templ_type
;
8271 if (type0
->is_fixed_instance ())
8274 templ_type
= dynamic_template_type (type0
);
8276 if (templ_type
!= NULL
)
8277 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8278 else if (variant_field_index (type0
) >= 0)
8280 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8282 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8287 type0
->set_is_fixed_instance (true);
8293 /* An ordinary record type (with fixed-length fields) that describes
8294 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8295 union type. Any necessary discriminants' values should be in DVAL,
8296 a record value. That is, this routine selects the appropriate
8297 branch of the union at ADDR according to the discriminant value
8298 indicated in the union's type name. Returns VAR_TYPE0 itself if
8299 it represents a variant subject to a pragma Unchecked_Union. */
8301 static struct type
*
8302 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8303 CORE_ADDR address
, struct value
*dval
)
8306 struct type
*templ_type
;
8307 struct type
*var_type
;
8309 if (var_type0
->code () == TYPE_CODE_PTR
)
8310 var_type
= TYPE_TARGET_TYPE (var_type0
);
8312 var_type
= var_type0
;
8314 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8316 if (templ_type
!= NULL
)
8317 var_type
= templ_type
;
8319 if (is_unchecked_variant (var_type
, value_type (dval
)))
8321 which
= ada_which_variant_applies (var_type
, dval
);
8324 return empty_record (var_type
);
8325 else if (is_dynamic_field (var_type
, which
))
8326 return to_fixed_record_type
8327 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8328 valaddr
, address
, dval
);
8329 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8331 to_fixed_record_type
8332 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8334 return var_type
->field (which
).type ();
8337 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8338 ENCODING_TYPE, a type following the GNAT conventions for discrete
8339 type encodings, only carries redundant information. */
8342 ada_is_redundant_range_encoding (struct type
*range_type
,
8343 struct type
*encoding_type
)
8345 const char *bounds_str
;
8349 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8351 if (get_base_type (range_type
)->code ()
8352 != get_base_type (encoding_type
)->code ())
8354 /* The compiler probably used a simple base type to describe
8355 the range type instead of the range's actual base type,
8356 expecting us to get the real base type from the encoding
8357 anyway. In this situation, the encoding cannot be ignored
8362 if (is_dynamic_type (range_type
))
8365 if (encoding_type
->name () == NULL
)
8368 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8369 if (bounds_str
== NULL
)
8372 n
= 8; /* Skip "___XDLU_". */
8373 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8375 if (range_type
->bounds ()->low
.const_val () != lo
)
8378 n
+= 2; /* Skip the "__" separator between the two bounds. */
8379 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8381 if (range_type
->bounds ()->high
.const_val () != hi
)
8387 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8388 a type following the GNAT encoding for describing array type
8389 indices, only carries redundant information. */
8392 ada_is_redundant_index_type_desc (struct type
*array_type
,
8393 struct type
*desc_type
)
8395 struct type
*this_layer
= check_typedef (array_type
);
8398 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8400 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8401 desc_type
->field (i
).type ()))
8403 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8409 /* Assuming that TYPE0 is an array type describing the type of a value
8410 at ADDR, and that DVAL describes a record containing any
8411 discriminants used in TYPE0, returns a type for the value that
8412 contains no dynamic components (that is, no components whose sizes
8413 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8414 true, gives an error message if the resulting type's size is over
8417 static struct type
*
8418 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8421 struct type
*index_type_desc
;
8422 struct type
*result
;
8423 int constrained_packed_array_p
;
8424 static const char *xa_suffix
= "___XA";
8426 type0
= ada_check_typedef (type0
);
8427 if (type0
->is_fixed_instance ())
8430 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8431 if (constrained_packed_array_p
)
8433 type0
= decode_constrained_packed_array_type (type0
);
8434 if (type0
== nullptr)
8435 error (_("could not decode constrained packed array type"));
8438 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8440 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8441 encoding suffixed with 'P' may still be generated. If so,
8442 it should be used to find the XA type. */
8444 if (index_type_desc
== NULL
)
8446 const char *type_name
= ada_type_name (type0
);
8448 if (type_name
!= NULL
)
8450 const int len
= strlen (type_name
);
8451 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8453 if (type_name
[len
- 1] == 'P')
8455 strcpy (name
, type_name
);
8456 strcpy (name
+ len
- 1, xa_suffix
);
8457 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8462 ada_fixup_array_indexes_type (index_type_desc
);
8463 if (index_type_desc
!= NULL
8464 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8466 /* Ignore this ___XA parallel type, as it does not bring any
8467 useful information. This allows us to avoid creating fixed
8468 versions of the array's index types, which would be identical
8469 to the original ones. This, in turn, can also help avoid
8470 the creation of fixed versions of the array itself. */
8471 index_type_desc
= NULL
;
8474 if (index_type_desc
== NULL
)
8476 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8478 /* NOTE: elt_type---the fixed version of elt_type0---should never
8479 depend on the contents of the array in properly constructed
8481 /* Create a fixed version of the array element type.
8482 We're not providing the address of an element here,
8483 and thus the actual object value cannot be inspected to do
8484 the conversion. This should not be a problem, since arrays of
8485 unconstrained objects are not allowed. In particular, all
8486 the elements of an array of a tagged type should all be of
8487 the same type specified in the debugging info. No need to
8488 consult the object tag. */
8489 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8491 /* Make sure we always create a new array type when dealing with
8492 packed array types, since we're going to fix-up the array
8493 type length and element bitsize a little further down. */
8494 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8497 result
= create_array_type (alloc_type_copy (type0
),
8498 elt_type
, type0
->index_type ());
8503 struct type
*elt_type0
;
8506 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8507 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8509 /* NOTE: result---the fixed version of elt_type0---should never
8510 depend on the contents of the array in properly constructed
8512 /* Create a fixed version of the array element type.
8513 We're not providing the address of an element here,
8514 and thus the actual object value cannot be inspected to do
8515 the conversion. This should not be a problem, since arrays of
8516 unconstrained objects are not allowed. In particular, all
8517 the elements of an array of a tagged type should all be of
8518 the same type specified in the debugging info. No need to
8519 consult the object tag. */
8521 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8524 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8526 struct type
*range_type
=
8527 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8529 result
= create_array_type (alloc_type_copy (elt_type0
),
8530 result
, range_type
);
8531 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8533 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8534 error (_("array type with dynamic size is larger than varsize-limit"));
8537 /* We want to preserve the type name. This can be useful when
8538 trying to get the type name of a value that has already been
8539 printed (for instance, if the user did "print VAR; whatis $". */
8540 result
->set_name (type0
->name ());
8542 if (constrained_packed_array_p
)
8544 /* So far, the resulting type has been created as if the original
8545 type was a regular (non-packed) array type. As a result, the
8546 bitsize of the array elements needs to be set again, and the array
8547 length needs to be recomputed based on that bitsize. */
8548 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8549 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8551 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8552 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8553 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8554 TYPE_LENGTH (result
)++;
8557 result
->set_is_fixed_instance (true);
8562 /* A standard type (containing no dynamically sized components)
8563 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8564 DVAL describes a record containing any discriminants used in TYPE0,
8565 and may be NULL if there are none, or if the object of type TYPE at
8566 ADDRESS or in VALADDR contains these discriminants.
8568 If CHECK_TAG is not null, in the case of tagged types, this function
8569 attempts to locate the object's tag and use it to compute the actual
8570 type. However, when ADDRESS is null, we cannot use it to determine the
8571 location of the tag, and therefore compute the tagged type's actual type.
8572 So we return the tagged type without consulting the tag. */
8574 static struct type
*
8575 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8576 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8578 type
= ada_check_typedef (type
);
8580 /* Only un-fixed types need to be handled here. */
8581 if (!HAVE_GNAT_AUX_INFO (type
))
8584 switch (type
->code ())
8588 case TYPE_CODE_STRUCT
:
8590 struct type
*static_type
= to_static_fixed_type (type
);
8591 struct type
*fixed_record_type
=
8592 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8594 /* If STATIC_TYPE is a tagged type and we know the object's address,
8595 then we can determine its tag, and compute the object's actual
8596 type from there. Note that we have to use the fixed record
8597 type (the parent part of the record may have dynamic fields
8598 and the way the location of _tag is expressed may depend on
8601 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8604 value_tag_from_contents_and_address
8608 struct type
*real_type
= type_from_tag (tag
);
8610 value_from_contents_and_address (fixed_record_type
,
8613 fixed_record_type
= value_type (obj
);
8614 if (real_type
!= NULL
)
8615 return to_fixed_record_type
8617 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8620 /* Check to see if there is a parallel ___XVZ variable.
8621 If there is, then it provides the actual size of our type. */
8622 else if (ada_type_name (fixed_record_type
) != NULL
)
8624 const char *name
= ada_type_name (fixed_record_type
);
8626 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8627 bool xvz_found
= false;
8630 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8633 xvz_found
= get_int_var_value (xvz_name
, size
);
8635 catch (const gdb_exception_error
&except
)
8637 /* We found the variable, but somehow failed to read
8638 its value. Rethrow the same error, but with a little
8639 bit more information, to help the user understand
8640 what went wrong (Eg: the variable might have been
8642 throw_error (except
.error
,
8643 _("unable to read value of %s (%s)"),
8644 xvz_name
, except
.what ());
8647 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8649 fixed_record_type
= copy_type (fixed_record_type
);
8650 TYPE_LENGTH (fixed_record_type
) = size
;
8652 /* The FIXED_RECORD_TYPE may have be a stub. We have
8653 observed this when the debugging info is STABS, and
8654 apparently it is something that is hard to fix.
8656 In practice, we don't need the actual type definition
8657 at all, because the presence of the XVZ variable allows us
8658 to assume that there must be a XVS type as well, which we
8659 should be able to use later, when we need the actual type
8662 In the meantime, pretend that the "fixed" type we are
8663 returning is NOT a stub, because this can cause trouble
8664 when using this type to create new types targeting it.
8665 Indeed, the associated creation routines often check
8666 whether the target type is a stub and will try to replace
8667 it, thus using a type with the wrong size. This, in turn,
8668 might cause the new type to have the wrong size too.
8669 Consider the case of an array, for instance, where the size
8670 of the array is computed from the number of elements in
8671 our array multiplied by the size of its element. */
8672 fixed_record_type
->set_is_stub (false);
8675 return fixed_record_type
;
8677 case TYPE_CODE_ARRAY
:
8678 return to_fixed_array_type (type
, dval
, 1);
8679 case TYPE_CODE_UNION
:
8683 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8687 /* The same as ada_to_fixed_type_1, except that it preserves the type
8688 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8690 The typedef layer needs be preserved in order to differentiate between
8691 arrays and array pointers when both types are implemented using the same
8692 fat pointer. In the array pointer case, the pointer is encoded as
8693 a typedef of the pointer type. For instance, considering:
8695 type String_Access is access String;
8696 S1 : String_Access := null;
8698 To the debugger, S1 is defined as a typedef of type String. But
8699 to the user, it is a pointer. So if the user tries to print S1,
8700 we should not dereference the array, but print the array address
8703 If we didn't preserve the typedef layer, we would lose the fact that
8704 the type is to be presented as a pointer (needs de-reference before
8705 being printed). And we would also use the source-level type name. */
8708 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8709 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8712 struct type
*fixed_type
=
8713 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8715 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8716 then preserve the typedef layer.
8718 Implementation note: We can only check the main-type portion of
8719 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8720 from TYPE now returns a type that has the same instance flags
8721 as TYPE. For instance, if TYPE is a "typedef const", and its
8722 target type is a "struct", then the typedef elimination will return
8723 a "const" version of the target type. See check_typedef for more
8724 details about how the typedef layer elimination is done.
8726 brobecker/2010-11-19: It seems to me that the only case where it is
8727 useful to preserve the typedef layer is when dealing with fat pointers.
8728 Perhaps, we could add a check for that and preserve the typedef layer
8729 only in that situation. But this seems unnecessary so far, probably
8730 because we call check_typedef/ada_check_typedef pretty much everywhere.
8732 if (type
->code () == TYPE_CODE_TYPEDEF
8733 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8734 == TYPE_MAIN_TYPE (fixed_type
)))
8740 /* A standard (static-sized) type corresponding as well as possible to
8741 TYPE0, but based on no runtime data. */
8743 static struct type
*
8744 to_static_fixed_type (struct type
*type0
)
8751 if (type0
->is_fixed_instance ())
8754 type0
= ada_check_typedef (type0
);
8756 switch (type0
->code ())
8760 case TYPE_CODE_STRUCT
:
8761 type
= dynamic_template_type (type0
);
8763 return template_to_static_fixed_type (type
);
8765 return template_to_static_fixed_type (type0
);
8766 case TYPE_CODE_UNION
:
8767 type
= ada_find_parallel_type (type0
, "___XVU");
8769 return template_to_static_fixed_type (type
);
8771 return template_to_static_fixed_type (type0
);
8775 /* A static approximation of TYPE with all type wrappers removed. */
8777 static struct type
*
8778 static_unwrap_type (struct type
*type
)
8780 if (ada_is_aligner_type (type
))
8782 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8783 if (ada_type_name (type1
) == NULL
)
8784 type1
->set_name (ada_type_name (type
));
8786 return static_unwrap_type (type1
);
8790 struct type
*raw_real_type
= ada_get_base_type (type
);
8792 if (raw_real_type
== type
)
8795 return to_static_fixed_type (raw_real_type
);
8799 /* In some cases, incomplete and private types require
8800 cross-references that are not resolved as records (for example,
8802 type FooP is access Foo;
8804 type Foo is array ...;
8805 ). In these cases, since there is no mechanism for producing
8806 cross-references to such types, we instead substitute for FooP a
8807 stub enumeration type that is nowhere resolved, and whose tag is
8808 the name of the actual type. Call these types "non-record stubs". */
8810 /* A type equivalent to TYPE that is not a non-record stub, if one
8811 exists, otherwise TYPE. */
8814 ada_check_typedef (struct type
*type
)
8819 /* If our type is an access to an unconstrained array, which is encoded
8820 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8821 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8822 what allows us to distinguish between fat pointers that represent
8823 array types, and fat pointers that represent array access types
8824 (in both cases, the compiler implements them as fat pointers). */
8825 if (ada_is_access_to_unconstrained_array (type
))
8828 type
= check_typedef (type
);
8829 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8830 || !type
->is_stub ()
8831 || type
->name () == NULL
)
8835 const char *name
= type
->name ();
8836 struct type
*type1
= ada_find_any_type (name
);
8841 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8842 stubs pointing to arrays, as we don't create symbols for array
8843 types, only for the typedef-to-array types). If that's the case,
8844 strip the typedef layer. */
8845 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8846 type1
= ada_check_typedef (type1
);
8852 /* A value representing the data at VALADDR/ADDRESS as described by
8853 type TYPE0, but with a standard (static-sized) type that correctly
8854 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8855 type, then return VAL0 [this feature is simply to avoid redundant
8856 creation of struct values]. */
8858 static struct value
*
8859 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8862 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8864 if (type
== type0
&& val0
!= NULL
)
8867 if (VALUE_LVAL (val0
) != lval_memory
)
8869 /* Our value does not live in memory; it could be a convenience
8870 variable, for instance. Create a not_lval value using val0's
8872 return value_from_contents (type
, value_contents (val0
));
8875 return value_from_contents_and_address (type
, 0, address
);
8878 /* A value representing VAL, but with a standard (static-sized) type
8879 that correctly describes it. Does not necessarily create a new
8883 ada_to_fixed_value (struct value
*val
)
8885 val
= unwrap_value (val
);
8886 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8893 /* Table mapping attribute numbers to names.
8894 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8896 static const char * const attribute_names
[] = {
8914 ada_attribute_name (enum exp_opcode n
)
8916 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8917 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8919 return attribute_names
[0];
8922 /* Evaluate the 'POS attribute applied to ARG. */
8925 pos_atr (struct value
*arg
)
8927 struct value
*val
= coerce_ref (arg
);
8928 struct type
*type
= value_type (val
);
8931 if (!discrete_type_p (type
))
8932 error (_("'POS only defined on discrete types"));
8934 if (!discrete_position (type
, value_as_long (val
), &result
))
8935 error (_("enumeration value is invalid: can't find 'POS"));
8940 static struct value
*
8941 value_pos_atr (struct type
*type
, struct value
*arg
)
8943 return value_from_longest (type
, pos_atr (arg
));
8946 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8948 static struct value
*
8949 val_atr (struct type
*type
, LONGEST val
)
8951 gdb_assert (discrete_type_p (type
));
8952 if (type
->code () == TYPE_CODE_RANGE
)
8953 type
= TYPE_TARGET_TYPE (type
);
8954 if (type
->code () == TYPE_CODE_ENUM
)
8956 if (val
< 0 || val
>= type
->num_fields ())
8957 error (_("argument to 'VAL out of range"));
8958 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8960 return value_from_longest (type
, val
);
8963 static struct value
*
8964 value_val_atr (struct type
*type
, struct value
*arg
)
8966 if (!discrete_type_p (type
))
8967 error (_("'VAL only defined on discrete types"));
8968 if (!integer_type_p (value_type (arg
)))
8969 error (_("'VAL requires integral argument"));
8971 return val_atr (type
, value_as_long (arg
));
8977 /* True if TYPE appears to be an Ada character type.
8978 [At the moment, this is true only for Character and Wide_Character;
8979 It is a heuristic test that could stand improvement]. */
8982 ada_is_character_type (struct type
*type
)
8986 /* If the type code says it's a character, then assume it really is,
8987 and don't check any further. */
8988 if (type
->code () == TYPE_CODE_CHAR
)
8991 /* Otherwise, assume it's a character type iff it is a discrete type
8992 with a known character type name. */
8993 name
= ada_type_name (type
);
8994 return (name
!= NULL
8995 && (type
->code () == TYPE_CODE_INT
8996 || type
->code () == TYPE_CODE_RANGE
)
8997 && (strcmp (name
, "character") == 0
8998 || strcmp (name
, "wide_character") == 0
8999 || strcmp (name
, "wide_wide_character") == 0
9000 || strcmp (name
, "unsigned char") == 0));
9003 /* True if TYPE appears to be an Ada string type. */
9006 ada_is_string_type (struct type
*type
)
9008 type
= ada_check_typedef (type
);
9010 && type
->code () != TYPE_CODE_PTR
9011 && (ada_is_simple_array_type (type
)
9012 || ada_is_array_descriptor_type (type
))
9013 && ada_array_arity (type
) == 1)
9015 struct type
*elttype
= ada_array_element_type (type
, 1);
9017 return ada_is_character_type (elttype
);
9023 /* The compiler sometimes provides a parallel XVS type for a given
9024 PAD type. Normally, it is safe to follow the PAD type directly,
9025 but older versions of the compiler have a bug that causes the offset
9026 of its "F" field to be wrong. Following that field in that case
9027 would lead to incorrect results, but this can be worked around
9028 by ignoring the PAD type and using the associated XVS type instead.
9030 Set to True if the debugger should trust the contents of PAD types.
9031 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9032 static bool trust_pad_over_xvs
= true;
9034 /* True if TYPE is a struct type introduced by the compiler to force the
9035 alignment of a value. Such types have a single field with a
9036 distinctive name. */
9039 ada_is_aligner_type (struct type
*type
)
9041 type
= ada_check_typedef (type
);
9043 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9046 return (type
->code () == TYPE_CODE_STRUCT
9047 && type
->num_fields () == 1
9048 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9051 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9052 the parallel type. */
9055 ada_get_base_type (struct type
*raw_type
)
9057 struct type
*real_type_namer
;
9058 struct type
*raw_real_type
;
9060 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9063 if (ada_is_aligner_type (raw_type
))
9064 /* The encoding specifies that we should always use the aligner type.
9065 So, even if this aligner type has an associated XVS type, we should
9068 According to the compiler gurus, an XVS type parallel to an aligner
9069 type may exist because of a stabs limitation. In stabs, aligner
9070 types are empty because the field has a variable-sized type, and
9071 thus cannot actually be used as an aligner type. As a result,
9072 we need the associated parallel XVS type to decode the type.
9073 Since the policy in the compiler is to not change the internal
9074 representation based on the debugging info format, we sometimes
9075 end up having a redundant XVS type parallel to the aligner type. */
9078 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9079 if (real_type_namer
== NULL
9080 || real_type_namer
->code () != TYPE_CODE_STRUCT
9081 || real_type_namer
->num_fields () != 1)
9084 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9086 /* This is an older encoding form where the base type needs to be
9087 looked up by name. We prefer the newer encoding because it is
9089 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9090 if (raw_real_type
== NULL
)
9093 return raw_real_type
;
9096 /* The field in our XVS type is a reference to the base type. */
9097 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9100 /* The type of value designated by TYPE, with all aligners removed. */
9103 ada_aligned_type (struct type
*type
)
9105 if (ada_is_aligner_type (type
))
9106 return ada_aligned_type (type
->field (0).type ());
9108 return ada_get_base_type (type
);
9112 /* The address of the aligned value in an object at address VALADDR
9113 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9116 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9118 if (ada_is_aligner_type (type
))
9119 return ada_aligned_value_addr (type
->field (0).type (),
9121 TYPE_FIELD_BITPOS (type
,
9122 0) / TARGET_CHAR_BIT
);
9129 /* The printed representation of an enumeration literal with encoded
9130 name NAME. The value is good to the next call of ada_enum_name. */
9132 ada_enum_name (const char *name
)
9134 static char *result
;
9135 static size_t result_len
= 0;
9138 /* First, unqualify the enumeration name:
9139 1. Search for the last '.' character. If we find one, then skip
9140 all the preceding characters, the unqualified name starts
9141 right after that dot.
9142 2. Otherwise, we may be debugging on a target where the compiler
9143 translates dots into "__". Search forward for double underscores,
9144 but stop searching when we hit an overloading suffix, which is
9145 of the form "__" followed by digits. */
9147 tmp
= strrchr (name
, '.');
9152 while ((tmp
= strstr (name
, "__")) != NULL
)
9154 if (isdigit (tmp
[2]))
9165 if (name
[1] == 'U' || name
[1] == 'W')
9167 if (sscanf (name
+ 2, "%x", &v
) != 1)
9170 else if (((name
[1] >= '0' && name
[1] <= '9')
9171 || (name
[1] >= 'a' && name
[1] <= 'z'))
9174 GROW_VECT (result
, result_len
, 4);
9175 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9181 GROW_VECT (result
, result_len
, 16);
9182 if (isascii (v
) && isprint (v
))
9183 xsnprintf (result
, result_len
, "'%c'", v
);
9184 else if (name
[1] == 'U')
9185 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9187 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9193 tmp
= strstr (name
, "__");
9195 tmp
= strstr (name
, "$");
9198 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9199 strncpy (result
, name
, tmp
- name
);
9200 result
[tmp
- name
] = '\0';
9208 /* Evaluate the subexpression of EXP starting at *POS as for
9209 evaluate_type, updating *POS to point just past the evaluated
9212 static struct value
*
9213 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9215 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9218 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9221 static struct value
*
9222 unwrap_value (struct value
*val
)
9224 struct type
*type
= ada_check_typedef (value_type (val
));
9226 if (ada_is_aligner_type (type
))
9228 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9229 struct type
*val_type
= ada_check_typedef (value_type (v
));
9231 if (ada_type_name (val_type
) == NULL
)
9232 val_type
->set_name (ada_type_name (type
));
9234 return unwrap_value (v
);
9238 struct type
*raw_real_type
=
9239 ada_check_typedef (ada_get_base_type (type
));
9241 /* If there is no parallel XVS or XVE type, then the value is
9242 already unwrapped. Return it without further modification. */
9243 if ((type
== raw_real_type
)
9244 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9248 coerce_unspec_val_to_type
9249 (val
, ada_to_fixed_type (raw_real_type
, 0,
9250 value_address (val
),
9255 static struct value
*
9256 cast_from_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9259 = gnat_encoded_fixed_point_scaling_factor (value_type (arg
));
9260 arg
= value_cast (value_type (scale
), arg
);
9262 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9263 return value_cast (type
, arg
);
9266 static struct value
*
9267 cast_to_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9269 if (type
== value_type (arg
))
9272 struct value
*scale
= gnat_encoded_fixed_point_scaling_factor (type
);
9273 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9274 arg
= cast_from_gnat_encoded_fixed_point_type (value_type (scale
), arg
);
9276 arg
= value_cast (value_type (scale
), arg
);
9278 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9279 return value_cast (type
, arg
);
9282 /* Given two array types T1 and T2, return nonzero iff both arrays
9283 contain the same number of elements. */
9286 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9288 LONGEST lo1
, hi1
, lo2
, hi2
;
9290 /* Get the array bounds in order to verify that the size of
9291 the two arrays match. */
9292 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9293 || !get_array_bounds (t2
, &lo2
, &hi2
))
9294 error (_("unable to determine array bounds"));
9296 /* To make things easier for size comparison, normalize a bit
9297 the case of empty arrays by making sure that the difference
9298 between upper bound and lower bound is always -1. */
9304 return (hi1
- lo1
== hi2
- lo2
);
9307 /* Assuming that VAL is an array of integrals, and TYPE represents
9308 an array with the same number of elements, but with wider integral
9309 elements, return an array "casted" to TYPE. In practice, this
9310 means that the returned array is built by casting each element
9311 of the original array into TYPE's (wider) element type. */
9313 static struct value
*
9314 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9316 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9321 /* Verify that both val and type are arrays of scalars, and
9322 that the size of val's elements is smaller than the size
9323 of type's element. */
9324 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9325 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9326 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9327 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9328 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9329 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9331 if (!get_array_bounds (type
, &lo
, &hi
))
9332 error (_("unable to determine array bounds"));
9334 res
= allocate_value (type
);
9336 /* Promote each array element. */
9337 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9339 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9341 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9342 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9348 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9349 return the converted value. */
9351 static struct value
*
9352 coerce_for_assign (struct type
*type
, struct value
*val
)
9354 struct type
*type2
= value_type (val
);
9359 type2
= ada_check_typedef (type2
);
9360 type
= ada_check_typedef (type
);
9362 if (type2
->code () == TYPE_CODE_PTR
9363 && type
->code () == TYPE_CODE_ARRAY
)
9365 val
= ada_value_ind (val
);
9366 type2
= value_type (val
);
9369 if (type2
->code () == TYPE_CODE_ARRAY
9370 && type
->code () == TYPE_CODE_ARRAY
)
9372 if (!ada_same_array_size_p (type
, type2
))
9373 error (_("cannot assign arrays of different length"));
9375 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9376 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9377 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9378 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9380 /* Allow implicit promotion of the array elements to
9382 return ada_promote_array_of_integrals (type
, val
);
9385 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9386 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9387 error (_("Incompatible types in assignment"));
9388 deprecated_set_value_type (val
, type
);
9393 static struct value
*
9394 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9397 struct type
*type1
, *type2
;
9400 arg1
= coerce_ref (arg1
);
9401 arg2
= coerce_ref (arg2
);
9402 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9403 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9405 if (type1
->code () != TYPE_CODE_INT
9406 || type2
->code () != TYPE_CODE_INT
)
9407 return value_binop (arg1
, arg2
, op
);
9416 return value_binop (arg1
, arg2
, op
);
9419 v2
= value_as_long (arg2
);
9421 error (_("second operand of %s must not be zero."), op_string (op
));
9423 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9424 return value_binop (arg1
, arg2
, op
);
9426 v1
= value_as_long (arg1
);
9431 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9432 v
+= v
> 0 ? -1 : 1;
9440 /* Should not reach this point. */
9444 val
= allocate_value (type1
);
9445 store_unsigned_integer (value_contents_raw (val
),
9446 TYPE_LENGTH (value_type (val
)),
9447 type_byte_order (type1
), v
);
9452 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9454 if (ada_is_direct_array_type (value_type (arg1
))
9455 || ada_is_direct_array_type (value_type (arg2
)))
9457 struct type
*arg1_type
, *arg2_type
;
9459 /* Automatically dereference any array reference before
9460 we attempt to perform the comparison. */
9461 arg1
= ada_coerce_ref (arg1
);
9462 arg2
= ada_coerce_ref (arg2
);
9464 arg1
= ada_coerce_to_simple_array (arg1
);
9465 arg2
= ada_coerce_to_simple_array (arg2
);
9467 arg1_type
= ada_check_typedef (value_type (arg1
));
9468 arg2_type
= ada_check_typedef (value_type (arg2
));
9470 if (arg1_type
->code () != TYPE_CODE_ARRAY
9471 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9472 error (_("Attempt to compare array with non-array"));
9473 /* FIXME: The following works only for types whose
9474 representations use all bits (no padding or undefined bits)
9475 and do not have user-defined equality. */
9476 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9477 && memcmp (value_contents (arg1
), value_contents (arg2
),
9478 TYPE_LENGTH (arg1_type
)) == 0);
9480 return value_equal (arg1
, arg2
);
9483 /* Total number of component associations in the aggregate starting at
9484 index PC in EXP. Assumes that index PC is the start of an
9488 num_component_specs (struct expression
*exp
, int pc
)
9492 m
= exp
->elts
[pc
+ 1].longconst
;
9495 for (i
= 0; i
< m
; i
+= 1)
9497 switch (exp
->elts
[pc
].opcode
)
9503 n
+= exp
->elts
[pc
+ 1].longconst
;
9506 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9511 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9512 component of LHS (a simple array or a record), updating *POS past
9513 the expression, assuming that LHS is contained in CONTAINER. Does
9514 not modify the inferior's memory, nor does it modify LHS (unless
9515 LHS == CONTAINER). */
9518 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9519 struct expression
*exp
, int *pos
)
9521 struct value
*mark
= value_mark ();
9523 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9525 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9527 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9528 struct value
*index_val
= value_from_longest (index_type
, index
);
9530 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9534 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9535 elt
= ada_to_fixed_value (elt
);
9538 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9539 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9541 value_assign_to_component (container
, elt
,
9542 ada_evaluate_subexp (NULL
, exp
, pos
,
9545 value_free_to_mark (mark
);
9548 /* Assuming that LHS represents an lvalue having a record or array
9549 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9550 of that aggregate's value to LHS, advancing *POS past the
9551 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9552 lvalue containing LHS (possibly LHS itself). Does not modify
9553 the inferior's memory, nor does it modify the contents of
9554 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9556 static struct value
*
9557 assign_aggregate (struct value
*container
,
9558 struct value
*lhs
, struct expression
*exp
,
9559 int *pos
, enum noside noside
)
9561 struct type
*lhs_type
;
9562 int n
= exp
->elts
[*pos
+1].longconst
;
9563 LONGEST low_index
, high_index
;
9566 int max_indices
, num_indices
;
9570 if (noside
!= EVAL_NORMAL
)
9572 for (i
= 0; i
< n
; i
+= 1)
9573 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9577 container
= ada_coerce_ref (container
);
9578 if (ada_is_direct_array_type (value_type (container
)))
9579 container
= ada_coerce_to_simple_array (container
);
9580 lhs
= ada_coerce_ref (lhs
);
9581 if (!deprecated_value_modifiable (lhs
))
9582 error (_("Left operand of assignment is not a modifiable lvalue."));
9584 lhs_type
= check_typedef (value_type (lhs
));
9585 if (ada_is_direct_array_type (lhs_type
))
9587 lhs
= ada_coerce_to_simple_array (lhs
);
9588 lhs_type
= check_typedef (value_type (lhs
));
9589 low_index
= lhs_type
->bounds ()->low
.const_val ();
9590 high_index
= lhs_type
->bounds ()->high
.const_val ();
9592 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9595 high_index
= num_visible_fields (lhs_type
) - 1;
9598 error (_("Left-hand side must be array or record."));
9600 num_specs
= num_component_specs (exp
, *pos
- 3);
9601 max_indices
= 4 * num_specs
+ 4;
9602 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9603 indices
[0] = indices
[1] = low_index
- 1;
9604 indices
[2] = indices
[3] = high_index
+ 1;
9607 for (i
= 0; i
< n
; i
+= 1)
9609 switch (exp
->elts
[*pos
].opcode
)
9612 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9613 &num_indices
, max_indices
,
9614 low_index
, high_index
);
9617 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9618 &num_indices
, max_indices
,
9619 low_index
, high_index
);
9623 error (_("Misplaced 'others' clause"));
9624 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9625 num_indices
, low_index
, high_index
);
9628 error (_("Internal error: bad aggregate clause"));
9635 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9636 construct at *POS, updating *POS past the construct, given that
9637 the positions are relative to lower bound LOW, where HIGH is the
9638 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9639 updating *NUM_INDICES as needed. CONTAINER is as for
9640 assign_aggregate. */
9642 aggregate_assign_positional (struct value
*container
,
9643 struct value
*lhs
, struct expression
*exp
,
9644 int *pos
, LONGEST
*indices
, int *num_indices
,
9645 int max_indices
, LONGEST low
, LONGEST high
)
9647 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9649 if (ind
- 1 == high
)
9650 warning (_("Extra components in aggregate ignored."));
9653 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9655 assign_component (container
, lhs
, ind
, exp
, pos
);
9658 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9661 /* Assign into the components of LHS indexed by the OP_CHOICES
9662 construct at *POS, updating *POS past the construct, given that
9663 the allowable indices are LOW..HIGH. Record the indices assigned
9664 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9665 needed. CONTAINER is as for assign_aggregate. */
9667 aggregate_assign_from_choices (struct value
*container
,
9668 struct value
*lhs
, struct expression
*exp
,
9669 int *pos
, LONGEST
*indices
, int *num_indices
,
9670 int max_indices
, LONGEST low
, LONGEST high
)
9673 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9674 int choice_pos
, expr_pc
;
9675 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9677 choice_pos
= *pos
+= 3;
9679 for (j
= 0; j
< n_choices
; j
+= 1)
9680 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9682 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9684 for (j
= 0; j
< n_choices
; j
+= 1)
9686 LONGEST lower
, upper
;
9687 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9689 if (op
== OP_DISCRETE_RANGE
)
9692 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9694 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9699 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9711 name
= &exp
->elts
[choice_pos
+ 2].string
;
9714 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9717 error (_("Invalid record component association."));
9719 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9721 if (! find_struct_field (name
, value_type (lhs
), 0,
9722 NULL
, NULL
, NULL
, NULL
, &ind
))
9723 error (_("Unknown component name: %s."), name
);
9724 lower
= upper
= ind
;
9727 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9728 error (_("Index in component association out of bounds."));
9730 add_component_interval (lower
, upper
, indices
, num_indices
,
9732 while (lower
<= upper
)
9737 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9743 /* Assign the value of the expression in the OP_OTHERS construct in
9744 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9745 have not been previously assigned. The index intervals already assigned
9746 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9747 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9749 aggregate_assign_others (struct value
*container
,
9750 struct value
*lhs
, struct expression
*exp
,
9751 int *pos
, LONGEST
*indices
, int num_indices
,
9752 LONGEST low
, LONGEST high
)
9755 int expr_pc
= *pos
+ 1;
9757 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9761 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9766 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9769 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9772 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9773 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9774 modifying *SIZE as needed. It is an error if *SIZE exceeds
9775 MAX_SIZE. The resulting intervals do not overlap. */
9777 add_component_interval (LONGEST low
, LONGEST high
,
9778 LONGEST
* indices
, int *size
, int max_size
)
9782 for (i
= 0; i
< *size
; i
+= 2) {
9783 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9787 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9788 if (high
< indices
[kh
])
9790 if (low
< indices
[i
])
9792 indices
[i
+ 1] = indices
[kh
- 1];
9793 if (high
> indices
[i
+ 1])
9794 indices
[i
+ 1] = high
;
9795 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9796 *size
-= kh
- i
- 2;
9799 else if (high
< indices
[i
])
9803 if (*size
== max_size
)
9804 error (_("Internal error: miscounted aggregate components."));
9806 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9807 indices
[j
] = indices
[j
- 2];
9809 indices
[i
+ 1] = high
;
9812 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9815 static struct value
*
9816 ada_value_cast (struct type
*type
, struct value
*arg2
)
9818 if (type
== ada_check_typedef (value_type (arg2
)))
9821 if (ada_is_gnat_encoded_fixed_point_type (type
))
9822 return cast_to_gnat_encoded_fixed_point_type (type
, arg2
);
9824 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9825 return cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
9827 return value_cast (type
, arg2
);
9830 /* Evaluating Ada expressions, and printing their result.
9831 ------------------------------------------------------
9836 We usually evaluate an Ada expression in order to print its value.
9837 We also evaluate an expression in order to print its type, which
9838 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9839 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9840 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9841 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9844 Evaluating expressions is a little more complicated for Ada entities
9845 than it is for entities in languages such as C. The main reason for
9846 this is that Ada provides types whose definition might be dynamic.
9847 One example of such types is variant records. Or another example
9848 would be an array whose bounds can only be known at run time.
9850 The following description is a general guide as to what should be
9851 done (and what should NOT be done) in order to evaluate an expression
9852 involving such types, and when. This does not cover how the semantic
9853 information is encoded by GNAT as this is covered separatly. For the
9854 document used as the reference for the GNAT encoding, see exp_dbug.ads
9855 in the GNAT sources.
9857 Ideally, we should embed each part of this description next to its
9858 associated code. Unfortunately, the amount of code is so vast right
9859 now that it's hard to see whether the code handling a particular
9860 situation might be duplicated or not. One day, when the code is
9861 cleaned up, this guide might become redundant with the comments
9862 inserted in the code, and we might want to remove it.
9864 2. ``Fixing'' an Entity, the Simple Case:
9865 -----------------------------------------
9867 When evaluating Ada expressions, the tricky issue is that they may
9868 reference entities whose type contents and size are not statically
9869 known. Consider for instance a variant record:
9871 type Rec (Empty : Boolean := True) is record
9874 when False => Value : Integer;
9877 Yes : Rec := (Empty => False, Value => 1);
9878 No : Rec := (empty => True);
9880 The size and contents of that record depends on the value of the
9881 descriminant (Rec.Empty). At this point, neither the debugging
9882 information nor the associated type structure in GDB are able to
9883 express such dynamic types. So what the debugger does is to create
9884 "fixed" versions of the type that applies to the specific object.
9885 We also informally refer to this operation as "fixing" an object,
9886 which means creating its associated fixed type.
9888 Example: when printing the value of variable "Yes" above, its fixed
9889 type would look like this:
9896 On the other hand, if we printed the value of "No", its fixed type
9903 Things become a little more complicated when trying to fix an entity
9904 with a dynamic type that directly contains another dynamic type,
9905 such as an array of variant records, for instance. There are
9906 two possible cases: Arrays, and records.
9908 3. ``Fixing'' Arrays:
9909 ---------------------
9911 The type structure in GDB describes an array in terms of its bounds,
9912 and the type of its elements. By design, all elements in the array
9913 have the same type and we cannot represent an array of variant elements
9914 using the current type structure in GDB. When fixing an array,
9915 we cannot fix the array element, as we would potentially need one
9916 fixed type per element of the array. As a result, the best we can do
9917 when fixing an array is to produce an array whose bounds and size
9918 are correct (allowing us to read it from memory), but without having
9919 touched its element type. Fixing each element will be done later,
9920 when (if) necessary.
9922 Arrays are a little simpler to handle than records, because the same
9923 amount of memory is allocated for each element of the array, even if
9924 the amount of space actually used by each element differs from element
9925 to element. Consider for instance the following array of type Rec:
9927 type Rec_Array is array (1 .. 2) of Rec;
9929 The actual amount of memory occupied by each element might be different
9930 from element to element, depending on the value of their discriminant.
9931 But the amount of space reserved for each element in the array remains
9932 fixed regardless. So we simply need to compute that size using
9933 the debugging information available, from which we can then determine
9934 the array size (we multiply the number of elements of the array by
9935 the size of each element).
9937 The simplest case is when we have an array of a constrained element
9938 type. For instance, consider the following type declarations:
9940 type Bounded_String (Max_Size : Integer) is
9942 Buffer : String (1 .. Max_Size);
9944 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9946 In this case, the compiler describes the array as an array of
9947 variable-size elements (identified by its XVS suffix) for which
9948 the size can be read in the parallel XVZ variable.
9950 In the case of an array of an unconstrained element type, the compiler
9951 wraps the array element inside a private PAD type. This type should not
9952 be shown to the user, and must be "unwrap"'ed before printing. Note
9953 that we also use the adjective "aligner" in our code to designate
9954 these wrapper types.
9956 In some cases, the size allocated for each element is statically
9957 known. In that case, the PAD type already has the correct size,
9958 and the array element should remain unfixed.
9960 But there are cases when this size is not statically known.
9961 For instance, assuming that "Five" is an integer variable:
9963 type Dynamic is array (1 .. Five) of Integer;
9964 type Wrapper (Has_Length : Boolean := False) is record
9967 when True => Length : Integer;
9971 type Wrapper_Array is array (1 .. 2) of Wrapper;
9973 Hello : Wrapper_Array := (others => (Has_Length => True,
9974 Data => (others => 17),
9978 The debugging info would describe variable Hello as being an
9979 array of a PAD type. The size of that PAD type is not statically
9980 known, but can be determined using a parallel XVZ variable.
9981 In that case, a copy of the PAD type with the correct size should
9982 be used for the fixed array.
9984 3. ``Fixing'' record type objects:
9985 ----------------------------------
9987 Things are slightly different from arrays in the case of dynamic
9988 record types. In this case, in order to compute the associated
9989 fixed type, we need to determine the size and offset of each of
9990 its components. This, in turn, requires us to compute the fixed
9991 type of each of these components.
9993 Consider for instance the example:
9995 type Bounded_String (Max_Size : Natural) is record
9996 Str : String (1 .. Max_Size);
9999 My_String : Bounded_String (Max_Size => 10);
10001 In that case, the position of field "Length" depends on the size
10002 of field Str, which itself depends on the value of the Max_Size
10003 discriminant. In order to fix the type of variable My_String,
10004 we need to fix the type of field Str. Therefore, fixing a variant
10005 record requires us to fix each of its components.
10007 However, if a component does not have a dynamic size, the component
10008 should not be fixed. In particular, fields that use a PAD type
10009 should not fixed. Here is an example where this might happen
10010 (assuming type Rec above):
10012 type Container (Big : Boolean) is record
10016 when True => Another : Integer;
10017 when False => null;
10020 My_Container : Container := (Big => False,
10021 First => (Empty => True),
10024 In that example, the compiler creates a PAD type for component First,
10025 whose size is constant, and then positions the component After just
10026 right after it. The offset of component After is therefore constant
10029 The debugger computes the position of each field based on an algorithm
10030 that uses, among other things, the actual position and size of the field
10031 preceding it. Let's now imagine that the user is trying to print
10032 the value of My_Container. If the type fixing was recursive, we would
10033 end up computing the offset of field After based on the size of the
10034 fixed version of field First. And since in our example First has
10035 only one actual field, the size of the fixed type is actually smaller
10036 than the amount of space allocated to that field, and thus we would
10037 compute the wrong offset of field After.
10039 To make things more complicated, we need to watch out for dynamic
10040 components of variant records (identified by the ___XVL suffix in
10041 the component name). Even if the target type is a PAD type, the size
10042 of that type might not be statically known. So the PAD type needs
10043 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10044 we might end up with the wrong size for our component. This can be
10045 observed with the following type declarations:
10047 type Octal is new Integer range 0 .. 7;
10048 type Octal_Array is array (Positive range <>) of Octal;
10049 pragma Pack (Octal_Array);
10051 type Octal_Buffer (Size : Positive) is record
10052 Buffer : Octal_Array (1 .. Size);
10056 In that case, Buffer is a PAD type whose size is unset and needs
10057 to be computed by fixing the unwrapped type.
10059 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10060 ----------------------------------------------------------
10062 Lastly, when should the sub-elements of an entity that remained unfixed
10063 thus far, be actually fixed?
10065 The answer is: Only when referencing that element. For instance
10066 when selecting one component of a record, this specific component
10067 should be fixed at that point in time. Or when printing the value
10068 of a record, each component should be fixed before its value gets
10069 printed. Similarly for arrays, the element of the array should be
10070 fixed when printing each element of the array, or when extracting
10071 one element out of that array. On the other hand, fixing should
10072 not be performed on the elements when taking a slice of an array!
10074 Note that one of the side effects of miscomputing the offset and
10075 size of each field is that we end up also miscomputing the size
10076 of the containing type. This can have adverse results when computing
10077 the value of an entity. GDB fetches the value of an entity based
10078 on the size of its type, and thus a wrong size causes GDB to fetch
10079 the wrong amount of memory. In the case where the computed size is
10080 too small, GDB fetches too little data to print the value of our
10081 entity. Results in this case are unpredictable, as we usually read
10082 past the buffer containing the data =:-o. */
10084 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10085 for that subexpression cast to TO_TYPE. Advance *POS over the
10089 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10090 enum noside noside
, struct type
*to_type
)
10094 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10095 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10100 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10102 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10103 return value_zero (to_type
, not_lval
);
10105 val
= evaluate_var_msym_value (noside
,
10106 exp
->elts
[pc
+ 1].objfile
,
10107 exp
->elts
[pc
+ 2].msymbol
);
10110 val
= evaluate_var_value (noside
,
10111 exp
->elts
[pc
+ 1].block
,
10112 exp
->elts
[pc
+ 2].symbol
);
10114 if (noside
== EVAL_SKIP
)
10115 return eval_skip_value (exp
);
10117 val
= ada_value_cast (to_type
, val
);
10119 /* Follow the Ada language semantics that do not allow taking
10120 an address of the result of a cast (view conversion in Ada). */
10121 if (VALUE_LVAL (val
) == lval_memory
)
10123 if (value_lazy (val
))
10124 value_fetch_lazy (val
);
10125 VALUE_LVAL (val
) = not_lval
;
10130 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10131 if (noside
== EVAL_SKIP
)
10132 return eval_skip_value (exp
);
10133 return ada_value_cast (to_type
, val
);
10136 /* Implement the evaluate_exp routine in the exp_descriptor structure
10137 for the Ada language. */
10139 static struct value
*
10140 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10141 int *pos
, enum noside noside
)
10143 enum exp_opcode op
;
10147 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10150 struct value
**argvec
;
10154 op
= exp
->elts
[pc
].opcode
;
10160 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10162 if (noside
== EVAL_NORMAL
)
10163 arg1
= unwrap_value (arg1
);
10165 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10166 then we need to perform the conversion manually, because
10167 evaluate_subexp_standard doesn't do it. This conversion is
10168 necessary in Ada because the different kinds of float/fixed
10169 types in Ada have different representations.
10171 Similarly, we need to perform the conversion from OP_LONG
10173 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10174 arg1
= ada_value_cast (expect_type
, arg1
);
10180 struct value
*result
;
10183 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10184 /* The result type will have code OP_STRING, bashed there from
10185 OP_ARRAY. Bash it back. */
10186 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10187 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10193 type
= exp
->elts
[pc
+ 1].type
;
10194 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10198 type
= exp
->elts
[pc
+ 1].type
;
10199 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10202 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10203 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10205 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10206 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10208 return ada_value_assign (arg1
, arg1
);
10210 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10211 except if the lhs of our assignment is a convenience variable.
10212 In the case of assigning to a convenience variable, the lhs
10213 should be exactly the result of the evaluation of the rhs. */
10214 type
= value_type (arg1
);
10215 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10217 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10218 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10220 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10224 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10225 arg2
= cast_to_gnat_encoded_fixed_point_type (value_type (arg1
), arg2
);
10226 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10228 (_("Fixed-point values must be assigned to fixed-point variables"));
10230 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10231 return ada_value_assign (arg1
, arg2
);
10234 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10235 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10236 if (noside
== EVAL_SKIP
)
10238 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10239 return (value_from_longest
10240 (value_type (arg1
),
10241 value_as_long (arg1
) + value_as_long (arg2
)));
10242 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10243 return (value_from_longest
10244 (value_type (arg2
),
10245 value_as_long (arg1
) + value_as_long (arg2
)));
10246 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10247 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10248 && value_type (arg1
) != value_type (arg2
))
10249 error (_("Operands of fixed-point addition must have the same type"));
10250 /* Do the addition, and cast the result to the type of the first
10251 argument. We cannot cast the result to a reference type, so if
10252 ARG1 is a reference type, find its underlying type. */
10253 type
= value_type (arg1
);
10254 while (type
->code () == TYPE_CODE_REF
)
10255 type
= TYPE_TARGET_TYPE (type
);
10256 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10257 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10260 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10261 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10262 if (noside
== EVAL_SKIP
)
10264 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10265 return (value_from_longest
10266 (value_type (arg1
),
10267 value_as_long (arg1
) - value_as_long (arg2
)));
10268 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10269 return (value_from_longest
10270 (value_type (arg2
),
10271 value_as_long (arg1
) - value_as_long (arg2
)));
10272 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10273 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10274 && value_type (arg1
) != value_type (arg2
))
10275 error (_("Operands of fixed-point subtraction "
10276 "must have the same type"));
10277 /* Do the substraction, and cast the result to the type of the first
10278 argument. We cannot cast the result to a reference type, so if
10279 ARG1 is a reference type, find its underlying type. */
10280 type
= value_type (arg1
);
10281 while (type
->code () == TYPE_CODE_REF
)
10282 type
= TYPE_TARGET_TYPE (type
);
10283 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10284 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10290 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10291 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10292 if (noside
== EVAL_SKIP
)
10294 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10296 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10297 return value_zero (value_type (arg1
), not_lval
);
10301 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10302 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10303 arg1
= cast_from_gnat_encoded_fixed_point_type (type
, arg1
);
10304 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10305 arg2
= cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
10306 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10307 return ada_value_binop (arg1
, arg2
, op
);
10311 case BINOP_NOTEQUAL
:
10312 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10313 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10314 if (noside
== EVAL_SKIP
)
10316 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10320 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10321 tem
= ada_value_equal (arg1
, arg2
);
10323 if (op
== BINOP_NOTEQUAL
)
10325 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10326 return value_from_longest (type
, (LONGEST
) tem
);
10329 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10330 if (noside
== EVAL_SKIP
)
10332 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10333 return value_cast (value_type (arg1
), value_neg (arg1
));
10336 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10337 return value_neg (arg1
);
10340 case BINOP_LOGICAL_AND
:
10341 case BINOP_LOGICAL_OR
:
10342 case UNOP_LOGICAL_NOT
:
10347 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10348 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10349 return value_cast (type
, val
);
10352 case BINOP_BITWISE_AND
:
10353 case BINOP_BITWISE_IOR
:
10354 case BINOP_BITWISE_XOR
:
10358 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10360 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10362 return value_cast (value_type (arg1
), val
);
10368 if (noside
== EVAL_SKIP
)
10374 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10375 /* Only encountered when an unresolved symbol occurs in a
10376 context other than a function call, in which case, it is
10378 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10379 exp
->elts
[pc
+ 2].symbol
->print_name ());
10381 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10383 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10384 /* Check to see if this is a tagged type. We also need to handle
10385 the case where the type is a reference to a tagged type, but
10386 we have to be careful to exclude pointers to tagged types.
10387 The latter should be shown as usual (as a pointer), whereas
10388 a reference should mostly be transparent to the user. */
10389 if (ada_is_tagged_type (type
, 0)
10390 || (type
->code () == TYPE_CODE_REF
10391 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10393 /* Tagged types are a little special in the fact that the real
10394 type is dynamic and can only be determined by inspecting the
10395 object's tag. This means that we need to get the object's
10396 value first (EVAL_NORMAL) and then extract the actual object
10399 Note that we cannot skip the final step where we extract
10400 the object type from its tag, because the EVAL_NORMAL phase
10401 results in dynamic components being resolved into fixed ones.
10402 This can cause problems when trying to print the type
10403 description of tagged types whose parent has a dynamic size:
10404 We use the type name of the "_parent" component in order
10405 to print the name of the ancestor type in the type description.
10406 If that component had a dynamic size, the resolution into
10407 a fixed type would result in the loss of that type name,
10408 thus preventing us from printing the name of the ancestor
10409 type in the type description. */
10410 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10412 if (type
->code () != TYPE_CODE_REF
)
10414 struct type
*actual_type
;
10416 actual_type
= type_from_tag (ada_value_tag (arg1
));
10417 if (actual_type
== NULL
)
10418 /* If, for some reason, we were unable to determine
10419 the actual type from the tag, then use the static
10420 approximation that we just computed as a fallback.
10421 This can happen if the debugging information is
10422 incomplete, for instance. */
10423 actual_type
= type
;
10424 return value_zero (actual_type
, not_lval
);
10428 /* In the case of a ref, ada_coerce_ref takes care
10429 of determining the actual type. But the evaluation
10430 should return a ref as it should be valid to ask
10431 for its address; so rebuild a ref after coerce. */
10432 arg1
= ada_coerce_ref (arg1
);
10433 return value_ref (arg1
, TYPE_CODE_REF
);
10437 /* Records and unions for which GNAT encodings have been
10438 generated need to be statically fixed as well.
10439 Otherwise, non-static fixing produces a type where
10440 all dynamic properties are removed, which prevents "ptype"
10441 from being able to completely describe the type.
10442 For instance, a case statement in a variant record would be
10443 replaced by the relevant components based on the actual
10444 value of the discriminants. */
10445 if ((type
->code () == TYPE_CODE_STRUCT
10446 && dynamic_template_type (type
) != NULL
)
10447 || (type
->code () == TYPE_CODE_UNION
10448 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10451 return value_zero (to_static_fixed_type (type
), not_lval
);
10455 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10456 return ada_to_fixed_value (arg1
);
10461 /* Allocate arg vector, including space for the function to be
10462 called in argvec[0] and a terminating NULL. */
10463 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10464 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10466 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10467 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10468 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10469 exp
->elts
[pc
+ 5].symbol
->print_name ());
10472 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10473 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10476 if (noside
== EVAL_SKIP
)
10480 if (ada_is_constrained_packed_array_type
10481 (desc_base_type (value_type (argvec
[0]))))
10482 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10483 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10484 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10485 /* This is a packed array that has already been fixed, and
10486 therefore already coerced to a simple array. Nothing further
10489 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10491 /* Make sure we dereference references so that all the code below
10492 feels like it's really handling the referenced value. Wrapping
10493 types (for alignment) may be there, so make sure we strip them as
10495 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10497 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10498 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10499 argvec
[0] = value_addr (argvec
[0]);
10501 type
= ada_check_typedef (value_type (argvec
[0]));
10503 /* Ada allows us to implicitly dereference arrays when subscripting
10504 them. So, if this is an array typedef (encoding use for array
10505 access types encoded as fat pointers), strip it now. */
10506 if (type
->code () == TYPE_CODE_TYPEDEF
)
10507 type
= ada_typedef_target_type (type
);
10509 if (type
->code () == TYPE_CODE_PTR
)
10511 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10513 case TYPE_CODE_FUNC
:
10514 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10516 case TYPE_CODE_ARRAY
:
10518 case TYPE_CODE_STRUCT
:
10519 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10520 argvec
[0] = ada_value_ind (argvec
[0]);
10521 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10524 error (_("cannot subscript or call something of type `%s'"),
10525 ada_type_name (value_type (argvec
[0])));
10530 switch (type
->code ())
10532 case TYPE_CODE_FUNC
:
10533 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10535 if (TYPE_TARGET_TYPE (type
) == NULL
)
10536 error_call_unknown_return_type (NULL
);
10537 return allocate_value (TYPE_TARGET_TYPE (type
));
10539 return call_function_by_hand (argvec
[0], NULL
,
10540 gdb::make_array_view (argvec
+ 1,
10542 case TYPE_CODE_INTERNAL_FUNCTION
:
10543 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10544 /* We don't know anything about what the internal
10545 function might return, but we have to return
10547 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10550 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10551 argvec
[0], nargs
, argvec
+ 1);
10553 case TYPE_CODE_STRUCT
:
10557 arity
= ada_array_arity (type
);
10558 type
= ada_array_element_type (type
, nargs
);
10560 error (_("cannot subscript or call a record"));
10561 if (arity
!= nargs
)
10562 error (_("wrong number of subscripts; expecting %d"), arity
);
10563 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10564 return value_zero (ada_aligned_type (type
), lval_memory
);
10566 unwrap_value (ada_value_subscript
10567 (argvec
[0], nargs
, argvec
+ 1));
10569 case TYPE_CODE_ARRAY
:
10570 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10572 type
= ada_array_element_type (type
, nargs
);
10574 error (_("element type of array unknown"));
10576 return value_zero (ada_aligned_type (type
), lval_memory
);
10579 unwrap_value (ada_value_subscript
10580 (ada_coerce_to_simple_array (argvec
[0]),
10581 nargs
, argvec
+ 1));
10582 case TYPE_CODE_PTR
: /* Pointer to array */
10583 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10585 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10586 type
= ada_array_element_type (type
, nargs
);
10588 error (_("element type of array unknown"));
10590 return value_zero (ada_aligned_type (type
), lval_memory
);
10593 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10594 nargs
, argvec
+ 1));
10597 error (_("Attempt to index or call something other than an "
10598 "array or function"));
10603 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10604 struct value
*low_bound_val
10605 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10606 struct value
*high_bound_val
10607 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10609 LONGEST high_bound
;
10611 low_bound_val
= coerce_ref (low_bound_val
);
10612 high_bound_val
= coerce_ref (high_bound_val
);
10613 low_bound
= value_as_long (low_bound_val
);
10614 high_bound
= value_as_long (high_bound_val
);
10616 if (noside
== EVAL_SKIP
)
10619 /* If this is a reference to an aligner type, then remove all
10621 if (value_type (array
)->code () == TYPE_CODE_REF
10622 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10623 TYPE_TARGET_TYPE (value_type (array
)) =
10624 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10626 if (ada_is_any_packed_array_type (value_type (array
)))
10627 error (_("cannot slice a packed array"));
10629 /* If this is a reference to an array or an array lvalue,
10630 convert to a pointer. */
10631 if (value_type (array
)->code () == TYPE_CODE_REF
10632 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10633 && VALUE_LVAL (array
) == lval_memory
))
10634 array
= value_addr (array
);
10636 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10637 && ada_is_array_descriptor_type (ada_check_typedef
10638 (value_type (array
))))
10639 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10642 array
= ada_coerce_to_simple_array_ptr (array
);
10644 /* If we have more than one level of pointer indirection,
10645 dereference the value until we get only one level. */
10646 while (value_type (array
)->code () == TYPE_CODE_PTR
10647 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10649 array
= value_ind (array
);
10651 /* Make sure we really do have an array type before going further,
10652 to avoid a SEGV when trying to get the index type or the target
10653 type later down the road if the debug info generated by
10654 the compiler is incorrect or incomplete. */
10655 if (!ada_is_simple_array_type (value_type (array
)))
10656 error (_("cannot take slice of non-array"));
10658 if (ada_check_typedef (value_type (array
))->code ()
10661 struct type
*type0
= ada_check_typedef (value_type (array
));
10663 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10664 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10667 struct type
*arr_type0
=
10668 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10670 return ada_value_slice_from_ptr (array
, arr_type0
,
10671 longest_to_int (low_bound
),
10672 longest_to_int (high_bound
));
10675 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10677 else if (high_bound
< low_bound
)
10678 return empty_array (value_type (array
), low_bound
, high_bound
);
10680 return ada_value_slice (array
, longest_to_int (low_bound
),
10681 longest_to_int (high_bound
));
10684 case UNOP_IN_RANGE
:
10686 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10687 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10689 if (noside
== EVAL_SKIP
)
10692 switch (type
->code ())
10695 lim_warning (_("Membership test incompletely implemented; "
10696 "always returns true"));
10697 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10698 return value_from_longest (type
, (LONGEST
) 1);
10700 case TYPE_CODE_RANGE
:
10701 arg2
= value_from_longest (type
,
10702 type
->bounds ()->low
.const_val ());
10703 arg3
= value_from_longest (type
,
10704 type
->bounds ()->high
.const_val ());
10705 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10706 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10707 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10709 value_from_longest (type
,
10710 (value_less (arg1
, arg3
)
10711 || value_equal (arg1
, arg3
))
10712 && (value_less (arg2
, arg1
)
10713 || value_equal (arg2
, arg1
)));
10716 case BINOP_IN_BOUNDS
:
10718 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10719 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10721 if (noside
== EVAL_SKIP
)
10724 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10726 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10727 return value_zero (type
, not_lval
);
10730 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10732 type
= ada_index_type (value_type (arg2
), tem
, "range");
10734 type
= value_type (arg1
);
10736 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10737 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10739 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10740 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10741 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10743 value_from_longest (type
,
10744 (value_less (arg1
, arg3
)
10745 || value_equal (arg1
, arg3
))
10746 && (value_less (arg2
, arg1
)
10747 || value_equal (arg2
, arg1
)));
10749 case TERNOP_IN_RANGE
:
10750 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10751 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10752 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10754 if (noside
== EVAL_SKIP
)
10757 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10758 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10759 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10761 value_from_longest (type
,
10762 (value_less (arg1
, arg3
)
10763 || value_equal (arg1
, arg3
))
10764 && (value_less (arg2
, arg1
)
10765 || value_equal (arg2
, arg1
)));
10769 case OP_ATR_LENGTH
:
10771 struct type
*type_arg
;
10773 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10775 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10777 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10781 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10785 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10786 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10787 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10790 if (noside
== EVAL_SKIP
)
10792 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10794 if (type_arg
== NULL
)
10795 type_arg
= value_type (arg1
);
10797 if (ada_is_constrained_packed_array_type (type_arg
))
10798 type_arg
= decode_constrained_packed_array_type (type_arg
);
10800 if (!discrete_type_p (type_arg
))
10804 default: /* Should never happen. */
10805 error (_("unexpected attribute encountered"));
10808 type_arg
= ada_index_type (type_arg
, tem
,
10809 ada_attribute_name (op
));
10811 case OP_ATR_LENGTH
:
10812 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10817 return value_zero (type_arg
, not_lval
);
10819 else if (type_arg
== NULL
)
10821 arg1
= ada_coerce_ref (arg1
);
10823 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10824 arg1
= ada_coerce_to_simple_array (arg1
);
10826 if (op
== OP_ATR_LENGTH
)
10827 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10830 type
= ada_index_type (value_type (arg1
), tem
,
10831 ada_attribute_name (op
));
10833 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10838 default: /* Should never happen. */
10839 error (_("unexpected attribute encountered"));
10841 return value_from_longest
10842 (type
, ada_array_bound (arg1
, tem
, 0));
10844 return value_from_longest
10845 (type
, ada_array_bound (arg1
, tem
, 1));
10846 case OP_ATR_LENGTH
:
10847 return value_from_longest
10848 (type
, ada_array_length (arg1
, tem
));
10851 else if (discrete_type_p (type_arg
))
10853 struct type
*range_type
;
10854 const char *name
= ada_type_name (type_arg
);
10857 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10858 range_type
= to_fixed_range_type (type_arg
, NULL
);
10859 if (range_type
== NULL
)
10860 range_type
= type_arg
;
10864 error (_("unexpected attribute encountered"));
10866 return value_from_longest
10867 (range_type
, ada_discrete_type_low_bound (range_type
));
10869 return value_from_longest
10870 (range_type
, ada_discrete_type_high_bound (range_type
));
10871 case OP_ATR_LENGTH
:
10872 error (_("the 'length attribute applies only to array types"));
10875 else if (type_arg
->code () == TYPE_CODE_FLT
)
10876 error (_("unimplemented type attribute"));
10881 if (ada_is_constrained_packed_array_type (type_arg
))
10882 type_arg
= decode_constrained_packed_array_type (type_arg
);
10884 if (op
== OP_ATR_LENGTH
)
10885 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10888 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10890 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10896 error (_("unexpected attribute encountered"));
10898 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10899 return value_from_longest (type
, low
);
10901 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10902 return value_from_longest (type
, high
);
10903 case OP_ATR_LENGTH
:
10904 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10905 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10906 return value_from_longest (type
, high
- low
+ 1);
10912 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10913 if (noside
== EVAL_SKIP
)
10916 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10917 return value_zero (ada_tag_type (arg1
), not_lval
);
10919 return ada_value_tag (arg1
);
10923 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10924 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10925 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10926 if (noside
== EVAL_SKIP
)
10928 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10929 return value_zero (value_type (arg1
), not_lval
);
10932 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10933 return value_binop (arg1
, arg2
,
10934 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10937 case OP_ATR_MODULUS
:
10939 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10941 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10942 if (noside
== EVAL_SKIP
)
10945 if (!ada_is_modular_type (type_arg
))
10946 error (_("'modulus must be applied to modular type"));
10948 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10949 ada_modulus (type_arg
));
10954 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10955 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10956 if (noside
== EVAL_SKIP
)
10958 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10959 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10960 return value_zero (type
, not_lval
);
10962 return value_pos_atr (type
, arg1
);
10965 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10966 type
= value_type (arg1
);
10968 /* If the argument is a reference, then dereference its type, since
10969 the user is really asking for the size of the actual object,
10970 not the size of the pointer. */
10971 if (type
->code () == TYPE_CODE_REF
)
10972 type
= TYPE_TARGET_TYPE (type
);
10974 if (noside
== EVAL_SKIP
)
10976 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10977 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10979 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10980 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10983 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10984 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10985 type
= exp
->elts
[pc
+ 2].type
;
10986 if (noside
== EVAL_SKIP
)
10988 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10989 return value_zero (type
, not_lval
);
10991 return value_val_atr (type
, arg1
);
10994 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10995 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10996 if (noside
== EVAL_SKIP
)
10998 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10999 return value_zero (value_type (arg1
), not_lval
);
11002 /* For integer exponentiation operations,
11003 only promote the first argument. */
11004 if (is_integral_type (value_type (arg2
)))
11005 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11007 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11009 return value_binop (arg1
, arg2
, op
);
11013 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11014 if (noside
== EVAL_SKIP
)
11020 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11021 if (noside
== EVAL_SKIP
)
11023 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11024 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11025 return value_neg (arg1
);
11030 preeval_pos
= *pos
;
11031 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11032 if (noside
== EVAL_SKIP
)
11034 type
= ada_check_typedef (value_type (arg1
));
11035 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11037 if (ada_is_array_descriptor_type (type
))
11038 /* GDB allows dereferencing GNAT array descriptors. */
11040 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11042 if (arrType
== NULL
)
11043 error (_("Attempt to dereference null array pointer."));
11044 return value_at_lazy (arrType
, 0);
11046 else if (type
->code () == TYPE_CODE_PTR
11047 || type
->code () == TYPE_CODE_REF
11048 /* In C you can dereference an array to get the 1st elt. */
11049 || type
->code () == TYPE_CODE_ARRAY
)
11051 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11052 only be determined by inspecting the object's tag.
11053 This means that we need to evaluate completely the
11054 expression in order to get its type. */
11056 if ((type
->code () == TYPE_CODE_REF
11057 || type
->code () == TYPE_CODE_PTR
)
11058 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11061 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11062 type
= value_type (ada_value_ind (arg1
));
11066 type
= to_static_fixed_type
11068 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11070 ada_ensure_varsize_limit (type
);
11071 return value_zero (type
, lval_memory
);
11073 else if (type
->code () == TYPE_CODE_INT
)
11075 /* GDB allows dereferencing an int. */
11076 if (expect_type
== NULL
)
11077 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11082 to_static_fixed_type (ada_aligned_type (expect_type
));
11083 return value_zero (expect_type
, lval_memory
);
11087 error (_("Attempt to take contents of a non-pointer value."));
11089 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11090 type
= ada_check_typedef (value_type (arg1
));
11092 if (type
->code () == TYPE_CODE_INT
)
11093 /* GDB allows dereferencing an int. If we were given
11094 the expect_type, then use that as the target type.
11095 Otherwise, assume that the target type is an int. */
11097 if (expect_type
!= NULL
)
11098 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11101 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11102 (CORE_ADDR
) value_as_address (arg1
));
11105 if (ada_is_array_descriptor_type (type
))
11106 /* GDB allows dereferencing GNAT array descriptors. */
11107 return ada_coerce_to_simple_array (arg1
);
11109 return ada_value_ind (arg1
);
11111 case STRUCTOP_STRUCT
:
11112 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11113 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11114 preeval_pos
= *pos
;
11115 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11116 if (noside
== EVAL_SKIP
)
11118 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11120 struct type
*type1
= value_type (arg1
);
11122 if (ada_is_tagged_type (type1
, 1))
11124 type
= ada_lookup_struct_elt_type (type1
,
11125 &exp
->elts
[pc
+ 2].string
,
11128 /* If the field is not found, check if it exists in the
11129 extension of this object's type. This means that we
11130 need to evaluate completely the expression. */
11135 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11136 arg1
= ada_value_struct_elt (arg1
,
11137 &exp
->elts
[pc
+ 2].string
,
11139 arg1
= unwrap_value (arg1
);
11140 type
= value_type (ada_to_fixed_value (arg1
));
11145 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11148 return value_zero (ada_aligned_type (type
), lval_memory
);
11152 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11153 arg1
= unwrap_value (arg1
);
11154 return ada_to_fixed_value (arg1
);
11158 /* The value is not supposed to be used. This is here to make it
11159 easier to accommodate expressions that contain types. */
11161 if (noside
== EVAL_SKIP
)
11163 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11164 return allocate_value (exp
->elts
[pc
+ 1].type
);
11166 error (_("Attempt to use a type name as an expression"));
11171 case OP_DISCRETE_RANGE
:
11172 case OP_POSITIONAL
:
11174 if (noside
== EVAL_NORMAL
)
11178 error (_("Undefined name, ambiguous name, or renaming used in "
11179 "component association: %s."), &exp
->elts
[pc
+2].string
);
11181 error (_("Aggregates only allowed on the right of an assignment"));
11183 internal_error (__FILE__
, __LINE__
,
11184 _("aggregate apparently mangled"));
11187 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11189 for (tem
= 0; tem
< nargs
; tem
+= 1)
11190 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11195 return eval_skip_value (exp
);
11201 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11202 type name that encodes the 'small and 'delta information.
11203 Otherwise, return NULL. */
11205 static const char *
11206 gnat_encoded_fixed_point_type_info (struct type
*type
)
11208 const char *name
= ada_type_name (type
);
11209 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11211 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11213 const char *tail
= strstr (name
, "___XF_");
11220 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11221 return gnat_encoded_fixed_point_type_info (TYPE_TARGET_TYPE (type
));
11226 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11229 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11231 return gnat_encoded_fixed_point_type_info (type
) != NULL
;
11234 /* Return non-zero iff TYPE represents a System.Address type. */
11237 ada_is_system_address_type (struct type
*type
)
11239 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11242 /* Assuming that TYPE is the representation of an Ada fixed-point
11243 type, return the target floating-point type to be used to represent
11244 of this type during internal computation. */
11246 static struct type
*
11247 ada_scaling_type (struct type
*type
)
11249 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11252 /* Assuming that TYPE is the representation of an Ada fixed-point
11253 type, return its delta, or NULL if the type is malformed and the
11254 delta cannot be determined. */
11257 gnat_encoded_fixed_point_delta (struct type
*type
)
11259 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11260 struct type
*scale_type
= ada_scaling_type (type
);
11262 long long num
, den
;
11264 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11267 return value_binop (value_from_longest (scale_type
, num
),
11268 value_from_longest (scale_type
, den
), BINOP_DIV
);
11271 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11272 the scaling factor ('SMALL value) associated with the type. */
11275 gnat_encoded_fixed_point_scaling_factor (struct type
*type
)
11277 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11278 struct type
*scale_type
= ada_scaling_type (type
);
11280 long long num0
, den0
, num1
, den1
;
11283 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11284 &num0
, &den0
, &num1
, &den1
);
11287 return value_from_longest (scale_type
, 1);
11289 return value_binop (value_from_longest (scale_type
, num1
),
11290 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11292 return value_binop (value_from_longest (scale_type
, num0
),
11293 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11300 /* Scan STR beginning at position K for a discriminant name, and
11301 return the value of that discriminant field of DVAL in *PX. If
11302 PNEW_K is not null, put the position of the character beyond the
11303 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11304 not alter *PX and *PNEW_K if unsuccessful. */
11307 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11310 static char *bound_buffer
= NULL
;
11311 static size_t bound_buffer_len
= 0;
11312 const char *pstart
, *pend
, *bound
;
11313 struct value
*bound_val
;
11315 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11319 pend
= strstr (pstart
, "__");
11323 k
+= strlen (bound
);
11327 int len
= pend
- pstart
;
11329 /* Strip __ and beyond. */
11330 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11331 strncpy (bound_buffer
, pstart
, len
);
11332 bound_buffer
[len
] = '\0';
11334 bound
= bound_buffer
;
11338 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11339 if (bound_val
== NULL
)
11342 *px
= value_as_long (bound_val
);
11343 if (pnew_k
!= NULL
)
11348 /* Value of variable named NAME in the current environment. If
11349 no such variable found, then if ERR_MSG is null, returns 0, and
11350 otherwise causes an error with message ERR_MSG. */
11352 static struct value
*
11353 get_var_value (const char *name
, const char *err_msg
)
11355 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11357 std::vector
<struct block_symbol
> syms
;
11358 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11359 get_selected_block (0),
11360 VAR_DOMAIN
, &syms
, 1);
11364 if (err_msg
== NULL
)
11367 error (("%s"), err_msg
);
11370 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11373 /* Value of integer variable named NAME in the current environment.
11374 If no such variable is found, returns false. Otherwise, sets VALUE
11375 to the variable's value and returns true. */
11378 get_int_var_value (const char *name
, LONGEST
&value
)
11380 struct value
*var_val
= get_var_value (name
, 0);
11385 value
= value_as_long (var_val
);
11390 /* Return a range type whose base type is that of the range type named
11391 NAME in the current environment, and whose bounds are calculated
11392 from NAME according to the GNAT range encoding conventions.
11393 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11394 corresponding range type from debug information; fall back to using it
11395 if symbol lookup fails. If a new type must be created, allocate it
11396 like ORIG_TYPE was. The bounds information, in general, is encoded
11397 in NAME, the base type given in the named range type. */
11399 static struct type
*
11400 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11403 struct type
*base_type
;
11404 const char *subtype_info
;
11406 gdb_assert (raw_type
!= NULL
);
11407 gdb_assert (raw_type
->name () != NULL
);
11409 if (raw_type
->code () == TYPE_CODE_RANGE
)
11410 base_type
= TYPE_TARGET_TYPE (raw_type
);
11412 base_type
= raw_type
;
11414 name
= raw_type
->name ();
11415 subtype_info
= strstr (name
, "___XD");
11416 if (subtype_info
== NULL
)
11418 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11419 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11421 if (L
< INT_MIN
|| U
> INT_MAX
)
11424 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11429 static char *name_buf
= NULL
;
11430 static size_t name_len
= 0;
11431 int prefix_len
= subtype_info
- name
;
11434 const char *bounds_str
;
11437 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11438 strncpy (name_buf
, name
, prefix_len
);
11439 name_buf
[prefix_len
] = '\0';
11442 bounds_str
= strchr (subtype_info
, '_');
11445 if (*subtype_info
== 'L')
11447 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11448 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11450 if (bounds_str
[n
] == '_')
11452 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11458 strcpy (name_buf
+ prefix_len
, "___L");
11459 if (!get_int_var_value (name_buf
, L
))
11461 lim_warning (_("Unknown lower bound, using 1."));
11466 if (*subtype_info
== 'U')
11468 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11469 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11474 strcpy (name_buf
+ prefix_len
, "___U");
11475 if (!get_int_var_value (name_buf
, U
))
11477 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11482 type
= create_static_range_type (alloc_type_copy (raw_type
),
11484 /* create_static_range_type alters the resulting type's length
11485 to match the size of the base_type, which is not what we want.
11486 Set it back to the original range type's length. */
11487 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11488 type
->set_name (name
);
11493 /* True iff NAME is the name of a range type. */
11496 ada_is_range_type_name (const char *name
)
11498 return (name
!= NULL
&& strstr (name
, "___XD"));
11502 /* Modular types */
11504 /* True iff TYPE is an Ada modular type. */
11507 ada_is_modular_type (struct type
*type
)
11509 struct type
*subranged_type
= get_base_type (type
);
11511 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11512 && subranged_type
->code () == TYPE_CODE_INT
11513 && subranged_type
->is_unsigned ());
11516 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11519 ada_modulus (struct type
*type
)
11521 const dynamic_prop
&high
= type
->bounds ()->high
;
11523 if (high
.kind () == PROP_CONST
)
11524 return (ULONGEST
) high
.const_val () + 1;
11526 /* If TYPE is unresolved, the high bound might be a location list. Return
11527 0, for lack of a better value to return. */
11532 /* Ada exception catchpoint support:
11533 ---------------------------------
11535 We support 3 kinds of exception catchpoints:
11536 . catchpoints on Ada exceptions
11537 . catchpoints on unhandled Ada exceptions
11538 . catchpoints on failed assertions
11540 Exceptions raised during failed assertions, or unhandled exceptions
11541 could perfectly be caught with the general catchpoint on Ada exceptions.
11542 However, we can easily differentiate these two special cases, and having
11543 the option to distinguish these two cases from the rest can be useful
11544 to zero-in on certain situations.
11546 Exception catchpoints are a specialized form of breakpoint,
11547 since they rely on inserting breakpoints inside known routines
11548 of the GNAT runtime. The implementation therefore uses a standard
11549 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11552 Support in the runtime for exception catchpoints have been changed
11553 a few times already, and these changes affect the implementation
11554 of these catchpoints. In order to be able to support several
11555 variants of the runtime, we use a sniffer that will determine
11556 the runtime variant used by the program being debugged. */
11558 /* Ada's standard exceptions.
11560 The Ada 83 standard also defined Numeric_Error. But there so many
11561 situations where it was unclear from the Ada 83 Reference Manual
11562 (RM) whether Constraint_Error or Numeric_Error should be raised,
11563 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11564 Interpretation saying that anytime the RM says that Numeric_Error
11565 should be raised, the implementation may raise Constraint_Error.
11566 Ada 95 went one step further and pretty much removed Numeric_Error
11567 from the list of standard exceptions (it made it a renaming of
11568 Constraint_Error, to help preserve compatibility when compiling
11569 an Ada83 compiler). As such, we do not include Numeric_Error from
11570 this list of standard exceptions. */
11572 static const char * const standard_exc
[] = {
11573 "constraint_error",
11579 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11581 /* A structure that describes how to support exception catchpoints
11582 for a given executable. */
11584 struct exception_support_info
11586 /* The name of the symbol to break on in order to insert
11587 a catchpoint on exceptions. */
11588 const char *catch_exception_sym
;
11590 /* The name of the symbol to break on in order to insert
11591 a catchpoint on unhandled exceptions. */
11592 const char *catch_exception_unhandled_sym
;
11594 /* The name of the symbol to break on in order to insert
11595 a catchpoint on failed assertions. */
11596 const char *catch_assert_sym
;
11598 /* The name of the symbol to break on in order to insert
11599 a catchpoint on exception handling. */
11600 const char *catch_handlers_sym
;
11602 /* Assuming that the inferior just triggered an unhandled exception
11603 catchpoint, this function is responsible for returning the address
11604 in inferior memory where the name of that exception is stored.
11605 Return zero if the address could not be computed. */
11606 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11609 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11610 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11612 /* The following exception support info structure describes how to
11613 implement exception catchpoints with the latest version of the
11614 Ada runtime (as of 2019-08-??). */
11616 static const struct exception_support_info default_exception_support_info
=
11618 "__gnat_debug_raise_exception", /* catch_exception_sym */
11619 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11620 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11621 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11622 ada_unhandled_exception_name_addr
11625 /* The following exception support info structure describes how to
11626 implement exception catchpoints with an earlier version of the
11627 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11629 static const struct exception_support_info exception_support_info_v0
=
11631 "__gnat_debug_raise_exception", /* catch_exception_sym */
11632 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11633 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11634 "__gnat_begin_handler", /* catch_handlers_sym */
11635 ada_unhandled_exception_name_addr
11638 /* The following exception support info structure describes how to
11639 implement exception catchpoints with a slightly older version
11640 of the Ada runtime. */
11642 static const struct exception_support_info exception_support_info_fallback
=
11644 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11645 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11646 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11647 "__gnat_begin_handler", /* catch_handlers_sym */
11648 ada_unhandled_exception_name_addr_from_raise
11651 /* Return nonzero if we can detect the exception support routines
11652 described in EINFO.
11654 This function errors out if an abnormal situation is detected
11655 (for instance, if we find the exception support routines, but
11656 that support is found to be incomplete). */
11659 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11661 struct symbol
*sym
;
11663 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11664 that should be compiled with debugging information. As a result, we
11665 expect to find that symbol in the symtabs. */
11667 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11670 /* Perhaps we did not find our symbol because the Ada runtime was
11671 compiled without debugging info, or simply stripped of it.
11672 It happens on some GNU/Linux distributions for instance, where
11673 users have to install a separate debug package in order to get
11674 the runtime's debugging info. In that situation, let the user
11675 know why we cannot insert an Ada exception catchpoint.
11677 Note: Just for the purpose of inserting our Ada exception
11678 catchpoint, we could rely purely on the associated minimal symbol.
11679 But we would be operating in degraded mode anyway, since we are
11680 still lacking the debugging info needed later on to extract
11681 the name of the exception being raised (this name is printed in
11682 the catchpoint message, and is also used when trying to catch
11683 a specific exception). We do not handle this case for now. */
11684 struct bound_minimal_symbol msym
11685 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11687 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11688 error (_("Your Ada runtime appears to be missing some debugging "
11689 "information.\nCannot insert Ada exception catchpoint "
11690 "in this configuration."));
11695 /* Make sure that the symbol we found corresponds to a function. */
11697 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11699 error (_("Symbol \"%s\" is not a function (class = %d)"),
11700 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11704 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11707 struct bound_minimal_symbol msym
11708 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11710 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11711 error (_("Your Ada runtime appears to be missing some debugging "
11712 "information.\nCannot insert Ada exception catchpoint "
11713 "in this configuration."));
11718 /* Make sure that the symbol we found corresponds to a function. */
11720 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11722 error (_("Symbol \"%s\" is not a function (class = %d)"),
11723 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11730 /* Inspect the Ada runtime and determine which exception info structure
11731 should be used to provide support for exception catchpoints.
11733 This function will always set the per-inferior exception_info,
11734 or raise an error. */
11737 ada_exception_support_info_sniffer (void)
11739 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11741 /* If the exception info is already known, then no need to recompute it. */
11742 if (data
->exception_info
!= NULL
)
11745 /* Check the latest (default) exception support info. */
11746 if (ada_has_this_exception_support (&default_exception_support_info
))
11748 data
->exception_info
= &default_exception_support_info
;
11752 /* Try the v0 exception suport info. */
11753 if (ada_has_this_exception_support (&exception_support_info_v0
))
11755 data
->exception_info
= &exception_support_info_v0
;
11759 /* Try our fallback exception suport info. */
11760 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11762 data
->exception_info
= &exception_support_info_fallback
;
11766 /* Sometimes, it is normal for us to not be able to find the routine
11767 we are looking for. This happens when the program is linked with
11768 the shared version of the GNAT runtime, and the program has not been
11769 started yet. Inform the user of these two possible causes if
11772 if (ada_update_initial_language (language_unknown
) != language_ada
)
11773 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11775 /* If the symbol does not exist, then check that the program is
11776 already started, to make sure that shared libraries have been
11777 loaded. If it is not started, this may mean that the symbol is
11778 in a shared library. */
11780 if (inferior_ptid
.pid () == 0)
11781 error (_("Unable to insert catchpoint. Try to start the program first."));
11783 /* At this point, we know that we are debugging an Ada program and
11784 that the inferior has been started, but we still are not able to
11785 find the run-time symbols. That can mean that we are in
11786 configurable run time mode, or that a-except as been optimized
11787 out by the linker... In any case, at this point it is not worth
11788 supporting this feature. */
11790 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11793 /* True iff FRAME is very likely to be that of a function that is
11794 part of the runtime system. This is all very heuristic, but is
11795 intended to be used as advice as to what frames are uninteresting
11799 is_known_support_routine (struct frame_info
*frame
)
11801 enum language func_lang
;
11803 const char *fullname
;
11805 /* If this code does not have any debugging information (no symtab),
11806 This cannot be any user code. */
11808 symtab_and_line sal
= find_frame_sal (frame
);
11809 if (sal
.symtab
== NULL
)
11812 /* If there is a symtab, but the associated source file cannot be
11813 located, then assume this is not user code: Selecting a frame
11814 for which we cannot display the code would not be very helpful
11815 for the user. This should also take care of case such as VxWorks
11816 where the kernel has some debugging info provided for a few units. */
11818 fullname
= symtab_to_fullname (sal
.symtab
);
11819 if (access (fullname
, R_OK
) != 0)
11822 /* Check the unit filename against the Ada runtime file naming.
11823 We also check the name of the objfile against the name of some
11824 known system libraries that sometimes come with debugging info
11827 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11829 re_comp (known_runtime_file_name_patterns
[i
]);
11830 if (re_exec (lbasename (sal
.symtab
->filename
)))
11832 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11833 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11837 /* Check whether the function is a GNAT-generated entity. */
11839 gdb::unique_xmalloc_ptr
<char> func_name
11840 = find_frame_funname (frame
, &func_lang
, NULL
);
11841 if (func_name
== NULL
)
11844 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11846 re_comp (known_auxiliary_function_name_patterns
[i
]);
11847 if (re_exec (func_name
.get ()))
11854 /* Find the first frame that contains debugging information and that is not
11855 part of the Ada run-time, starting from FI and moving upward. */
11858 ada_find_printable_frame (struct frame_info
*fi
)
11860 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11862 if (!is_known_support_routine (fi
))
11871 /* Assuming that the inferior just triggered an unhandled exception
11872 catchpoint, return the address in inferior memory where the name
11873 of the exception is stored.
11875 Return zero if the address could not be computed. */
11878 ada_unhandled_exception_name_addr (void)
11880 return parse_and_eval_address ("e.full_name");
11883 /* Same as ada_unhandled_exception_name_addr, except that this function
11884 should be used when the inferior uses an older version of the runtime,
11885 where the exception name needs to be extracted from a specific frame
11886 several frames up in the callstack. */
11889 ada_unhandled_exception_name_addr_from_raise (void)
11892 struct frame_info
*fi
;
11893 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11895 /* To determine the name of this exception, we need to select
11896 the frame corresponding to RAISE_SYM_NAME. This frame is
11897 at least 3 levels up, so we simply skip the first 3 frames
11898 without checking the name of their associated function. */
11899 fi
= get_current_frame ();
11900 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11902 fi
= get_prev_frame (fi
);
11906 enum language func_lang
;
11908 gdb::unique_xmalloc_ptr
<char> func_name
11909 = find_frame_funname (fi
, &func_lang
, NULL
);
11910 if (func_name
!= NULL
)
11912 if (strcmp (func_name
.get (),
11913 data
->exception_info
->catch_exception_sym
) == 0)
11914 break; /* We found the frame we were looking for... */
11916 fi
= get_prev_frame (fi
);
11923 return parse_and_eval_address ("id.full_name");
11926 /* Assuming the inferior just triggered an Ada exception catchpoint
11927 (of any type), return the address in inferior memory where the name
11928 of the exception is stored, if applicable.
11930 Assumes the selected frame is the current frame.
11932 Return zero if the address could not be computed, or if not relevant. */
11935 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11936 struct breakpoint
*b
)
11938 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11942 case ada_catch_exception
:
11943 return (parse_and_eval_address ("e.full_name"));
11946 case ada_catch_exception_unhandled
:
11947 return data
->exception_info
->unhandled_exception_name_addr ();
11950 case ada_catch_handlers
:
11951 return 0; /* The runtimes does not provide access to the exception
11955 case ada_catch_assert
:
11956 return 0; /* Exception name is not relevant in this case. */
11960 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11964 return 0; /* Should never be reached. */
11967 /* Assuming the inferior is stopped at an exception catchpoint,
11968 return the message which was associated to the exception, if
11969 available. Return NULL if the message could not be retrieved.
11971 Note: The exception message can be associated to an exception
11972 either through the use of the Raise_Exception function, or
11973 more simply (Ada 2005 and later), via:
11975 raise Exception_Name with "exception message";
11979 static gdb::unique_xmalloc_ptr
<char>
11980 ada_exception_message_1 (void)
11982 struct value
*e_msg_val
;
11985 /* For runtimes that support this feature, the exception message
11986 is passed as an unbounded string argument called "message". */
11987 e_msg_val
= parse_and_eval ("message");
11988 if (e_msg_val
== NULL
)
11989 return NULL
; /* Exception message not supported. */
11991 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11992 gdb_assert (e_msg_val
!= NULL
);
11993 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11995 /* If the message string is empty, then treat it as if there was
11996 no exception message. */
11997 if (e_msg_len
<= 0)
12000 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12001 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
12003 e_msg
.get ()[e_msg_len
] = '\0';
12008 /* Same as ada_exception_message_1, except that all exceptions are
12009 contained here (returning NULL instead). */
12011 static gdb::unique_xmalloc_ptr
<char>
12012 ada_exception_message (void)
12014 gdb::unique_xmalloc_ptr
<char> e_msg
;
12018 e_msg
= ada_exception_message_1 ();
12020 catch (const gdb_exception_error
&e
)
12022 e_msg
.reset (nullptr);
12028 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12029 any error that ada_exception_name_addr_1 might cause to be thrown.
12030 When an error is intercepted, a warning with the error message is printed,
12031 and zero is returned. */
12034 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12035 struct breakpoint
*b
)
12037 CORE_ADDR result
= 0;
12041 result
= ada_exception_name_addr_1 (ex
, b
);
12044 catch (const gdb_exception_error
&e
)
12046 warning (_("failed to get exception name: %s"), e
.what ());
12053 static std::string ada_exception_catchpoint_cond_string
12054 (const char *excep_string
,
12055 enum ada_exception_catchpoint_kind ex
);
12057 /* Ada catchpoints.
12059 In the case of catchpoints on Ada exceptions, the catchpoint will
12060 stop the target on every exception the program throws. When a user
12061 specifies the name of a specific exception, we translate this
12062 request into a condition expression (in text form), and then parse
12063 it into an expression stored in each of the catchpoint's locations.
12064 We then use this condition to check whether the exception that was
12065 raised is the one the user is interested in. If not, then the
12066 target is resumed again. We store the name of the requested
12067 exception, in order to be able to re-set the condition expression
12068 when symbols change. */
12070 /* An instance of this type is used to represent an Ada catchpoint
12071 breakpoint location. */
12073 class ada_catchpoint_location
: public bp_location
12076 ada_catchpoint_location (breakpoint
*owner
)
12077 : bp_location (owner
, bp_loc_software_breakpoint
)
12080 /* The condition that checks whether the exception that was raised
12081 is the specific exception the user specified on catchpoint
12083 expression_up excep_cond_expr
;
12086 /* An instance of this type is used to represent an Ada catchpoint. */
12088 struct ada_catchpoint
: public breakpoint
12090 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12095 /* The name of the specific exception the user specified. */
12096 std::string excep_string
;
12098 /* What kind of catchpoint this is. */
12099 enum ada_exception_catchpoint_kind m_kind
;
12102 /* Parse the exception condition string in the context of each of the
12103 catchpoint's locations, and store them for later evaluation. */
12106 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12107 enum ada_exception_catchpoint_kind ex
)
12109 struct bp_location
*bl
;
12111 /* Nothing to do if there's no specific exception to catch. */
12112 if (c
->excep_string
.empty ())
12115 /* Same if there are no locations... */
12116 if (c
->loc
== NULL
)
12119 /* Compute the condition expression in text form, from the specific
12120 expection we want to catch. */
12121 std::string cond_string
12122 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12124 /* Iterate over all the catchpoint's locations, and parse an
12125 expression for each. */
12126 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12128 struct ada_catchpoint_location
*ada_loc
12129 = (struct ada_catchpoint_location
*) bl
;
12132 if (!bl
->shlib_disabled
)
12136 s
= cond_string
.c_str ();
12139 exp
= parse_exp_1 (&s
, bl
->address
,
12140 block_for_pc (bl
->address
),
12143 catch (const gdb_exception_error
&e
)
12145 warning (_("failed to reevaluate internal exception condition "
12146 "for catchpoint %d: %s"),
12147 c
->number
, e
.what ());
12151 ada_loc
->excep_cond_expr
= std::move (exp
);
12155 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12156 structure for all exception catchpoint kinds. */
12158 static struct bp_location
*
12159 allocate_location_exception (struct breakpoint
*self
)
12161 return new ada_catchpoint_location (self
);
12164 /* Implement the RE_SET method in the breakpoint_ops structure for all
12165 exception catchpoint kinds. */
12168 re_set_exception (struct breakpoint
*b
)
12170 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12172 /* Call the base class's method. This updates the catchpoint's
12174 bkpt_breakpoint_ops
.re_set (b
);
12176 /* Reparse the exception conditional expressions. One for each
12178 create_excep_cond_exprs (c
, c
->m_kind
);
12181 /* Returns true if we should stop for this breakpoint hit. If the
12182 user specified a specific exception, we only want to cause a stop
12183 if the program thrown that exception. */
12186 should_stop_exception (const struct bp_location
*bl
)
12188 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12189 const struct ada_catchpoint_location
*ada_loc
12190 = (const struct ada_catchpoint_location
*) bl
;
12193 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12194 if (c
->m_kind
== ada_catch_assert
)
12195 clear_internalvar (var
);
12202 if (c
->m_kind
== ada_catch_handlers
)
12203 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12204 ".all.occurrence.id");
12208 struct value
*exc
= parse_and_eval (expr
);
12209 set_internalvar (var
, exc
);
12211 catch (const gdb_exception_error
&ex
)
12213 clear_internalvar (var
);
12217 /* With no specific exception, should always stop. */
12218 if (c
->excep_string
.empty ())
12221 if (ada_loc
->excep_cond_expr
== NULL
)
12223 /* We will have a NULL expression if back when we were creating
12224 the expressions, this location's had failed to parse. */
12231 struct value
*mark
;
12233 mark
= value_mark ();
12234 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12235 value_free_to_mark (mark
);
12237 catch (const gdb_exception
&ex
)
12239 exception_fprintf (gdb_stderr
, ex
,
12240 _("Error in testing exception condition:\n"));
12246 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12247 for all exception catchpoint kinds. */
12250 check_status_exception (bpstat bs
)
12252 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12255 /* Implement the PRINT_IT method in the breakpoint_ops structure
12256 for all exception catchpoint kinds. */
12258 static enum print_stop_action
12259 print_it_exception (bpstat bs
)
12261 struct ui_out
*uiout
= current_uiout
;
12262 struct breakpoint
*b
= bs
->breakpoint_at
;
12264 annotate_catchpoint (b
->number
);
12266 if (uiout
->is_mi_like_p ())
12268 uiout
->field_string ("reason",
12269 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12270 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12273 uiout
->text (b
->disposition
== disp_del
12274 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12275 uiout
->field_signed ("bkptno", b
->number
);
12276 uiout
->text (", ");
12278 /* ada_exception_name_addr relies on the selected frame being the
12279 current frame. Need to do this here because this function may be
12280 called more than once when printing a stop, and below, we'll
12281 select the first frame past the Ada run-time (see
12282 ada_find_printable_frame). */
12283 select_frame (get_current_frame ());
12285 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12288 case ada_catch_exception
:
12289 case ada_catch_exception_unhandled
:
12290 case ada_catch_handlers
:
12292 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12293 char exception_name
[256];
12297 read_memory (addr
, (gdb_byte
*) exception_name
,
12298 sizeof (exception_name
) - 1);
12299 exception_name
[sizeof (exception_name
) - 1] = '\0';
12303 /* For some reason, we were unable to read the exception
12304 name. This could happen if the Runtime was compiled
12305 without debugging info, for instance. In that case,
12306 just replace the exception name by the generic string
12307 "exception" - it will read as "an exception" in the
12308 notification we are about to print. */
12309 memcpy (exception_name
, "exception", sizeof ("exception"));
12311 /* In the case of unhandled exception breakpoints, we print
12312 the exception name as "unhandled EXCEPTION_NAME", to make
12313 it clearer to the user which kind of catchpoint just got
12314 hit. We used ui_out_text to make sure that this extra
12315 info does not pollute the exception name in the MI case. */
12316 if (c
->m_kind
== ada_catch_exception_unhandled
)
12317 uiout
->text ("unhandled ");
12318 uiout
->field_string ("exception-name", exception_name
);
12321 case ada_catch_assert
:
12322 /* In this case, the name of the exception is not really
12323 important. Just print "failed assertion" to make it clearer
12324 that his program just hit an assertion-failure catchpoint.
12325 We used ui_out_text because this info does not belong in
12327 uiout
->text ("failed assertion");
12331 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12332 if (exception_message
!= NULL
)
12334 uiout
->text (" (");
12335 uiout
->field_string ("exception-message", exception_message
.get ());
12339 uiout
->text (" at ");
12340 ada_find_printable_frame (get_current_frame ());
12342 return PRINT_SRC_AND_LOC
;
12345 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12346 for all exception catchpoint kinds. */
12349 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12351 struct ui_out
*uiout
= current_uiout
;
12352 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12353 struct value_print_options opts
;
12355 get_user_print_options (&opts
);
12357 if (opts
.addressprint
)
12358 uiout
->field_skip ("addr");
12360 annotate_field (5);
12363 case ada_catch_exception
:
12364 if (!c
->excep_string
.empty ())
12366 std::string msg
= string_printf (_("`%s' Ada exception"),
12367 c
->excep_string
.c_str ());
12369 uiout
->field_string ("what", msg
);
12372 uiout
->field_string ("what", "all Ada exceptions");
12376 case ada_catch_exception_unhandled
:
12377 uiout
->field_string ("what", "unhandled Ada exceptions");
12380 case ada_catch_handlers
:
12381 if (!c
->excep_string
.empty ())
12383 uiout
->field_fmt ("what",
12384 _("`%s' Ada exception handlers"),
12385 c
->excep_string
.c_str ());
12388 uiout
->field_string ("what", "all Ada exceptions handlers");
12391 case ada_catch_assert
:
12392 uiout
->field_string ("what", "failed Ada assertions");
12396 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12401 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12402 for all exception catchpoint kinds. */
12405 print_mention_exception (struct breakpoint
*b
)
12407 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12408 struct ui_out
*uiout
= current_uiout
;
12410 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12411 : _("Catchpoint "));
12412 uiout
->field_signed ("bkptno", b
->number
);
12413 uiout
->text (": ");
12417 case ada_catch_exception
:
12418 if (!c
->excep_string
.empty ())
12420 std::string info
= string_printf (_("`%s' Ada exception"),
12421 c
->excep_string
.c_str ());
12422 uiout
->text (info
.c_str ());
12425 uiout
->text (_("all Ada exceptions"));
12428 case ada_catch_exception_unhandled
:
12429 uiout
->text (_("unhandled Ada exceptions"));
12432 case ada_catch_handlers
:
12433 if (!c
->excep_string
.empty ())
12436 = string_printf (_("`%s' Ada exception handlers"),
12437 c
->excep_string
.c_str ());
12438 uiout
->text (info
.c_str ());
12441 uiout
->text (_("all Ada exceptions handlers"));
12444 case ada_catch_assert
:
12445 uiout
->text (_("failed Ada assertions"));
12449 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12454 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12455 for all exception catchpoint kinds. */
12458 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12460 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12464 case ada_catch_exception
:
12465 fprintf_filtered (fp
, "catch exception");
12466 if (!c
->excep_string
.empty ())
12467 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12470 case ada_catch_exception_unhandled
:
12471 fprintf_filtered (fp
, "catch exception unhandled");
12474 case ada_catch_handlers
:
12475 fprintf_filtered (fp
, "catch handlers");
12478 case ada_catch_assert
:
12479 fprintf_filtered (fp
, "catch assert");
12483 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12485 print_recreate_thread (b
, fp
);
12488 /* Virtual tables for various breakpoint types. */
12489 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12490 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12491 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12492 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12494 /* See ada-lang.h. */
12497 is_ada_exception_catchpoint (breakpoint
*bp
)
12499 return (bp
->ops
== &catch_exception_breakpoint_ops
12500 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12501 || bp
->ops
== &catch_assert_breakpoint_ops
12502 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12505 /* Split the arguments specified in a "catch exception" command.
12506 Set EX to the appropriate catchpoint type.
12507 Set EXCEP_STRING to the name of the specific exception if
12508 specified by the user.
12509 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12510 "catch handlers" command. False otherwise.
12511 If a condition is found at the end of the arguments, the condition
12512 expression is stored in COND_STRING (memory must be deallocated
12513 after use). Otherwise COND_STRING is set to NULL. */
12516 catch_ada_exception_command_split (const char *args
,
12517 bool is_catch_handlers_cmd
,
12518 enum ada_exception_catchpoint_kind
*ex
,
12519 std::string
*excep_string
,
12520 std::string
*cond_string
)
12522 std::string exception_name
;
12524 exception_name
= extract_arg (&args
);
12525 if (exception_name
== "if")
12527 /* This is not an exception name; this is the start of a condition
12528 expression for a catchpoint on all exceptions. So, "un-get"
12529 this token, and set exception_name to NULL. */
12530 exception_name
.clear ();
12534 /* Check to see if we have a condition. */
12536 args
= skip_spaces (args
);
12537 if (startswith (args
, "if")
12538 && (isspace (args
[2]) || args
[2] == '\0'))
12541 args
= skip_spaces (args
);
12543 if (args
[0] == '\0')
12544 error (_("Condition missing after `if' keyword"));
12545 *cond_string
= args
;
12547 args
+= strlen (args
);
12550 /* Check that we do not have any more arguments. Anything else
12553 if (args
[0] != '\0')
12554 error (_("Junk at end of expression"));
12556 if (is_catch_handlers_cmd
)
12558 /* Catch handling of exceptions. */
12559 *ex
= ada_catch_handlers
;
12560 *excep_string
= exception_name
;
12562 else if (exception_name
.empty ())
12564 /* Catch all exceptions. */
12565 *ex
= ada_catch_exception
;
12566 excep_string
->clear ();
12568 else if (exception_name
== "unhandled")
12570 /* Catch unhandled exceptions. */
12571 *ex
= ada_catch_exception_unhandled
;
12572 excep_string
->clear ();
12576 /* Catch a specific exception. */
12577 *ex
= ada_catch_exception
;
12578 *excep_string
= exception_name
;
12582 /* Return the name of the symbol on which we should break in order to
12583 implement a catchpoint of the EX kind. */
12585 static const char *
12586 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12588 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12590 gdb_assert (data
->exception_info
!= NULL
);
12594 case ada_catch_exception
:
12595 return (data
->exception_info
->catch_exception_sym
);
12597 case ada_catch_exception_unhandled
:
12598 return (data
->exception_info
->catch_exception_unhandled_sym
);
12600 case ada_catch_assert
:
12601 return (data
->exception_info
->catch_assert_sym
);
12603 case ada_catch_handlers
:
12604 return (data
->exception_info
->catch_handlers_sym
);
12607 internal_error (__FILE__
, __LINE__
,
12608 _("unexpected catchpoint kind (%d)"), ex
);
12612 /* Return the breakpoint ops "virtual table" used for catchpoints
12615 static const struct breakpoint_ops
*
12616 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12620 case ada_catch_exception
:
12621 return (&catch_exception_breakpoint_ops
);
12623 case ada_catch_exception_unhandled
:
12624 return (&catch_exception_unhandled_breakpoint_ops
);
12626 case ada_catch_assert
:
12627 return (&catch_assert_breakpoint_ops
);
12629 case ada_catch_handlers
:
12630 return (&catch_handlers_breakpoint_ops
);
12633 internal_error (__FILE__
, __LINE__
,
12634 _("unexpected catchpoint kind (%d)"), ex
);
12638 /* Return the condition that will be used to match the current exception
12639 being raised with the exception that the user wants to catch. This
12640 assumes that this condition is used when the inferior just triggered
12641 an exception catchpoint.
12642 EX: the type of catchpoints used for catching Ada exceptions. */
12645 ada_exception_catchpoint_cond_string (const char *excep_string
,
12646 enum ada_exception_catchpoint_kind ex
)
12649 bool is_standard_exc
= false;
12650 std::string result
;
12652 if (ex
== ada_catch_handlers
)
12654 /* For exception handlers catchpoints, the condition string does
12655 not use the same parameter as for the other exceptions. */
12656 result
= ("long_integer (GNAT_GCC_exception_Access"
12657 "(gcc_exception).all.occurrence.id)");
12660 result
= "long_integer (e)";
12662 /* The standard exceptions are a special case. They are defined in
12663 runtime units that have been compiled without debugging info; if
12664 EXCEP_STRING is the not-fully-qualified name of a standard
12665 exception (e.g. "constraint_error") then, during the evaluation
12666 of the condition expression, the symbol lookup on this name would
12667 *not* return this standard exception. The catchpoint condition
12668 may then be set only on user-defined exceptions which have the
12669 same not-fully-qualified name (e.g. my_package.constraint_error).
12671 To avoid this unexcepted behavior, these standard exceptions are
12672 systematically prefixed by "standard". This means that "catch
12673 exception constraint_error" is rewritten into "catch exception
12674 standard.constraint_error".
12676 If an exception named constraint_error is defined in another package of
12677 the inferior program, then the only way to specify this exception as a
12678 breakpoint condition is to use its fully-qualified named:
12679 e.g. my_package.constraint_error. */
12681 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12683 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12685 is_standard_exc
= true;
12692 if (is_standard_exc
)
12693 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12695 string_appendf (result
, "long_integer (&%s)", excep_string
);
12700 /* Return the symtab_and_line that should be used to insert an exception
12701 catchpoint of the TYPE kind.
12703 ADDR_STRING returns the name of the function where the real
12704 breakpoint that implements the catchpoints is set, depending on the
12705 type of catchpoint we need to create. */
12707 static struct symtab_and_line
12708 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12709 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12711 const char *sym_name
;
12712 struct symbol
*sym
;
12714 /* First, find out which exception support info to use. */
12715 ada_exception_support_info_sniffer ();
12717 /* Then lookup the function on which we will break in order to catch
12718 the Ada exceptions requested by the user. */
12719 sym_name
= ada_exception_sym_name (ex
);
12720 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12723 error (_("Catchpoint symbol not found: %s"), sym_name
);
12725 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12726 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12728 /* Set ADDR_STRING. */
12729 *addr_string
= sym_name
;
12732 *ops
= ada_exception_breakpoint_ops (ex
);
12734 return find_function_start_sal (sym
, 1);
12737 /* Create an Ada exception catchpoint.
12739 EX_KIND is the kind of exception catchpoint to be created.
12741 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12742 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12743 of the exception to which this catchpoint applies.
12745 COND_STRING, if not empty, is the catchpoint condition.
12747 TEMPFLAG, if nonzero, means that the underlying breakpoint
12748 should be temporary.
12750 FROM_TTY is the usual argument passed to all commands implementations. */
12753 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12754 enum ada_exception_catchpoint_kind ex_kind
,
12755 const std::string
&excep_string
,
12756 const std::string
&cond_string
,
12761 std::string addr_string
;
12762 const struct breakpoint_ops
*ops
= NULL
;
12763 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12765 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12766 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12767 ops
, tempflag
, disabled
, from_tty
);
12768 c
->excep_string
= excep_string
;
12769 create_excep_cond_exprs (c
.get (), ex_kind
);
12770 if (!cond_string
.empty ())
12771 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12772 install_breakpoint (0, std::move (c
), 1);
12775 /* Implement the "catch exception" command. */
12778 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12779 struct cmd_list_element
*command
)
12781 const char *arg
= arg_entry
;
12782 struct gdbarch
*gdbarch
= get_current_arch ();
12784 enum ada_exception_catchpoint_kind ex_kind
;
12785 std::string excep_string
;
12786 std::string cond_string
;
12788 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12792 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12794 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12795 excep_string
, cond_string
,
12796 tempflag
, 1 /* enabled */,
12800 /* Implement the "catch handlers" command. */
12803 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12804 struct cmd_list_element
*command
)
12806 const char *arg
= arg_entry
;
12807 struct gdbarch
*gdbarch
= get_current_arch ();
12809 enum ada_exception_catchpoint_kind ex_kind
;
12810 std::string excep_string
;
12811 std::string cond_string
;
12813 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12817 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12819 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12820 excep_string
, cond_string
,
12821 tempflag
, 1 /* enabled */,
12825 /* Completion function for the Ada "catch" commands. */
12828 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12829 const char *text
, const char *word
)
12831 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12833 for (const ada_exc_info
&info
: exceptions
)
12835 if (startswith (info
.name
, word
))
12836 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12840 /* Split the arguments specified in a "catch assert" command.
12842 ARGS contains the command's arguments (or the empty string if
12843 no arguments were passed).
12845 If ARGS contains a condition, set COND_STRING to that condition
12846 (the memory needs to be deallocated after use). */
12849 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12851 args
= skip_spaces (args
);
12853 /* Check whether a condition was provided. */
12854 if (startswith (args
, "if")
12855 && (isspace (args
[2]) || args
[2] == '\0'))
12858 args
= skip_spaces (args
);
12859 if (args
[0] == '\0')
12860 error (_("condition missing after `if' keyword"));
12861 cond_string
.assign (args
);
12864 /* Otherwise, there should be no other argument at the end of
12866 else if (args
[0] != '\0')
12867 error (_("Junk at end of arguments."));
12870 /* Implement the "catch assert" command. */
12873 catch_assert_command (const char *arg_entry
, int from_tty
,
12874 struct cmd_list_element
*command
)
12876 const char *arg
= arg_entry
;
12877 struct gdbarch
*gdbarch
= get_current_arch ();
12879 std::string cond_string
;
12881 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12885 catch_ada_assert_command_split (arg
, cond_string
);
12886 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12888 tempflag
, 1 /* enabled */,
12892 /* Return non-zero if the symbol SYM is an Ada exception object. */
12895 ada_is_exception_sym (struct symbol
*sym
)
12897 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12899 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12900 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12901 && SYMBOL_CLASS (sym
) != LOC_CONST
12902 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12903 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12906 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12907 Ada exception object. This matches all exceptions except the ones
12908 defined by the Ada language. */
12911 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12915 if (!ada_is_exception_sym (sym
))
12918 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12919 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12920 return 0; /* A standard exception. */
12922 /* Numeric_Error is also a standard exception, so exclude it.
12923 See the STANDARD_EXC description for more details as to why
12924 this exception is not listed in that array. */
12925 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12931 /* A helper function for std::sort, comparing two struct ada_exc_info
12934 The comparison is determined first by exception name, and then
12935 by exception address. */
12938 ada_exc_info::operator< (const ada_exc_info
&other
) const
12942 result
= strcmp (name
, other
.name
);
12945 if (result
== 0 && addr
< other
.addr
)
12951 ada_exc_info::operator== (const ada_exc_info
&other
) const
12953 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12956 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12957 routine, but keeping the first SKIP elements untouched.
12959 All duplicates are also removed. */
12962 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12965 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12966 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12967 exceptions
->end ());
12970 /* Add all exceptions defined by the Ada standard whose name match
12971 a regular expression.
12973 If PREG is not NULL, then this regexp_t object is used to
12974 perform the symbol name matching. Otherwise, no name-based
12975 filtering is performed.
12977 EXCEPTIONS is a vector of exceptions to which matching exceptions
12981 ada_add_standard_exceptions (compiled_regex
*preg
,
12982 std::vector
<ada_exc_info
> *exceptions
)
12986 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12989 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12991 struct bound_minimal_symbol msymbol
12992 = ada_lookup_simple_minsym (standard_exc
[i
]);
12994 if (msymbol
.minsym
!= NULL
)
12996 struct ada_exc_info info
12997 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12999 exceptions
->push_back (info
);
13005 /* Add all Ada exceptions defined locally and accessible from the given
13008 If PREG is not NULL, then this regexp_t object is used to
13009 perform the symbol name matching. Otherwise, no name-based
13010 filtering is performed.
13012 EXCEPTIONS is a vector of exceptions to which matching exceptions
13016 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13017 struct frame_info
*frame
,
13018 std::vector
<ada_exc_info
> *exceptions
)
13020 const struct block
*block
= get_frame_block (frame
, 0);
13024 struct block_iterator iter
;
13025 struct symbol
*sym
;
13027 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13029 switch (SYMBOL_CLASS (sym
))
13036 if (ada_is_exception_sym (sym
))
13038 struct ada_exc_info info
= {sym
->print_name (),
13039 SYMBOL_VALUE_ADDRESS (sym
)};
13041 exceptions
->push_back (info
);
13045 if (BLOCK_FUNCTION (block
) != NULL
)
13047 block
= BLOCK_SUPERBLOCK (block
);
13051 /* Return true if NAME matches PREG or if PREG is NULL. */
13054 name_matches_regex (const char *name
, compiled_regex
*preg
)
13056 return (preg
== NULL
13057 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13060 /* Add all exceptions defined globally whose name name match
13061 a regular expression, excluding standard exceptions.
13063 The reason we exclude standard exceptions is that they need
13064 to be handled separately: Standard exceptions are defined inside
13065 a runtime unit which is normally not compiled with debugging info,
13066 and thus usually do not show up in our symbol search. However,
13067 if the unit was in fact built with debugging info, we need to
13068 exclude them because they would duplicate the entry we found
13069 during the special loop that specifically searches for those
13070 standard exceptions.
13072 If PREG is not NULL, then this regexp_t object is used to
13073 perform the symbol name matching. Otherwise, no name-based
13074 filtering is performed.
13076 EXCEPTIONS is a vector of exceptions to which matching exceptions
13080 ada_add_global_exceptions (compiled_regex
*preg
,
13081 std::vector
<ada_exc_info
> *exceptions
)
13083 /* In Ada, the symbol "search name" is a linkage name, whereas the
13084 regular expression used to do the matching refers to the natural
13085 name. So match against the decoded name. */
13086 expand_symtabs_matching (NULL
,
13087 lookup_name_info::match_any (),
13088 [&] (const char *search_name
)
13090 std::string decoded
= ada_decode (search_name
);
13091 return name_matches_regex (decoded
.c_str (), preg
);
13096 for (objfile
*objfile
: current_program_space
->objfiles ())
13098 for (compunit_symtab
*s
: objfile
->compunits ())
13100 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13103 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13105 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13106 struct block_iterator iter
;
13107 struct symbol
*sym
;
13109 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13110 if (ada_is_non_standard_exception_sym (sym
)
13111 && name_matches_regex (sym
->natural_name (), preg
))
13113 struct ada_exc_info info
13114 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13116 exceptions
->push_back (info
);
13123 /* Implements ada_exceptions_list with the regular expression passed
13124 as a regex_t, rather than a string.
13126 If not NULL, PREG is used to filter out exceptions whose names
13127 do not match. Otherwise, all exceptions are listed. */
13129 static std::vector
<ada_exc_info
>
13130 ada_exceptions_list_1 (compiled_regex
*preg
)
13132 std::vector
<ada_exc_info
> result
;
13135 /* First, list the known standard exceptions. These exceptions
13136 need to be handled separately, as they are usually defined in
13137 runtime units that have been compiled without debugging info. */
13139 ada_add_standard_exceptions (preg
, &result
);
13141 /* Next, find all exceptions whose scope is local and accessible
13142 from the currently selected frame. */
13144 if (has_stack_frames ())
13146 prev_len
= result
.size ();
13147 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13149 if (result
.size () > prev_len
)
13150 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13153 /* Add all exceptions whose scope is global. */
13155 prev_len
= result
.size ();
13156 ada_add_global_exceptions (preg
, &result
);
13157 if (result
.size () > prev_len
)
13158 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13163 /* Return a vector of ada_exc_info.
13165 If REGEXP is NULL, all exceptions are included in the result.
13166 Otherwise, it should contain a valid regular expression,
13167 and only the exceptions whose names match that regular expression
13168 are included in the result.
13170 The exceptions are sorted in the following order:
13171 - Standard exceptions (defined by the Ada language), in
13172 alphabetical order;
13173 - Exceptions only visible from the current frame, in
13174 alphabetical order;
13175 - Exceptions whose scope is global, in alphabetical order. */
13177 std::vector
<ada_exc_info
>
13178 ada_exceptions_list (const char *regexp
)
13180 if (regexp
== NULL
)
13181 return ada_exceptions_list_1 (NULL
);
13183 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13184 return ada_exceptions_list_1 (®
);
13187 /* Implement the "info exceptions" command. */
13190 info_exceptions_command (const char *regexp
, int from_tty
)
13192 struct gdbarch
*gdbarch
= get_current_arch ();
13194 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13196 if (regexp
!= NULL
)
13198 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13200 printf_filtered (_("All defined Ada exceptions:\n"));
13202 for (const ada_exc_info
&info
: exceptions
)
13203 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13207 /* Information about operators given special treatment in functions
13209 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13211 #define ADA_OPERATORS \
13212 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13213 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13214 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13215 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13216 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13217 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13218 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13219 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13220 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13221 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13222 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13223 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13224 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13225 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13226 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13227 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13228 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13229 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13230 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13233 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13236 switch (exp
->elts
[pc
- 1].opcode
)
13239 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13242 #define OP_DEFN(op, len, args, binop) \
13243 case op: *oplenp = len; *argsp = args; break;
13249 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13254 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13259 /* Implementation of the exp_descriptor method operator_check. */
13262 ada_operator_check (struct expression
*exp
, int pos
,
13263 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13266 const union exp_element
*const elts
= exp
->elts
;
13267 struct type
*type
= NULL
;
13269 switch (elts
[pos
].opcode
)
13271 case UNOP_IN_RANGE
:
13273 type
= elts
[pos
+ 1].type
;
13277 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13280 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13282 if (type
&& TYPE_OBJFILE (type
)
13283 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13289 /* As for operator_length, but assumes PC is pointing at the first
13290 element of the operator, and gives meaningful results only for the
13291 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13294 ada_forward_operator_length (struct expression
*exp
, int pc
,
13295 int *oplenp
, int *argsp
)
13297 switch (exp
->elts
[pc
].opcode
)
13300 *oplenp
= *argsp
= 0;
13303 #define OP_DEFN(op, len, args, binop) \
13304 case op: *oplenp = len; *argsp = args; break;
13310 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13315 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13321 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13323 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13331 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13333 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13338 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13342 /* Ada attributes ('Foo). */
13345 case OP_ATR_LENGTH
:
13349 case OP_ATR_MODULUS
:
13356 case UNOP_IN_RANGE
:
13358 /* XXX: gdb_sprint_host_address, type_sprint */
13359 fprintf_filtered (stream
, _("Type @"));
13360 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13361 fprintf_filtered (stream
, " (");
13362 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13363 fprintf_filtered (stream
, ")");
13365 case BINOP_IN_BOUNDS
:
13366 fprintf_filtered (stream
, " (%d)",
13367 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13369 case TERNOP_IN_RANGE
:
13374 case OP_DISCRETE_RANGE
:
13375 case OP_POSITIONAL
:
13382 char *name
= &exp
->elts
[elt
+ 2].string
;
13383 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13385 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13390 return dump_subexp_body_standard (exp
, stream
, elt
);
13394 for (i
= 0; i
< nargs
; i
+= 1)
13395 elt
= dump_subexp (exp
, stream
, elt
);
13400 /* The Ada extension of print_subexp (q.v.). */
13403 ada_print_subexp (struct expression
*exp
, int *pos
,
13404 struct ui_file
*stream
, enum precedence prec
)
13406 int oplen
, nargs
, i
;
13408 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13410 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13417 print_subexp_standard (exp
, pos
, stream
, prec
);
13421 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13424 case BINOP_IN_BOUNDS
:
13425 /* XXX: sprint_subexp */
13426 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13427 fputs_filtered (" in ", stream
);
13428 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13429 fputs_filtered ("'range", stream
);
13430 if (exp
->elts
[pc
+ 1].longconst
> 1)
13431 fprintf_filtered (stream
, "(%ld)",
13432 (long) exp
->elts
[pc
+ 1].longconst
);
13435 case TERNOP_IN_RANGE
:
13436 if (prec
>= PREC_EQUAL
)
13437 fputs_filtered ("(", stream
);
13438 /* XXX: sprint_subexp */
13439 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13440 fputs_filtered (" in ", stream
);
13441 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13442 fputs_filtered (" .. ", stream
);
13443 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13444 if (prec
>= PREC_EQUAL
)
13445 fputs_filtered (")", stream
);
13450 case OP_ATR_LENGTH
:
13454 case OP_ATR_MODULUS
:
13459 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13461 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13462 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13463 &type_print_raw_options
);
13467 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13468 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13473 for (tem
= 1; tem
< nargs
; tem
+= 1)
13475 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13476 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13478 fputs_filtered (")", stream
);
13483 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13484 fputs_filtered ("'(", stream
);
13485 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13486 fputs_filtered (")", stream
);
13489 case UNOP_IN_RANGE
:
13490 /* XXX: sprint_subexp */
13491 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13492 fputs_filtered (" in ", stream
);
13493 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13494 &type_print_raw_options
);
13497 case OP_DISCRETE_RANGE
:
13498 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13499 fputs_filtered ("..", stream
);
13500 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13504 fputs_filtered ("others => ", stream
);
13505 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13509 for (i
= 0; i
< nargs
-1; i
+= 1)
13512 fputs_filtered ("|", stream
);
13513 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13515 fputs_filtered (" => ", stream
);
13516 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13519 case OP_POSITIONAL
:
13520 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13524 fputs_filtered ("(", stream
);
13525 for (i
= 0; i
< nargs
; i
+= 1)
13528 fputs_filtered (", ", stream
);
13529 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13531 fputs_filtered (")", stream
);
13536 /* Table mapping opcodes into strings for printing operators
13537 and precedences of the operators. */
13539 static const struct op_print ada_op_print_tab
[] = {
13540 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13541 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13542 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13543 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13544 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13545 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13546 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13547 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13548 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13549 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13550 {">", BINOP_GTR
, PREC_ORDER
, 0},
13551 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13552 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13553 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13554 {"+", BINOP_ADD
, PREC_ADD
, 0},
13555 {"-", BINOP_SUB
, PREC_ADD
, 0},
13556 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13557 {"*", BINOP_MUL
, PREC_MUL
, 0},
13558 {"/", BINOP_DIV
, PREC_MUL
, 0},
13559 {"rem", BINOP_REM
, PREC_MUL
, 0},
13560 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13561 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13562 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13563 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13564 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13565 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13566 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13567 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13568 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13569 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13570 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13571 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13574 /* Language vector */
13576 static const struct exp_descriptor ada_exp_descriptor
= {
13578 ada_operator_length
,
13579 ada_operator_check
,
13580 ada_dump_subexp_body
,
13581 ada_evaluate_subexp
13584 /* symbol_name_matcher_ftype adapter for wild_match. */
13587 do_wild_match (const char *symbol_search_name
,
13588 const lookup_name_info
&lookup_name
,
13589 completion_match_result
*comp_match_res
)
13591 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13594 /* symbol_name_matcher_ftype adapter for full_match. */
13597 do_full_match (const char *symbol_search_name
,
13598 const lookup_name_info
&lookup_name
,
13599 completion_match_result
*comp_match_res
)
13601 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13604 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13607 do_exact_match (const char *symbol_search_name
,
13608 const lookup_name_info
&lookup_name
,
13609 completion_match_result
*comp_match_res
)
13611 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13614 /* Build the Ada lookup name for LOOKUP_NAME. */
13616 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13618 gdb::string_view user_name
= lookup_name
.name ();
13620 if (user_name
[0] == '<')
13622 if (user_name
.back () == '>')
13624 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13627 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13628 m_encoded_p
= true;
13629 m_verbatim_p
= true;
13630 m_wild_match_p
= false;
13631 m_standard_p
= false;
13635 m_verbatim_p
= false;
13637 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13641 const char *folded
= ada_fold_name (user_name
);
13642 m_encoded_name
= ada_encode_1 (folded
, false);
13643 if (m_encoded_name
.empty ())
13644 m_encoded_name
= gdb::to_string (user_name
);
13647 m_encoded_name
= gdb::to_string (user_name
);
13649 /* Handle the 'package Standard' special case. See description
13650 of m_standard_p. */
13651 if (startswith (m_encoded_name
.c_str (), "standard__"))
13653 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13654 m_standard_p
= true;
13657 m_standard_p
= false;
13659 /* If the name contains a ".", then the user is entering a fully
13660 qualified entity name, and the match must not be done in wild
13661 mode. Similarly, if the user wants to complete what looks
13662 like an encoded name, the match must not be done in wild
13663 mode. Also, in the standard__ special case always do
13664 non-wild matching. */
13666 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13669 && user_name
.find ('.') == std::string::npos
);
13673 /* symbol_name_matcher_ftype method for Ada. This only handles
13674 completion mode. */
13677 ada_symbol_name_matches (const char *symbol_search_name
,
13678 const lookup_name_info
&lookup_name
,
13679 completion_match_result
*comp_match_res
)
13681 return lookup_name
.ada ().matches (symbol_search_name
,
13682 lookup_name
.match_type (),
13686 /* A name matcher that matches the symbol name exactly, with
13690 literal_symbol_name_matcher (const char *symbol_search_name
,
13691 const lookup_name_info
&lookup_name
,
13692 completion_match_result
*comp_match_res
)
13694 gdb::string_view name_view
= lookup_name
.name ();
13696 if (lookup_name
.completion_mode ()
13697 ? (strncmp (symbol_search_name
, name_view
.data (),
13698 name_view
.size ()) == 0)
13699 : symbol_search_name
== name_view
)
13701 if (comp_match_res
!= NULL
)
13702 comp_match_res
->set_match (symbol_search_name
);
13709 /* Implement the "get_symbol_name_matcher" language_defn method for
13712 static symbol_name_matcher_ftype
*
13713 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13715 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13716 return literal_symbol_name_matcher
;
13718 if (lookup_name
.completion_mode ())
13719 return ada_symbol_name_matches
;
13722 if (lookup_name
.ada ().wild_match_p ())
13723 return do_wild_match
;
13724 else if (lookup_name
.ada ().verbatim_p ())
13725 return do_exact_match
;
13727 return do_full_match
;
13731 /* Class representing the Ada language. */
13733 class ada_language
: public language_defn
13737 : language_defn (language_ada
)
13740 /* See language.h. */
13742 const char *name () const override
13745 /* See language.h. */
13747 const char *natural_name () const override
13750 /* See language.h. */
13752 const std::vector
<const char *> &filename_extensions () const override
13754 static const std::vector
<const char *> extensions
13755 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13759 /* Print an array element index using the Ada syntax. */
13761 void print_array_index (struct type
*index_type
,
13763 struct ui_file
*stream
,
13764 const value_print_options
*options
) const override
13766 struct value
*index_value
= val_atr (index_type
, index
);
13768 value_print (index_value
, stream
, options
);
13769 fprintf_filtered (stream
, " => ");
13772 /* Implement the "read_var_value" language_defn method for Ada. */
13774 struct value
*read_var_value (struct symbol
*var
,
13775 const struct block
*var_block
,
13776 struct frame_info
*frame
) const override
13778 /* The only case where default_read_var_value is not sufficient
13779 is when VAR is a renaming... */
13780 if (frame
!= nullptr)
13782 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13783 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13784 return ada_read_renaming_var_value (var
, frame_block
);
13787 /* This is a typical case where we expect the default_read_var_value
13788 function to work. */
13789 return language_defn::read_var_value (var
, var_block
, frame
);
13792 /* See language.h. */
13793 void language_arch_info (struct gdbarch
*gdbarch
,
13794 struct language_arch_info
*lai
) const override
13796 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13798 /* Helper function to allow shorter lines below. */
13799 auto add
= [&] (struct type
*t
)
13801 lai
->add_primitive_type (t
);
13804 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13806 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13807 0, "long_integer"));
13808 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13809 0, "short_integer"));
13810 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13812 lai
->set_string_char_type (char_type
);
13814 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13815 "float", gdbarch_float_format (gdbarch
)));
13816 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13817 "long_float", gdbarch_double_format (gdbarch
)));
13818 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13819 0, "long_long_integer"));
13820 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13822 gdbarch_long_double_format (gdbarch
)));
13823 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13825 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13827 add (builtin
->builtin_void
);
13829 struct type
*system_addr_ptr
13830 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13832 system_addr_ptr
->set_name ("system__address");
13833 add (system_addr_ptr
);
13835 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13836 type. This is a signed integral type whose size is the same as
13837 the size of addresses. */
13838 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13839 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13840 "storage_offset"));
13842 lai
->set_bool_type (builtin
->builtin_bool
);
13845 /* See language.h. */
13847 bool iterate_over_symbols
13848 (const struct block
*block
, const lookup_name_info
&name
,
13849 domain_enum domain
,
13850 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13852 std::vector
<struct block_symbol
> results
;
13854 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13855 for (block_symbol
&sym
: results
)
13857 if (!callback (&sym
))
13864 /* See language.h. */
13865 bool sniff_from_mangled_name (const char *mangled
,
13866 char **out
) const override
13868 std::string demangled
= ada_decode (mangled
);
13872 if (demangled
!= mangled
&& demangled
[0] != '<')
13874 /* Set the gsymbol language to Ada, but still return 0.
13875 Two reasons for that:
13877 1. For Ada, we prefer computing the symbol's decoded name
13878 on the fly rather than pre-compute it, in order to save
13879 memory (Ada projects are typically very large).
13881 2. There are some areas in the definition of the GNAT
13882 encoding where, with a bit of bad luck, we might be able
13883 to decode a non-Ada symbol, generating an incorrect
13884 demangled name (Eg: names ending with "TB" for instance
13885 are identified as task bodies and so stripped from
13886 the decoded name returned).
13888 Returning true, here, but not setting *DEMANGLED, helps us get
13889 a little bit of the best of both worlds. Because we're last,
13890 we should not affect any of the other languages that were
13891 able to demangle the symbol before us; we get to correctly
13892 tag Ada symbols as such; and even if we incorrectly tagged a
13893 non-Ada symbol, which should be rare, any routing through the
13894 Ada language should be transparent (Ada tries to behave much
13895 like C/C++ with non-Ada symbols). */
13902 /* See language.h. */
13904 char *demangle_symbol (const char *mangled
, int options
) const override
13906 return ada_la_decode (mangled
, options
);
13909 /* See language.h. */
13911 void print_type (struct type
*type
, const char *varstring
,
13912 struct ui_file
*stream
, int show
, int level
,
13913 const struct type_print_options
*flags
) const override
13915 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13918 /* See language.h. */
13920 const char *word_break_characters (void) const override
13922 return ada_completer_word_break_characters
;
13925 /* See language.h. */
13927 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13928 complete_symbol_mode mode
,
13929 symbol_name_match_type name_match_type
,
13930 const char *text
, const char *word
,
13931 enum type_code code
) const override
13933 struct symbol
*sym
;
13934 const struct block
*b
, *surrounding_static_block
= 0;
13935 struct block_iterator iter
;
13937 gdb_assert (code
== TYPE_CODE_UNDEF
);
13939 lookup_name_info
lookup_name (text
, name_match_type
, true);
13941 /* First, look at the partial symtab symbols. */
13942 expand_symtabs_matching (NULL
,
13948 /* At this point scan through the misc symbol vectors and add each
13949 symbol you find to the list. Eventually we want to ignore
13950 anything that isn't a text symbol (everything else will be
13951 handled by the psymtab code above). */
13953 for (objfile
*objfile
: current_program_space
->objfiles ())
13955 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13959 if (completion_skip_symbol (mode
, msymbol
))
13962 language symbol_language
= msymbol
->language ();
13964 /* Ada minimal symbols won't have their language set to Ada. If
13965 we let completion_list_add_name compare using the
13966 default/C-like matcher, then when completing e.g., symbols in a
13967 package named "pck", we'd match internal Ada symbols like
13968 "pckS", which are invalid in an Ada expression, unless you wrap
13969 them in '<' '>' to request a verbatim match.
13971 Unfortunately, some Ada encoded names successfully demangle as
13972 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13973 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13974 with the wrong language set. Paper over that issue here. */
13975 if (symbol_language
== language_auto
13976 || symbol_language
== language_cplus
)
13977 symbol_language
= language_ada
;
13979 completion_list_add_name (tracker
,
13981 msymbol
->linkage_name (),
13982 lookup_name
, text
, word
);
13986 /* Search upwards from currently selected frame (so that we can
13987 complete on local vars. */
13989 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13991 if (!BLOCK_SUPERBLOCK (b
))
13992 surrounding_static_block
= b
; /* For elmin of dups */
13994 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13996 if (completion_skip_symbol (mode
, sym
))
13999 completion_list_add_name (tracker
,
14001 sym
->linkage_name (),
14002 lookup_name
, text
, word
);
14006 /* Go through the symtabs and check the externs and statics for
14007 symbols which match. */
14009 for (objfile
*objfile
: current_program_space
->objfiles ())
14011 for (compunit_symtab
*s
: objfile
->compunits ())
14014 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14015 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14017 if (completion_skip_symbol (mode
, sym
))
14020 completion_list_add_name (tracker
,
14022 sym
->linkage_name (),
14023 lookup_name
, text
, word
);
14028 for (objfile
*objfile
: current_program_space
->objfiles ())
14030 for (compunit_symtab
*s
: objfile
->compunits ())
14033 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14034 /* Don't do this block twice. */
14035 if (b
== surrounding_static_block
)
14037 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14039 if (completion_skip_symbol (mode
, sym
))
14042 completion_list_add_name (tracker
,
14044 sym
->linkage_name (),
14045 lookup_name
, text
, word
);
14051 /* See language.h. */
14053 gdb::unique_xmalloc_ptr
<char> watch_location_expression
14054 (struct type
*type
, CORE_ADDR addr
) const override
14056 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
14057 std::string name
= type_to_string (type
);
14058 return gdb::unique_xmalloc_ptr
<char>
14059 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
14062 /* See language.h. */
14064 void value_print (struct value
*val
, struct ui_file
*stream
,
14065 const struct value_print_options
*options
) const override
14067 return ada_value_print (val
, stream
, options
);
14070 /* See language.h. */
14072 void value_print_inner
14073 (struct value
*val
, struct ui_file
*stream
, int recurse
,
14074 const struct value_print_options
*options
) const override
14076 return ada_value_print_inner (val
, stream
, recurse
, options
);
14079 /* See language.h. */
14081 struct block_symbol lookup_symbol_nonlocal
14082 (const char *name
, const struct block
*block
,
14083 const domain_enum domain
) const override
14085 struct block_symbol sym
;
14087 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
14088 if (sym
.symbol
!= NULL
)
14091 /* If we haven't found a match at this point, try the primitive
14092 types. In other languages, this search is performed before
14093 searching for global symbols in order to short-circuit that
14094 global-symbol search if it happens that the name corresponds
14095 to a primitive type. But we cannot do the same in Ada, because
14096 it is perfectly legitimate for a program to declare a type which
14097 has the same name as a standard type. If looking up a type in
14098 that situation, we have traditionally ignored the primitive type
14099 in favor of user-defined types. This is why, unlike most other
14100 languages, we search the primitive types this late and only after
14101 having searched the global symbols without success. */
14103 if (domain
== VAR_DOMAIN
)
14105 struct gdbarch
*gdbarch
;
14108 gdbarch
= target_gdbarch ();
14110 gdbarch
= block_gdbarch (block
);
14112 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
14113 if (sym
.symbol
!= NULL
)
14120 /* See language.h. */
14122 int parser (struct parser_state
*ps
) const override
14124 warnings_issued
= 0;
14125 return ada_parse (ps
);
14130 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
14131 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
14132 namespace) and converts operators that are user-defined into
14133 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
14134 a preferred result type [at the moment, only type void has any
14135 effect---causing procedures to be preferred over functions in calls].
14136 A null CONTEXT_TYPE indicates that a non-void return type is
14137 preferred. May change (expand) *EXP. */
14139 void post_parser (expression_up
*expp
, int void_context_p
, int completing
,
14140 innermost_block_tracker
*tracker
) const override
14142 struct type
*context_type
= NULL
;
14145 if (void_context_p
)
14146 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14148 resolve_subexp (expp
, &pc
, 1, context_type
, completing
, tracker
);
14151 /* See language.h. */
14153 void emitchar (int ch
, struct type
*chtype
,
14154 struct ui_file
*stream
, int quoter
) const override
14156 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14159 /* See language.h. */
14161 void printchar (int ch
, struct type
*chtype
,
14162 struct ui_file
*stream
) const override
14164 ada_printchar (ch
, chtype
, stream
);
14167 /* See language.h. */
14169 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14170 const gdb_byte
*string
, unsigned int length
,
14171 const char *encoding
, int force_ellipses
,
14172 const struct value_print_options
*options
) const override
14174 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14175 force_ellipses
, options
);
14178 /* See language.h. */
14180 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14181 struct ui_file
*stream
) const override
14183 ada_print_typedef (type
, new_symbol
, stream
);
14186 /* See language.h. */
14188 bool is_string_type_p (struct type
*type
) const override
14190 return ada_is_string_type (type
);
14193 /* See language.h. */
14195 const char *struct_too_deep_ellipsis () const override
14196 { return "(...)"; }
14198 /* See language.h. */
14200 bool c_style_arrays_p () const override
14203 /* See language.h. */
14205 bool store_sym_names_in_linkage_form_p () const override
14208 /* See language.h. */
14210 const struct lang_varobj_ops
*varobj_ops () const override
14211 { return &ada_varobj_ops
; }
14213 /* See language.h. */
14215 const struct exp_descriptor
*expression_ops () const override
14216 { return &ada_exp_descriptor
; }
14218 /* See language.h. */
14220 const struct op_print
*opcode_print_table () const override
14221 { return ada_op_print_tab
; }
14224 /* See language.h. */
14226 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14227 (const lookup_name_info
&lookup_name
) const override
14229 return ada_get_symbol_name_matcher (lookup_name
);
14233 /* Single instance of the Ada language class. */
14235 static ada_language ada_language_defn
;
14237 /* Command-list for the "set/show ada" prefix command. */
14238 static struct cmd_list_element
*set_ada_list
;
14239 static struct cmd_list_element
*show_ada_list
;
14242 initialize_ada_catchpoint_ops (void)
14244 struct breakpoint_ops
*ops
;
14246 initialize_breakpoint_ops ();
14248 ops
= &catch_exception_breakpoint_ops
;
14249 *ops
= bkpt_breakpoint_ops
;
14250 ops
->allocate_location
= allocate_location_exception
;
14251 ops
->re_set
= re_set_exception
;
14252 ops
->check_status
= check_status_exception
;
14253 ops
->print_it
= print_it_exception
;
14254 ops
->print_one
= print_one_exception
;
14255 ops
->print_mention
= print_mention_exception
;
14256 ops
->print_recreate
= print_recreate_exception
;
14258 ops
= &catch_exception_unhandled_breakpoint_ops
;
14259 *ops
= bkpt_breakpoint_ops
;
14260 ops
->allocate_location
= allocate_location_exception
;
14261 ops
->re_set
= re_set_exception
;
14262 ops
->check_status
= check_status_exception
;
14263 ops
->print_it
= print_it_exception
;
14264 ops
->print_one
= print_one_exception
;
14265 ops
->print_mention
= print_mention_exception
;
14266 ops
->print_recreate
= print_recreate_exception
;
14268 ops
= &catch_assert_breakpoint_ops
;
14269 *ops
= bkpt_breakpoint_ops
;
14270 ops
->allocate_location
= allocate_location_exception
;
14271 ops
->re_set
= re_set_exception
;
14272 ops
->check_status
= check_status_exception
;
14273 ops
->print_it
= print_it_exception
;
14274 ops
->print_one
= print_one_exception
;
14275 ops
->print_mention
= print_mention_exception
;
14276 ops
->print_recreate
= print_recreate_exception
;
14278 ops
= &catch_handlers_breakpoint_ops
;
14279 *ops
= bkpt_breakpoint_ops
;
14280 ops
->allocate_location
= allocate_location_exception
;
14281 ops
->re_set
= re_set_exception
;
14282 ops
->check_status
= check_status_exception
;
14283 ops
->print_it
= print_it_exception
;
14284 ops
->print_one
= print_one_exception
;
14285 ops
->print_mention
= print_mention_exception
;
14286 ops
->print_recreate
= print_recreate_exception
;
14289 /* This module's 'new_objfile' observer. */
14292 ada_new_objfile_observer (struct objfile
*objfile
)
14294 ada_clear_symbol_cache ();
14297 /* This module's 'free_objfile' observer. */
14300 ada_free_objfile_observer (struct objfile
*objfile
)
14302 ada_clear_symbol_cache ();
14305 void _initialize_ada_language ();
14307 _initialize_ada_language ()
14309 initialize_ada_catchpoint_ops ();
14311 add_basic_prefix_cmd ("ada", no_class
,
14312 _("Prefix command for changing Ada-specific settings."),
14313 &set_ada_list
, "set ada ", 0, &setlist
);
14315 add_show_prefix_cmd ("ada", no_class
,
14316 _("Generic command for showing Ada-specific settings."),
14317 &show_ada_list
, "show ada ", 0, &showlist
);
14319 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14320 &trust_pad_over_xvs
, _("\
14321 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14322 Show whether an optimization trusting PAD types over XVS types is activated."),
14324 This is related to the encoding used by the GNAT compiler. The debugger\n\
14325 should normally trust the contents of PAD types, but certain older versions\n\
14326 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14327 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14328 work around this bug. It is always safe to turn this option \"off\", but\n\
14329 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14330 this option to \"off\" unless necessary."),
14331 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14333 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14334 &print_signatures
, _("\
14335 Enable or disable the output of formal and return types for functions in the \
14336 overloads selection menu."), _("\
14337 Show whether the output of formal and return types for functions in the \
14338 overloads selection menu is activated."),
14339 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14341 add_catch_command ("exception", _("\
14342 Catch Ada exceptions, when raised.\n\
14343 Usage: catch exception [ARG] [if CONDITION]\n\
14344 Without any argument, stop when any Ada exception is raised.\n\
14345 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14346 being raised does not have a handler (and will therefore lead to the task's\n\
14348 Otherwise, the catchpoint only stops when the name of the exception being\n\
14349 raised is the same as ARG.\n\
14350 CONDITION is a boolean expression that is evaluated to see whether the\n\
14351 exception should cause a stop."),
14352 catch_ada_exception_command
,
14353 catch_ada_completer
,
14357 add_catch_command ("handlers", _("\
14358 Catch Ada exceptions, when handled.\n\
14359 Usage: catch handlers [ARG] [if CONDITION]\n\
14360 Without any argument, stop when any Ada exception is handled.\n\
14361 With an argument, catch only exceptions with the given name.\n\
14362 CONDITION is a boolean expression that is evaluated to see whether the\n\
14363 exception should cause a stop."),
14364 catch_ada_handlers_command
,
14365 catch_ada_completer
,
14368 add_catch_command ("assert", _("\
14369 Catch failed Ada assertions, when raised.\n\
14370 Usage: catch assert [if CONDITION]\n\
14371 CONDITION is a boolean expression that is evaluated to see whether the\n\
14372 exception should cause a stop."),
14373 catch_assert_command
,
14378 varsize_limit
= 65536;
14379 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14380 &varsize_limit
, _("\
14381 Set the maximum number of bytes allowed in a variable-size object."), _("\
14382 Show the maximum number of bytes allowed in a variable-size object."), _("\
14383 Attempts to access an object whose size is not a compile-time constant\n\
14384 and exceeds this limit will cause an error."),
14385 NULL
, NULL
, &setlist
, &showlist
);
14387 add_info ("exceptions", info_exceptions_command
,
14389 List all Ada exception names.\n\
14390 Usage: info exceptions [REGEXP]\n\
14391 If a regular expression is passed as an argument, only those matching\n\
14392 the regular expression are listed."));
14394 add_basic_prefix_cmd ("ada", class_maintenance
,
14395 _("Set Ada maintenance-related variables."),
14396 &maint_set_ada_cmdlist
, "maintenance set ada ",
14397 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14399 add_show_prefix_cmd ("ada", class_maintenance
,
14400 _("Show Ada maintenance-related variables."),
14401 &maint_show_ada_cmdlist
, "maintenance show ada ",
14402 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14404 add_setshow_boolean_cmd
14405 ("ignore-descriptive-types", class_maintenance
,
14406 &ada_ignore_descriptive_types_p
,
14407 _("Set whether descriptive types generated by GNAT should be ignored."),
14408 _("Show whether descriptive types generated by GNAT should be ignored."),
14410 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14411 DWARF attribute."),
14412 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14414 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14415 NULL
, xcalloc
, xfree
);
14417 /* The ada-lang observers. */
14418 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14419 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14420 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);