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
]);
989 fold_buffer
[i
] = '\0';
995 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
998 is_lower_alphanum (const char c
)
1000 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1003 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1004 This function saves in LEN the length of that same symbol name but
1005 without either of these suffixes:
1011 These are suffixes introduced by the compiler for entities such as
1012 nested subprogram for instance, in order to avoid name clashes.
1013 They do not serve any purpose for the debugger. */
1016 ada_remove_trailing_digits (const char *encoded
, int *len
)
1018 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1022 while (i
> 0 && isdigit (encoded
[i
]))
1024 if (i
>= 0 && encoded
[i
] == '.')
1026 else if (i
>= 0 && encoded
[i
] == '$')
1028 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1030 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1035 /* Remove the suffix introduced by the compiler for protected object
1039 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1041 /* Remove trailing N. */
1043 /* Protected entry subprograms are broken into two
1044 separate subprograms: The first one is unprotected, and has
1045 a 'N' suffix; the second is the protected version, and has
1046 the 'P' suffix. The second calls the first one after handling
1047 the protection. Since the P subprograms are internally generated,
1048 we leave these names undecoded, giving the user a clue that this
1049 entity is internal. */
1052 && encoded
[*len
- 1] == 'N'
1053 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1057 /* If ENCODED follows the GNAT entity encoding conventions, then return
1058 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1059 replaced by ENCODED. */
1062 ada_decode (const char *encoded
)
1068 std::string decoded
;
1070 /* With function descriptors on PPC64, the value of a symbol named
1071 ".FN", if it exists, is the entry point of the function "FN". */
1072 if (encoded
[0] == '.')
1075 /* The name of the Ada main procedure starts with "_ada_".
1076 This prefix is not part of the decoded name, so skip this part
1077 if we see this prefix. */
1078 if (startswith (encoded
, "_ada_"))
1081 /* If the name starts with '_', then it is not a properly encoded
1082 name, so do not attempt to decode it. Similarly, if the name
1083 starts with '<', the name should not be decoded. */
1084 if (encoded
[0] == '_' || encoded
[0] == '<')
1087 len0
= strlen (encoded
);
1089 ada_remove_trailing_digits (encoded
, &len0
);
1090 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1092 /* Remove the ___X.* suffix if present. Do not forget to verify that
1093 the suffix is located before the current "end" of ENCODED. We want
1094 to avoid re-matching parts of ENCODED that have previously been
1095 marked as discarded (by decrementing LEN0). */
1096 p
= strstr (encoded
, "___");
1097 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1105 /* Remove any trailing TKB suffix. It tells us that this symbol
1106 is for the body of a task, but that information does not actually
1107 appear in the decoded name. */
1109 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1112 /* Remove any trailing TB suffix. The TB suffix is slightly different
1113 from the TKB suffix because it is used for non-anonymous task
1116 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1119 /* Remove trailing "B" suffixes. */
1120 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1122 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1125 /* Make decoded big enough for possible expansion by operator name. */
1127 decoded
.resize (2 * len0
+ 1, 'X');
1129 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1131 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1134 while ((i
>= 0 && isdigit (encoded
[i
]))
1135 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1137 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1139 else if (encoded
[i
] == '$')
1143 /* The first few characters that are not alphabetic are not part
1144 of any encoding we use, so we can copy them over verbatim. */
1146 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1147 decoded
[j
] = encoded
[i
];
1152 /* Is this a symbol function? */
1153 if (at_start_name
&& encoded
[i
] == 'O')
1157 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1159 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1160 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1162 && !isalnum (encoded
[i
+ op_len
]))
1164 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1167 j
+= strlen (ada_opname_table
[k
].decoded
);
1171 if (ada_opname_table
[k
].encoded
!= NULL
)
1176 /* Replace "TK__" with "__", which will eventually be translated
1177 into "." (just below). */
1179 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1182 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1183 be translated into "." (just below). These are internal names
1184 generated for anonymous blocks inside which our symbol is nested. */
1186 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1187 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1188 && isdigit (encoded
[i
+4]))
1192 while (k
< len0
&& isdigit (encoded
[k
]))
1193 k
++; /* Skip any extra digit. */
1195 /* Double-check that the "__B_{DIGITS}+" sequence we found
1196 is indeed followed by "__". */
1197 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1201 /* Remove _E{DIGITS}+[sb] */
1203 /* Just as for protected object subprograms, there are 2 categories
1204 of subprograms created by the compiler for each entry. The first
1205 one implements the actual entry code, and has a suffix following
1206 the convention above; the second one implements the barrier and
1207 uses the same convention as above, except that the 'E' is replaced
1210 Just as above, we do not decode the name of barrier functions
1211 to give the user a clue that the code he is debugging has been
1212 internally generated. */
1214 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1215 && isdigit (encoded
[i
+2]))
1219 while (k
< len0
&& isdigit (encoded
[k
]))
1223 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1226 /* Just as an extra precaution, make sure that if this
1227 suffix is followed by anything else, it is a '_'.
1228 Otherwise, we matched this sequence by accident. */
1230 || (k
< len0
&& encoded
[k
] == '_'))
1235 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1236 the GNAT front-end in protected object subprograms. */
1239 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1241 /* Backtrack a bit up until we reach either the begining of
1242 the encoded name, or "__". Make sure that we only find
1243 digits or lowercase characters. */
1244 const char *ptr
= encoded
+ i
- 1;
1246 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1249 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1253 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1255 /* This is a X[bn]* sequence not separated from the previous
1256 part of the name with a non-alpha-numeric character (in other
1257 words, immediately following an alpha-numeric character), then
1258 verify that it is placed at the end of the encoded name. If
1259 not, then the encoding is not valid and we should abort the
1260 decoding. Otherwise, just skip it, it is used in body-nested
1264 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1268 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1270 /* Replace '__' by '.'. */
1278 /* It's a character part of the decoded name, so just copy it
1280 decoded
[j
] = encoded
[i
];
1287 /* Decoded names should never contain any uppercase character.
1288 Double-check this, and abort the decoding if we find one. */
1290 for (i
= 0; i
< decoded
.length(); ++i
)
1291 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1297 if (encoded
[0] == '<')
1300 decoded
= '<' + std::string(encoded
) + '>';
1305 /* Table for keeping permanent unique copies of decoded names. Once
1306 allocated, names in this table are never released. While this is a
1307 storage leak, it should not be significant unless there are massive
1308 changes in the set of decoded names in successive versions of a
1309 symbol table loaded during a single session. */
1310 static struct htab
*decoded_names_store
;
1312 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1313 in the language-specific part of GSYMBOL, if it has not been
1314 previously computed. Tries to save the decoded name in the same
1315 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1316 in any case, the decoded symbol has a lifetime at least that of
1318 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1319 const, but nevertheless modified to a semantically equivalent form
1320 when a decoded name is cached in it. */
1323 ada_decode_symbol (const struct general_symbol_info
*arg
)
1325 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1326 const char **resultp
=
1327 &gsymbol
->language_specific
.demangled_name
;
1329 if (!gsymbol
->ada_mangled
)
1331 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1332 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1334 gsymbol
->ada_mangled
= 1;
1336 if (obstack
!= NULL
)
1337 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1340 /* Sometimes, we can't find a corresponding objfile, in
1341 which case, we put the result on the heap. Since we only
1342 decode when needed, we hope this usually does not cause a
1343 significant memory leak (FIXME). */
1345 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1346 decoded
.c_str (), INSERT
);
1349 *slot
= xstrdup (decoded
.c_str ());
1358 ada_la_decode (const char *encoded
, int options
)
1360 return xstrdup (ada_decode (encoded
).c_str ());
1367 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1368 generated by the GNAT compiler to describe the index type used
1369 for each dimension of an array, check whether it follows the latest
1370 known encoding. If not, fix it up to conform to the latest encoding.
1371 Otherwise, do nothing. This function also does nothing if
1372 INDEX_DESC_TYPE is NULL.
1374 The GNAT encoding used to describe the array index type evolved a bit.
1375 Initially, the information would be provided through the name of each
1376 field of the structure type only, while the type of these fields was
1377 described as unspecified and irrelevant. The debugger was then expected
1378 to perform a global type lookup using the name of that field in order
1379 to get access to the full index type description. Because these global
1380 lookups can be very expensive, the encoding was later enhanced to make
1381 the global lookup unnecessary by defining the field type as being
1382 the full index type description.
1384 The purpose of this routine is to allow us to support older versions
1385 of the compiler by detecting the use of the older encoding, and by
1386 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1387 we essentially replace each field's meaningless type by the associated
1391 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1395 if (index_desc_type
== NULL
)
1397 gdb_assert (index_desc_type
->num_fields () > 0);
1399 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1400 to check one field only, no need to check them all). If not, return
1403 If our INDEX_DESC_TYPE was generated using the older encoding,
1404 the field type should be a meaningless integer type whose name
1405 is not equal to the field name. */
1406 if (index_desc_type
->field (0).type ()->name () != NULL
1407 && strcmp (index_desc_type
->field (0).type ()->name (),
1408 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1411 /* Fixup each field of INDEX_DESC_TYPE. */
1412 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1414 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1415 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1418 index_desc_type
->field (i
).set_type (raw_type
);
1422 /* The desc_* routines return primitive portions of array descriptors
1425 /* The descriptor or array type, if any, indicated by TYPE; removes
1426 level of indirection, if needed. */
1428 static struct type
*
1429 desc_base_type (struct type
*type
)
1433 type
= ada_check_typedef (type
);
1434 if (type
->code () == TYPE_CODE_TYPEDEF
)
1435 type
= ada_typedef_target_type (type
);
1438 && (type
->code () == TYPE_CODE_PTR
1439 || type
->code () == TYPE_CODE_REF
))
1440 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1445 /* True iff TYPE indicates a "thin" array pointer type. */
1448 is_thin_pntr (struct type
*type
)
1451 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1452 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1455 /* The descriptor type for thin pointer type TYPE. */
1457 static struct type
*
1458 thin_descriptor_type (struct type
*type
)
1460 struct type
*base_type
= desc_base_type (type
);
1462 if (base_type
== NULL
)
1464 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1468 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1470 if (alt_type
== NULL
)
1477 /* A pointer to the array data for thin-pointer value VAL. */
1479 static struct value
*
1480 thin_data_pntr (struct value
*val
)
1482 struct type
*type
= ada_check_typedef (value_type (val
));
1483 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1485 data_type
= lookup_pointer_type (data_type
);
1487 if (type
->code () == TYPE_CODE_PTR
)
1488 return value_cast (data_type
, value_copy (val
));
1490 return value_from_longest (data_type
, value_address (val
));
1493 /* True iff TYPE indicates a "thick" array pointer type. */
1496 is_thick_pntr (struct type
*type
)
1498 type
= desc_base_type (type
);
1499 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1500 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1503 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1504 pointer to one, the type of its bounds data; otherwise, NULL. */
1506 static struct type
*
1507 desc_bounds_type (struct type
*type
)
1511 type
= desc_base_type (type
);
1515 else if (is_thin_pntr (type
))
1517 type
= thin_descriptor_type (type
);
1520 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1522 return ada_check_typedef (r
);
1524 else if (type
->code () == TYPE_CODE_STRUCT
)
1526 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1528 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1533 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1534 one, a pointer to its bounds data. Otherwise NULL. */
1536 static struct value
*
1537 desc_bounds (struct value
*arr
)
1539 struct type
*type
= ada_check_typedef (value_type (arr
));
1541 if (is_thin_pntr (type
))
1543 struct type
*bounds_type
=
1544 desc_bounds_type (thin_descriptor_type (type
));
1547 if (bounds_type
== NULL
)
1548 error (_("Bad GNAT array descriptor"));
1550 /* NOTE: The following calculation is not really kosher, but
1551 since desc_type is an XVE-encoded type (and shouldn't be),
1552 the correct calculation is a real pain. FIXME (and fix GCC). */
1553 if (type
->code () == TYPE_CODE_PTR
)
1554 addr
= value_as_long (arr
);
1556 addr
= value_address (arr
);
1559 value_from_longest (lookup_pointer_type (bounds_type
),
1560 addr
- TYPE_LENGTH (bounds_type
));
1563 else if (is_thick_pntr (type
))
1565 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1566 _("Bad GNAT array descriptor"));
1567 struct type
*p_bounds_type
= value_type (p_bounds
);
1570 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1572 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1574 if (target_type
->is_stub ())
1575 p_bounds
= value_cast (lookup_pointer_type
1576 (ada_check_typedef (target_type
)),
1580 error (_("Bad GNAT array descriptor"));
1588 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1589 position of the field containing the address of the bounds data. */
1592 fat_pntr_bounds_bitpos (struct type
*type
)
1594 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1597 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1598 size of the field containing the address of the bounds data. */
1601 fat_pntr_bounds_bitsize (struct type
*type
)
1603 type
= desc_base_type (type
);
1605 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1606 return TYPE_FIELD_BITSIZE (type
, 1);
1608 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1611 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1612 pointer to one, the type of its array data (a array-with-no-bounds type);
1613 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1616 static struct type
*
1617 desc_data_target_type (struct type
*type
)
1619 type
= desc_base_type (type
);
1621 /* NOTE: The following is bogus; see comment in desc_bounds. */
1622 if (is_thin_pntr (type
))
1623 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1624 else if (is_thick_pntr (type
))
1626 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1629 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1630 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1636 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1639 static struct value
*
1640 desc_data (struct value
*arr
)
1642 struct type
*type
= value_type (arr
);
1644 if (is_thin_pntr (type
))
1645 return thin_data_pntr (arr
);
1646 else if (is_thick_pntr (type
))
1647 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1648 _("Bad GNAT array descriptor"));
1654 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1655 position of the field containing the address of the data. */
1658 fat_pntr_data_bitpos (struct type
*type
)
1660 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1663 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1664 size of the field containing the address of the data. */
1667 fat_pntr_data_bitsize (struct type
*type
)
1669 type
= desc_base_type (type
);
1671 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1672 return TYPE_FIELD_BITSIZE (type
, 0);
1674 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1677 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1678 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1679 bound, if WHICH is 1. The first bound is I=1. */
1681 static struct value
*
1682 desc_one_bound (struct value
*bounds
, int i
, int which
)
1684 char bound_name
[20];
1685 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1686 which
? 'U' : 'L', i
- 1);
1687 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1688 _("Bad GNAT array descriptor bounds"));
1691 /* If BOUNDS is an array-bounds structure type, return the bit position
1692 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1693 bound, if WHICH is 1. The first bound is I=1. */
1696 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1698 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1701 /* If BOUNDS is an array-bounds structure type, return the bit field size
1702 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1703 bound, if WHICH is 1. The first bound is I=1. */
1706 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1708 type
= desc_base_type (type
);
1710 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1711 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1713 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1716 /* If TYPE is the type of an array-bounds structure, the type of its
1717 Ith bound (numbering from 1). Otherwise, NULL. */
1719 static struct type
*
1720 desc_index_type (struct type
*type
, int i
)
1722 type
= desc_base_type (type
);
1724 if (type
->code () == TYPE_CODE_STRUCT
)
1726 char bound_name
[20];
1727 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1728 return lookup_struct_elt_type (type
, bound_name
, 1);
1734 /* The number of index positions in the array-bounds type TYPE.
1735 Return 0 if TYPE is NULL. */
1738 desc_arity (struct type
*type
)
1740 type
= desc_base_type (type
);
1743 return type
->num_fields () / 2;
1747 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1748 an array descriptor type (representing an unconstrained array
1752 ada_is_direct_array_type (struct type
*type
)
1756 type
= ada_check_typedef (type
);
1757 return (type
->code () == TYPE_CODE_ARRAY
1758 || ada_is_array_descriptor_type (type
));
1761 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1765 ada_is_array_type (struct type
*type
)
1768 && (type
->code () == TYPE_CODE_PTR
1769 || type
->code () == TYPE_CODE_REF
))
1770 type
= TYPE_TARGET_TYPE (type
);
1771 return ada_is_direct_array_type (type
);
1774 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1777 ada_is_simple_array_type (struct type
*type
)
1781 type
= ada_check_typedef (type
);
1782 return (type
->code () == TYPE_CODE_ARRAY
1783 || (type
->code () == TYPE_CODE_PTR
1784 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1785 == TYPE_CODE_ARRAY
)));
1788 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1791 ada_is_array_descriptor_type (struct type
*type
)
1793 struct type
*data_type
= desc_data_target_type (type
);
1797 type
= ada_check_typedef (type
);
1798 return (data_type
!= NULL
1799 && data_type
->code () == TYPE_CODE_ARRAY
1800 && desc_arity (desc_bounds_type (type
)) > 0);
1803 /* Non-zero iff type is a partially mal-formed GNAT array
1804 descriptor. FIXME: This is to compensate for some problems with
1805 debugging output from GNAT. Re-examine periodically to see if it
1809 ada_is_bogus_array_descriptor (struct type
*type
)
1813 && type
->code () == TYPE_CODE_STRUCT
1814 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1815 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1816 && !ada_is_array_descriptor_type (type
);
1820 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1821 (fat pointer) returns the type of the array data described---specifically,
1822 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1823 in from the descriptor; otherwise, they are left unspecified. If
1824 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1825 returns NULL. The result is simply the type of ARR if ARR is not
1828 static struct type
*
1829 ada_type_of_array (struct value
*arr
, int bounds
)
1831 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1832 return decode_constrained_packed_array_type (value_type (arr
));
1834 if (!ada_is_array_descriptor_type (value_type (arr
)))
1835 return value_type (arr
);
1839 struct type
*array_type
=
1840 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1842 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1843 TYPE_FIELD_BITSIZE (array_type
, 0) =
1844 decode_packed_array_bitsize (value_type (arr
));
1850 struct type
*elt_type
;
1852 struct value
*descriptor
;
1854 elt_type
= ada_array_element_type (value_type (arr
), -1);
1855 arity
= ada_array_arity (value_type (arr
));
1857 if (elt_type
== NULL
|| arity
== 0)
1858 return ada_check_typedef (value_type (arr
));
1860 descriptor
= desc_bounds (arr
);
1861 if (value_as_long (descriptor
) == 0)
1865 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1866 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1867 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1868 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1871 create_static_range_type (range_type
, value_type (low
),
1872 longest_to_int (value_as_long (low
)),
1873 longest_to_int (value_as_long (high
)));
1874 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1876 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1878 /* We need to store the element packed bitsize, as well as
1879 recompute the array size, because it was previously
1880 computed based on the unpacked element size. */
1881 LONGEST lo
= value_as_long (low
);
1882 LONGEST hi
= value_as_long (high
);
1884 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1885 decode_packed_array_bitsize (value_type (arr
));
1886 /* If the array has no element, then the size is already
1887 zero, and does not need to be recomputed. */
1891 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1893 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1898 return lookup_pointer_type (elt_type
);
1902 /* If ARR does not represent an array, returns ARR unchanged.
1903 Otherwise, returns either a standard GDB array with bounds set
1904 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1905 GDB array. Returns NULL if ARR is a null fat pointer. */
1908 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1910 if (ada_is_array_descriptor_type (value_type (arr
)))
1912 struct type
*arrType
= ada_type_of_array (arr
, 1);
1914 if (arrType
== NULL
)
1916 return value_cast (arrType
, value_copy (desc_data (arr
)));
1918 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1919 return decode_constrained_packed_array (arr
);
1924 /* If ARR does not represent an array, returns ARR unchanged.
1925 Otherwise, returns a standard GDB array describing ARR (which may
1926 be ARR itself if it already is in the proper form). */
1929 ada_coerce_to_simple_array (struct value
*arr
)
1931 if (ada_is_array_descriptor_type (value_type (arr
)))
1933 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1936 error (_("Bounds unavailable for null array pointer."));
1937 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1938 return value_ind (arrVal
);
1940 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1941 return decode_constrained_packed_array (arr
);
1946 /* If TYPE represents a GNAT array type, return it translated to an
1947 ordinary GDB array type (possibly with BITSIZE fields indicating
1948 packing). For other types, is the identity. */
1951 ada_coerce_to_simple_array_type (struct type
*type
)
1953 if (ada_is_constrained_packed_array_type (type
))
1954 return decode_constrained_packed_array_type (type
);
1956 if (ada_is_array_descriptor_type (type
))
1957 return ada_check_typedef (desc_data_target_type (type
));
1962 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1965 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
1969 type
= desc_base_type (type
);
1970 type
= ada_check_typedef (type
);
1972 ada_type_name (type
) != NULL
1973 && strstr (ada_type_name (type
), "___XP") != NULL
;
1976 /* Non-zero iff TYPE represents a standard GNAT constrained
1977 packed-array type. */
1980 ada_is_constrained_packed_array_type (struct type
*type
)
1982 return ada_is_gnat_encoded_packed_array_type (type
)
1983 && !ada_is_array_descriptor_type (type
);
1986 /* Non-zero iff TYPE represents an array descriptor for a
1987 unconstrained packed-array type. */
1990 ada_is_unconstrained_packed_array_type (struct type
*type
)
1992 if (!ada_is_array_descriptor_type (type
))
1995 if (ada_is_gnat_encoded_packed_array_type (type
))
1998 /* If we saw GNAT encodings, then the above code is sufficient.
1999 However, with minimal encodings, we will just have a thick
2001 if (is_thick_pntr (type
))
2003 type
= desc_base_type (type
);
2004 /* The structure's first field is a pointer to an array, so this
2005 fetches the array type. */
2006 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2007 /* Now we can see if the array elements are packed. */
2008 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
2014 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2015 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2018 ada_is_any_packed_array_type (struct type
*type
)
2020 return (ada_is_constrained_packed_array_type (type
)
2021 || (type
->code () == TYPE_CODE_ARRAY
2022 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
2025 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2026 return the size of its elements in bits. */
2029 decode_packed_array_bitsize (struct type
*type
)
2031 const char *raw_name
;
2035 /* Access to arrays implemented as fat pointers are encoded as a typedef
2036 of the fat pointer type. We need the name of the fat pointer type
2037 to do the decoding, so strip the typedef layer. */
2038 if (type
->code () == TYPE_CODE_TYPEDEF
)
2039 type
= ada_typedef_target_type (type
);
2041 raw_name
= ada_type_name (ada_check_typedef (type
));
2043 raw_name
= ada_type_name (desc_base_type (type
));
2048 tail
= strstr (raw_name
, "___XP");
2049 if (tail
== nullptr)
2051 gdb_assert (is_thick_pntr (type
));
2052 /* The structure's first field is a pointer to an array, so this
2053 fetches the array type. */
2054 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2055 /* Now we can see if the array elements are packed. */
2056 return TYPE_FIELD_BITSIZE (type
, 0);
2059 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2062 (_("could not understand bit size information on packed array"));
2069 /* Given that TYPE is a standard GDB array type with all bounds filled
2070 in, and that the element size of its ultimate scalar constituents
2071 (that is, either its elements, or, if it is an array of arrays, its
2072 elements' elements, etc.) is *ELT_BITS, return an identical type,
2073 but with the bit sizes of its elements (and those of any
2074 constituent arrays) recorded in the BITSIZE components of its
2075 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2078 Note that, for arrays whose index type has an XA encoding where
2079 a bound references a record discriminant, getting that discriminant,
2080 and therefore the actual value of that bound, is not possible
2081 because none of the given parameters gives us access to the record.
2082 This function assumes that it is OK in the context where it is being
2083 used to return an array whose bounds are still dynamic and where
2084 the length is arbitrary. */
2086 static struct type
*
2087 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2089 struct type
*new_elt_type
;
2090 struct type
*new_type
;
2091 struct type
*index_type_desc
;
2092 struct type
*index_type
;
2093 LONGEST low_bound
, high_bound
;
2095 type
= ada_check_typedef (type
);
2096 if (type
->code () != TYPE_CODE_ARRAY
)
2099 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2100 if (index_type_desc
)
2101 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2104 index_type
= type
->index_type ();
2106 new_type
= alloc_type_copy (type
);
2108 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2110 create_array_type (new_type
, new_elt_type
, index_type
);
2111 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2112 new_type
->set_name (ada_type_name (type
));
2114 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2115 && is_dynamic_type (check_typedef (index_type
)))
2116 || !get_discrete_bounds (index_type
, &low_bound
, &high_bound
))
2117 low_bound
= high_bound
= 0;
2118 if (high_bound
< low_bound
)
2119 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2122 *elt_bits
*= (high_bound
- low_bound
+ 1);
2123 TYPE_LENGTH (new_type
) =
2124 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2127 new_type
->set_is_fixed_instance (true);
2131 /* The array type encoded by TYPE, where
2132 ada_is_constrained_packed_array_type (TYPE). */
2134 static struct type
*
2135 decode_constrained_packed_array_type (struct type
*type
)
2137 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2140 struct type
*shadow_type
;
2144 raw_name
= ada_type_name (desc_base_type (type
));
2149 name
= (char *) alloca (strlen (raw_name
) + 1);
2150 tail
= strstr (raw_name
, "___XP");
2151 type
= desc_base_type (type
);
2153 memcpy (name
, raw_name
, tail
- raw_name
);
2154 name
[tail
- raw_name
] = '\000';
2156 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2158 if (shadow_type
== NULL
)
2160 lim_warning (_("could not find bounds information on packed array"));
2163 shadow_type
= check_typedef (shadow_type
);
2165 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2167 lim_warning (_("could not understand bounds "
2168 "information on packed array"));
2172 bits
= decode_packed_array_bitsize (type
);
2173 return constrained_packed_array_type (shadow_type
, &bits
);
2176 /* Helper function for decode_constrained_packed_array. Set the field
2177 bitsize on a series of packed arrays. Returns the number of
2178 elements in TYPE. */
2181 recursively_update_array_bitsize (struct type
*type
)
2183 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2186 if (!get_discrete_bounds (type
->index_type (), &low
, &high
)
2189 LONGEST our_len
= high
- low
+ 1;
2191 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
2192 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2194 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2195 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2196 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2198 TYPE_LENGTH (type
) = ((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2205 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2206 array, returns a simple array that denotes that array. Its type is a
2207 standard GDB array type except that the BITSIZEs of the array
2208 target types are set to the number of bits in each element, and the
2209 type length is set appropriately. */
2211 static struct value
*
2212 decode_constrained_packed_array (struct value
*arr
)
2216 /* If our value is a pointer, then dereference it. Likewise if
2217 the value is a reference. Make sure that this operation does not
2218 cause the target type to be fixed, as this would indirectly cause
2219 this array to be decoded. The rest of the routine assumes that
2220 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2221 and "value_ind" routines to perform the dereferencing, as opposed
2222 to using "ada_coerce_ref" or "ada_value_ind". */
2223 arr
= coerce_ref (arr
);
2224 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2225 arr
= value_ind (arr
);
2227 type
= decode_constrained_packed_array_type (value_type (arr
));
2230 error (_("can't unpack array"));
2234 /* Decoding the packed array type could not correctly set the field
2235 bitsizes for any dimension except the innermost, because the
2236 bounds may be variable and were not passed to that function. So,
2237 we further resolve the array bounds here and then update the
2239 const gdb_byte
*valaddr
= value_contents_for_printing (arr
);
2240 CORE_ADDR address
= value_address (arr
);
2241 gdb::array_view
<const gdb_byte
> view
2242 = gdb::make_array_view (valaddr
, TYPE_LENGTH (type
));
2243 type
= resolve_dynamic_type (type
, view
, address
);
2244 recursively_update_array_bitsize (type
);
2246 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2247 && ada_is_modular_type (value_type (arr
)))
2249 /* This is a (right-justified) modular type representing a packed
2250 array with no wrapper. In order to interpret the value through
2251 the (left-justified) packed array type we just built, we must
2252 first left-justify it. */
2253 int bit_size
, bit_pos
;
2256 mod
= ada_modulus (value_type (arr
)) - 1;
2263 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2264 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2265 bit_pos
/ HOST_CHAR_BIT
,
2266 bit_pos
% HOST_CHAR_BIT
,
2271 return coerce_unspec_val_to_type (arr
, type
);
2275 /* The value of the element of packed array ARR at the ARITY indices
2276 given in IND. ARR must be a simple array. */
2278 static struct value
*
2279 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2282 int bits
, elt_off
, bit_off
;
2283 long elt_total_bit_offset
;
2284 struct type
*elt_type
;
2288 elt_total_bit_offset
= 0;
2289 elt_type
= ada_check_typedef (value_type (arr
));
2290 for (i
= 0; i
< arity
; i
+= 1)
2292 if (elt_type
->code () != TYPE_CODE_ARRAY
2293 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2295 (_("attempt to do packed indexing of "
2296 "something other than a packed array"));
2299 struct type
*range_type
= elt_type
->index_type ();
2300 LONGEST lowerbound
, upperbound
;
2303 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2305 lim_warning (_("don't know bounds of array"));
2306 lowerbound
= upperbound
= 0;
2309 idx
= pos_atr (ind
[i
]);
2310 if (idx
< lowerbound
|| idx
> upperbound
)
2311 lim_warning (_("packed array index %ld out of bounds"),
2313 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2314 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2315 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2318 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2319 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2321 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2326 /* Non-zero iff TYPE includes negative integer values. */
2329 has_negatives (struct type
*type
)
2331 switch (type
->code ())
2336 return !type
->is_unsigned ();
2337 case TYPE_CODE_RANGE
:
2338 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2342 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2343 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2344 the unpacked buffer.
2346 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2347 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2349 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2352 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2354 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2357 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2358 gdb_byte
*unpacked
, int unpacked_len
,
2359 int is_big_endian
, int is_signed_type
,
2362 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2363 int src_idx
; /* Index into the source area */
2364 int src_bytes_left
; /* Number of source bytes left to process. */
2365 int srcBitsLeft
; /* Number of source bits left to move */
2366 int unusedLS
; /* Number of bits in next significant
2367 byte of source that are unused */
2369 int unpacked_idx
; /* Index into the unpacked buffer */
2370 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2372 unsigned long accum
; /* Staging area for bits being transferred */
2373 int accumSize
; /* Number of meaningful bits in accum */
2376 /* Transmit bytes from least to most significant; delta is the direction
2377 the indices move. */
2378 int delta
= is_big_endian
? -1 : 1;
2380 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2382 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2383 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2384 bit_size
, unpacked_len
);
2386 srcBitsLeft
= bit_size
;
2387 src_bytes_left
= src_len
;
2388 unpacked_bytes_left
= unpacked_len
;
2393 src_idx
= src_len
- 1;
2395 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2399 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2405 unpacked_idx
= unpacked_len
- 1;
2409 /* Non-scalar values must be aligned at a byte boundary... */
2411 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2412 /* ... And are placed at the beginning (most-significant) bytes
2414 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2415 unpacked_bytes_left
= unpacked_idx
+ 1;
2420 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2422 src_idx
= unpacked_idx
= 0;
2423 unusedLS
= bit_offset
;
2426 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2431 while (src_bytes_left
> 0)
2433 /* Mask for removing bits of the next source byte that are not
2434 part of the value. */
2435 unsigned int unusedMSMask
=
2436 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2438 /* Sign-extend bits for this byte. */
2439 unsigned int signMask
= sign
& ~unusedMSMask
;
2442 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2443 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2444 if (accumSize
>= HOST_CHAR_BIT
)
2446 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2447 accumSize
-= HOST_CHAR_BIT
;
2448 accum
>>= HOST_CHAR_BIT
;
2449 unpacked_bytes_left
-= 1;
2450 unpacked_idx
+= delta
;
2452 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2454 src_bytes_left
-= 1;
2457 while (unpacked_bytes_left
> 0)
2459 accum
|= sign
<< accumSize
;
2460 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2461 accumSize
-= HOST_CHAR_BIT
;
2464 accum
>>= HOST_CHAR_BIT
;
2465 unpacked_bytes_left
-= 1;
2466 unpacked_idx
+= delta
;
2470 /* Create a new value of type TYPE from the contents of OBJ starting
2471 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2472 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2473 assigning through the result will set the field fetched from.
2474 VALADDR is ignored unless OBJ is NULL, in which case,
2475 VALADDR+OFFSET must address the start of storage containing the
2476 packed value. The value returned in this case is never an lval.
2477 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2480 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2481 long offset
, int bit_offset
, int bit_size
,
2485 const gdb_byte
*src
; /* First byte containing data to unpack */
2487 const int is_scalar
= is_scalar_type (type
);
2488 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2489 gdb::byte_vector staging
;
2491 type
= ada_check_typedef (type
);
2494 src
= valaddr
+ offset
;
2496 src
= value_contents (obj
) + offset
;
2498 if (is_dynamic_type (type
))
2500 /* The length of TYPE might by dynamic, so we need to resolve
2501 TYPE in order to know its actual size, which we then use
2502 to create the contents buffer of the value we return.
2503 The difficulty is that the data containing our object is
2504 packed, and therefore maybe not at a byte boundary. So, what
2505 we do, is unpack the data into a byte-aligned buffer, and then
2506 use that buffer as our object's value for resolving the type. */
2507 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2508 staging
.resize (staging_len
);
2510 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2511 staging
.data (), staging
.size (),
2512 is_big_endian
, has_negatives (type
),
2514 type
= resolve_dynamic_type (type
, staging
, 0);
2515 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2517 /* This happens when the length of the object is dynamic,
2518 and is actually smaller than the space reserved for it.
2519 For instance, in an array of variant records, the bit_size
2520 we're given is the array stride, which is constant and
2521 normally equal to the maximum size of its element.
2522 But, in reality, each element only actually spans a portion
2524 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2530 v
= allocate_value (type
);
2531 src
= valaddr
+ offset
;
2533 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2535 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2538 v
= value_at (type
, value_address (obj
) + offset
);
2539 buf
= (gdb_byte
*) alloca (src_len
);
2540 read_memory (value_address (v
), buf
, src_len
);
2545 v
= allocate_value (type
);
2546 src
= value_contents (obj
) + offset
;
2551 long new_offset
= offset
;
2553 set_value_component_location (v
, obj
);
2554 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2555 set_value_bitsize (v
, bit_size
);
2556 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2559 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2561 set_value_offset (v
, new_offset
);
2563 /* Also set the parent value. This is needed when trying to
2564 assign a new value (in inferior memory). */
2565 set_value_parent (v
, obj
);
2568 set_value_bitsize (v
, bit_size
);
2569 unpacked
= value_contents_writeable (v
);
2573 memset (unpacked
, 0, TYPE_LENGTH (type
));
2577 if (staging
.size () == TYPE_LENGTH (type
))
2579 /* Small short-cut: If we've unpacked the data into a buffer
2580 of the same size as TYPE's length, then we can reuse that,
2581 instead of doing the unpacking again. */
2582 memcpy (unpacked
, staging
.data (), staging
.size ());
2585 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2586 unpacked
, TYPE_LENGTH (type
),
2587 is_big_endian
, has_negatives (type
), is_scalar
);
2592 /* Store the contents of FROMVAL into the location of TOVAL.
2593 Return a new value with the location of TOVAL and contents of
2594 FROMVAL. Handles assignment into packed fields that have
2595 floating-point or non-scalar types. */
2597 static struct value
*
2598 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2600 struct type
*type
= value_type (toval
);
2601 int bits
= value_bitsize (toval
);
2603 toval
= ada_coerce_ref (toval
);
2604 fromval
= ada_coerce_ref (fromval
);
2606 if (ada_is_direct_array_type (value_type (toval
)))
2607 toval
= ada_coerce_to_simple_array (toval
);
2608 if (ada_is_direct_array_type (value_type (fromval
)))
2609 fromval
= ada_coerce_to_simple_array (fromval
);
2611 if (!deprecated_value_modifiable (toval
))
2612 error (_("Left operand of assignment is not a modifiable lvalue."));
2614 if (VALUE_LVAL (toval
) == lval_memory
2616 && (type
->code () == TYPE_CODE_FLT
2617 || type
->code () == TYPE_CODE_STRUCT
))
2619 int len
= (value_bitpos (toval
)
2620 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2622 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2624 CORE_ADDR to_addr
= value_address (toval
);
2626 if (type
->code () == TYPE_CODE_FLT
)
2627 fromval
= value_cast (type
, fromval
);
2629 read_memory (to_addr
, buffer
, len
);
2630 from_size
= value_bitsize (fromval
);
2632 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2634 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2635 ULONGEST from_offset
= 0;
2636 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2637 from_offset
= from_size
- bits
;
2638 copy_bitwise (buffer
, value_bitpos (toval
),
2639 value_contents (fromval
), from_offset
,
2640 bits
, is_big_endian
);
2641 write_memory_with_notification (to_addr
, buffer
, len
);
2643 val
= value_copy (toval
);
2644 memcpy (value_contents_raw (val
), value_contents (fromval
),
2645 TYPE_LENGTH (type
));
2646 deprecated_set_value_type (val
, type
);
2651 return value_assign (toval
, fromval
);
2655 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2656 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2657 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2658 COMPONENT, and not the inferior's memory. The current contents
2659 of COMPONENT are ignored.
2661 Although not part of the initial design, this function also works
2662 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2663 had a null address, and COMPONENT had an address which is equal to
2664 its offset inside CONTAINER. */
2667 value_assign_to_component (struct value
*container
, struct value
*component
,
2670 LONGEST offset_in_container
=
2671 (LONGEST
) (value_address (component
) - value_address (container
));
2672 int bit_offset_in_container
=
2673 value_bitpos (component
) - value_bitpos (container
);
2676 val
= value_cast (value_type (component
), val
);
2678 if (value_bitsize (component
) == 0)
2679 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2681 bits
= value_bitsize (component
);
2683 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2687 if (is_scalar_type (check_typedef (value_type (component
))))
2689 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2692 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2693 value_bitpos (container
) + bit_offset_in_container
,
2694 value_contents (val
), src_offset
, bits
, 1);
2697 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2698 value_bitpos (container
) + bit_offset_in_container
,
2699 value_contents (val
), 0, bits
, 0);
2702 /* Determine if TYPE is an access to an unconstrained array. */
2705 ada_is_access_to_unconstrained_array (struct type
*type
)
2707 return (type
->code () == TYPE_CODE_TYPEDEF
2708 && is_thick_pntr (ada_typedef_target_type (type
)));
2711 /* The value of the element of array ARR at the ARITY indices given in IND.
2712 ARR may be either a simple array, GNAT array descriptor, or pointer
2716 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2720 struct type
*elt_type
;
2722 elt
= ada_coerce_to_simple_array (arr
);
2724 elt_type
= ada_check_typedef (value_type (elt
));
2725 if (elt_type
->code () == TYPE_CODE_ARRAY
2726 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2727 return value_subscript_packed (elt
, arity
, ind
);
2729 for (k
= 0; k
< arity
; k
+= 1)
2731 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2733 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2734 error (_("too many subscripts (%d expected)"), k
);
2736 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2738 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2739 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2741 /* The element is a typedef to an unconstrained array,
2742 except that the value_subscript call stripped the
2743 typedef layer. The typedef layer is GNAT's way to
2744 specify that the element is, at the source level, an
2745 access to the unconstrained array, rather than the
2746 unconstrained array. So, we need to restore that
2747 typedef layer, which we can do by forcing the element's
2748 type back to its original type. Otherwise, the returned
2749 value is going to be printed as the array, rather
2750 than as an access. Another symptom of the same issue
2751 would be that an expression trying to dereference the
2752 element would also be improperly rejected. */
2753 deprecated_set_value_type (elt
, saved_elt_type
);
2756 elt_type
= ada_check_typedef (value_type (elt
));
2762 /* Assuming ARR is a pointer to a GDB array, the value of the element
2763 of *ARR at the ARITY indices given in IND.
2764 Does not read the entire array into memory.
2766 Note: Unlike what one would expect, this function is used instead of
2767 ada_value_subscript for basically all non-packed array types. The reason
2768 for this is that a side effect of doing our own pointer arithmetics instead
2769 of relying on value_subscript is that there is no implicit typedef peeling.
2770 This is important for arrays of array accesses, where it allows us to
2771 preserve the fact that the array's element is an array access, where the
2772 access part os encoded in a typedef layer. */
2774 static struct value
*
2775 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2778 struct value
*array_ind
= ada_value_ind (arr
);
2780 = check_typedef (value_enclosing_type (array_ind
));
2782 if (type
->code () == TYPE_CODE_ARRAY
2783 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2784 return value_subscript_packed (array_ind
, arity
, ind
);
2786 for (k
= 0; k
< arity
; k
+= 1)
2790 if (type
->code () != TYPE_CODE_ARRAY
)
2791 error (_("too many subscripts (%d expected)"), k
);
2792 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2794 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2795 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2796 type
= TYPE_TARGET_TYPE (type
);
2799 return value_ind (arr
);
2802 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2803 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2804 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2805 this array is LOW, as per Ada rules. */
2806 static struct value
*
2807 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2810 struct type
*type0
= ada_check_typedef (type
);
2811 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2812 struct type
*index_type
2813 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2814 struct type
*slice_type
= create_array_type_with_stride
2815 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2816 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2817 TYPE_FIELD_BITSIZE (type0
, 0));
2818 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2819 gdb::optional
<LONGEST
> base_low_pos
, low_pos
;
2822 low_pos
= discrete_position (base_index_type
, low
);
2823 base_low_pos
= discrete_position (base_index_type
, base_low
);
2825 if (!low_pos
.has_value () || !base_low_pos
.has_value ())
2827 warning (_("unable to get positions in slice, use bounds instead"));
2829 base_low_pos
= base_low
;
2832 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
2834 stride
= TYPE_LENGTH (TYPE_TARGET_TYPE (type0
));
2836 base
= value_as_address (array_ptr
) + (*low_pos
- *base_low_pos
) * stride
;
2837 return value_at_lazy (slice_type
, base
);
2841 static struct value
*
2842 ada_value_slice (struct value
*array
, int low
, int high
)
2844 struct type
*type
= ada_check_typedef (value_type (array
));
2845 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2846 struct type
*index_type
2847 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2848 struct type
*slice_type
= create_array_type_with_stride
2849 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2850 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2851 TYPE_FIELD_BITSIZE (type
, 0));
2852 gdb::optional
<LONGEST
> low_pos
, high_pos
;
2855 low_pos
= discrete_position (base_index_type
, low
);
2856 high_pos
= discrete_position (base_index_type
, high
);
2858 if (!low_pos
.has_value () || !high_pos
.has_value ())
2860 warning (_("unable to get positions in slice, use bounds instead"));
2865 return value_cast (slice_type
,
2866 value_slice (array
, low
, *high_pos
- *low_pos
+ 1));
2869 /* If type is a record type in the form of a standard GNAT array
2870 descriptor, returns the number of dimensions for type. If arr is a
2871 simple array, returns the number of "array of"s that prefix its
2872 type designation. Otherwise, returns 0. */
2875 ada_array_arity (struct type
*type
)
2882 type
= desc_base_type (type
);
2885 if (type
->code () == TYPE_CODE_STRUCT
)
2886 return desc_arity (desc_bounds_type (type
));
2888 while (type
->code () == TYPE_CODE_ARRAY
)
2891 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2897 /* If TYPE is a record type in the form of a standard GNAT array
2898 descriptor or a simple array type, returns the element type for
2899 TYPE after indexing by NINDICES indices, or by all indices if
2900 NINDICES is -1. Otherwise, returns NULL. */
2903 ada_array_element_type (struct type
*type
, int nindices
)
2905 type
= desc_base_type (type
);
2907 if (type
->code () == TYPE_CODE_STRUCT
)
2910 struct type
*p_array_type
;
2912 p_array_type
= desc_data_target_type (type
);
2914 k
= ada_array_arity (type
);
2918 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2919 if (nindices
>= 0 && k
> nindices
)
2921 while (k
> 0 && p_array_type
!= NULL
)
2923 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2926 return p_array_type
;
2928 else if (type
->code () == TYPE_CODE_ARRAY
)
2930 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2932 type
= TYPE_TARGET_TYPE (type
);
2941 /* The type of nth index in arrays of given type (n numbering from 1).
2942 Does not examine memory. Throws an error if N is invalid or TYPE
2943 is not an array type. NAME is the name of the Ada attribute being
2944 evaluated ('range, 'first, 'last, or 'length); it is used in building
2945 the error message. */
2947 static struct type
*
2948 ada_index_type (struct type
*type
, int n
, const char *name
)
2950 struct type
*result_type
;
2952 type
= desc_base_type (type
);
2954 if (n
< 0 || n
> ada_array_arity (type
))
2955 error (_("invalid dimension number to '%s"), name
);
2957 if (ada_is_simple_array_type (type
))
2961 for (i
= 1; i
< n
; i
+= 1)
2962 type
= TYPE_TARGET_TYPE (type
);
2963 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2964 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2965 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2966 perhaps stabsread.c would make more sense. */
2967 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2972 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2973 if (result_type
== NULL
)
2974 error (_("attempt to take bound of something that is not an array"));
2980 /* Given that arr is an array type, returns the lower bound of the
2981 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2982 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2983 array-descriptor type. It works for other arrays with bounds supplied
2984 by run-time quantities other than discriminants. */
2987 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2989 struct type
*type
, *index_type_desc
, *index_type
;
2992 gdb_assert (which
== 0 || which
== 1);
2994 if (ada_is_constrained_packed_array_type (arr_type
))
2995 arr_type
= decode_constrained_packed_array_type (arr_type
);
2997 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2998 return (LONGEST
) - which
;
3000 if (arr_type
->code () == TYPE_CODE_PTR
)
3001 type
= TYPE_TARGET_TYPE (arr_type
);
3005 if (type
->is_fixed_instance ())
3007 /* The array has already been fixed, so we do not need to
3008 check the parallel ___XA type again. That encoding has
3009 already been applied, so ignore it now. */
3010 index_type_desc
= NULL
;
3014 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3015 ada_fixup_array_indexes_type (index_type_desc
);
3018 if (index_type_desc
!= NULL
)
3019 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
3023 struct type
*elt_type
= check_typedef (type
);
3025 for (i
= 1; i
< n
; i
++)
3026 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3028 index_type
= elt_type
->index_type ();
3032 (LONGEST
) (which
== 0
3033 ? ada_discrete_type_low_bound (index_type
)
3034 : ada_discrete_type_high_bound (index_type
));
3037 /* Given that arr is an array value, returns the lower bound of the
3038 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3039 WHICH is 1. This routine will also work for arrays with bounds
3040 supplied by run-time quantities other than discriminants. */
3043 ada_array_bound (struct value
*arr
, int n
, int which
)
3045 struct type
*arr_type
;
3047 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3048 arr
= value_ind (arr
);
3049 arr_type
= value_enclosing_type (arr
);
3051 if (ada_is_constrained_packed_array_type (arr_type
))
3052 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3053 else if (ada_is_simple_array_type (arr_type
))
3054 return ada_array_bound_from_type (arr_type
, n
, which
);
3056 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3059 /* Given that arr is an array value, returns the length of the
3060 nth index. This routine will also work for arrays with bounds
3061 supplied by run-time quantities other than discriminants.
3062 Does not work for arrays indexed by enumeration types with representation
3063 clauses at the moment. */
3066 ada_array_length (struct value
*arr
, int n
)
3068 struct type
*arr_type
, *index_type
;
3071 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3072 arr
= value_ind (arr
);
3073 arr_type
= value_enclosing_type (arr
);
3075 if (ada_is_constrained_packed_array_type (arr_type
))
3076 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3078 if (ada_is_simple_array_type (arr_type
))
3080 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3081 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3085 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3086 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3089 arr_type
= check_typedef (arr_type
);
3090 index_type
= ada_index_type (arr_type
, n
, "length");
3091 if (index_type
!= NULL
)
3093 struct type
*base_type
;
3094 if (index_type
->code () == TYPE_CODE_RANGE
)
3095 base_type
= TYPE_TARGET_TYPE (index_type
);
3097 base_type
= index_type
;
3099 low
= pos_atr (value_from_longest (base_type
, low
));
3100 high
= pos_atr (value_from_longest (base_type
, high
));
3102 return high
- low
+ 1;
3105 /* An array whose type is that of ARR_TYPE (an array type), with
3106 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3107 less than LOW, then LOW-1 is used. */
3109 static struct value
*
3110 empty_array (struct type
*arr_type
, int low
, int high
)
3112 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3113 struct type
*index_type
3114 = create_static_range_type
3115 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3116 high
< low
? low
- 1 : high
);
3117 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3119 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3123 /* Name resolution */
3125 /* The "decoded" name for the user-definable Ada operator corresponding
3129 ada_decoded_op_name (enum exp_opcode op
)
3133 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3135 if (ada_opname_table
[i
].op
== op
)
3136 return ada_opname_table
[i
].decoded
;
3138 error (_("Could not find operator name for opcode"));
3141 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3142 in a listing of choices during disambiguation (see sort_choices, below).
3143 The idea is that overloadings of a subprogram name from the
3144 same package should sort in their source order. We settle for ordering
3145 such symbols by their trailing number (__N or $N). */
3148 encoded_ordered_before (const char *N0
, const char *N1
)
3152 else if (N0
== NULL
)
3158 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3160 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3162 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3163 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3168 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3171 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3173 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3174 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3176 return (strcmp (N0
, N1
) < 0);
3180 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3184 sort_choices (struct block_symbol syms
[], int nsyms
)
3188 for (i
= 1; i
< nsyms
; i
+= 1)
3190 struct block_symbol sym
= syms
[i
];
3193 for (j
= i
- 1; j
>= 0; j
-= 1)
3195 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3196 sym
.symbol
->linkage_name ()))
3198 syms
[j
+ 1] = syms
[j
];
3204 /* Whether GDB should display formals and return types for functions in the
3205 overloads selection menu. */
3206 static bool print_signatures
= true;
3208 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3209 all but functions, the signature is just the name of the symbol. For
3210 functions, this is the name of the function, the list of types for formals
3211 and the return type (if any). */
3214 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3215 const struct type_print_options
*flags
)
3217 struct type
*type
= SYMBOL_TYPE (sym
);
3219 fprintf_filtered (stream
, "%s", sym
->print_name ());
3220 if (!print_signatures
3222 || type
->code () != TYPE_CODE_FUNC
)
3225 if (type
->num_fields () > 0)
3229 fprintf_filtered (stream
, " (");
3230 for (i
= 0; i
< type
->num_fields (); ++i
)
3233 fprintf_filtered (stream
, "; ");
3234 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3237 fprintf_filtered (stream
, ")");
3239 if (TYPE_TARGET_TYPE (type
) != NULL
3240 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3242 fprintf_filtered (stream
, " return ");
3243 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3247 /* Read and validate a set of numeric choices from the user in the
3248 range 0 .. N_CHOICES-1. Place the results in increasing
3249 order in CHOICES[0 .. N-1], and return N.
3251 The user types choices as a sequence of numbers on one line
3252 separated by blanks, encoding them as follows:
3254 + A choice of 0 means to cancel the selection, throwing an error.
3255 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3256 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3258 The user is not allowed to choose more than MAX_RESULTS values.
3260 ANNOTATION_SUFFIX, if present, is used to annotate the input
3261 prompts (for use with the -f switch). */
3264 get_selections (int *choices
, int n_choices
, int max_results
,
3265 int is_all_choice
, const char *annotation_suffix
)
3270 int first_choice
= is_all_choice
? 2 : 1;
3272 prompt
= getenv ("PS2");
3276 args
= command_line_input (prompt
, annotation_suffix
);
3279 error_no_arg (_("one or more choice numbers"));
3283 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3284 order, as given in args. Choices are validated. */
3290 args
= skip_spaces (args
);
3291 if (*args
== '\0' && n_chosen
== 0)
3292 error_no_arg (_("one or more choice numbers"));
3293 else if (*args
== '\0')
3296 choice
= strtol (args
, &args2
, 10);
3297 if (args
== args2
|| choice
< 0
3298 || choice
> n_choices
+ first_choice
- 1)
3299 error (_("Argument must be choice number"));
3303 error (_("cancelled"));
3305 if (choice
< first_choice
)
3307 n_chosen
= n_choices
;
3308 for (j
= 0; j
< n_choices
; j
+= 1)
3312 choice
-= first_choice
;
3314 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3318 if (j
< 0 || choice
!= choices
[j
])
3322 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3323 choices
[k
+ 1] = choices
[k
];
3324 choices
[j
+ 1] = choice
;
3329 if (n_chosen
> max_results
)
3330 error (_("Select no more than %d of the above"), max_results
);
3335 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3336 by asking the user (if necessary), returning the number selected,
3337 and setting the first elements of SYMS items. Error if no symbols
3340 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3341 to be re-integrated one of these days. */
3344 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3347 int *chosen
= XALLOCAVEC (int , nsyms
);
3349 int first_choice
= (max_results
== 1) ? 1 : 2;
3350 const char *select_mode
= multiple_symbols_select_mode ();
3352 if (max_results
< 1)
3353 error (_("Request to select 0 symbols!"));
3357 if (select_mode
== multiple_symbols_cancel
)
3359 canceled because the command is ambiguous\n\
3360 See set/show multiple-symbol."));
3362 /* If select_mode is "all", then return all possible symbols.
3363 Only do that if more than one symbol can be selected, of course.
3364 Otherwise, display the menu as usual. */
3365 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3368 printf_filtered (_("[0] cancel\n"));
3369 if (max_results
> 1)
3370 printf_filtered (_("[1] all\n"));
3372 sort_choices (syms
, nsyms
);
3374 for (i
= 0; i
< nsyms
; i
+= 1)
3376 if (syms
[i
].symbol
== NULL
)
3379 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3381 struct symtab_and_line sal
=
3382 find_function_start_sal (syms
[i
].symbol
, 1);
3384 printf_filtered ("[%d] ", i
+ first_choice
);
3385 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3386 &type_print_raw_options
);
3387 if (sal
.symtab
== NULL
)
3388 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3389 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3393 styled_string (file_name_style
.style (),
3394 symtab_to_filename_for_display (sal
.symtab
)),
3401 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3402 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3403 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3404 struct symtab
*symtab
= NULL
;
3406 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3407 symtab
= symbol_symtab (syms
[i
].symbol
);
3409 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3411 printf_filtered ("[%d] ", i
+ first_choice
);
3412 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3413 &type_print_raw_options
);
3414 printf_filtered (_(" at %s:%d\n"),
3415 symtab_to_filename_for_display (symtab
),
3416 SYMBOL_LINE (syms
[i
].symbol
));
3418 else if (is_enumeral
3419 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3421 printf_filtered (("[%d] "), i
+ first_choice
);
3422 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3423 gdb_stdout
, -1, 0, &type_print_raw_options
);
3424 printf_filtered (_("'(%s) (enumeral)\n"),
3425 syms
[i
].symbol
->print_name ());
3429 printf_filtered ("[%d] ", i
+ first_choice
);
3430 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3431 &type_print_raw_options
);
3434 printf_filtered (is_enumeral
3435 ? _(" in %s (enumeral)\n")
3437 symtab_to_filename_for_display (symtab
));
3439 printf_filtered (is_enumeral
3440 ? _(" (enumeral)\n")
3446 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3449 for (i
= 0; i
< n_chosen
; i
+= 1)
3450 syms
[i
] = syms
[chosen
[i
]];
3455 /* Resolve the operator of the subexpression beginning at
3456 position *POS of *EXPP. "Resolving" consists of replacing
3457 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3458 with their resolutions, replacing built-in operators with
3459 function calls to user-defined operators, where appropriate, and,
3460 when DEPROCEDURE_P is non-zero, converting function-valued variables
3461 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3462 are as in ada_resolve, above. */
3464 static struct value
*
3465 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3466 struct type
*context_type
, int parse_completion
,
3467 innermost_block_tracker
*tracker
)
3471 struct expression
*exp
; /* Convenience: == *expp. */
3472 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3473 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3474 int nargs
; /* Number of operands. */
3481 /* Pass one: resolve operands, saving their types and updating *pos,
3486 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3487 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3492 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3494 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3499 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3504 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3505 parse_completion
, tracker
);
3508 case OP_ATR_MODULUS
:
3518 case TERNOP_IN_RANGE
:
3519 case BINOP_IN_BOUNDS
:
3525 case OP_DISCRETE_RANGE
:
3527 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3536 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3538 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3540 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3558 case BINOP_LOGICAL_AND
:
3559 case BINOP_LOGICAL_OR
:
3560 case BINOP_BITWISE_AND
:
3561 case BINOP_BITWISE_IOR
:
3562 case BINOP_BITWISE_XOR
:
3565 case BINOP_NOTEQUAL
:
3572 case BINOP_SUBSCRIPT
:
3580 case UNOP_LOGICAL_NOT
:
3590 case OP_VAR_MSYM_VALUE
:
3597 case OP_INTERNALVAR
:
3607 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3610 case STRUCTOP_STRUCT
:
3611 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3624 error (_("Unexpected operator during name resolution"));
3627 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3628 for (i
= 0; i
< nargs
; i
+= 1)
3629 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3634 /* Pass two: perform any resolution on principal operator. */
3641 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3643 std::vector
<struct block_symbol
> candidates
;
3647 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3648 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3651 if (n_candidates
> 1)
3653 /* Types tend to get re-introduced locally, so if there
3654 are any local symbols that are not types, first filter
3657 for (j
= 0; j
< n_candidates
; j
+= 1)
3658 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3663 case LOC_REGPARM_ADDR
:
3671 if (j
< n_candidates
)
3674 while (j
< n_candidates
)
3676 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3678 candidates
[j
] = candidates
[n_candidates
- 1];
3687 if (n_candidates
== 0)
3688 error (_("No definition found for %s"),
3689 exp
->elts
[pc
+ 2].symbol
->print_name ());
3690 else if (n_candidates
== 1)
3692 else if (deprocedure_p
3693 && !is_nonfunction (candidates
.data (), n_candidates
))
3695 i
= ada_resolve_function
3696 (candidates
.data (), n_candidates
, NULL
, 0,
3697 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3698 context_type
, parse_completion
);
3700 error (_("Could not find a match for %s"),
3701 exp
->elts
[pc
+ 2].symbol
->print_name ());
3705 printf_filtered (_("Multiple matches for %s\n"),
3706 exp
->elts
[pc
+ 2].symbol
->print_name ());
3707 user_select_syms (candidates
.data (), n_candidates
, 1);
3711 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3712 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3713 tracker
->update (candidates
[i
]);
3717 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3720 replace_operator_with_call (expp
, pc
, 0, 4,
3721 exp
->elts
[pc
+ 2].symbol
,
3722 exp
->elts
[pc
+ 1].block
);
3729 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3730 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3732 std::vector
<struct block_symbol
> candidates
;
3736 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3737 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3740 if (n_candidates
== 1)
3744 i
= ada_resolve_function
3745 (candidates
.data (), n_candidates
,
3747 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3748 context_type
, parse_completion
);
3750 error (_("Could not find a match for %s"),
3751 exp
->elts
[pc
+ 5].symbol
->print_name ());
3754 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3755 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3756 tracker
->update (candidates
[i
]);
3767 case BINOP_BITWISE_AND
:
3768 case BINOP_BITWISE_IOR
:
3769 case BINOP_BITWISE_XOR
:
3771 case BINOP_NOTEQUAL
:
3779 case UNOP_LOGICAL_NOT
:
3781 if (possible_user_operator_p (op
, argvec
))
3783 std::vector
<struct block_symbol
> candidates
;
3787 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3791 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3792 nargs
, ada_decoded_op_name (op
), NULL
,
3797 replace_operator_with_call (expp
, pc
, nargs
, 1,
3798 candidates
[i
].symbol
,
3799 candidates
[i
].block
);
3810 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3811 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3812 exp
->elts
[pc
+ 1].objfile
,
3813 exp
->elts
[pc
+ 2].msymbol
);
3815 return evaluate_subexp_type (exp
, pos
);
3818 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3819 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3821 /* The term "match" here is rather loose. The match is heuristic and
3825 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3827 ftype
= ada_check_typedef (ftype
);
3828 atype
= ada_check_typedef (atype
);
3830 if (ftype
->code () == TYPE_CODE_REF
)
3831 ftype
= TYPE_TARGET_TYPE (ftype
);
3832 if (atype
->code () == TYPE_CODE_REF
)
3833 atype
= TYPE_TARGET_TYPE (atype
);
3835 switch (ftype
->code ())
3838 return ftype
->code () == atype
->code ();
3840 if (atype
->code () == TYPE_CODE_PTR
)
3841 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3842 TYPE_TARGET_TYPE (atype
), 0);
3845 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3847 case TYPE_CODE_ENUM
:
3848 case TYPE_CODE_RANGE
:
3849 switch (atype
->code ())
3852 case TYPE_CODE_ENUM
:
3853 case TYPE_CODE_RANGE
:
3859 case TYPE_CODE_ARRAY
:
3860 return (atype
->code () == TYPE_CODE_ARRAY
3861 || ada_is_array_descriptor_type (atype
));
3863 case TYPE_CODE_STRUCT
:
3864 if (ada_is_array_descriptor_type (ftype
))
3865 return (atype
->code () == TYPE_CODE_ARRAY
3866 || ada_is_array_descriptor_type (atype
));
3868 return (atype
->code () == TYPE_CODE_STRUCT
3869 && !ada_is_array_descriptor_type (atype
));
3871 case TYPE_CODE_UNION
:
3873 return (atype
->code () == ftype
->code ());
3877 /* Return non-zero if the formals of FUNC "sufficiently match" the
3878 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3879 may also be an enumeral, in which case it is treated as a 0-
3880 argument function. */
3883 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3886 struct type
*func_type
= SYMBOL_TYPE (func
);
3888 if (SYMBOL_CLASS (func
) == LOC_CONST
3889 && func_type
->code () == TYPE_CODE_ENUM
)
3890 return (n_actuals
== 0);
3891 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3894 if (func_type
->num_fields () != n_actuals
)
3897 for (i
= 0; i
< n_actuals
; i
+= 1)
3899 if (actuals
[i
] == NULL
)
3903 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3904 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3906 if (!ada_type_match (ftype
, atype
, 1))
3913 /* False iff function type FUNC_TYPE definitely does not produce a value
3914 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3915 FUNC_TYPE is not a valid function type with a non-null return type
3916 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3919 return_match (struct type
*func_type
, struct type
*context_type
)
3921 struct type
*return_type
;
3923 if (func_type
== NULL
)
3926 if (func_type
->code () == TYPE_CODE_FUNC
)
3927 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3929 return_type
= get_base_type (func_type
);
3930 if (return_type
== NULL
)
3933 context_type
= get_base_type (context_type
);
3935 if (return_type
->code () == TYPE_CODE_ENUM
)
3936 return context_type
== NULL
|| return_type
== context_type
;
3937 else if (context_type
== NULL
)
3938 return return_type
->code () != TYPE_CODE_VOID
;
3940 return return_type
->code () == context_type
->code ();
3944 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3945 function (if any) that matches the types of the NARGS arguments in
3946 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3947 that returns that type, then eliminate matches that don't. If
3948 CONTEXT_TYPE is void and there is at least one match that does not
3949 return void, eliminate all matches that do.
3951 Asks the user if there is more than one match remaining. Returns -1
3952 if there is no such symbol or none is selected. NAME is used
3953 solely for messages. May re-arrange and modify SYMS in
3954 the process; the index returned is for the modified vector. */
3957 ada_resolve_function (struct block_symbol syms
[],
3958 int nsyms
, struct value
**args
, int nargs
,
3959 const char *name
, struct type
*context_type
,
3960 int parse_completion
)
3964 int m
; /* Number of hits */
3967 /* In the first pass of the loop, we only accept functions matching
3968 context_type. If none are found, we add a second pass of the loop
3969 where every function is accepted. */
3970 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3972 for (k
= 0; k
< nsyms
; k
+= 1)
3974 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3976 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3977 && (fallback
|| return_match (type
, context_type
)))
3985 /* If we got multiple matches, ask the user which one to use. Don't do this
3986 interactive thing during completion, though, as the purpose of the
3987 completion is providing a list of all possible matches. Prompting the
3988 user to filter it down would be completely unexpected in this case. */
3991 else if (m
> 1 && !parse_completion
)
3993 printf_filtered (_("Multiple matches for %s\n"), name
);
3994 user_select_syms (syms
, m
, 1);
4000 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4001 on the function identified by SYM and BLOCK, and taking NARGS
4002 arguments. Update *EXPP as needed to hold more space. */
4005 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4006 int oplen
, struct symbol
*sym
,
4007 const struct block
*block
)
4009 /* We want to add 6 more elements (3 for funcall, 4 for function
4010 symbol, -OPLEN for operator being replaced) to the
4012 struct expression
*exp
= expp
->get ();
4013 int save_nelts
= exp
->nelts
;
4014 int extra_elts
= 7 - oplen
;
4015 exp
->nelts
+= extra_elts
;
4018 exp
->resize (exp
->nelts
);
4019 memmove (exp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4020 EXP_ELEM_TO_BYTES (save_nelts
- pc
- oplen
));
4022 exp
->resize (exp
->nelts
);
4024 exp
->elts
[pc
].opcode
= exp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4025 exp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4027 exp
->elts
[pc
+ 3].opcode
= exp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4028 exp
->elts
[pc
+ 4].block
= block
;
4029 exp
->elts
[pc
+ 5].symbol
= sym
;
4032 /* Type-class predicates */
4034 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4038 numeric_type_p (struct type
*type
)
4044 switch (type
->code ())
4049 case TYPE_CODE_RANGE
:
4050 return (type
== TYPE_TARGET_TYPE (type
)
4051 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4058 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4061 integer_type_p (struct type
*type
)
4067 switch (type
->code ())
4071 case TYPE_CODE_RANGE
:
4072 return (type
== TYPE_TARGET_TYPE (type
)
4073 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4080 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4083 scalar_type_p (struct type
*type
)
4089 switch (type
->code ())
4092 case TYPE_CODE_RANGE
:
4093 case TYPE_CODE_ENUM
:
4102 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4105 discrete_type_p (struct type
*type
)
4111 switch (type
->code ())
4114 case TYPE_CODE_RANGE
:
4115 case TYPE_CODE_ENUM
:
4116 case TYPE_CODE_BOOL
:
4124 /* Returns non-zero if OP with operands in the vector ARGS could be
4125 a user-defined function. Errs on the side of pre-defined operators
4126 (i.e., result 0). */
4129 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4131 struct type
*type0
=
4132 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4133 struct type
*type1
=
4134 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4148 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4152 case BINOP_BITWISE_AND
:
4153 case BINOP_BITWISE_IOR
:
4154 case BINOP_BITWISE_XOR
:
4155 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4158 case BINOP_NOTEQUAL
:
4163 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4166 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4169 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4173 case UNOP_LOGICAL_NOT
:
4175 return (!numeric_type_p (type0
));
4184 1. In the following, we assume that a renaming type's name may
4185 have an ___XD suffix. It would be nice if this went away at some
4187 2. We handle both the (old) purely type-based representation of
4188 renamings and the (new) variable-based encoding. At some point,
4189 it is devoutly to be hoped that the former goes away
4190 (FIXME: hilfinger-2007-07-09).
4191 3. Subprogram renamings are not implemented, although the XRS
4192 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4194 /* If SYM encodes a renaming,
4196 <renaming> renames <renamed entity>,
4198 sets *LEN to the length of the renamed entity's name,
4199 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4200 the string describing the subcomponent selected from the renamed
4201 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4202 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4203 are undefined). Otherwise, returns a value indicating the category
4204 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4205 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4206 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4207 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4208 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4209 may be NULL, in which case they are not assigned.
4211 [Currently, however, GCC does not generate subprogram renamings.] */
4213 enum ada_renaming_category
4214 ada_parse_renaming (struct symbol
*sym
,
4215 const char **renamed_entity
, int *len
,
4216 const char **renaming_expr
)
4218 enum ada_renaming_category kind
;
4223 return ADA_NOT_RENAMING
;
4224 switch (SYMBOL_CLASS (sym
))
4227 return ADA_NOT_RENAMING
;
4231 case LOC_OPTIMIZED_OUT
:
4232 info
= strstr (sym
->linkage_name (), "___XR");
4234 return ADA_NOT_RENAMING
;
4238 kind
= ADA_OBJECT_RENAMING
;
4242 kind
= ADA_EXCEPTION_RENAMING
;
4246 kind
= ADA_PACKAGE_RENAMING
;
4250 kind
= ADA_SUBPROGRAM_RENAMING
;
4254 return ADA_NOT_RENAMING
;
4258 if (renamed_entity
!= NULL
)
4259 *renamed_entity
= info
;
4260 suffix
= strstr (info
, "___XE");
4261 if (suffix
== NULL
|| suffix
== info
)
4262 return ADA_NOT_RENAMING
;
4264 *len
= strlen (info
) - strlen (suffix
);
4266 if (renaming_expr
!= NULL
)
4267 *renaming_expr
= suffix
;
4271 /* Compute the value of the given RENAMING_SYM, which is expected to
4272 be a symbol encoding a renaming expression. BLOCK is the block
4273 used to evaluate the renaming. */
4275 static struct value
*
4276 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4277 const struct block
*block
)
4279 const char *sym_name
;
4281 sym_name
= renaming_sym
->linkage_name ();
4282 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4283 return evaluate_expression (expr
.get ());
4287 /* Evaluation: Function Calls */
4289 /* Return an lvalue containing the value VAL. This is the identity on
4290 lvalues, and otherwise has the side-effect of allocating memory
4291 in the inferior where a copy of the value contents is copied. */
4293 static struct value
*
4294 ensure_lval (struct value
*val
)
4296 if (VALUE_LVAL (val
) == not_lval
4297 || VALUE_LVAL (val
) == lval_internalvar
)
4299 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4300 const CORE_ADDR addr
=
4301 value_as_long (value_allocate_space_in_inferior (len
));
4303 VALUE_LVAL (val
) = lval_memory
;
4304 set_value_address (val
, addr
);
4305 write_memory (addr
, value_contents (val
), len
);
4311 /* Given ARG, a value of type (pointer or reference to a)*
4312 structure/union, extract the component named NAME from the ultimate
4313 target structure/union and return it as a value with its
4316 The routine searches for NAME among all members of the structure itself
4317 and (recursively) among all members of any wrapper members
4320 If NO_ERR, then simply return NULL in case of error, rather than
4323 static struct value
*
4324 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4326 struct type
*t
, *t1
;
4331 t1
= t
= ada_check_typedef (value_type (arg
));
4332 if (t
->code () == TYPE_CODE_REF
)
4334 t1
= TYPE_TARGET_TYPE (t
);
4337 t1
= ada_check_typedef (t1
);
4338 if (t1
->code () == TYPE_CODE_PTR
)
4340 arg
= coerce_ref (arg
);
4345 while (t
->code () == TYPE_CODE_PTR
)
4347 t1
= TYPE_TARGET_TYPE (t
);
4350 t1
= ada_check_typedef (t1
);
4351 if (t1
->code () == TYPE_CODE_PTR
)
4353 arg
= value_ind (arg
);
4360 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4364 v
= ada_search_struct_field (name
, arg
, 0, t
);
4367 int bit_offset
, bit_size
, byte_offset
;
4368 struct type
*field_type
;
4371 if (t
->code () == TYPE_CODE_PTR
)
4372 address
= value_address (ada_value_ind (arg
));
4374 address
= value_address (ada_coerce_ref (arg
));
4376 /* Check to see if this is a tagged type. We also need to handle
4377 the case where the type is a reference to a tagged type, but
4378 we have to be careful to exclude pointers to tagged types.
4379 The latter should be shown as usual (as a pointer), whereas
4380 a reference should mostly be transparent to the user. */
4382 if (ada_is_tagged_type (t1
, 0)
4383 || (t1
->code () == TYPE_CODE_REF
4384 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4386 /* We first try to find the searched field in the current type.
4387 If not found then let's look in the fixed type. */
4389 if (!find_struct_field (name
, t1
, 0,
4390 &field_type
, &byte_offset
, &bit_offset
,
4399 /* Convert to fixed type in all cases, so that we have proper
4400 offsets to each field in unconstrained record types. */
4401 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4402 address
, NULL
, check_tag
);
4404 /* Resolve the dynamic type as well. */
4405 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4406 t1
= value_type (arg
);
4408 if (find_struct_field (name
, t1
, 0,
4409 &field_type
, &byte_offset
, &bit_offset
,
4414 if (t
->code () == TYPE_CODE_REF
)
4415 arg
= ada_coerce_ref (arg
);
4417 arg
= ada_value_ind (arg
);
4418 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4419 bit_offset
, bit_size
,
4423 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4427 if (v
!= NULL
|| no_err
)
4430 error (_("There is no member named %s."), name
);
4436 error (_("Attempt to extract a component of "
4437 "a value that is not a record."));
4440 /* Return the value ACTUAL, converted to be an appropriate value for a
4441 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4442 allocating any necessary descriptors (fat pointers), or copies of
4443 values not residing in memory, updating it as needed. */
4446 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4448 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4449 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4450 struct type
*formal_target
=
4451 formal_type
->code () == TYPE_CODE_PTR
4452 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4453 struct type
*actual_target
=
4454 actual_type
->code () == TYPE_CODE_PTR
4455 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4457 if (ada_is_array_descriptor_type (formal_target
)
4458 && actual_target
->code () == TYPE_CODE_ARRAY
)
4459 return make_array_descriptor (formal_type
, actual
);
4460 else if (formal_type
->code () == TYPE_CODE_PTR
4461 || formal_type
->code () == TYPE_CODE_REF
)
4463 struct value
*result
;
4465 if (formal_target
->code () == TYPE_CODE_ARRAY
4466 && ada_is_array_descriptor_type (actual_target
))
4467 result
= desc_data (actual
);
4468 else if (formal_type
->code () != TYPE_CODE_PTR
)
4470 if (VALUE_LVAL (actual
) != lval_memory
)
4474 actual_type
= ada_check_typedef (value_type (actual
));
4475 val
= allocate_value (actual_type
);
4476 memcpy ((char *) value_contents_raw (val
),
4477 (char *) value_contents (actual
),
4478 TYPE_LENGTH (actual_type
));
4479 actual
= ensure_lval (val
);
4481 result
= value_addr (actual
);
4485 return value_cast_pointers (formal_type
, result
, 0);
4487 else if (actual_type
->code () == TYPE_CODE_PTR
)
4488 return ada_value_ind (actual
);
4489 else if (ada_is_aligner_type (formal_type
))
4491 /* We need to turn this parameter into an aligner type
4493 struct value
*aligner
= allocate_value (formal_type
);
4494 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4496 value_assign_to_component (aligner
, component
, actual
);
4503 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4504 type TYPE. This is usually an inefficient no-op except on some targets
4505 (such as AVR) where the representation of a pointer and an address
4509 value_pointer (struct value
*value
, struct type
*type
)
4511 struct gdbarch
*gdbarch
= get_type_arch (type
);
4512 unsigned len
= TYPE_LENGTH (type
);
4513 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4516 addr
= value_address (value
);
4517 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4518 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4523 /* Push a descriptor of type TYPE for array value ARR on the stack at
4524 *SP, updating *SP to reflect the new descriptor. Return either
4525 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4526 to-descriptor type rather than a descriptor type), a struct value *
4527 representing a pointer to this descriptor. */
4529 static struct value
*
4530 make_array_descriptor (struct type
*type
, struct value
*arr
)
4532 struct type
*bounds_type
= desc_bounds_type (type
);
4533 struct type
*desc_type
= desc_base_type (type
);
4534 struct value
*descriptor
= allocate_value (desc_type
);
4535 struct value
*bounds
= allocate_value (bounds_type
);
4538 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4541 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4542 ada_array_bound (arr
, i
, 0),
4543 desc_bound_bitpos (bounds_type
, i
, 0),
4544 desc_bound_bitsize (bounds_type
, i
, 0));
4545 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4546 ada_array_bound (arr
, i
, 1),
4547 desc_bound_bitpos (bounds_type
, i
, 1),
4548 desc_bound_bitsize (bounds_type
, i
, 1));
4551 bounds
= ensure_lval (bounds
);
4553 modify_field (value_type (descriptor
),
4554 value_contents_writeable (descriptor
),
4555 value_pointer (ensure_lval (arr
),
4556 desc_type
->field (0).type ()),
4557 fat_pntr_data_bitpos (desc_type
),
4558 fat_pntr_data_bitsize (desc_type
));
4560 modify_field (value_type (descriptor
),
4561 value_contents_writeable (descriptor
),
4562 value_pointer (bounds
,
4563 desc_type
->field (1).type ()),
4564 fat_pntr_bounds_bitpos (desc_type
),
4565 fat_pntr_bounds_bitsize (desc_type
));
4567 descriptor
= ensure_lval (descriptor
);
4569 if (type
->code () == TYPE_CODE_PTR
)
4570 return value_addr (descriptor
);
4575 /* Symbol Cache Module */
4577 /* Performance measurements made as of 2010-01-15 indicate that
4578 this cache does bring some noticeable improvements. Depending
4579 on the type of entity being printed, the cache can make it as much
4580 as an order of magnitude faster than without it.
4582 The descriptive type DWARF extension has significantly reduced
4583 the need for this cache, at least when DWARF is being used. However,
4584 even in this case, some expensive name-based symbol searches are still
4585 sometimes necessary - to find an XVZ variable, mostly. */
4587 /* Initialize the contents of SYM_CACHE. */
4590 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4592 obstack_init (&sym_cache
->cache_space
);
4593 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4596 /* Free the memory used by SYM_CACHE. */
4599 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4601 obstack_free (&sym_cache
->cache_space
, NULL
);
4605 /* Return the symbol cache associated to the given program space PSPACE.
4606 If not allocated for this PSPACE yet, allocate and initialize one. */
4608 static struct ada_symbol_cache
*
4609 ada_get_symbol_cache (struct program_space
*pspace
)
4611 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4613 if (pspace_data
->sym_cache
== NULL
)
4615 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4616 ada_init_symbol_cache (pspace_data
->sym_cache
);
4619 return pspace_data
->sym_cache
;
4622 /* Clear all entries from the symbol cache. */
4625 ada_clear_symbol_cache (void)
4627 struct ada_symbol_cache
*sym_cache
4628 = ada_get_symbol_cache (current_program_space
);
4630 obstack_free (&sym_cache
->cache_space
, NULL
);
4631 ada_init_symbol_cache (sym_cache
);
4634 /* Search our cache for an entry matching NAME and DOMAIN.
4635 Return it if found, or NULL otherwise. */
4637 static struct cache_entry
**
4638 find_entry (const char *name
, domain_enum domain
)
4640 struct ada_symbol_cache
*sym_cache
4641 = ada_get_symbol_cache (current_program_space
);
4642 int h
= msymbol_hash (name
) % HASH_SIZE
;
4643 struct cache_entry
**e
;
4645 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4647 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4653 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4654 Return 1 if found, 0 otherwise.
4656 If an entry was found and SYM is not NULL, set *SYM to the entry's
4657 SYM. Same principle for BLOCK if not NULL. */
4660 lookup_cached_symbol (const char *name
, domain_enum domain
,
4661 struct symbol
**sym
, const struct block
**block
)
4663 struct cache_entry
**e
= find_entry (name
, domain
);
4670 *block
= (*e
)->block
;
4674 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4675 in domain DOMAIN, save this result in our symbol cache. */
4678 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4679 const struct block
*block
)
4681 struct ada_symbol_cache
*sym_cache
4682 = ada_get_symbol_cache (current_program_space
);
4684 struct cache_entry
*e
;
4686 /* Symbols for builtin types don't have a block.
4687 For now don't cache such symbols. */
4688 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4691 /* If the symbol is a local symbol, then do not cache it, as a search
4692 for that symbol depends on the context. To determine whether
4693 the symbol is local or not, we check the block where we found it
4694 against the global and static blocks of its associated symtab. */
4696 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4697 GLOBAL_BLOCK
) != block
4698 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4699 STATIC_BLOCK
) != block
)
4702 h
= msymbol_hash (name
) % HASH_SIZE
;
4703 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4704 e
->next
= sym_cache
->root
[h
];
4705 sym_cache
->root
[h
] = e
;
4706 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4714 /* Return the symbol name match type that should be used used when
4715 searching for all symbols matching LOOKUP_NAME.
4717 LOOKUP_NAME is expected to be a symbol name after transformation
4720 static symbol_name_match_type
4721 name_match_type_from_name (const char *lookup_name
)
4723 return (strstr (lookup_name
, "__") == NULL
4724 ? symbol_name_match_type::WILD
4725 : symbol_name_match_type::FULL
);
4728 /* Return the result of a standard (literal, C-like) lookup of NAME in
4729 given DOMAIN, visible from lexical block BLOCK. */
4731 static struct symbol
*
4732 standard_lookup (const char *name
, const struct block
*block
,
4735 /* Initialize it just to avoid a GCC false warning. */
4736 struct block_symbol sym
= {};
4738 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4740 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4741 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4746 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4747 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4748 since they contend in overloading in the same way. */
4750 is_nonfunction (struct block_symbol syms
[], int n
)
4754 for (i
= 0; i
< n
; i
+= 1)
4755 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4756 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4757 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4763 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4764 struct types. Otherwise, they may not. */
4767 equiv_types (struct type
*type0
, struct type
*type1
)
4771 if (type0
== NULL
|| type1
== NULL
4772 || type0
->code () != type1
->code ())
4774 if ((type0
->code () == TYPE_CODE_STRUCT
4775 || type0
->code () == TYPE_CODE_ENUM
)
4776 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4777 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4783 /* True iff SYM0 represents the same entity as SYM1, or one that is
4784 no more defined than that of SYM1. */
4787 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4791 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4792 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4795 switch (SYMBOL_CLASS (sym0
))
4801 struct type
*type0
= SYMBOL_TYPE (sym0
);
4802 struct type
*type1
= SYMBOL_TYPE (sym1
);
4803 const char *name0
= sym0
->linkage_name ();
4804 const char *name1
= sym1
->linkage_name ();
4805 int len0
= strlen (name0
);
4808 type0
->code () == type1
->code ()
4809 && (equiv_types (type0
, type1
)
4810 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4811 && startswith (name1
+ len0
, "___XV")));
4814 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4815 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4819 const char *name0
= sym0
->linkage_name ();
4820 const char *name1
= sym1
->linkage_name ();
4821 return (strcmp (name0
, name1
) == 0
4822 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4830 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4831 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4834 add_defn_to_vec (struct obstack
*obstackp
,
4836 const struct block
*block
)
4839 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4841 /* Do not try to complete stub types, as the debugger is probably
4842 already scanning all symbols matching a certain name at the
4843 time when this function is called. Trying to replace the stub
4844 type by its associated full type will cause us to restart a scan
4845 which may lead to an infinite recursion. Instead, the client
4846 collecting the matching symbols will end up collecting several
4847 matches, with at least one of them complete. It can then filter
4848 out the stub ones if needed. */
4850 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4852 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4854 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4856 prevDefns
[i
].symbol
= sym
;
4857 prevDefns
[i
].block
= block
;
4863 struct block_symbol info
;
4867 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4871 /* Number of block_symbol structures currently collected in current vector in
4875 num_defns_collected (struct obstack
*obstackp
)
4877 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4880 /* Vector of block_symbol structures currently collected in current vector in
4881 OBSTACKP. If FINISH, close off the vector and return its final address. */
4883 static struct block_symbol
*
4884 defns_collected (struct obstack
*obstackp
, int finish
)
4887 return (struct block_symbol
*) obstack_finish (obstackp
);
4889 return (struct block_symbol
*) obstack_base (obstackp
);
4892 /* Return a bound minimal symbol matching NAME according to Ada
4893 decoding rules. Returns an invalid symbol if there is no such
4894 minimal symbol. Names prefixed with "standard__" are handled
4895 specially: "standard__" is first stripped off, and only static and
4896 global symbols are searched. */
4898 struct bound_minimal_symbol
4899 ada_lookup_simple_minsym (const char *name
)
4901 struct bound_minimal_symbol result
;
4903 memset (&result
, 0, sizeof (result
));
4905 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4906 lookup_name_info
lookup_name (name
, match_type
);
4908 symbol_name_matcher_ftype
*match_name
4909 = ada_get_symbol_name_matcher (lookup_name
);
4911 for (objfile
*objfile
: current_program_space
->objfiles ())
4913 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4915 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4916 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4918 result
.minsym
= msymbol
;
4919 result
.objfile
= objfile
;
4928 /* For all subprograms that statically enclose the subprogram of the
4929 selected frame, add symbols matching identifier NAME in DOMAIN
4930 and their blocks to the list of data in OBSTACKP, as for
4931 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4932 with a wildcard prefix. */
4935 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4936 const lookup_name_info
&lookup_name
,
4941 /* True if TYPE is definitely an artificial type supplied to a symbol
4942 for which no debugging information was given in the symbol file. */
4945 is_nondebugging_type (struct type
*type
)
4947 const char *name
= ada_type_name (type
);
4949 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4952 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4953 that are deemed "identical" for practical purposes.
4955 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4956 types and that their number of enumerals is identical (in other
4957 words, type1->num_fields () == type2->num_fields ()). */
4960 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4964 /* The heuristic we use here is fairly conservative. We consider
4965 that 2 enumerate types are identical if they have the same
4966 number of enumerals and that all enumerals have the same
4967 underlying value and name. */
4969 /* All enums in the type should have an identical underlying value. */
4970 for (i
= 0; i
< type1
->num_fields (); i
++)
4971 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4974 /* All enumerals should also have the same name (modulo any numerical
4976 for (i
= 0; i
< type1
->num_fields (); i
++)
4978 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4979 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4980 int len_1
= strlen (name_1
);
4981 int len_2
= strlen (name_2
);
4983 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4984 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4986 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4987 TYPE_FIELD_NAME (type2
, i
),
4995 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4996 that are deemed "identical" for practical purposes. Sometimes,
4997 enumerals are not strictly identical, but their types are so similar
4998 that they can be considered identical.
5000 For instance, consider the following code:
5002 type Color is (Black, Red, Green, Blue, White);
5003 type RGB_Color is new Color range Red .. Blue;
5005 Type RGB_Color is a subrange of an implicit type which is a copy
5006 of type Color. If we call that implicit type RGB_ColorB ("B" is
5007 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5008 As a result, when an expression references any of the enumeral
5009 by name (Eg. "print green"), the expression is technically
5010 ambiguous and the user should be asked to disambiguate. But
5011 doing so would only hinder the user, since it wouldn't matter
5012 what choice he makes, the outcome would always be the same.
5013 So, for practical purposes, we consider them as the same. */
5016 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5020 /* Before performing a thorough comparison check of each type,
5021 we perform a series of inexpensive checks. We expect that these
5022 checks will quickly fail in the vast majority of cases, and thus
5023 help prevent the unnecessary use of a more expensive comparison.
5024 Said comparison also expects us to make some of these checks
5025 (see ada_identical_enum_types_p). */
5027 /* Quick check: All symbols should have an enum type. */
5028 for (i
= 0; i
< syms
.size (); i
++)
5029 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
5032 /* Quick check: They should all have the same value. */
5033 for (i
= 1; i
< syms
.size (); i
++)
5034 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5037 /* Quick check: They should all have the same number of enumerals. */
5038 for (i
= 1; i
< syms
.size (); i
++)
5039 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
5040 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
5043 /* All the sanity checks passed, so we might have a set of
5044 identical enumeration types. Perform a more complete
5045 comparison of the type of each symbol. */
5046 for (i
= 1; i
< syms
.size (); i
++)
5047 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5048 SYMBOL_TYPE (syms
[0].symbol
)))
5054 /* Remove any non-debugging symbols in SYMS that definitely
5055 duplicate other symbols in the list (The only case I know of where
5056 this happens is when object files containing stabs-in-ecoff are
5057 linked with files containing ordinary ecoff debugging symbols (or no
5058 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5059 Returns the number of items in the modified list. */
5062 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5066 /* We should never be called with less than 2 symbols, as there
5067 cannot be any extra symbol in that case. But it's easy to
5068 handle, since we have nothing to do in that case. */
5069 if (syms
->size () < 2)
5070 return syms
->size ();
5073 while (i
< syms
->size ())
5077 /* If two symbols have the same name and one of them is a stub type,
5078 the get rid of the stub. */
5080 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
5081 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5083 for (j
= 0; j
< syms
->size (); j
++)
5086 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
5087 && (*syms
)[j
].symbol
->linkage_name () != NULL
5088 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5089 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5094 /* Two symbols with the same name, same class and same address
5095 should be identical. */
5097 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5098 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5099 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5101 for (j
= 0; j
< syms
->size (); j
+= 1)
5104 && (*syms
)[j
].symbol
->linkage_name () != NULL
5105 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5106 (*syms
)[j
].symbol
->linkage_name ()) == 0
5107 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5108 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5109 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5110 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5116 syms
->erase (syms
->begin () + i
);
5121 /* If all the remaining symbols are identical enumerals, then
5122 just keep the first one and discard the rest.
5124 Unlike what we did previously, we do not discard any entry
5125 unless they are ALL identical. This is because the symbol
5126 comparison is not a strict comparison, but rather a practical
5127 comparison. If all symbols are considered identical, then
5128 we can just go ahead and use the first one and discard the rest.
5129 But if we cannot reduce the list to a single element, we have
5130 to ask the user to disambiguate anyways. And if we have to
5131 present a multiple-choice menu, it's less confusing if the list
5132 isn't missing some choices that were identical and yet distinct. */
5133 if (symbols_are_identical_enums (*syms
))
5136 return syms
->size ();
5139 /* Given a type that corresponds to a renaming entity, use the type name
5140 to extract the scope (package name or function name, fully qualified,
5141 and following the GNAT encoding convention) where this renaming has been
5145 xget_renaming_scope (struct type
*renaming_type
)
5147 /* The renaming types adhere to the following convention:
5148 <scope>__<rename>___<XR extension>.
5149 So, to extract the scope, we search for the "___XR" extension,
5150 and then backtrack until we find the first "__". */
5152 const char *name
= renaming_type
->name ();
5153 const char *suffix
= strstr (name
, "___XR");
5156 /* Now, backtrack a bit until we find the first "__". Start looking
5157 at suffix - 3, as the <rename> part is at least one character long. */
5159 for (last
= suffix
- 3; last
> name
; last
--)
5160 if (last
[0] == '_' && last
[1] == '_')
5163 /* Make a copy of scope and return it. */
5164 return std::string (name
, last
);
5167 /* Return nonzero if NAME corresponds to a package name. */
5170 is_package_name (const char *name
)
5172 /* Here, We take advantage of the fact that no symbols are generated
5173 for packages, while symbols are generated for each function.
5174 So the condition for NAME represent a package becomes equivalent
5175 to NAME not existing in our list of symbols. There is only one
5176 small complication with library-level functions (see below). */
5178 /* If it is a function that has not been defined at library level,
5179 then we should be able to look it up in the symbols. */
5180 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5183 /* Library-level function names start with "_ada_". See if function
5184 "_ada_" followed by NAME can be found. */
5186 /* Do a quick check that NAME does not contain "__", since library-level
5187 functions names cannot contain "__" in them. */
5188 if (strstr (name
, "__") != NULL
)
5191 std::string fun_name
= string_printf ("_ada_%s", name
);
5193 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5196 /* Return nonzero if SYM corresponds to a renaming entity that is
5197 not visible from FUNCTION_NAME. */
5200 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5202 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5205 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5207 /* If the rename has been defined in a package, then it is visible. */
5208 if (is_package_name (scope
.c_str ()))
5211 /* Check that the rename is in the current function scope by checking
5212 that its name starts with SCOPE. */
5214 /* If the function name starts with "_ada_", it means that it is
5215 a library-level function. Strip this prefix before doing the
5216 comparison, as the encoding for the renaming does not contain
5218 if (startswith (function_name
, "_ada_"))
5221 return !startswith (function_name
, scope
.c_str ());
5224 /* Remove entries from SYMS that corresponds to a renaming entity that
5225 is not visible from the function associated with CURRENT_BLOCK or
5226 that is superfluous due to the presence of more specific renaming
5227 information. Places surviving symbols in the initial entries of
5228 SYMS and returns the number of surviving symbols.
5231 First, in cases where an object renaming is implemented as a
5232 reference variable, GNAT may produce both the actual reference
5233 variable and the renaming encoding. In this case, we discard the
5236 Second, GNAT emits a type following a specified encoding for each renaming
5237 entity. Unfortunately, STABS currently does not support the definition
5238 of types that are local to a given lexical block, so all renamings types
5239 are emitted at library level. As a consequence, if an application
5240 contains two renaming entities using the same name, and a user tries to
5241 print the value of one of these entities, the result of the ada symbol
5242 lookup will also contain the wrong renaming type.
5244 This function partially covers for this limitation by attempting to
5245 remove from the SYMS list renaming symbols that should be visible
5246 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5247 method with the current information available. The implementation
5248 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5250 - When the user tries to print a rename in a function while there
5251 is another rename entity defined in a package: Normally, the
5252 rename in the function has precedence over the rename in the
5253 package, so the latter should be removed from the list. This is
5254 currently not the case.
5256 - This function will incorrectly remove valid renames if
5257 the CURRENT_BLOCK corresponds to a function which symbol name
5258 has been changed by an "Export" pragma. As a consequence,
5259 the user will be unable to print such rename entities. */
5262 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5263 const struct block
*current_block
)
5265 struct symbol
*current_function
;
5266 const char *current_function_name
;
5268 int is_new_style_renaming
;
5270 /* If there is both a renaming foo___XR... encoded as a variable and
5271 a simple variable foo in the same block, discard the latter.
5272 First, zero out such symbols, then compress. */
5273 is_new_style_renaming
= 0;
5274 for (i
= 0; i
< syms
->size (); i
+= 1)
5276 struct symbol
*sym
= (*syms
)[i
].symbol
;
5277 const struct block
*block
= (*syms
)[i
].block
;
5281 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5283 name
= sym
->linkage_name ();
5284 suffix
= strstr (name
, "___XR");
5288 int name_len
= suffix
- name
;
5291 is_new_style_renaming
= 1;
5292 for (j
= 0; j
< syms
->size (); j
+= 1)
5293 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5294 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5296 && block
== (*syms
)[j
].block
)
5297 (*syms
)[j
].symbol
= NULL
;
5300 if (is_new_style_renaming
)
5304 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5305 if ((*syms
)[j
].symbol
!= NULL
)
5307 (*syms
)[k
] = (*syms
)[j
];
5313 /* Extract the function name associated to CURRENT_BLOCK.
5314 Abort if unable to do so. */
5316 if (current_block
== NULL
)
5317 return syms
->size ();
5319 current_function
= block_linkage_function (current_block
);
5320 if (current_function
== NULL
)
5321 return syms
->size ();
5323 current_function_name
= current_function
->linkage_name ();
5324 if (current_function_name
== NULL
)
5325 return syms
->size ();
5327 /* Check each of the symbols, and remove it from the list if it is
5328 a type corresponding to a renaming that is out of the scope of
5329 the current block. */
5332 while (i
< syms
->size ())
5334 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5335 == ADA_OBJECT_RENAMING
5336 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5337 current_function_name
))
5338 syms
->erase (syms
->begin () + i
);
5343 return syms
->size ();
5346 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5347 whose name and domain match NAME and DOMAIN respectively.
5348 If no match was found, then extend the search to "enclosing"
5349 routines (in other words, if we're inside a nested function,
5350 search the symbols defined inside the enclosing functions).
5351 If WILD_MATCH_P is nonzero, perform the naming matching in
5352 "wild" mode (see function "wild_match" for more info).
5354 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5357 ada_add_local_symbols (struct obstack
*obstackp
,
5358 const lookup_name_info
&lookup_name
,
5359 const struct block
*block
, domain_enum domain
)
5361 int block_depth
= 0;
5363 while (block
!= NULL
)
5366 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5368 /* If we found a non-function match, assume that's the one. */
5369 if (is_nonfunction (defns_collected (obstackp
, 0),
5370 num_defns_collected (obstackp
)))
5373 block
= BLOCK_SUPERBLOCK (block
);
5376 /* If no luck so far, try to find NAME as a local symbol in some lexically
5377 enclosing subprogram. */
5378 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5379 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5382 /* An object of this type is used as the user_data argument when
5383 calling the map_matching_symbols method. */
5387 struct objfile
*objfile
;
5388 struct obstack
*obstackp
;
5389 struct symbol
*arg_sym
;
5393 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5394 to a list of symbols. DATA is a pointer to a struct match_data *
5395 containing the obstack that collects the symbol list, the file that SYM
5396 must come from, a flag indicating whether a non-argument symbol has
5397 been found in the current block, and the last argument symbol
5398 passed in SYM within the current block (if any). When SYM is null,
5399 marking the end of a block, the argument symbol is added if no
5400 other has been found. */
5403 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5404 struct match_data
*data
)
5406 const struct block
*block
= bsym
->block
;
5407 struct symbol
*sym
= bsym
->symbol
;
5411 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5412 add_defn_to_vec (data
->obstackp
,
5413 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5415 data
->found_sym
= 0;
5416 data
->arg_sym
= NULL
;
5420 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5422 else if (SYMBOL_IS_ARGUMENT (sym
))
5423 data
->arg_sym
= sym
;
5426 data
->found_sym
= 1;
5427 add_defn_to_vec (data
->obstackp
,
5428 fixup_symbol_section (sym
, data
->objfile
),
5435 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5436 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5437 symbols to OBSTACKP. Return whether we found such symbols. */
5440 ada_add_block_renamings (struct obstack
*obstackp
,
5441 const struct block
*block
,
5442 const lookup_name_info
&lookup_name
,
5445 struct using_direct
*renaming
;
5446 int defns_mark
= num_defns_collected (obstackp
);
5448 symbol_name_matcher_ftype
*name_match
5449 = ada_get_symbol_name_matcher (lookup_name
);
5451 for (renaming
= block_using (block
);
5453 renaming
= renaming
->next
)
5457 /* Avoid infinite recursions: skip this renaming if we are actually
5458 already traversing it.
5460 Currently, symbol lookup in Ada don't use the namespace machinery from
5461 C++/Fortran support: skip namespace imports that use them. */
5462 if (renaming
->searched
5463 || (renaming
->import_src
!= NULL
5464 && renaming
->import_src
[0] != '\0')
5465 || (renaming
->import_dest
!= NULL
5466 && renaming
->import_dest
[0] != '\0'))
5468 renaming
->searched
= 1;
5470 /* TODO: here, we perform another name-based symbol lookup, which can
5471 pull its own multiple overloads. In theory, we should be able to do
5472 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5473 not a simple name. But in order to do this, we would need to enhance
5474 the DWARF reader to associate a symbol to this renaming, instead of a
5475 name. So, for now, we do something simpler: re-use the C++/Fortran
5476 namespace machinery. */
5477 r_name
= (renaming
->alias
!= NULL
5479 : renaming
->declaration
);
5480 if (name_match (r_name
, lookup_name
, NULL
))
5482 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5483 lookup_name
.match_type ());
5484 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5487 renaming
->searched
= 0;
5489 return num_defns_collected (obstackp
) != defns_mark
;
5492 /* Implements compare_names, but only applying the comparision using
5493 the given CASING. */
5496 compare_names_with_case (const char *string1
, const char *string2
,
5497 enum case_sensitivity casing
)
5499 while (*string1
!= '\0' && *string2
!= '\0')
5503 if (isspace (*string1
) || isspace (*string2
))
5504 return strcmp_iw_ordered (string1
, string2
);
5506 if (casing
== case_sensitive_off
)
5508 c1
= tolower (*string1
);
5509 c2
= tolower (*string2
);
5526 return strcmp_iw_ordered (string1
, string2
);
5528 if (*string2
== '\0')
5530 if (is_name_suffix (string1
))
5537 if (*string2
== '(')
5538 return strcmp_iw_ordered (string1
, string2
);
5541 if (casing
== case_sensitive_off
)
5542 return tolower (*string1
) - tolower (*string2
);
5544 return *string1
- *string2
;
5549 /* Compare STRING1 to STRING2, with results as for strcmp.
5550 Compatible with strcmp_iw_ordered in that...
5552 strcmp_iw_ordered (STRING1, STRING2) <= 0
5556 compare_names (STRING1, STRING2) <= 0
5558 (they may differ as to what symbols compare equal). */
5561 compare_names (const char *string1
, const char *string2
)
5565 /* Similar to what strcmp_iw_ordered does, we need to perform
5566 a case-insensitive comparison first, and only resort to
5567 a second, case-sensitive, comparison if the first one was
5568 not sufficient to differentiate the two strings. */
5570 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5572 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5577 /* Convenience function to get at the Ada encoded lookup name for
5578 LOOKUP_NAME, as a C string. */
5581 ada_lookup_name (const lookup_name_info
&lookup_name
)
5583 return lookup_name
.ada ().lookup_name ().c_str ();
5586 /* Add to OBSTACKP all non-local symbols whose name and domain match
5587 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5588 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5589 symbols otherwise. */
5592 add_nonlocal_symbols (struct obstack
*obstackp
,
5593 const lookup_name_info
&lookup_name
,
5594 domain_enum domain
, int global
)
5596 struct match_data data
;
5598 memset (&data
, 0, sizeof data
);
5599 data
.obstackp
= obstackp
;
5601 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5603 auto callback
= [&] (struct block_symbol
*bsym
)
5605 return aux_add_nonlocal_symbols (bsym
, &data
);
5608 for (objfile
*objfile
: current_program_space
->objfiles ())
5610 data
.objfile
= objfile
;
5612 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5613 domain
, global
, callback
,
5615 ? NULL
: compare_names
));
5617 for (compunit_symtab
*cu
: objfile
->compunits ())
5619 const struct block
*global_block
5620 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5622 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5628 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5630 const char *name
= ada_lookup_name (lookup_name
);
5631 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5632 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5634 for (objfile
*objfile
: current_program_space
->objfiles ())
5636 data
.objfile
= objfile
;
5637 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5638 domain
, global
, callback
,
5644 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5645 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5646 returning the number of matches. Add these to OBSTACKP.
5648 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5649 symbol match within the nest of blocks whose innermost member is BLOCK,
5650 is the one match returned (no other matches in that or
5651 enclosing blocks is returned). If there are any matches in or
5652 surrounding BLOCK, then these alone are returned.
5654 Names prefixed with "standard__" are handled specially:
5655 "standard__" is first stripped off (by the lookup_name
5656 constructor), and only static and global symbols are searched.
5658 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5659 to lookup global symbols. */
5662 ada_add_all_symbols (struct obstack
*obstackp
,
5663 const struct block
*block
,
5664 const lookup_name_info
&lookup_name
,
5667 int *made_global_lookup_p
)
5671 if (made_global_lookup_p
)
5672 *made_global_lookup_p
= 0;
5674 /* Special case: If the user specifies a symbol name inside package
5675 Standard, do a non-wild matching of the symbol name without
5676 the "standard__" prefix. This was primarily introduced in order
5677 to allow the user to specifically access the standard exceptions
5678 using, for instance, Standard.Constraint_Error when Constraint_Error
5679 is ambiguous (due to the user defining its own Constraint_Error
5680 entity inside its program). */
5681 if (lookup_name
.ada ().standard_p ())
5684 /* Check the non-global symbols. If we have ANY match, then we're done. */
5689 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5692 /* In the !full_search case we're are being called by
5693 iterate_over_symbols, and we don't want to search
5695 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5697 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5701 /* No non-global symbols found. Check our cache to see if we have
5702 already performed this search before. If we have, then return
5705 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5706 domain
, &sym
, &block
))
5709 add_defn_to_vec (obstackp
, sym
, block
);
5713 if (made_global_lookup_p
)
5714 *made_global_lookup_p
= 1;
5716 /* Search symbols from all global blocks. */
5718 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5720 /* Now add symbols from all per-file blocks if we've gotten no hits
5721 (not strictly correct, but perhaps better than an error). */
5723 if (num_defns_collected (obstackp
) == 0)
5724 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5727 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5728 is non-zero, enclosing scope and in global scopes, returning the number of
5730 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5731 found and the blocks and symbol tables (if any) in which they were
5734 When full_search is non-zero, any non-function/non-enumeral
5735 symbol match within the nest of blocks whose innermost member is BLOCK,
5736 is the one match returned (no other matches in that or
5737 enclosing blocks is returned). If there are any matches in or
5738 surrounding BLOCK, then these alone are returned.
5740 Names prefixed with "standard__" are handled specially: "standard__"
5741 is first stripped off, and only static and global symbols are searched. */
5744 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5745 const struct block
*block
,
5747 std::vector
<struct block_symbol
> *results
,
5750 int syms_from_global_search
;
5752 auto_obstack obstack
;
5754 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5755 domain
, full_search
, &syms_from_global_search
);
5757 ndefns
= num_defns_collected (&obstack
);
5759 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5760 for (int i
= 0; i
< ndefns
; ++i
)
5761 results
->push_back (base
[i
]);
5763 ndefns
= remove_extra_symbols (results
);
5765 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5766 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5768 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5769 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5770 (*results
)[0].symbol
, (*results
)[0].block
);
5772 ndefns
= remove_irrelevant_renamings (results
, block
);
5777 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5778 in global scopes, returning the number of matches, and filling *RESULTS
5779 with (SYM,BLOCK) tuples.
5781 See ada_lookup_symbol_list_worker for further details. */
5784 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5786 std::vector
<struct block_symbol
> *results
)
5788 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5789 lookup_name_info
lookup_name (name
, name_match_type
);
5791 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5794 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5795 to 1, but choosing the first symbol found if there are multiple
5798 The result is stored in *INFO, which must be non-NULL.
5799 If no match is found, INFO->SYM is set to NULL. */
5802 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5804 struct block_symbol
*info
)
5806 /* Since we already have an encoded name, wrap it in '<>' to force a
5807 verbatim match. Otherwise, if the name happens to not look like
5808 an encoded name (because it doesn't include a "__"),
5809 ada_lookup_name_info would re-encode/fold it again, and that
5810 would e.g., incorrectly lowercase object renaming names like
5811 "R28b" -> "r28b". */
5812 std::string verbatim
= add_angle_brackets (name
);
5814 gdb_assert (info
!= NULL
);
5815 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5818 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5819 scope and in global scopes, or NULL if none. NAME is folded and
5820 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5821 choosing the first symbol if there are multiple choices. */
5824 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5827 std::vector
<struct block_symbol
> candidates
;
5830 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5832 if (n_candidates
== 0)
5835 block_symbol info
= candidates
[0];
5836 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5841 /* True iff STR is a possible encoded suffix of a normal Ada name
5842 that is to be ignored for matching purposes. Suffixes of parallel
5843 names (e.g., XVE) are not included here. Currently, the possible suffixes
5844 are given by any of the regular expressions:
5846 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5847 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5848 TKB [subprogram suffix for task bodies]
5849 _E[0-9]+[bs]$ [protected object entry suffixes]
5850 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5852 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5853 match is performed. This sequence is used to differentiate homonyms,
5854 is an optional part of a valid name suffix. */
5857 is_name_suffix (const char *str
)
5860 const char *matching
;
5861 const int len
= strlen (str
);
5863 /* Skip optional leading __[0-9]+. */
5865 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5868 while (isdigit (str
[0]))
5874 if (str
[0] == '.' || str
[0] == '$')
5877 while (isdigit (matching
[0]))
5879 if (matching
[0] == '\0')
5885 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5888 while (isdigit (matching
[0]))
5890 if (matching
[0] == '\0')
5894 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5896 if (strcmp (str
, "TKB") == 0)
5900 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5901 with a N at the end. Unfortunately, the compiler uses the same
5902 convention for other internal types it creates. So treating
5903 all entity names that end with an "N" as a name suffix causes
5904 some regressions. For instance, consider the case of an enumerated
5905 type. To support the 'Image attribute, it creates an array whose
5907 Having a single character like this as a suffix carrying some
5908 information is a bit risky. Perhaps we should change the encoding
5909 to be something like "_N" instead. In the meantime, do not do
5910 the following check. */
5911 /* Protected Object Subprograms */
5912 if (len
== 1 && str
[0] == 'N')
5917 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5920 while (isdigit (matching
[0]))
5922 if ((matching
[0] == 'b' || matching
[0] == 's')
5923 && matching
[1] == '\0')
5927 /* ??? We should not modify STR directly, as we are doing below. This
5928 is fine in this case, but may become problematic later if we find
5929 that this alternative did not work, and want to try matching
5930 another one from the begining of STR. Since we modified it, we
5931 won't be able to find the begining of the string anymore! */
5935 while (str
[0] != '_' && str
[0] != '\0')
5937 if (str
[0] != 'n' && str
[0] != 'b')
5943 if (str
[0] == '\000')
5948 if (str
[1] != '_' || str
[2] == '\000')
5952 if (strcmp (str
+ 3, "JM") == 0)
5954 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5955 the LJM suffix in favor of the JM one. But we will
5956 still accept LJM as a valid suffix for a reasonable
5957 amount of time, just to allow ourselves to debug programs
5958 compiled using an older version of GNAT. */
5959 if (strcmp (str
+ 3, "LJM") == 0)
5963 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5964 || str
[4] == 'U' || str
[4] == 'P')
5966 if (str
[4] == 'R' && str
[5] != 'T')
5970 if (!isdigit (str
[2]))
5972 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5973 if (!isdigit (str
[k
]) && str
[k
] != '_')
5977 if (str
[0] == '$' && isdigit (str
[1]))
5979 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5980 if (!isdigit (str
[k
]) && str
[k
] != '_')
5987 /* Return non-zero if the string starting at NAME and ending before
5988 NAME_END contains no capital letters. */
5991 is_valid_name_for_wild_match (const char *name0
)
5993 std::string decoded_name
= ada_decode (name0
);
5996 /* If the decoded name starts with an angle bracket, it means that
5997 NAME0 does not follow the GNAT encoding format. It should then
5998 not be allowed as a possible wild match. */
5999 if (decoded_name
[0] == '<')
6002 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6003 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6009 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
6010 character which could start a simple name. Assumes that *NAMEP points
6011 somewhere inside the string beginning at NAME0. */
6014 advance_wild_match (const char **namep
, const char *name0
, char target0
)
6016 const char *name
= *namep
;
6026 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6029 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6034 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6035 || name
[2] == target0
))
6043 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6053 /* Return true iff NAME encodes a name of the form prefix.PATN.
6054 Ignores any informational suffixes of NAME (i.e., for which
6055 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6059 wild_match (const char *name
, const char *patn
)
6062 const char *name0
= name
;
6066 const char *match
= name
;
6070 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6073 if (*p
== '\0' && is_name_suffix (name
))
6074 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6076 if (name
[-1] == '_')
6079 if (!advance_wild_match (&name
, name0
, *patn
))
6084 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6085 any trailing suffixes that encode debugging information or leading
6086 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6087 information that is ignored). */
6090 full_match (const char *sym_name
, const char *search_name
)
6092 size_t search_name_len
= strlen (search_name
);
6094 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6095 && is_name_suffix (sym_name
+ search_name_len
))
6098 if (startswith (sym_name
, "_ada_")
6099 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6100 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6106 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6107 *defn_symbols, updating the list of symbols in OBSTACKP (if
6108 necessary). OBJFILE is the section containing BLOCK. */
6111 ada_add_block_symbols (struct obstack
*obstackp
,
6112 const struct block
*block
,
6113 const lookup_name_info
&lookup_name
,
6114 domain_enum domain
, struct objfile
*objfile
)
6116 struct block_iterator iter
;
6117 /* A matching argument symbol, if any. */
6118 struct symbol
*arg_sym
;
6119 /* Set true when we find a matching non-argument symbol. */
6125 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6127 sym
= block_iter_match_next (lookup_name
, &iter
))
6129 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6131 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6133 if (SYMBOL_IS_ARGUMENT (sym
))
6138 add_defn_to_vec (obstackp
,
6139 fixup_symbol_section (sym
, objfile
),
6146 /* Handle renamings. */
6148 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6151 if (!found_sym
&& arg_sym
!= NULL
)
6153 add_defn_to_vec (obstackp
,
6154 fixup_symbol_section (arg_sym
, objfile
),
6158 if (!lookup_name
.ada ().wild_match_p ())
6162 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6163 const char *name
= ada_lookup_name
.c_str ();
6164 size_t name_len
= ada_lookup_name
.size ();
6166 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6168 if (symbol_matches_domain (sym
->language (),
6169 SYMBOL_DOMAIN (sym
), domain
))
6173 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6176 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6178 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6183 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6185 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6187 if (SYMBOL_IS_ARGUMENT (sym
))
6192 add_defn_to_vec (obstackp
,
6193 fixup_symbol_section (sym
, objfile
),
6201 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6202 They aren't parameters, right? */
6203 if (!found_sym
&& arg_sym
!= NULL
)
6205 add_defn_to_vec (obstackp
,
6206 fixup_symbol_section (arg_sym
, objfile
),
6213 /* Symbol Completion */
6218 ada_lookup_name_info::matches
6219 (const char *sym_name
,
6220 symbol_name_match_type match_type
,
6221 completion_match_result
*comp_match_res
) const
6224 const char *text
= m_encoded_name
.c_str ();
6225 size_t text_len
= m_encoded_name
.size ();
6227 /* First, test against the fully qualified name of the symbol. */
6229 if (strncmp (sym_name
, text
, text_len
) == 0)
6232 std::string decoded_name
= ada_decode (sym_name
);
6233 if (match
&& !m_encoded_p
)
6235 /* One needed check before declaring a positive match is to verify
6236 that iff we are doing a verbatim match, the decoded version
6237 of the symbol name starts with '<'. Otherwise, this symbol name
6238 is not a suitable completion. */
6240 bool has_angle_bracket
= (decoded_name
[0] == '<');
6241 match
= (has_angle_bracket
== m_verbatim_p
);
6244 if (match
&& !m_verbatim_p
)
6246 /* When doing non-verbatim match, another check that needs to
6247 be done is to verify that the potentially matching symbol name
6248 does not include capital letters, because the ada-mode would
6249 not be able to understand these symbol names without the
6250 angle bracket notation. */
6253 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6258 /* Second: Try wild matching... */
6260 if (!match
&& m_wild_match_p
)
6262 /* Since we are doing wild matching, this means that TEXT
6263 may represent an unqualified symbol name. We therefore must
6264 also compare TEXT against the unqualified name of the symbol. */
6265 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6267 if (strncmp (sym_name
, text
, text_len
) == 0)
6271 /* Finally: If we found a match, prepare the result to return. */
6276 if (comp_match_res
!= NULL
)
6278 std::string
&match_str
= comp_match_res
->match
.storage ();
6281 match_str
= ada_decode (sym_name
);
6285 match_str
= add_angle_brackets (sym_name
);
6287 match_str
= sym_name
;
6291 comp_match_res
->set_match (match_str
.c_str ());
6299 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6300 for tagged types. */
6303 ada_is_dispatch_table_ptr_type (struct type
*type
)
6307 if (type
->code () != TYPE_CODE_PTR
)
6310 name
= TYPE_TARGET_TYPE (type
)->name ();
6314 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6317 /* Return non-zero if TYPE is an interface tag. */
6320 ada_is_interface_tag (struct type
*type
)
6322 const char *name
= type
->name ();
6327 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6330 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6331 to be invisible to users. */
6334 ada_is_ignored_field (struct type
*type
, int field_num
)
6336 if (field_num
< 0 || field_num
> type
->num_fields ())
6339 /* Check the name of that field. */
6341 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6343 /* Anonymous field names should not be printed.
6344 brobecker/2007-02-20: I don't think this can actually happen
6345 but we don't want to print the value of anonymous fields anyway. */
6349 /* Normally, fields whose name start with an underscore ("_")
6350 are fields that have been internally generated by the compiler,
6351 and thus should not be printed. The "_parent" field is special,
6352 however: This is a field internally generated by the compiler
6353 for tagged types, and it contains the components inherited from
6354 the parent type. This field should not be printed as is, but
6355 should not be ignored either. */
6356 if (name
[0] == '_' && !startswith (name
, "_parent"))
6360 /* If this is the dispatch table of a tagged type or an interface tag,
6362 if (ada_is_tagged_type (type
, 1)
6363 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6364 || ada_is_interface_tag (type
->field (field_num
).type ())))
6367 /* Not a special field, so it should not be ignored. */
6371 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6372 pointer or reference type whose ultimate target has a tag field. */
6375 ada_is_tagged_type (struct type
*type
, int refok
)
6377 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6380 /* True iff TYPE represents the type of X'Tag */
6383 ada_is_tag_type (struct type
*type
)
6385 type
= ada_check_typedef (type
);
6387 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6391 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6393 return (name
!= NULL
6394 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6398 /* The type of the tag on VAL. */
6400 static struct type
*
6401 ada_tag_type (struct value
*val
)
6403 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6406 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6407 retired at Ada 05). */
6410 is_ada95_tag (struct value
*tag
)
6412 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6415 /* The value of the tag on VAL. */
6417 static struct value
*
6418 ada_value_tag (struct value
*val
)
6420 return ada_value_struct_elt (val
, "_tag", 0);
6423 /* The value of the tag on the object of type TYPE whose contents are
6424 saved at VALADDR, if it is non-null, or is at memory address
6427 static struct value
*
6428 value_tag_from_contents_and_address (struct type
*type
,
6429 const gdb_byte
*valaddr
,
6432 int tag_byte_offset
;
6433 struct type
*tag_type
;
6435 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6438 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6440 : valaddr
+ tag_byte_offset
);
6441 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6443 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6448 static struct type
*
6449 type_from_tag (struct value
*tag
)
6451 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6453 if (type_name
!= NULL
)
6454 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6458 /* Given a value OBJ of a tagged type, return a value of this
6459 type at the base address of the object. The base address, as
6460 defined in Ada.Tags, it is the address of the primary tag of
6461 the object, and therefore where the field values of its full
6462 view can be fetched. */
6465 ada_tag_value_at_base_address (struct value
*obj
)
6468 LONGEST offset_to_top
= 0;
6469 struct type
*ptr_type
, *obj_type
;
6471 CORE_ADDR base_address
;
6473 obj_type
= value_type (obj
);
6475 /* It is the responsability of the caller to deref pointers. */
6477 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6480 tag
= ada_value_tag (obj
);
6484 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6486 if (is_ada95_tag (tag
))
6489 ptr_type
= language_lookup_primitive_type
6490 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6491 ptr_type
= lookup_pointer_type (ptr_type
);
6492 val
= value_cast (ptr_type
, tag
);
6496 /* It is perfectly possible that an exception be raised while
6497 trying to determine the base address, just like for the tag;
6498 see ada_tag_name for more details. We do not print the error
6499 message for the same reason. */
6503 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6506 catch (const gdb_exception_error
&e
)
6511 /* If offset is null, nothing to do. */
6513 if (offset_to_top
== 0)
6516 /* -1 is a special case in Ada.Tags; however, what should be done
6517 is not quite clear from the documentation. So do nothing for
6520 if (offset_to_top
== -1)
6523 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6524 from the base address. This was however incompatible with
6525 C++ dispatch table: C++ uses a *negative* value to *add*
6526 to the base address. Ada's convention has therefore been
6527 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6528 use the same convention. Here, we support both cases by
6529 checking the sign of OFFSET_TO_TOP. */
6531 if (offset_to_top
> 0)
6532 offset_to_top
= -offset_to_top
;
6534 base_address
= value_address (obj
) + offset_to_top
;
6535 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6537 /* Make sure that we have a proper tag at the new address.
6538 Otherwise, offset_to_top is bogus (which can happen when
6539 the object is not initialized yet). */
6544 obj_type
= type_from_tag (tag
);
6549 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6552 /* Return the "ada__tags__type_specific_data" type. */
6554 static struct type
*
6555 ada_get_tsd_type (struct inferior
*inf
)
6557 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6559 if (data
->tsd_type
== 0)
6560 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6561 return data
->tsd_type
;
6564 /* Return the TSD (type-specific data) associated to the given TAG.
6565 TAG is assumed to be the tag of a tagged-type entity.
6567 May return NULL if we are unable to get the TSD. */
6569 static struct value
*
6570 ada_get_tsd_from_tag (struct value
*tag
)
6575 /* First option: The TSD is simply stored as a field of our TAG.
6576 Only older versions of GNAT would use this format, but we have
6577 to test it first, because there are no visible markers for
6578 the current approach except the absence of that field. */
6580 val
= ada_value_struct_elt (tag
, "tsd", 1);
6584 /* Try the second representation for the dispatch table (in which
6585 there is no explicit 'tsd' field in the referent of the tag pointer,
6586 and instead the tsd pointer is stored just before the dispatch
6589 type
= ada_get_tsd_type (current_inferior());
6592 type
= lookup_pointer_type (lookup_pointer_type (type
));
6593 val
= value_cast (type
, tag
);
6596 return value_ind (value_ptradd (val
, -1));
6599 /* Given the TSD of a tag (type-specific data), return a string
6600 containing the name of the associated type.
6602 May return NULL if we are unable to determine the tag name. */
6604 static gdb::unique_xmalloc_ptr
<char>
6605 ada_tag_name_from_tsd (struct value
*tsd
)
6610 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6613 gdb::unique_xmalloc_ptr
<char> buffer
6614 = target_read_string (value_as_address (val
), INT_MAX
);
6615 if (buffer
== nullptr)
6618 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6627 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6630 Return NULL if the TAG is not an Ada tag, or if we were unable to
6631 determine the name of that tag. */
6633 gdb::unique_xmalloc_ptr
<char>
6634 ada_tag_name (struct value
*tag
)
6636 gdb::unique_xmalloc_ptr
<char> name
;
6638 if (!ada_is_tag_type (value_type (tag
)))
6641 /* It is perfectly possible that an exception be raised while trying
6642 to determine the TAG's name, even under normal circumstances:
6643 The associated variable may be uninitialized or corrupted, for
6644 instance. We do not let any exception propagate past this point.
6645 instead we return NULL.
6647 We also do not print the error message either (which often is very
6648 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6649 the caller print a more meaningful message if necessary. */
6652 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6655 name
= ada_tag_name_from_tsd (tsd
);
6657 catch (const gdb_exception_error
&e
)
6664 /* The parent type of TYPE, or NULL if none. */
6667 ada_parent_type (struct type
*type
)
6671 type
= ada_check_typedef (type
);
6673 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6676 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6677 if (ada_is_parent_field (type
, i
))
6679 struct type
*parent_type
= type
->field (i
).type ();
6681 /* If the _parent field is a pointer, then dereference it. */
6682 if (parent_type
->code () == TYPE_CODE_PTR
)
6683 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6684 /* If there is a parallel XVS type, get the actual base type. */
6685 parent_type
= ada_get_base_type (parent_type
);
6687 return ada_check_typedef (parent_type
);
6693 /* True iff field number FIELD_NUM of structure type TYPE contains the
6694 parent-type (inherited) fields of a derived type. Assumes TYPE is
6695 a structure type with at least FIELD_NUM+1 fields. */
6698 ada_is_parent_field (struct type
*type
, int field_num
)
6700 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6702 return (name
!= NULL
6703 && (startswith (name
, "PARENT")
6704 || startswith (name
, "_parent")));
6707 /* True iff field number FIELD_NUM of structure type TYPE is a
6708 transparent wrapper field (which should be silently traversed when doing
6709 field selection and flattened when printing). Assumes TYPE is a
6710 structure type with at least FIELD_NUM+1 fields. Such fields are always
6714 ada_is_wrapper_field (struct type
*type
, int field_num
)
6716 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6718 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6720 /* This happens in functions with "out" or "in out" parameters
6721 which are passed by copy. For such functions, GNAT describes
6722 the function's return type as being a struct where the return
6723 value is in a field called RETVAL, and where the other "out"
6724 or "in out" parameters are fields of that struct. This is not
6729 return (name
!= NULL
6730 && (startswith (name
, "PARENT")
6731 || strcmp (name
, "REP") == 0
6732 || startswith (name
, "_parent")
6733 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6736 /* True iff field number FIELD_NUM of structure or union type TYPE
6737 is a variant wrapper. Assumes TYPE is a structure type with at least
6738 FIELD_NUM+1 fields. */
6741 ada_is_variant_part (struct type
*type
, int field_num
)
6743 /* Only Ada types are eligible. */
6744 if (!ADA_TYPE_P (type
))
6747 struct type
*field_type
= type
->field (field_num
).type ();
6749 return (field_type
->code () == TYPE_CODE_UNION
6750 || (is_dynamic_field (type
, field_num
)
6751 && (TYPE_TARGET_TYPE (field_type
)->code ()
6752 == TYPE_CODE_UNION
)));
6755 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6756 whose discriminants are contained in the record type OUTER_TYPE,
6757 returns the type of the controlling discriminant for the variant.
6758 May return NULL if the type could not be found. */
6761 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6763 const char *name
= ada_variant_discrim_name (var_type
);
6765 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6768 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6769 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6770 represents a 'when others' clause; otherwise 0. */
6773 ada_is_others_clause (struct type
*type
, int field_num
)
6775 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6777 return (name
!= NULL
&& name
[0] == 'O');
6780 /* Assuming that TYPE0 is the type of the variant part of a record,
6781 returns the name of the discriminant controlling the variant.
6782 The value is valid until the next call to ada_variant_discrim_name. */
6785 ada_variant_discrim_name (struct type
*type0
)
6787 static char *result
= NULL
;
6788 static size_t result_len
= 0;
6791 const char *discrim_end
;
6792 const char *discrim_start
;
6794 if (type0
->code () == TYPE_CODE_PTR
)
6795 type
= TYPE_TARGET_TYPE (type0
);
6799 name
= ada_type_name (type
);
6801 if (name
== NULL
|| name
[0] == '\000')
6804 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6807 if (startswith (discrim_end
, "___XVN"))
6810 if (discrim_end
== name
)
6813 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6816 if (discrim_start
== name
+ 1)
6818 if ((discrim_start
> name
+ 3
6819 && startswith (discrim_start
- 3, "___"))
6820 || discrim_start
[-1] == '.')
6824 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6825 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6826 result
[discrim_end
- discrim_start
] = '\0';
6830 /* Scan STR for a subtype-encoded number, beginning at position K.
6831 Put the position of the character just past the number scanned in
6832 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6833 Return 1 if there was a valid number at the given position, and 0
6834 otherwise. A "subtype-encoded" number consists of the absolute value
6835 in decimal, followed by the letter 'm' to indicate a negative number.
6836 Assumes 0m does not occur. */
6839 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6843 if (!isdigit (str
[k
]))
6846 /* Do it the hard way so as not to make any assumption about
6847 the relationship of unsigned long (%lu scan format code) and
6850 while (isdigit (str
[k
]))
6852 RU
= RU
* 10 + (str
[k
] - '0');
6859 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6865 /* NOTE on the above: Technically, C does not say what the results of
6866 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6867 number representable as a LONGEST (although either would probably work
6868 in most implementations). When RU>0, the locution in the then branch
6869 above is always equivalent to the negative of RU. */
6876 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6877 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6878 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6881 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6883 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6897 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6907 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6908 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6910 if (val
>= L
&& val
<= U
)
6922 /* FIXME: Lots of redundancy below. Try to consolidate. */
6924 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6925 ARG_TYPE, extract and return the value of one of its (non-static)
6926 fields. FIELDNO says which field. Differs from value_primitive_field
6927 only in that it can handle packed values of arbitrary type. */
6930 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6931 struct type
*arg_type
)
6935 arg_type
= ada_check_typedef (arg_type
);
6936 type
= arg_type
->field (fieldno
).type ();
6938 /* Handle packed fields. It might be that the field is not packed
6939 relative to its containing structure, but the structure itself is
6940 packed; in this case we must take the bit-field path. */
6941 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6943 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6944 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6946 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6947 offset
+ bit_pos
/ 8,
6948 bit_pos
% 8, bit_size
, type
);
6951 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6954 /* Find field with name NAME in object of type TYPE. If found,
6955 set the following for each argument that is non-null:
6956 - *FIELD_TYPE_P to the field's type;
6957 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6958 an object of that type;
6959 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6960 - *BIT_SIZE_P to its size in bits if the field is packed, and
6962 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6963 fields up to but not including the desired field, or by the total
6964 number of fields if not found. A NULL value of NAME never
6965 matches; the function just counts visible fields in this case.
6967 Notice that we need to handle when a tagged record hierarchy
6968 has some components with the same name, like in this scenario:
6970 type Top_T is tagged record
6976 type Middle_T is new Top.Top_T with record
6977 N : Character := 'a';
6981 type Bottom_T is new Middle.Middle_T with record
6983 C : Character := '5';
6985 A : Character := 'J';
6988 Let's say we now have a variable declared and initialized as follow:
6990 TC : Top_A := new Bottom_T;
6992 And then we use this variable to call this function
6994 procedure Assign (Obj: in out Top_T; TV : Integer);
6998 Assign (Top_T (B), 12);
7000 Now, we're in the debugger, and we're inside that procedure
7001 then and we want to print the value of obj.c:
7003 Usually, the tagged record or one of the parent type owns the
7004 component to print and there's no issue but in this particular
7005 case, what does it mean to ask for Obj.C? Since the actual
7006 type for object is type Bottom_T, it could mean two things: type
7007 component C from the Middle_T view, but also component C from
7008 Bottom_T. So in that "undefined" case, when the component is
7009 not found in the non-resolved type (which includes all the
7010 components of the parent type), then resolve it and see if we
7011 get better luck once expanded.
7013 In the case of homonyms in the derived tagged type, we don't
7014 guaranty anything, and pick the one that's easiest for us
7017 Returns 1 if found, 0 otherwise. */
7020 find_struct_field (const char *name
, struct type
*type
, int offset
,
7021 struct type
**field_type_p
,
7022 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7026 int parent_offset
= -1;
7028 type
= ada_check_typedef (type
);
7030 if (field_type_p
!= NULL
)
7031 *field_type_p
= NULL
;
7032 if (byte_offset_p
!= NULL
)
7034 if (bit_offset_p
!= NULL
)
7036 if (bit_size_p
!= NULL
)
7039 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7041 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7042 int fld_offset
= offset
+ bit_pos
/ 8;
7043 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7045 if (t_field_name
== NULL
)
7048 else if (ada_is_parent_field (type
, i
))
7050 /* This is a field pointing us to the parent type of a tagged
7051 type. As hinted in this function's documentation, we give
7052 preference to fields in the current record first, so what
7053 we do here is just record the index of this field before
7054 we skip it. If it turns out we couldn't find our field
7055 in the current record, then we'll get back to it and search
7056 inside it whether the field might exist in the parent. */
7062 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7064 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7066 if (field_type_p
!= NULL
)
7067 *field_type_p
= type
->field (i
).type ();
7068 if (byte_offset_p
!= NULL
)
7069 *byte_offset_p
= fld_offset
;
7070 if (bit_offset_p
!= NULL
)
7071 *bit_offset_p
= bit_pos
% 8;
7072 if (bit_size_p
!= NULL
)
7073 *bit_size_p
= bit_size
;
7076 else if (ada_is_wrapper_field (type
, i
))
7078 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7079 field_type_p
, byte_offset_p
, bit_offset_p
,
7080 bit_size_p
, index_p
))
7083 else if (ada_is_variant_part (type
, i
))
7085 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7088 struct type
*field_type
7089 = ada_check_typedef (type
->field (i
).type ());
7091 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7093 if (find_struct_field (name
, field_type
->field (j
).type (),
7095 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7096 field_type_p
, byte_offset_p
,
7097 bit_offset_p
, bit_size_p
, index_p
))
7101 else if (index_p
!= NULL
)
7105 /* Field not found so far. If this is a tagged type which
7106 has a parent, try finding that field in the parent now. */
7108 if (parent_offset
!= -1)
7110 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7111 int fld_offset
= offset
+ bit_pos
/ 8;
7113 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7114 fld_offset
, field_type_p
, byte_offset_p
,
7115 bit_offset_p
, bit_size_p
, index_p
))
7122 /* Number of user-visible fields in record type TYPE. */
7125 num_visible_fields (struct type
*type
)
7130 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7134 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7135 and search in it assuming it has (class) type TYPE.
7136 If found, return value, else return NULL.
7138 Searches recursively through wrapper fields (e.g., '_parent').
7140 In the case of homonyms in the tagged types, please refer to the
7141 long explanation in find_struct_field's function documentation. */
7143 static struct value
*
7144 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7148 int parent_offset
= -1;
7150 type
= ada_check_typedef (type
);
7151 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7153 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7155 if (t_field_name
== NULL
)
7158 else if (ada_is_parent_field (type
, i
))
7160 /* This is a field pointing us to the parent type of a tagged
7161 type. As hinted in this function's documentation, we give
7162 preference to fields in the current record first, so what
7163 we do here is just record the index of this field before
7164 we skip it. If it turns out we couldn't find our field
7165 in the current record, then we'll get back to it and search
7166 inside it whether the field might exist in the parent. */
7172 else if (field_name_match (t_field_name
, name
))
7173 return ada_value_primitive_field (arg
, offset
, i
, type
);
7175 else if (ada_is_wrapper_field (type
, i
))
7177 struct value
*v
= /* Do not let indent join lines here. */
7178 ada_search_struct_field (name
, arg
,
7179 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7180 type
->field (i
).type ());
7186 else if (ada_is_variant_part (type
, i
))
7188 /* PNH: Do we ever get here? See find_struct_field. */
7190 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7191 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7193 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7195 struct value
*v
= ada_search_struct_field
/* Force line
7198 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7199 field_type
->field (j
).type ());
7207 /* Field not found so far. If this is a tagged type which
7208 has a parent, try finding that field in the parent now. */
7210 if (parent_offset
!= -1)
7212 struct value
*v
= ada_search_struct_field (
7213 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7214 type
->field (parent_offset
).type ());
7223 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7224 int, struct type
*);
7227 /* Return field #INDEX in ARG, where the index is that returned by
7228 * find_struct_field through its INDEX_P argument. Adjust the address
7229 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7230 * If found, return value, else return NULL. */
7232 static struct value
*
7233 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7236 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7240 /* Auxiliary function for ada_index_struct_field. Like
7241 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7244 static struct value
*
7245 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7249 type
= ada_check_typedef (type
);
7251 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7253 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7255 else if (ada_is_wrapper_field (type
, i
))
7257 struct value
*v
= /* Do not let indent join lines here. */
7258 ada_index_struct_field_1 (index_p
, arg
,
7259 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7260 type
->field (i
).type ());
7266 else if (ada_is_variant_part (type
, i
))
7268 /* PNH: Do we ever get here? See ada_search_struct_field,
7269 find_struct_field. */
7270 error (_("Cannot assign this kind of variant record"));
7272 else if (*index_p
== 0)
7273 return ada_value_primitive_field (arg
, offset
, i
, type
);
7280 /* Return a string representation of type TYPE. */
7283 type_as_string (struct type
*type
)
7285 string_file tmp_stream
;
7287 type_print (type
, "", &tmp_stream
, -1);
7289 return std::move (tmp_stream
.string ());
7292 /* Given a type TYPE, look up the type of the component of type named NAME.
7293 If DISPP is non-null, add its byte displacement from the beginning of a
7294 structure (pointed to by a value) of type TYPE to *DISPP (does not
7295 work for packed fields).
7297 Matches any field whose name has NAME as a prefix, possibly
7300 TYPE can be either a struct or union. If REFOK, TYPE may also
7301 be a (pointer or reference)+ to a struct or union, and the
7302 ultimate target type will be searched.
7304 Looks recursively into variant clauses and parent types.
7306 In the case of homonyms in the tagged types, please refer to the
7307 long explanation in find_struct_field's function documentation.
7309 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7310 TYPE is not a type of the right kind. */
7312 static struct type
*
7313 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7317 int parent_offset
= -1;
7322 if (refok
&& type
!= NULL
)
7325 type
= ada_check_typedef (type
);
7326 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7328 type
= TYPE_TARGET_TYPE (type
);
7332 || (type
->code () != TYPE_CODE_STRUCT
7333 && type
->code () != TYPE_CODE_UNION
))
7338 error (_("Type %s is not a structure or union type"),
7339 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7342 type
= to_static_fixed_type (type
);
7344 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7346 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7349 if (t_field_name
== NULL
)
7352 else if (ada_is_parent_field (type
, i
))
7354 /* This is a field pointing us to the parent type of a tagged
7355 type. As hinted in this function's documentation, we give
7356 preference to fields in the current record first, so what
7357 we do here is just record the index of this field before
7358 we skip it. If it turns out we couldn't find our field
7359 in the current record, then we'll get back to it and search
7360 inside it whether the field might exist in the parent. */
7366 else if (field_name_match (t_field_name
, name
))
7367 return type
->field (i
).type ();
7369 else if (ada_is_wrapper_field (type
, i
))
7371 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7377 else if (ada_is_variant_part (type
, i
))
7380 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7382 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7384 /* FIXME pnh 2008/01/26: We check for a field that is
7385 NOT wrapped in a struct, since the compiler sometimes
7386 generates these for unchecked variant types. Revisit
7387 if the compiler changes this practice. */
7388 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7390 if (v_field_name
!= NULL
7391 && field_name_match (v_field_name
, name
))
7392 t
= field_type
->field (j
).type ();
7394 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7404 /* Field not found so far. If this is a tagged type which
7405 has a parent, try finding that field in the parent now. */
7407 if (parent_offset
!= -1)
7411 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7420 const char *name_str
= name
!= NULL
? name
: _("<null>");
7422 error (_("Type %s has no component named %s"),
7423 type_as_string (type
).c_str (), name_str
);
7429 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7430 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7431 represents an unchecked union (that is, the variant part of a
7432 record that is named in an Unchecked_Union pragma). */
7435 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7437 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7439 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7443 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7444 within OUTER, determine which variant clause (field number in VAR_TYPE,
7445 numbering from 0) is applicable. Returns -1 if none are. */
7448 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7452 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7453 struct value
*discrim
;
7454 LONGEST discrim_val
;
7456 /* Using plain value_from_contents_and_address here causes problems
7457 because we will end up trying to resolve a type that is currently
7458 being constructed. */
7459 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7460 if (discrim
== NULL
)
7462 discrim_val
= value_as_long (discrim
);
7465 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7467 if (ada_is_others_clause (var_type
, i
))
7469 else if (ada_in_variant (discrim_val
, var_type
, i
))
7473 return others_clause
;
7478 /* Dynamic-Sized Records */
7480 /* Strategy: The type ostensibly attached to a value with dynamic size
7481 (i.e., a size that is not statically recorded in the debugging
7482 data) does not accurately reflect the size or layout of the value.
7483 Our strategy is to convert these values to values with accurate,
7484 conventional types that are constructed on the fly. */
7486 /* There is a subtle and tricky problem here. In general, we cannot
7487 determine the size of dynamic records without its data. However,
7488 the 'struct value' data structure, which GDB uses to represent
7489 quantities in the inferior process (the target), requires the size
7490 of the type at the time of its allocation in order to reserve space
7491 for GDB's internal copy of the data. That's why the
7492 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7493 rather than struct value*s.
7495 However, GDB's internal history variables ($1, $2, etc.) are
7496 struct value*s containing internal copies of the data that are not, in
7497 general, the same as the data at their corresponding addresses in
7498 the target. Fortunately, the types we give to these values are all
7499 conventional, fixed-size types (as per the strategy described
7500 above), so that we don't usually have to perform the
7501 'to_fixed_xxx_type' conversions to look at their values.
7502 Unfortunately, there is one exception: if one of the internal
7503 history variables is an array whose elements are unconstrained
7504 records, then we will need to create distinct fixed types for each
7505 element selected. */
7507 /* The upshot of all of this is that many routines take a (type, host
7508 address, target address) triple as arguments to represent a value.
7509 The host address, if non-null, is supposed to contain an internal
7510 copy of the relevant data; otherwise, the program is to consult the
7511 target at the target address. */
7513 /* Assuming that VAL0 represents a pointer value, the result of
7514 dereferencing it. Differs from value_ind in its treatment of
7515 dynamic-sized types. */
7518 ada_value_ind (struct value
*val0
)
7520 struct value
*val
= value_ind (val0
);
7522 if (ada_is_tagged_type (value_type (val
), 0))
7523 val
= ada_tag_value_at_base_address (val
);
7525 return ada_to_fixed_value (val
);
7528 /* The value resulting from dereferencing any "reference to"
7529 qualifiers on VAL0. */
7531 static struct value
*
7532 ada_coerce_ref (struct value
*val0
)
7534 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7536 struct value
*val
= val0
;
7538 val
= coerce_ref (val
);
7540 if (ada_is_tagged_type (value_type (val
), 0))
7541 val
= ada_tag_value_at_base_address (val
);
7543 return ada_to_fixed_value (val
);
7549 /* Return the bit alignment required for field #F of template type TYPE. */
7552 field_alignment (struct type
*type
, int f
)
7554 const char *name
= TYPE_FIELD_NAME (type
, f
);
7558 /* The field name should never be null, unless the debugging information
7559 is somehow malformed. In this case, we assume the field does not
7560 require any alignment. */
7564 len
= strlen (name
);
7566 if (!isdigit (name
[len
- 1]))
7569 if (isdigit (name
[len
- 2]))
7570 align_offset
= len
- 2;
7572 align_offset
= len
- 1;
7574 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7575 return TARGET_CHAR_BIT
;
7577 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7580 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7582 static struct symbol
*
7583 ada_find_any_type_symbol (const char *name
)
7587 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7588 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7591 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7595 /* Find a type named NAME. Ignores ambiguity. This routine will look
7596 solely for types defined by debug info, it will not search the GDB
7599 static struct type
*
7600 ada_find_any_type (const char *name
)
7602 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7605 return SYMBOL_TYPE (sym
);
7610 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7611 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7612 symbol, in which case it is returned. Otherwise, this looks for
7613 symbols whose name is that of NAME_SYM suffixed with "___XR".
7614 Return symbol if found, and NULL otherwise. */
7617 ada_is_renaming_symbol (struct symbol
*name_sym
)
7619 const char *name
= name_sym
->linkage_name ();
7620 return strstr (name
, "___XR") != NULL
;
7623 /* Because of GNAT encoding conventions, several GDB symbols may match a
7624 given type name. If the type denoted by TYPE0 is to be preferred to
7625 that of TYPE1 for purposes of type printing, return non-zero;
7626 otherwise return 0. */
7629 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7633 else if (type0
== NULL
)
7635 else if (type1
->code () == TYPE_CODE_VOID
)
7637 else if (type0
->code () == TYPE_CODE_VOID
)
7639 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7641 else if (ada_is_constrained_packed_array_type (type0
))
7643 else if (ada_is_array_descriptor_type (type0
)
7644 && !ada_is_array_descriptor_type (type1
))
7648 const char *type0_name
= type0
->name ();
7649 const char *type1_name
= type1
->name ();
7651 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7652 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7658 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7662 ada_type_name (struct type
*type
)
7666 return type
->name ();
7669 /* Search the list of "descriptive" types associated to TYPE for a type
7670 whose name is NAME. */
7672 static struct type
*
7673 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7675 struct type
*result
, *tmp
;
7677 if (ada_ignore_descriptive_types_p
)
7680 /* If there no descriptive-type info, then there is no parallel type
7682 if (!HAVE_GNAT_AUX_INFO (type
))
7685 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7686 while (result
!= NULL
)
7688 const char *result_name
= ada_type_name (result
);
7690 if (result_name
== NULL
)
7692 warning (_("unexpected null name on descriptive type"));
7696 /* If the names match, stop. */
7697 if (strcmp (result_name
, name
) == 0)
7700 /* Otherwise, look at the next item on the list, if any. */
7701 if (HAVE_GNAT_AUX_INFO (result
))
7702 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7706 /* If not found either, try after having resolved the typedef. */
7711 result
= check_typedef (result
);
7712 if (HAVE_GNAT_AUX_INFO (result
))
7713 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7719 /* If we didn't find a match, see whether this is a packed array. With
7720 older compilers, the descriptive type information is either absent or
7721 irrelevant when it comes to packed arrays so the above lookup fails.
7722 Fall back to using a parallel lookup by name in this case. */
7723 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7724 return ada_find_any_type (name
);
7729 /* Find a parallel type to TYPE with the specified NAME, using the
7730 descriptive type taken from the debugging information, if available,
7731 and otherwise using the (slower) name-based method. */
7733 static struct type
*
7734 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7736 struct type
*result
= NULL
;
7738 if (HAVE_GNAT_AUX_INFO (type
))
7739 result
= find_parallel_type_by_descriptive_type (type
, name
);
7741 result
= ada_find_any_type (name
);
7746 /* Same as above, but specify the name of the parallel type by appending
7747 SUFFIX to the name of TYPE. */
7750 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7753 const char *type_name
= ada_type_name (type
);
7756 if (type_name
== NULL
)
7759 len
= strlen (type_name
);
7761 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7763 strcpy (name
, type_name
);
7764 strcpy (name
+ len
, suffix
);
7766 return ada_find_parallel_type_with_name (type
, name
);
7769 /* If TYPE is a variable-size record type, return the corresponding template
7770 type describing its fields. Otherwise, return NULL. */
7772 static struct type
*
7773 dynamic_template_type (struct type
*type
)
7775 type
= ada_check_typedef (type
);
7777 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7778 || ada_type_name (type
) == NULL
)
7782 int len
= strlen (ada_type_name (type
));
7784 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7787 return ada_find_parallel_type (type
, "___XVE");
7791 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7792 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7795 is_dynamic_field (struct type
*templ_type
, int field_num
)
7797 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7800 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7801 && strstr (name
, "___XVL") != NULL
;
7804 /* The index of the variant field of TYPE, or -1 if TYPE does not
7805 represent a variant record type. */
7808 variant_field_index (struct type
*type
)
7812 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7815 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7817 if (ada_is_variant_part (type
, f
))
7823 /* A record type with no fields. */
7825 static struct type
*
7826 empty_record (struct type
*templ
)
7828 struct type
*type
= alloc_type_copy (templ
);
7830 type
->set_code (TYPE_CODE_STRUCT
);
7831 INIT_NONE_SPECIFIC (type
);
7832 type
->set_name ("<empty>");
7833 TYPE_LENGTH (type
) = 0;
7837 /* An ordinary record type (with fixed-length fields) that describes
7838 the value of type TYPE at VALADDR or ADDRESS (see comments at
7839 the beginning of this section) VAL according to GNAT conventions.
7840 DVAL0 should describe the (portion of a) record that contains any
7841 necessary discriminants. It should be NULL if value_type (VAL) is
7842 an outer-level type (i.e., as opposed to a branch of a variant.) A
7843 variant field (unless unchecked) is replaced by a particular branch
7846 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7847 length are not statically known are discarded. As a consequence,
7848 VALADDR, ADDRESS and DVAL0 are ignored.
7850 NOTE: Limitations: For now, we assume that dynamic fields and
7851 variants occupy whole numbers of bytes. However, they need not be
7855 ada_template_to_fixed_record_type_1 (struct type
*type
,
7856 const gdb_byte
*valaddr
,
7857 CORE_ADDR address
, struct value
*dval0
,
7858 int keep_dynamic_fields
)
7860 struct value
*mark
= value_mark ();
7863 int nfields
, bit_len
;
7869 /* Compute the number of fields in this record type that are going
7870 to be processed: unless keep_dynamic_fields, this includes only
7871 fields whose position and length are static will be processed. */
7872 if (keep_dynamic_fields
)
7873 nfields
= type
->num_fields ();
7877 while (nfields
< type
->num_fields ()
7878 && !ada_is_variant_part (type
, nfields
)
7879 && !is_dynamic_field (type
, nfields
))
7883 rtype
= alloc_type_copy (type
);
7884 rtype
->set_code (TYPE_CODE_STRUCT
);
7885 INIT_NONE_SPECIFIC (rtype
);
7886 rtype
->set_num_fields (nfields
);
7888 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7889 rtype
->set_name (ada_type_name (type
));
7890 rtype
->set_is_fixed_instance (true);
7896 for (f
= 0; f
< nfields
; f
+= 1)
7898 off
= align_up (off
, field_alignment (type
, f
))
7899 + TYPE_FIELD_BITPOS (type
, f
);
7900 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7901 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7903 if (ada_is_variant_part (type
, f
))
7908 else if (is_dynamic_field (type
, f
))
7910 const gdb_byte
*field_valaddr
= valaddr
;
7911 CORE_ADDR field_address
= address
;
7912 struct type
*field_type
=
7913 TYPE_TARGET_TYPE (type
->field (f
).type ());
7917 /* rtype's length is computed based on the run-time
7918 value of discriminants. If the discriminants are not
7919 initialized, the type size may be completely bogus and
7920 GDB may fail to allocate a value for it. So check the
7921 size first before creating the value. */
7922 ada_ensure_varsize_limit (rtype
);
7923 /* Using plain value_from_contents_and_address here
7924 causes problems because we will end up trying to
7925 resolve a type that is currently being
7927 dval
= value_from_contents_and_address_unresolved (rtype
,
7930 rtype
= value_type (dval
);
7935 /* If the type referenced by this field is an aligner type, we need
7936 to unwrap that aligner type, because its size might not be set.
7937 Keeping the aligner type would cause us to compute the wrong
7938 size for this field, impacting the offset of the all the fields
7939 that follow this one. */
7940 if (ada_is_aligner_type (field_type
))
7942 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7944 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7945 field_address
= cond_offset_target (field_address
, field_offset
);
7946 field_type
= ada_aligned_type (field_type
);
7949 field_valaddr
= cond_offset_host (field_valaddr
,
7950 off
/ TARGET_CHAR_BIT
);
7951 field_address
= cond_offset_target (field_address
,
7952 off
/ TARGET_CHAR_BIT
);
7954 /* Get the fixed type of the field. Note that, in this case,
7955 we do not want to get the real type out of the tag: if
7956 the current field is the parent part of a tagged record,
7957 we will get the tag of the object. Clearly wrong: the real
7958 type of the parent is not the real type of the child. We
7959 would end up in an infinite loop. */
7960 field_type
= ada_get_base_type (field_type
);
7961 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7962 field_address
, dval
, 0);
7963 /* If the field size is already larger than the maximum
7964 object size, then the record itself will necessarily
7965 be larger than the maximum object size. We need to make
7966 this check now, because the size might be so ridiculously
7967 large (due to an uninitialized variable in the inferior)
7968 that it would cause an overflow when adding it to the
7970 ada_ensure_varsize_limit (field_type
);
7972 rtype
->field (f
).set_type (field_type
);
7973 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7974 /* The multiplication can potentially overflow. But because
7975 the field length has been size-checked just above, and
7976 assuming that the maximum size is a reasonable value,
7977 an overflow should not happen in practice. So rather than
7978 adding overflow recovery code to this already complex code,
7979 we just assume that it's not going to happen. */
7981 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7985 /* Note: If this field's type is a typedef, it is important
7986 to preserve the typedef layer.
7988 Otherwise, we might be transforming a typedef to a fat
7989 pointer (encoding a pointer to an unconstrained array),
7990 into a basic fat pointer (encoding an unconstrained
7991 array). As both types are implemented using the same
7992 structure, the typedef is the only clue which allows us
7993 to distinguish between the two options. Stripping it
7994 would prevent us from printing this field appropriately. */
7995 rtype
->field (f
).set_type (type
->field (f
).type ());
7996 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7997 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7999 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8002 struct type
*field_type
= type
->field (f
).type ();
8004 /* We need to be careful of typedefs when computing
8005 the length of our field. If this is a typedef,
8006 get the length of the target type, not the length
8008 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
8009 field_type
= ada_typedef_target_type (field_type
);
8012 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8015 if (off
+ fld_bit_len
> bit_len
)
8016 bit_len
= off
+ fld_bit_len
;
8018 TYPE_LENGTH (rtype
) =
8019 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8022 /* We handle the variant part, if any, at the end because of certain
8023 odd cases in which it is re-ordered so as NOT to be the last field of
8024 the record. This can happen in the presence of representation
8026 if (variant_field
>= 0)
8028 struct type
*branch_type
;
8030 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8034 /* Using plain value_from_contents_and_address here causes
8035 problems because we will end up trying to resolve a type
8036 that is currently being constructed. */
8037 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8039 rtype
= value_type (dval
);
8045 to_fixed_variant_branch_type
8046 (type
->field (variant_field
).type (),
8047 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8048 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8049 if (branch_type
== NULL
)
8051 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8052 rtype
->field (f
- 1) = rtype
->field (f
);
8053 rtype
->set_num_fields (rtype
->num_fields () - 1);
8057 rtype
->field (variant_field
).set_type (branch_type
);
8058 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8060 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8062 if (off
+ fld_bit_len
> bit_len
)
8063 bit_len
= off
+ fld_bit_len
;
8064 TYPE_LENGTH (rtype
) =
8065 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8069 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8070 should contain the alignment of that record, which should be a strictly
8071 positive value. If null or negative, then something is wrong, most
8072 probably in the debug info. In that case, we don't round up the size
8073 of the resulting type. If this record is not part of another structure,
8074 the current RTYPE length might be good enough for our purposes. */
8075 if (TYPE_LENGTH (type
) <= 0)
8078 warning (_("Invalid type size for `%s' detected: %s."),
8079 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8081 warning (_("Invalid type size for <unnamed> detected: %s."),
8082 pulongest (TYPE_LENGTH (type
)));
8086 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8087 TYPE_LENGTH (type
));
8090 value_free_to_mark (mark
);
8091 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8092 error (_("record type with dynamic size is larger than varsize-limit"));
8096 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8099 static struct type
*
8100 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8101 CORE_ADDR address
, struct value
*dval0
)
8103 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8107 /* An ordinary record type in which ___XVL-convention fields and
8108 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8109 static approximations, containing all possible fields. Uses
8110 no runtime values. Useless for use in values, but that's OK,
8111 since the results are used only for type determinations. Works on both
8112 structs and unions. Representation note: to save space, we memorize
8113 the result of this function in the TYPE_TARGET_TYPE of the
8116 static struct type
*
8117 template_to_static_fixed_type (struct type
*type0
)
8123 /* No need no do anything if the input type is already fixed. */
8124 if (type0
->is_fixed_instance ())
8127 /* Likewise if we already have computed the static approximation. */
8128 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8129 return TYPE_TARGET_TYPE (type0
);
8131 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8133 nfields
= type0
->num_fields ();
8135 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8136 recompute all over next time. */
8137 TYPE_TARGET_TYPE (type0
) = type
;
8139 for (f
= 0; f
< nfields
; f
+= 1)
8141 struct type
*field_type
= type0
->field (f
).type ();
8142 struct type
*new_type
;
8144 if (is_dynamic_field (type0
, f
))
8146 field_type
= ada_check_typedef (field_type
);
8147 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8150 new_type
= static_unwrap_type (field_type
);
8152 if (new_type
!= field_type
)
8154 /* Clone TYPE0 only the first time we get a new field type. */
8157 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8158 type
->set_code (type0
->code ());
8159 INIT_NONE_SPECIFIC (type
);
8160 type
->set_num_fields (nfields
);
8164 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8165 memcpy (fields
, type0
->fields (),
8166 sizeof (struct field
) * nfields
);
8167 type
->set_fields (fields
);
8169 type
->set_name (ada_type_name (type0
));
8170 type
->set_is_fixed_instance (true);
8171 TYPE_LENGTH (type
) = 0;
8173 type
->field (f
).set_type (new_type
);
8174 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8181 /* Given an object of type TYPE whose contents are at VALADDR and
8182 whose address in memory is ADDRESS, returns a revision of TYPE,
8183 which should be a non-dynamic-sized record, in which the variant
8184 part, if any, is replaced with the appropriate branch. Looks
8185 for discriminant values in DVAL0, which can be NULL if the record
8186 contains the necessary discriminant values. */
8188 static struct type
*
8189 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8190 CORE_ADDR address
, struct value
*dval0
)
8192 struct value
*mark
= value_mark ();
8195 struct type
*branch_type
;
8196 int nfields
= type
->num_fields ();
8197 int variant_field
= variant_field_index (type
);
8199 if (variant_field
== -1)
8204 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8205 type
= value_type (dval
);
8210 rtype
= alloc_type_copy (type
);
8211 rtype
->set_code (TYPE_CODE_STRUCT
);
8212 INIT_NONE_SPECIFIC (rtype
);
8213 rtype
->set_num_fields (nfields
);
8216 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8217 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8218 rtype
->set_fields (fields
);
8220 rtype
->set_name (ada_type_name (type
));
8221 rtype
->set_is_fixed_instance (true);
8222 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8224 branch_type
= to_fixed_variant_branch_type
8225 (type
->field (variant_field
).type (),
8226 cond_offset_host (valaddr
,
8227 TYPE_FIELD_BITPOS (type
, variant_field
)
8229 cond_offset_target (address
,
8230 TYPE_FIELD_BITPOS (type
, variant_field
)
8231 / TARGET_CHAR_BIT
), dval
);
8232 if (branch_type
== NULL
)
8236 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8237 rtype
->field (f
- 1) = rtype
->field (f
);
8238 rtype
->set_num_fields (rtype
->num_fields () - 1);
8242 rtype
->field (variant_field
).set_type (branch_type
);
8243 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8244 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8245 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8247 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8249 value_free_to_mark (mark
);
8253 /* An ordinary record type (with fixed-length fields) that describes
8254 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8255 beginning of this section]. Any necessary discriminants' values
8256 should be in DVAL, a record value; it may be NULL if the object
8257 at ADDR itself contains any necessary discriminant values.
8258 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8259 values from the record are needed. Except in the case that DVAL,
8260 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8261 unchecked) is replaced by a particular branch of the variant.
8263 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8264 is questionable and may be removed. It can arise during the
8265 processing of an unconstrained-array-of-record type where all the
8266 variant branches have exactly the same size. This is because in
8267 such cases, the compiler does not bother to use the XVS convention
8268 when encoding the record. I am currently dubious of this
8269 shortcut and suspect the compiler should be altered. FIXME. */
8271 static struct type
*
8272 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8273 CORE_ADDR address
, struct value
*dval
)
8275 struct type
*templ_type
;
8277 if (type0
->is_fixed_instance ())
8280 templ_type
= dynamic_template_type (type0
);
8282 if (templ_type
!= NULL
)
8283 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8284 else if (variant_field_index (type0
) >= 0)
8286 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8288 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8293 type0
->set_is_fixed_instance (true);
8299 /* An ordinary record type (with fixed-length fields) that describes
8300 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8301 union type. Any necessary discriminants' values should be in DVAL,
8302 a record value. That is, this routine selects the appropriate
8303 branch of the union at ADDR according to the discriminant value
8304 indicated in the union's type name. Returns VAR_TYPE0 itself if
8305 it represents a variant subject to a pragma Unchecked_Union. */
8307 static struct type
*
8308 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8309 CORE_ADDR address
, struct value
*dval
)
8312 struct type
*templ_type
;
8313 struct type
*var_type
;
8315 if (var_type0
->code () == TYPE_CODE_PTR
)
8316 var_type
= TYPE_TARGET_TYPE (var_type0
);
8318 var_type
= var_type0
;
8320 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8322 if (templ_type
!= NULL
)
8323 var_type
= templ_type
;
8325 if (is_unchecked_variant (var_type
, value_type (dval
)))
8327 which
= ada_which_variant_applies (var_type
, dval
);
8330 return empty_record (var_type
);
8331 else if (is_dynamic_field (var_type
, which
))
8332 return to_fixed_record_type
8333 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8334 valaddr
, address
, dval
);
8335 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8337 to_fixed_record_type
8338 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8340 return var_type
->field (which
).type ();
8343 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8344 ENCODING_TYPE, a type following the GNAT conventions for discrete
8345 type encodings, only carries redundant information. */
8348 ada_is_redundant_range_encoding (struct type
*range_type
,
8349 struct type
*encoding_type
)
8351 const char *bounds_str
;
8355 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8357 if (get_base_type (range_type
)->code ()
8358 != get_base_type (encoding_type
)->code ())
8360 /* The compiler probably used a simple base type to describe
8361 the range type instead of the range's actual base type,
8362 expecting us to get the real base type from the encoding
8363 anyway. In this situation, the encoding cannot be ignored
8368 if (is_dynamic_type (range_type
))
8371 if (encoding_type
->name () == NULL
)
8374 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8375 if (bounds_str
== NULL
)
8378 n
= 8; /* Skip "___XDLU_". */
8379 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8381 if (range_type
->bounds ()->low
.const_val () != lo
)
8384 n
+= 2; /* Skip the "__" separator between the two bounds. */
8385 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8387 if (range_type
->bounds ()->high
.const_val () != hi
)
8393 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8394 a type following the GNAT encoding for describing array type
8395 indices, only carries redundant information. */
8398 ada_is_redundant_index_type_desc (struct type
*array_type
,
8399 struct type
*desc_type
)
8401 struct type
*this_layer
= check_typedef (array_type
);
8404 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8406 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8407 desc_type
->field (i
).type ()))
8409 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8415 /* Assuming that TYPE0 is an array type describing the type of a value
8416 at ADDR, and that DVAL describes a record containing any
8417 discriminants used in TYPE0, returns a type for the value that
8418 contains no dynamic components (that is, no components whose sizes
8419 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8420 true, gives an error message if the resulting type's size is over
8423 static struct type
*
8424 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8427 struct type
*index_type_desc
;
8428 struct type
*result
;
8429 int constrained_packed_array_p
;
8430 static const char *xa_suffix
= "___XA";
8432 type0
= ada_check_typedef (type0
);
8433 if (type0
->is_fixed_instance ())
8436 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8437 if (constrained_packed_array_p
)
8439 type0
= decode_constrained_packed_array_type (type0
);
8440 if (type0
== nullptr)
8441 error (_("could not decode constrained packed array type"));
8444 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8446 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8447 encoding suffixed with 'P' may still be generated. If so,
8448 it should be used to find the XA type. */
8450 if (index_type_desc
== NULL
)
8452 const char *type_name
= ada_type_name (type0
);
8454 if (type_name
!= NULL
)
8456 const int len
= strlen (type_name
);
8457 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8459 if (type_name
[len
- 1] == 'P')
8461 strcpy (name
, type_name
);
8462 strcpy (name
+ len
- 1, xa_suffix
);
8463 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8468 ada_fixup_array_indexes_type (index_type_desc
);
8469 if (index_type_desc
!= NULL
8470 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8472 /* Ignore this ___XA parallel type, as it does not bring any
8473 useful information. This allows us to avoid creating fixed
8474 versions of the array's index types, which would be identical
8475 to the original ones. This, in turn, can also help avoid
8476 the creation of fixed versions of the array itself. */
8477 index_type_desc
= NULL
;
8480 if (index_type_desc
== NULL
)
8482 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8484 /* NOTE: elt_type---the fixed version of elt_type0---should never
8485 depend on the contents of the array in properly constructed
8487 /* Create a fixed version of the array element type.
8488 We're not providing the address of an element here,
8489 and thus the actual object value cannot be inspected to do
8490 the conversion. This should not be a problem, since arrays of
8491 unconstrained objects are not allowed. In particular, all
8492 the elements of an array of a tagged type should all be of
8493 the same type specified in the debugging info. No need to
8494 consult the object tag. */
8495 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8497 /* Make sure we always create a new array type when dealing with
8498 packed array types, since we're going to fix-up the array
8499 type length and element bitsize a little further down. */
8500 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8503 result
= create_array_type (alloc_type_copy (type0
),
8504 elt_type
, type0
->index_type ());
8509 struct type
*elt_type0
;
8512 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8513 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8515 /* NOTE: result---the fixed version of elt_type0---should never
8516 depend on the contents of the array in properly constructed
8518 /* Create a fixed version of the array element type.
8519 We're not providing the address of an element here,
8520 and thus the actual object value cannot be inspected to do
8521 the conversion. This should not be a problem, since arrays of
8522 unconstrained objects are not allowed. In particular, all
8523 the elements of an array of a tagged type should all be of
8524 the same type specified in the debugging info. No need to
8525 consult the object tag. */
8527 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8530 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8532 struct type
*range_type
=
8533 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8535 result
= create_array_type (alloc_type_copy (elt_type0
),
8536 result
, range_type
);
8537 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8539 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8540 error (_("array type with dynamic size is larger than varsize-limit"));
8543 /* We want to preserve the type name. This can be useful when
8544 trying to get the type name of a value that has already been
8545 printed (for instance, if the user did "print VAR; whatis $". */
8546 result
->set_name (type0
->name ());
8548 if (constrained_packed_array_p
)
8550 /* So far, the resulting type has been created as if the original
8551 type was a regular (non-packed) array type. As a result, the
8552 bitsize of the array elements needs to be set again, and the array
8553 length needs to be recomputed based on that bitsize. */
8554 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8555 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8557 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8558 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8559 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8560 TYPE_LENGTH (result
)++;
8563 result
->set_is_fixed_instance (true);
8568 /* A standard type (containing no dynamically sized components)
8569 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8570 DVAL describes a record containing any discriminants used in TYPE0,
8571 and may be NULL if there are none, or if the object of type TYPE at
8572 ADDRESS or in VALADDR contains these discriminants.
8574 If CHECK_TAG is not null, in the case of tagged types, this function
8575 attempts to locate the object's tag and use it to compute the actual
8576 type. However, when ADDRESS is null, we cannot use it to determine the
8577 location of the tag, and therefore compute the tagged type's actual type.
8578 So we return the tagged type without consulting the tag. */
8580 static struct type
*
8581 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8582 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8584 type
= ada_check_typedef (type
);
8586 /* Only un-fixed types need to be handled here. */
8587 if (!HAVE_GNAT_AUX_INFO (type
))
8590 switch (type
->code ())
8594 case TYPE_CODE_STRUCT
:
8596 struct type
*static_type
= to_static_fixed_type (type
);
8597 struct type
*fixed_record_type
=
8598 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8600 /* If STATIC_TYPE is a tagged type and we know the object's address,
8601 then we can determine its tag, and compute the object's actual
8602 type from there. Note that we have to use the fixed record
8603 type (the parent part of the record may have dynamic fields
8604 and the way the location of _tag is expressed may depend on
8607 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8610 value_tag_from_contents_and_address
8614 struct type
*real_type
= type_from_tag (tag
);
8616 value_from_contents_and_address (fixed_record_type
,
8619 fixed_record_type
= value_type (obj
);
8620 if (real_type
!= NULL
)
8621 return to_fixed_record_type
8623 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8626 /* Check to see if there is a parallel ___XVZ variable.
8627 If there is, then it provides the actual size of our type. */
8628 else if (ada_type_name (fixed_record_type
) != NULL
)
8630 const char *name
= ada_type_name (fixed_record_type
);
8632 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8633 bool xvz_found
= false;
8636 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8639 xvz_found
= get_int_var_value (xvz_name
, size
);
8641 catch (const gdb_exception_error
&except
)
8643 /* We found the variable, but somehow failed to read
8644 its value. Rethrow the same error, but with a little
8645 bit more information, to help the user understand
8646 what went wrong (Eg: the variable might have been
8648 throw_error (except
.error
,
8649 _("unable to read value of %s (%s)"),
8650 xvz_name
, except
.what ());
8653 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8655 fixed_record_type
= copy_type (fixed_record_type
);
8656 TYPE_LENGTH (fixed_record_type
) = size
;
8658 /* The FIXED_RECORD_TYPE may have be a stub. We have
8659 observed this when the debugging info is STABS, and
8660 apparently it is something that is hard to fix.
8662 In practice, we don't need the actual type definition
8663 at all, because the presence of the XVZ variable allows us
8664 to assume that there must be a XVS type as well, which we
8665 should be able to use later, when we need the actual type
8668 In the meantime, pretend that the "fixed" type we are
8669 returning is NOT a stub, because this can cause trouble
8670 when using this type to create new types targeting it.
8671 Indeed, the associated creation routines often check
8672 whether the target type is a stub and will try to replace
8673 it, thus using a type with the wrong size. This, in turn,
8674 might cause the new type to have the wrong size too.
8675 Consider the case of an array, for instance, where the size
8676 of the array is computed from the number of elements in
8677 our array multiplied by the size of its element. */
8678 fixed_record_type
->set_is_stub (false);
8681 return fixed_record_type
;
8683 case TYPE_CODE_ARRAY
:
8684 return to_fixed_array_type (type
, dval
, 1);
8685 case TYPE_CODE_UNION
:
8689 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8693 /* The same as ada_to_fixed_type_1, except that it preserves the type
8694 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8696 The typedef layer needs be preserved in order to differentiate between
8697 arrays and array pointers when both types are implemented using the same
8698 fat pointer. In the array pointer case, the pointer is encoded as
8699 a typedef of the pointer type. For instance, considering:
8701 type String_Access is access String;
8702 S1 : String_Access := null;
8704 To the debugger, S1 is defined as a typedef of type String. But
8705 to the user, it is a pointer. So if the user tries to print S1,
8706 we should not dereference the array, but print the array address
8709 If we didn't preserve the typedef layer, we would lose the fact that
8710 the type is to be presented as a pointer (needs de-reference before
8711 being printed). And we would also use the source-level type name. */
8714 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8715 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8718 struct type
*fixed_type
=
8719 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8721 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8722 then preserve the typedef layer.
8724 Implementation note: We can only check the main-type portion of
8725 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8726 from TYPE now returns a type that has the same instance flags
8727 as TYPE. For instance, if TYPE is a "typedef const", and its
8728 target type is a "struct", then the typedef elimination will return
8729 a "const" version of the target type. See check_typedef for more
8730 details about how the typedef layer elimination is done.
8732 brobecker/2010-11-19: It seems to me that the only case where it is
8733 useful to preserve the typedef layer is when dealing with fat pointers.
8734 Perhaps, we could add a check for that and preserve the typedef layer
8735 only in that situation. But this seems unnecessary so far, probably
8736 because we call check_typedef/ada_check_typedef pretty much everywhere.
8738 if (type
->code () == TYPE_CODE_TYPEDEF
8739 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8740 == TYPE_MAIN_TYPE (fixed_type
)))
8746 /* A standard (static-sized) type corresponding as well as possible to
8747 TYPE0, but based on no runtime data. */
8749 static struct type
*
8750 to_static_fixed_type (struct type
*type0
)
8757 if (type0
->is_fixed_instance ())
8760 type0
= ada_check_typedef (type0
);
8762 switch (type0
->code ())
8766 case TYPE_CODE_STRUCT
:
8767 type
= dynamic_template_type (type0
);
8769 return template_to_static_fixed_type (type
);
8771 return template_to_static_fixed_type (type0
);
8772 case TYPE_CODE_UNION
:
8773 type
= ada_find_parallel_type (type0
, "___XVU");
8775 return template_to_static_fixed_type (type
);
8777 return template_to_static_fixed_type (type0
);
8781 /* A static approximation of TYPE with all type wrappers removed. */
8783 static struct type
*
8784 static_unwrap_type (struct type
*type
)
8786 if (ada_is_aligner_type (type
))
8788 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8789 if (ada_type_name (type1
) == NULL
)
8790 type1
->set_name (ada_type_name (type
));
8792 return static_unwrap_type (type1
);
8796 struct type
*raw_real_type
= ada_get_base_type (type
);
8798 if (raw_real_type
== type
)
8801 return to_static_fixed_type (raw_real_type
);
8805 /* In some cases, incomplete and private types require
8806 cross-references that are not resolved as records (for example,
8808 type FooP is access Foo;
8810 type Foo is array ...;
8811 ). In these cases, since there is no mechanism for producing
8812 cross-references to such types, we instead substitute for FooP a
8813 stub enumeration type that is nowhere resolved, and whose tag is
8814 the name of the actual type. Call these types "non-record stubs". */
8816 /* A type equivalent to TYPE that is not a non-record stub, if one
8817 exists, otherwise TYPE. */
8820 ada_check_typedef (struct type
*type
)
8825 /* If our type is an access to an unconstrained array, which is encoded
8826 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8827 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8828 what allows us to distinguish between fat pointers that represent
8829 array types, and fat pointers that represent array access types
8830 (in both cases, the compiler implements them as fat pointers). */
8831 if (ada_is_access_to_unconstrained_array (type
))
8834 type
= check_typedef (type
);
8835 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8836 || !type
->is_stub ()
8837 || type
->name () == NULL
)
8841 const char *name
= type
->name ();
8842 struct type
*type1
= ada_find_any_type (name
);
8847 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8848 stubs pointing to arrays, as we don't create symbols for array
8849 types, only for the typedef-to-array types). If that's the case,
8850 strip the typedef layer. */
8851 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8852 type1
= ada_check_typedef (type1
);
8858 /* A value representing the data at VALADDR/ADDRESS as described by
8859 type TYPE0, but with a standard (static-sized) type that correctly
8860 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8861 type, then return VAL0 [this feature is simply to avoid redundant
8862 creation of struct values]. */
8864 static struct value
*
8865 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8868 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8870 if (type
== type0
&& val0
!= NULL
)
8873 if (VALUE_LVAL (val0
) != lval_memory
)
8875 /* Our value does not live in memory; it could be a convenience
8876 variable, for instance. Create a not_lval value using val0's
8878 return value_from_contents (type
, value_contents (val0
));
8881 return value_from_contents_and_address (type
, 0, address
);
8884 /* A value representing VAL, but with a standard (static-sized) type
8885 that correctly describes it. Does not necessarily create a new
8889 ada_to_fixed_value (struct value
*val
)
8891 val
= unwrap_value (val
);
8892 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8899 /* Table mapping attribute numbers to names.
8900 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8902 static const char * const attribute_names
[] = {
8920 ada_attribute_name (enum exp_opcode n
)
8922 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8923 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8925 return attribute_names
[0];
8928 /* Evaluate the 'POS attribute applied to ARG. */
8931 pos_atr (struct value
*arg
)
8933 struct value
*val
= coerce_ref (arg
);
8934 struct type
*type
= value_type (val
);
8936 if (!discrete_type_p (type
))
8937 error (_("'POS only defined on discrete types"));
8939 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8940 if (!result
.has_value ())
8941 error (_("enumeration value is invalid: can't find 'POS"));
8946 static struct value
*
8947 value_pos_atr (struct type
*type
, struct value
*arg
)
8949 return value_from_longest (type
, pos_atr (arg
));
8952 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8954 static struct value
*
8955 val_atr (struct type
*type
, LONGEST val
)
8957 gdb_assert (discrete_type_p (type
));
8958 if (type
->code () == TYPE_CODE_RANGE
)
8959 type
= TYPE_TARGET_TYPE (type
);
8960 if (type
->code () == TYPE_CODE_ENUM
)
8962 if (val
< 0 || val
>= type
->num_fields ())
8963 error (_("argument to 'VAL out of range"));
8964 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8966 return value_from_longest (type
, val
);
8969 static struct value
*
8970 value_val_atr (struct type
*type
, struct value
*arg
)
8972 if (!discrete_type_p (type
))
8973 error (_("'VAL only defined on discrete types"));
8974 if (!integer_type_p (value_type (arg
)))
8975 error (_("'VAL requires integral argument"));
8977 return val_atr (type
, value_as_long (arg
));
8983 /* True if TYPE appears to be an Ada character type.
8984 [At the moment, this is true only for Character and Wide_Character;
8985 It is a heuristic test that could stand improvement]. */
8988 ada_is_character_type (struct type
*type
)
8992 /* If the type code says it's a character, then assume it really is,
8993 and don't check any further. */
8994 if (type
->code () == TYPE_CODE_CHAR
)
8997 /* Otherwise, assume it's a character type iff it is a discrete type
8998 with a known character type name. */
8999 name
= ada_type_name (type
);
9000 return (name
!= NULL
9001 && (type
->code () == TYPE_CODE_INT
9002 || type
->code () == TYPE_CODE_RANGE
)
9003 && (strcmp (name
, "character") == 0
9004 || strcmp (name
, "wide_character") == 0
9005 || strcmp (name
, "wide_wide_character") == 0
9006 || strcmp (name
, "unsigned char") == 0));
9009 /* True if TYPE appears to be an Ada string type. */
9012 ada_is_string_type (struct type
*type
)
9014 type
= ada_check_typedef (type
);
9016 && type
->code () != TYPE_CODE_PTR
9017 && (ada_is_simple_array_type (type
)
9018 || ada_is_array_descriptor_type (type
))
9019 && ada_array_arity (type
) == 1)
9021 struct type
*elttype
= ada_array_element_type (type
, 1);
9023 return ada_is_character_type (elttype
);
9029 /* The compiler sometimes provides a parallel XVS type for a given
9030 PAD type. Normally, it is safe to follow the PAD type directly,
9031 but older versions of the compiler have a bug that causes the offset
9032 of its "F" field to be wrong. Following that field in that case
9033 would lead to incorrect results, but this can be worked around
9034 by ignoring the PAD type and using the associated XVS type instead.
9036 Set to True if the debugger should trust the contents of PAD types.
9037 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9038 static bool trust_pad_over_xvs
= true;
9040 /* True if TYPE is a struct type introduced by the compiler to force the
9041 alignment of a value. Such types have a single field with a
9042 distinctive name. */
9045 ada_is_aligner_type (struct type
*type
)
9047 type
= ada_check_typedef (type
);
9049 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9052 return (type
->code () == TYPE_CODE_STRUCT
9053 && type
->num_fields () == 1
9054 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9057 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9058 the parallel type. */
9061 ada_get_base_type (struct type
*raw_type
)
9063 struct type
*real_type_namer
;
9064 struct type
*raw_real_type
;
9066 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9069 if (ada_is_aligner_type (raw_type
))
9070 /* The encoding specifies that we should always use the aligner type.
9071 So, even if this aligner type has an associated XVS type, we should
9074 According to the compiler gurus, an XVS type parallel to an aligner
9075 type may exist because of a stabs limitation. In stabs, aligner
9076 types are empty because the field has a variable-sized type, and
9077 thus cannot actually be used as an aligner type. As a result,
9078 we need the associated parallel XVS type to decode the type.
9079 Since the policy in the compiler is to not change the internal
9080 representation based on the debugging info format, we sometimes
9081 end up having a redundant XVS type parallel to the aligner type. */
9084 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9085 if (real_type_namer
== NULL
9086 || real_type_namer
->code () != TYPE_CODE_STRUCT
9087 || real_type_namer
->num_fields () != 1)
9090 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9092 /* This is an older encoding form where the base type needs to be
9093 looked up by name. We prefer the newer encoding because it is
9095 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9096 if (raw_real_type
== NULL
)
9099 return raw_real_type
;
9102 /* The field in our XVS type is a reference to the base type. */
9103 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9106 /* The type of value designated by TYPE, with all aligners removed. */
9109 ada_aligned_type (struct type
*type
)
9111 if (ada_is_aligner_type (type
))
9112 return ada_aligned_type (type
->field (0).type ());
9114 return ada_get_base_type (type
);
9118 /* The address of the aligned value in an object at address VALADDR
9119 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9122 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9124 if (ada_is_aligner_type (type
))
9125 return ada_aligned_value_addr (type
->field (0).type (),
9127 TYPE_FIELD_BITPOS (type
,
9128 0) / TARGET_CHAR_BIT
);
9135 /* The printed representation of an enumeration literal with encoded
9136 name NAME. The value is good to the next call of ada_enum_name. */
9138 ada_enum_name (const char *name
)
9140 static char *result
;
9141 static size_t result_len
= 0;
9144 /* First, unqualify the enumeration name:
9145 1. Search for the last '.' character. If we find one, then skip
9146 all the preceding characters, the unqualified name starts
9147 right after that dot.
9148 2. Otherwise, we may be debugging on a target where the compiler
9149 translates dots into "__". Search forward for double underscores,
9150 but stop searching when we hit an overloading suffix, which is
9151 of the form "__" followed by digits. */
9153 tmp
= strrchr (name
, '.');
9158 while ((tmp
= strstr (name
, "__")) != NULL
)
9160 if (isdigit (tmp
[2]))
9171 if (name
[1] == 'U' || name
[1] == 'W')
9173 if (sscanf (name
+ 2, "%x", &v
) != 1)
9176 else if (((name
[1] >= '0' && name
[1] <= '9')
9177 || (name
[1] >= 'a' && name
[1] <= 'z'))
9180 GROW_VECT (result
, result_len
, 4);
9181 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9187 GROW_VECT (result
, result_len
, 16);
9188 if (isascii (v
) && isprint (v
))
9189 xsnprintf (result
, result_len
, "'%c'", v
);
9190 else if (name
[1] == 'U')
9191 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9193 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9199 tmp
= strstr (name
, "__");
9201 tmp
= strstr (name
, "$");
9204 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9205 strncpy (result
, name
, tmp
- name
);
9206 result
[tmp
- name
] = '\0';
9214 /* Evaluate the subexpression of EXP starting at *POS as for
9215 evaluate_type, updating *POS to point just past the evaluated
9218 static struct value
*
9219 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9221 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9224 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9227 static struct value
*
9228 unwrap_value (struct value
*val
)
9230 struct type
*type
= ada_check_typedef (value_type (val
));
9232 if (ada_is_aligner_type (type
))
9234 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9235 struct type
*val_type
= ada_check_typedef (value_type (v
));
9237 if (ada_type_name (val_type
) == NULL
)
9238 val_type
->set_name (ada_type_name (type
));
9240 return unwrap_value (v
);
9244 struct type
*raw_real_type
=
9245 ada_check_typedef (ada_get_base_type (type
));
9247 /* If there is no parallel XVS or XVE type, then the value is
9248 already unwrapped. Return it without further modification. */
9249 if ((type
== raw_real_type
)
9250 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9254 coerce_unspec_val_to_type
9255 (val
, ada_to_fixed_type (raw_real_type
, 0,
9256 value_address (val
),
9261 static struct value
*
9262 cast_from_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9265 = gnat_encoded_fixed_point_scaling_factor (value_type (arg
));
9266 arg
= value_cast (value_type (scale
), arg
);
9268 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9269 return value_cast (type
, arg
);
9272 static struct value
*
9273 cast_to_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9275 if (type
== value_type (arg
))
9278 struct value
*scale
= gnat_encoded_fixed_point_scaling_factor (type
);
9279 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9280 arg
= cast_from_gnat_encoded_fixed_point_type (value_type (scale
), arg
);
9282 arg
= value_cast (value_type (scale
), arg
);
9284 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9285 return value_cast (type
, arg
);
9288 /* Given two array types T1 and T2, return nonzero iff both arrays
9289 contain the same number of elements. */
9292 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9294 LONGEST lo1
, hi1
, lo2
, hi2
;
9296 /* Get the array bounds in order to verify that the size of
9297 the two arrays match. */
9298 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9299 || !get_array_bounds (t2
, &lo2
, &hi2
))
9300 error (_("unable to determine array bounds"));
9302 /* To make things easier for size comparison, normalize a bit
9303 the case of empty arrays by making sure that the difference
9304 between upper bound and lower bound is always -1. */
9310 return (hi1
- lo1
== hi2
- lo2
);
9313 /* Assuming that VAL is an array of integrals, and TYPE represents
9314 an array with the same number of elements, but with wider integral
9315 elements, return an array "casted" to TYPE. In practice, this
9316 means that the returned array is built by casting each element
9317 of the original array into TYPE's (wider) element type. */
9319 static struct value
*
9320 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9322 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9327 /* Verify that both val and type are arrays of scalars, and
9328 that the size of val's elements is smaller than the size
9329 of type's element. */
9330 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9331 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9332 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9333 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9334 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9335 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9337 if (!get_array_bounds (type
, &lo
, &hi
))
9338 error (_("unable to determine array bounds"));
9340 res
= allocate_value (type
);
9342 /* Promote each array element. */
9343 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9345 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9347 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9348 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9354 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9355 return the converted value. */
9357 static struct value
*
9358 coerce_for_assign (struct type
*type
, struct value
*val
)
9360 struct type
*type2
= value_type (val
);
9365 type2
= ada_check_typedef (type2
);
9366 type
= ada_check_typedef (type
);
9368 if (type2
->code () == TYPE_CODE_PTR
9369 && type
->code () == TYPE_CODE_ARRAY
)
9371 val
= ada_value_ind (val
);
9372 type2
= value_type (val
);
9375 if (type2
->code () == TYPE_CODE_ARRAY
9376 && type
->code () == TYPE_CODE_ARRAY
)
9378 if (!ada_same_array_size_p (type
, type2
))
9379 error (_("cannot assign arrays of different length"));
9381 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9382 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9383 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9384 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9386 /* Allow implicit promotion of the array elements to
9388 return ada_promote_array_of_integrals (type
, val
);
9391 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9392 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9393 error (_("Incompatible types in assignment"));
9394 deprecated_set_value_type (val
, type
);
9399 static struct value
*
9400 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9403 struct type
*type1
, *type2
;
9406 arg1
= coerce_ref (arg1
);
9407 arg2
= coerce_ref (arg2
);
9408 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9409 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9411 if (type1
->code () != TYPE_CODE_INT
9412 || type2
->code () != TYPE_CODE_INT
)
9413 return value_binop (arg1
, arg2
, op
);
9422 return value_binop (arg1
, arg2
, op
);
9425 v2
= value_as_long (arg2
);
9427 error (_("second operand of %s must not be zero."), op_string (op
));
9429 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9430 return value_binop (arg1
, arg2
, op
);
9432 v1
= value_as_long (arg1
);
9437 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9438 v
+= v
> 0 ? -1 : 1;
9446 /* Should not reach this point. */
9450 val
= allocate_value (type1
);
9451 store_unsigned_integer (value_contents_raw (val
),
9452 TYPE_LENGTH (value_type (val
)),
9453 type_byte_order (type1
), v
);
9458 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9460 if (ada_is_direct_array_type (value_type (arg1
))
9461 || ada_is_direct_array_type (value_type (arg2
)))
9463 struct type
*arg1_type
, *arg2_type
;
9465 /* Automatically dereference any array reference before
9466 we attempt to perform the comparison. */
9467 arg1
= ada_coerce_ref (arg1
);
9468 arg2
= ada_coerce_ref (arg2
);
9470 arg1
= ada_coerce_to_simple_array (arg1
);
9471 arg2
= ada_coerce_to_simple_array (arg2
);
9473 arg1_type
= ada_check_typedef (value_type (arg1
));
9474 arg2_type
= ada_check_typedef (value_type (arg2
));
9476 if (arg1_type
->code () != TYPE_CODE_ARRAY
9477 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9478 error (_("Attempt to compare array with non-array"));
9479 /* FIXME: The following works only for types whose
9480 representations use all bits (no padding or undefined bits)
9481 and do not have user-defined equality. */
9482 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9483 && memcmp (value_contents (arg1
), value_contents (arg2
),
9484 TYPE_LENGTH (arg1_type
)) == 0);
9486 return value_equal (arg1
, arg2
);
9489 /* Total number of component associations in the aggregate starting at
9490 index PC in EXP. Assumes that index PC is the start of an
9494 num_component_specs (struct expression
*exp
, int pc
)
9498 m
= exp
->elts
[pc
+ 1].longconst
;
9501 for (i
= 0; i
< m
; i
+= 1)
9503 switch (exp
->elts
[pc
].opcode
)
9509 n
+= exp
->elts
[pc
+ 1].longconst
;
9512 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9517 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9518 component of LHS (a simple array or a record), updating *POS past
9519 the expression, assuming that LHS is contained in CONTAINER. Does
9520 not modify the inferior's memory, nor does it modify LHS (unless
9521 LHS == CONTAINER). */
9524 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9525 struct expression
*exp
, int *pos
)
9527 struct value
*mark
= value_mark ();
9529 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9531 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9533 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9534 struct value
*index_val
= value_from_longest (index_type
, index
);
9536 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9540 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9541 elt
= ada_to_fixed_value (elt
);
9544 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9545 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9547 value_assign_to_component (container
, elt
,
9548 ada_evaluate_subexp (NULL
, exp
, pos
,
9551 value_free_to_mark (mark
);
9554 /* Assuming that LHS represents an lvalue having a record or array
9555 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9556 of that aggregate's value to LHS, advancing *POS past the
9557 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9558 lvalue containing LHS (possibly LHS itself). Does not modify
9559 the inferior's memory, nor does it modify the contents of
9560 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9562 static struct value
*
9563 assign_aggregate (struct value
*container
,
9564 struct value
*lhs
, struct expression
*exp
,
9565 int *pos
, enum noside noside
)
9567 struct type
*lhs_type
;
9568 int n
= exp
->elts
[*pos
+1].longconst
;
9569 LONGEST low_index
, high_index
;
9572 int max_indices
, num_indices
;
9576 if (noside
!= EVAL_NORMAL
)
9578 for (i
= 0; i
< n
; i
+= 1)
9579 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9583 container
= ada_coerce_ref (container
);
9584 if (ada_is_direct_array_type (value_type (container
)))
9585 container
= ada_coerce_to_simple_array (container
);
9586 lhs
= ada_coerce_ref (lhs
);
9587 if (!deprecated_value_modifiable (lhs
))
9588 error (_("Left operand of assignment is not a modifiable lvalue."));
9590 lhs_type
= check_typedef (value_type (lhs
));
9591 if (ada_is_direct_array_type (lhs_type
))
9593 lhs
= ada_coerce_to_simple_array (lhs
);
9594 lhs_type
= check_typedef (value_type (lhs
));
9595 low_index
= lhs_type
->bounds ()->low
.const_val ();
9596 high_index
= lhs_type
->bounds ()->high
.const_val ();
9598 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9601 high_index
= num_visible_fields (lhs_type
) - 1;
9604 error (_("Left-hand side must be array or record."));
9606 num_specs
= num_component_specs (exp
, *pos
- 3);
9607 max_indices
= 4 * num_specs
+ 4;
9608 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9609 indices
[0] = indices
[1] = low_index
- 1;
9610 indices
[2] = indices
[3] = high_index
+ 1;
9613 for (i
= 0; i
< n
; i
+= 1)
9615 switch (exp
->elts
[*pos
].opcode
)
9618 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9619 &num_indices
, max_indices
,
9620 low_index
, high_index
);
9623 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9624 &num_indices
, max_indices
,
9625 low_index
, high_index
);
9629 error (_("Misplaced 'others' clause"));
9630 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9631 num_indices
, low_index
, high_index
);
9634 error (_("Internal error: bad aggregate clause"));
9641 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9642 construct at *POS, updating *POS past the construct, given that
9643 the positions are relative to lower bound LOW, where HIGH is the
9644 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9645 updating *NUM_INDICES as needed. CONTAINER is as for
9646 assign_aggregate. */
9648 aggregate_assign_positional (struct value
*container
,
9649 struct value
*lhs
, struct expression
*exp
,
9650 int *pos
, LONGEST
*indices
, int *num_indices
,
9651 int max_indices
, LONGEST low
, LONGEST high
)
9653 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9655 if (ind
- 1 == high
)
9656 warning (_("Extra components in aggregate ignored."));
9659 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9661 assign_component (container
, lhs
, ind
, exp
, pos
);
9664 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9667 /* Assign into the components of LHS indexed by the OP_CHOICES
9668 construct at *POS, updating *POS past the construct, given that
9669 the allowable indices are LOW..HIGH. Record the indices assigned
9670 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9671 needed. CONTAINER is as for assign_aggregate. */
9673 aggregate_assign_from_choices (struct value
*container
,
9674 struct value
*lhs
, struct expression
*exp
,
9675 int *pos
, LONGEST
*indices
, int *num_indices
,
9676 int max_indices
, LONGEST low
, LONGEST high
)
9679 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9680 int choice_pos
, expr_pc
;
9681 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9683 choice_pos
= *pos
+= 3;
9685 for (j
= 0; j
< n_choices
; j
+= 1)
9686 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9688 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9690 for (j
= 0; j
< n_choices
; j
+= 1)
9692 LONGEST lower
, upper
;
9693 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9695 if (op
== OP_DISCRETE_RANGE
)
9698 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9700 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9705 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9717 name
= &exp
->elts
[choice_pos
+ 2].string
;
9720 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9723 error (_("Invalid record component association."));
9725 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9727 if (! find_struct_field (name
, value_type (lhs
), 0,
9728 NULL
, NULL
, NULL
, NULL
, &ind
))
9729 error (_("Unknown component name: %s."), name
);
9730 lower
= upper
= ind
;
9733 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9734 error (_("Index in component association out of bounds."));
9736 add_component_interval (lower
, upper
, indices
, num_indices
,
9738 while (lower
<= upper
)
9743 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9749 /* Assign the value of the expression in the OP_OTHERS construct in
9750 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9751 have not been previously assigned. The index intervals already assigned
9752 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9753 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9755 aggregate_assign_others (struct value
*container
,
9756 struct value
*lhs
, struct expression
*exp
,
9757 int *pos
, LONGEST
*indices
, int num_indices
,
9758 LONGEST low
, LONGEST high
)
9761 int expr_pc
= *pos
+ 1;
9763 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9767 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9772 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9775 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9778 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9779 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9780 modifying *SIZE as needed. It is an error if *SIZE exceeds
9781 MAX_SIZE. The resulting intervals do not overlap. */
9783 add_component_interval (LONGEST low
, LONGEST high
,
9784 LONGEST
* indices
, int *size
, int max_size
)
9788 for (i
= 0; i
< *size
; i
+= 2) {
9789 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9793 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9794 if (high
< indices
[kh
])
9796 if (low
< indices
[i
])
9798 indices
[i
+ 1] = indices
[kh
- 1];
9799 if (high
> indices
[i
+ 1])
9800 indices
[i
+ 1] = high
;
9801 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9802 *size
-= kh
- i
- 2;
9805 else if (high
< indices
[i
])
9809 if (*size
== max_size
)
9810 error (_("Internal error: miscounted aggregate components."));
9812 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9813 indices
[j
] = indices
[j
- 2];
9815 indices
[i
+ 1] = high
;
9818 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9821 static struct value
*
9822 ada_value_cast (struct type
*type
, struct value
*arg2
)
9824 if (type
== ada_check_typedef (value_type (arg2
)))
9827 if (ada_is_gnat_encoded_fixed_point_type (type
))
9828 return cast_to_gnat_encoded_fixed_point_type (type
, arg2
);
9830 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9831 return cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
9833 return value_cast (type
, arg2
);
9836 /* Evaluating Ada expressions, and printing their result.
9837 ------------------------------------------------------
9842 We usually evaluate an Ada expression in order to print its value.
9843 We also evaluate an expression in order to print its type, which
9844 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9845 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9846 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9847 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9850 Evaluating expressions is a little more complicated for Ada entities
9851 than it is for entities in languages such as C. The main reason for
9852 this is that Ada provides types whose definition might be dynamic.
9853 One example of such types is variant records. Or another example
9854 would be an array whose bounds can only be known at run time.
9856 The following description is a general guide as to what should be
9857 done (and what should NOT be done) in order to evaluate an expression
9858 involving such types, and when. This does not cover how the semantic
9859 information is encoded by GNAT as this is covered separatly. For the
9860 document used as the reference for the GNAT encoding, see exp_dbug.ads
9861 in the GNAT sources.
9863 Ideally, we should embed each part of this description next to its
9864 associated code. Unfortunately, the amount of code is so vast right
9865 now that it's hard to see whether the code handling a particular
9866 situation might be duplicated or not. One day, when the code is
9867 cleaned up, this guide might become redundant with the comments
9868 inserted in the code, and we might want to remove it.
9870 2. ``Fixing'' an Entity, the Simple Case:
9871 -----------------------------------------
9873 When evaluating Ada expressions, the tricky issue is that they may
9874 reference entities whose type contents and size are not statically
9875 known. Consider for instance a variant record:
9877 type Rec (Empty : Boolean := True) is record
9880 when False => Value : Integer;
9883 Yes : Rec := (Empty => False, Value => 1);
9884 No : Rec := (empty => True);
9886 The size and contents of that record depends on the value of the
9887 descriminant (Rec.Empty). At this point, neither the debugging
9888 information nor the associated type structure in GDB are able to
9889 express such dynamic types. So what the debugger does is to create
9890 "fixed" versions of the type that applies to the specific object.
9891 We also informally refer to this operation as "fixing" an object,
9892 which means creating its associated fixed type.
9894 Example: when printing the value of variable "Yes" above, its fixed
9895 type would look like this:
9902 On the other hand, if we printed the value of "No", its fixed type
9909 Things become a little more complicated when trying to fix an entity
9910 with a dynamic type that directly contains another dynamic type,
9911 such as an array of variant records, for instance. There are
9912 two possible cases: Arrays, and records.
9914 3. ``Fixing'' Arrays:
9915 ---------------------
9917 The type structure in GDB describes an array in terms of its bounds,
9918 and the type of its elements. By design, all elements in the array
9919 have the same type and we cannot represent an array of variant elements
9920 using the current type structure in GDB. When fixing an array,
9921 we cannot fix the array element, as we would potentially need one
9922 fixed type per element of the array. As a result, the best we can do
9923 when fixing an array is to produce an array whose bounds and size
9924 are correct (allowing us to read it from memory), but without having
9925 touched its element type. Fixing each element will be done later,
9926 when (if) necessary.
9928 Arrays are a little simpler to handle than records, because the same
9929 amount of memory is allocated for each element of the array, even if
9930 the amount of space actually used by each element differs from element
9931 to element. Consider for instance the following array of type Rec:
9933 type Rec_Array is array (1 .. 2) of Rec;
9935 The actual amount of memory occupied by each element might be different
9936 from element to element, depending on the value of their discriminant.
9937 But the amount of space reserved for each element in the array remains
9938 fixed regardless. So we simply need to compute that size using
9939 the debugging information available, from which we can then determine
9940 the array size (we multiply the number of elements of the array by
9941 the size of each element).
9943 The simplest case is when we have an array of a constrained element
9944 type. For instance, consider the following type declarations:
9946 type Bounded_String (Max_Size : Integer) is
9948 Buffer : String (1 .. Max_Size);
9950 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9952 In this case, the compiler describes the array as an array of
9953 variable-size elements (identified by its XVS suffix) for which
9954 the size can be read in the parallel XVZ variable.
9956 In the case of an array of an unconstrained element type, the compiler
9957 wraps the array element inside a private PAD type. This type should not
9958 be shown to the user, and must be "unwrap"'ed before printing. Note
9959 that we also use the adjective "aligner" in our code to designate
9960 these wrapper types.
9962 In some cases, the size allocated for each element is statically
9963 known. In that case, the PAD type already has the correct size,
9964 and the array element should remain unfixed.
9966 But there are cases when this size is not statically known.
9967 For instance, assuming that "Five" is an integer variable:
9969 type Dynamic is array (1 .. Five) of Integer;
9970 type Wrapper (Has_Length : Boolean := False) is record
9973 when True => Length : Integer;
9977 type Wrapper_Array is array (1 .. 2) of Wrapper;
9979 Hello : Wrapper_Array := (others => (Has_Length => True,
9980 Data => (others => 17),
9984 The debugging info would describe variable Hello as being an
9985 array of a PAD type. The size of that PAD type is not statically
9986 known, but can be determined using a parallel XVZ variable.
9987 In that case, a copy of the PAD type with the correct size should
9988 be used for the fixed array.
9990 3. ``Fixing'' record type objects:
9991 ----------------------------------
9993 Things are slightly different from arrays in the case of dynamic
9994 record types. In this case, in order to compute the associated
9995 fixed type, we need to determine the size and offset of each of
9996 its components. This, in turn, requires us to compute the fixed
9997 type of each of these components.
9999 Consider for instance the example:
10001 type Bounded_String (Max_Size : Natural) is record
10002 Str : String (1 .. Max_Size);
10005 My_String : Bounded_String (Max_Size => 10);
10007 In that case, the position of field "Length" depends on the size
10008 of field Str, which itself depends on the value of the Max_Size
10009 discriminant. In order to fix the type of variable My_String,
10010 we need to fix the type of field Str. Therefore, fixing a variant
10011 record requires us to fix each of its components.
10013 However, if a component does not have a dynamic size, the component
10014 should not be fixed. In particular, fields that use a PAD type
10015 should not fixed. Here is an example where this might happen
10016 (assuming type Rec above):
10018 type Container (Big : Boolean) is record
10022 when True => Another : Integer;
10023 when False => null;
10026 My_Container : Container := (Big => False,
10027 First => (Empty => True),
10030 In that example, the compiler creates a PAD type for component First,
10031 whose size is constant, and then positions the component After just
10032 right after it. The offset of component After is therefore constant
10035 The debugger computes the position of each field based on an algorithm
10036 that uses, among other things, the actual position and size of the field
10037 preceding it. Let's now imagine that the user is trying to print
10038 the value of My_Container. If the type fixing was recursive, we would
10039 end up computing the offset of field After based on the size of the
10040 fixed version of field First. And since in our example First has
10041 only one actual field, the size of the fixed type is actually smaller
10042 than the amount of space allocated to that field, and thus we would
10043 compute the wrong offset of field After.
10045 To make things more complicated, we need to watch out for dynamic
10046 components of variant records (identified by the ___XVL suffix in
10047 the component name). Even if the target type is a PAD type, the size
10048 of that type might not be statically known. So the PAD type needs
10049 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10050 we might end up with the wrong size for our component. This can be
10051 observed with the following type declarations:
10053 type Octal is new Integer range 0 .. 7;
10054 type Octal_Array is array (Positive range <>) of Octal;
10055 pragma Pack (Octal_Array);
10057 type Octal_Buffer (Size : Positive) is record
10058 Buffer : Octal_Array (1 .. Size);
10062 In that case, Buffer is a PAD type whose size is unset and needs
10063 to be computed by fixing the unwrapped type.
10065 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10066 ----------------------------------------------------------
10068 Lastly, when should the sub-elements of an entity that remained unfixed
10069 thus far, be actually fixed?
10071 The answer is: Only when referencing that element. For instance
10072 when selecting one component of a record, this specific component
10073 should be fixed at that point in time. Or when printing the value
10074 of a record, each component should be fixed before its value gets
10075 printed. Similarly for arrays, the element of the array should be
10076 fixed when printing each element of the array, or when extracting
10077 one element out of that array. On the other hand, fixing should
10078 not be performed on the elements when taking a slice of an array!
10080 Note that one of the side effects of miscomputing the offset and
10081 size of each field is that we end up also miscomputing the size
10082 of the containing type. This can have adverse results when computing
10083 the value of an entity. GDB fetches the value of an entity based
10084 on the size of its type, and thus a wrong size causes GDB to fetch
10085 the wrong amount of memory. In the case where the computed size is
10086 too small, GDB fetches too little data to print the value of our
10087 entity. Results in this case are unpredictable, as we usually read
10088 past the buffer containing the data =:-o. */
10090 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10091 for that subexpression cast to TO_TYPE. Advance *POS over the
10095 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10096 enum noside noside
, struct type
*to_type
)
10100 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10101 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10106 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10108 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10109 return value_zero (to_type
, not_lval
);
10111 val
= evaluate_var_msym_value (noside
,
10112 exp
->elts
[pc
+ 1].objfile
,
10113 exp
->elts
[pc
+ 2].msymbol
);
10116 val
= evaluate_var_value (noside
,
10117 exp
->elts
[pc
+ 1].block
,
10118 exp
->elts
[pc
+ 2].symbol
);
10120 if (noside
== EVAL_SKIP
)
10121 return eval_skip_value (exp
);
10123 val
= ada_value_cast (to_type
, val
);
10125 /* Follow the Ada language semantics that do not allow taking
10126 an address of the result of a cast (view conversion in Ada). */
10127 if (VALUE_LVAL (val
) == lval_memory
)
10129 if (value_lazy (val
))
10130 value_fetch_lazy (val
);
10131 VALUE_LVAL (val
) = not_lval
;
10136 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10137 if (noside
== EVAL_SKIP
)
10138 return eval_skip_value (exp
);
10139 return ada_value_cast (to_type
, val
);
10142 /* Implement the evaluate_exp routine in the exp_descriptor structure
10143 for the Ada language. */
10145 static struct value
*
10146 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10147 int *pos
, enum noside noside
)
10149 enum exp_opcode op
;
10153 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10156 struct value
**argvec
;
10160 op
= exp
->elts
[pc
].opcode
;
10166 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10168 if (noside
== EVAL_NORMAL
)
10169 arg1
= unwrap_value (arg1
);
10171 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10172 then we need to perform the conversion manually, because
10173 evaluate_subexp_standard doesn't do it. This conversion is
10174 necessary in Ada because the different kinds of float/fixed
10175 types in Ada have different representations.
10177 Similarly, we need to perform the conversion from OP_LONG
10179 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10180 arg1
= ada_value_cast (expect_type
, arg1
);
10186 struct value
*result
;
10189 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10190 /* The result type will have code OP_STRING, bashed there from
10191 OP_ARRAY. Bash it back. */
10192 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10193 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10199 type
= exp
->elts
[pc
+ 1].type
;
10200 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10204 type
= exp
->elts
[pc
+ 1].type
;
10205 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10208 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10209 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10211 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10212 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10214 return ada_value_assign (arg1
, arg1
);
10216 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10217 except if the lhs of our assignment is a convenience variable.
10218 In the case of assigning to a convenience variable, the lhs
10219 should be exactly the result of the evaluation of the rhs. */
10220 type
= value_type (arg1
);
10221 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10223 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10224 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10226 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10230 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10231 arg2
= cast_to_gnat_encoded_fixed_point_type (value_type (arg1
), arg2
);
10232 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10234 (_("Fixed-point values must be assigned to fixed-point variables"));
10236 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10237 return ada_value_assign (arg1
, arg2
);
10240 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10241 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10242 if (noside
== EVAL_SKIP
)
10244 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10245 return (value_from_longest
10246 (value_type (arg1
),
10247 value_as_long (arg1
) + value_as_long (arg2
)));
10248 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10249 return (value_from_longest
10250 (value_type (arg2
),
10251 value_as_long (arg1
) + value_as_long (arg2
)));
10252 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10253 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10254 && value_type (arg1
) != value_type (arg2
))
10255 error (_("Operands of fixed-point addition must have the same type"));
10256 /* Do the addition, and cast the result to the type of the first
10257 argument. We cannot cast the result to a reference type, so if
10258 ARG1 is a reference type, find its underlying type. */
10259 type
= value_type (arg1
);
10260 while (type
->code () == TYPE_CODE_REF
)
10261 type
= TYPE_TARGET_TYPE (type
);
10262 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10263 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10266 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10267 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10268 if (noside
== EVAL_SKIP
)
10270 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10271 return (value_from_longest
10272 (value_type (arg1
),
10273 value_as_long (arg1
) - value_as_long (arg2
)));
10274 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10275 return (value_from_longest
10276 (value_type (arg2
),
10277 value_as_long (arg1
) - value_as_long (arg2
)));
10278 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10279 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10280 && value_type (arg1
) != value_type (arg2
))
10281 error (_("Operands of fixed-point subtraction "
10282 "must have the same type"));
10283 /* Do the substraction, and cast the result to the type of the first
10284 argument. We cannot cast the result to a reference type, so if
10285 ARG1 is a reference type, find its underlying type. */
10286 type
= value_type (arg1
);
10287 while (type
->code () == TYPE_CODE_REF
)
10288 type
= TYPE_TARGET_TYPE (type
);
10289 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10290 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10296 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10297 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10298 if (noside
== EVAL_SKIP
)
10300 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10302 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10303 return value_zero (value_type (arg1
), not_lval
);
10307 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10308 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10309 arg1
= cast_from_gnat_encoded_fixed_point_type (type
, arg1
);
10310 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10311 arg2
= cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
10312 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10313 return ada_value_binop (arg1
, arg2
, op
);
10317 case BINOP_NOTEQUAL
:
10318 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10319 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10320 if (noside
== EVAL_SKIP
)
10322 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10326 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10327 tem
= ada_value_equal (arg1
, arg2
);
10329 if (op
== BINOP_NOTEQUAL
)
10331 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10332 return value_from_longest (type
, (LONGEST
) tem
);
10335 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10336 if (noside
== EVAL_SKIP
)
10338 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10339 return value_cast (value_type (arg1
), value_neg (arg1
));
10342 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10343 return value_neg (arg1
);
10346 case BINOP_LOGICAL_AND
:
10347 case BINOP_LOGICAL_OR
:
10348 case UNOP_LOGICAL_NOT
:
10353 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10354 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10355 return value_cast (type
, val
);
10358 case BINOP_BITWISE_AND
:
10359 case BINOP_BITWISE_IOR
:
10360 case BINOP_BITWISE_XOR
:
10364 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10366 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10368 return value_cast (value_type (arg1
), val
);
10374 if (noside
== EVAL_SKIP
)
10380 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10381 /* Only encountered when an unresolved symbol occurs in a
10382 context other than a function call, in which case, it is
10384 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10385 exp
->elts
[pc
+ 2].symbol
->print_name ());
10387 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10389 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10390 /* Check to see if this is a tagged type. We also need to handle
10391 the case where the type is a reference to a tagged type, but
10392 we have to be careful to exclude pointers to tagged types.
10393 The latter should be shown as usual (as a pointer), whereas
10394 a reference should mostly be transparent to the user. */
10395 if (ada_is_tagged_type (type
, 0)
10396 || (type
->code () == TYPE_CODE_REF
10397 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10399 /* Tagged types are a little special in the fact that the real
10400 type is dynamic and can only be determined by inspecting the
10401 object's tag. This means that we need to get the object's
10402 value first (EVAL_NORMAL) and then extract the actual object
10405 Note that we cannot skip the final step where we extract
10406 the object type from its tag, because the EVAL_NORMAL phase
10407 results in dynamic components being resolved into fixed ones.
10408 This can cause problems when trying to print the type
10409 description of tagged types whose parent has a dynamic size:
10410 We use the type name of the "_parent" component in order
10411 to print the name of the ancestor type in the type description.
10412 If that component had a dynamic size, the resolution into
10413 a fixed type would result in the loss of that type name,
10414 thus preventing us from printing the name of the ancestor
10415 type in the type description. */
10416 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10418 if (type
->code () != TYPE_CODE_REF
)
10420 struct type
*actual_type
;
10422 actual_type
= type_from_tag (ada_value_tag (arg1
));
10423 if (actual_type
== NULL
)
10424 /* If, for some reason, we were unable to determine
10425 the actual type from the tag, then use the static
10426 approximation that we just computed as a fallback.
10427 This can happen if the debugging information is
10428 incomplete, for instance. */
10429 actual_type
= type
;
10430 return value_zero (actual_type
, not_lval
);
10434 /* In the case of a ref, ada_coerce_ref takes care
10435 of determining the actual type. But the evaluation
10436 should return a ref as it should be valid to ask
10437 for its address; so rebuild a ref after coerce. */
10438 arg1
= ada_coerce_ref (arg1
);
10439 return value_ref (arg1
, TYPE_CODE_REF
);
10443 /* Records and unions for which GNAT encodings have been
10444 generated need to be statically fixed as well.
10445 Otherwise, non-static fixing produces a type where
10446 all dynamic properties are removed, which prevents "ptype"
10447 from being able to completely describe the type.
10448 For instance, a case statement in a variant record would be
10449 replaced by the relevant components based on the actual
10450 value of the discriminants. */
10451 if ((type
->code () == TYPE_CODE_STRUCT
10452 && dynamic_template_type (type
) != NULL
)
10453 || (type
->code () == TYPE_CODE_UNION
10454 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10457 return value_zero (to_static_fixed_type (type
), not_lval
);
10461 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10462 return ada_to_fixed_value (arg1
);
10467 /* Allocate arg vector, including space for the function to be
10468 called in argvec[0] and a terminating NULL. */
10469 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10470 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10472 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10473 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10474 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10475 exp
->elts
[pc
+ 5].symbol
->print_name ());
10478 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10479 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10482 if (noside
== EVAL_SKIP
)
10486 if (ada_is_constrained_packed_array_type
10487 (desc_base_type (value_type (argvec
[0]))))
10488 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10489 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10490 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10491 /* This is a packed array that has already been fixed, and
10492 therefore already coerced to a simple array. Nothing further
10495 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10497 /* Make sure we dereference references so that all the code below
10498 feels like it's really handling the referenced value. Wrapping
10499 types (for alignment) may be there, so make sure we strip them as
10501 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10503 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10504 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10505 argvec
[0] = value_addr (argvec
[0]);
10507 type
= ada_check_typedef (value_type (argvec
[0]));
10509 /* Ada allows us to implicitly dereference arrays when subscripting
10510 them. So, if this is an array typedef (encoding use for array
10511 access types encoded as fat pointers), strip it now. */
10512 if (type
->code () == TYPE_CODE_TYPEDEF
)
10513 type
= ada_typedef_target_type (type
);
10515 if (type
->code () == TYPE_CODE_PTR
)
10517 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10519 case TYPE_CODE_FUNC
:
10520 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10522 case TYPE_CODE_ARRAY
:
10524 case TYPE_CODE_STRUCT
:
10525 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10526 argvec
[0] = ada_value_ind (argvec
[0]);
10527 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10530 error (_("cannot subscript or call something of type `%s'"),
10531 ada_type_name (value_type (argvec
[0])));
10536 switch (type
->code ())
10538 case TYPE_CODE_FUNC
:
10539 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10541 if (TYPE_TARGET_TYPE (type
) == NULL
)
10542 error_call_unknown_return_type (NULL
);
10543 return allocate_value (TYPE_TARGET_TYPE (type
));
10545 return call_function_by_hand (argvec
[0], NULL
,
10546 gdb::make_array_view (argvec
+ 1,
10548 case TYPE_CODE_INTERNAL_FUNCTION
:
10549 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10550 /* We don't know anything about what the internal
10551 function might return, but we have to return
10553 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10556 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10557 argvec
[0], nargs
, argvec
+ 1);
10559 case TYPE_CODE_STRUCT
:
10563 arity
= ada_array_arity (type
);
10564 type
= ada_array_element_type (type
, nargs
);
10566 error (_("cannot subscript or call a record"));
10567 if (arity
!= nargs
)
10568 error (_("wrong number of subscripts; expecting %d"), arity
);
10569 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10570 return value_zero (ada_aligned_type (type
), lval_memory
);
10572 unwrap_value (ada_value_subscript
10573 (argvec
[0], nargs
, argvec
+ 1));
10575 case TYPE_CODE_ARRAY
:
10576 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10578 type
= ada_array_element_type (type
, nargs
);
10580 error (_("element type of array unknown"));
10582 return value_zero (ada_aligned_type (type
), lval_memory
);
10585 unwrap_value (ada_value_subscript
10586 (ada_coerce_to_simple_array (argvec
[0]),
10587 nargs
, argvec
+ 1));
10588 case TYPE_CODE_PTR
: /* Pointer to array */
10589 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10591 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10592 type
= ada_array_element_type (type
, nargs
);
10594 error (_("element type of array unknown"));
10596 return value_zero (ada_aligned_type (type
), lval_memory
);
10599 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10600 nargs
, argvec
+ 1));
10603 error (_("Attempt to index or call something other than an "
10604 "array or function"));
10609 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10610 struct value
*low_bound_val
10611 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10612 struct value
*high_bound_val
10613 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10615 LONGEST high_bound
;
10617 low_bound_val
= coerce_ref (low_bound_val
);
10618 high_bound_val
= coerce_ref (high_bound_val
);
10619 low_bound
= value_as_long (low_bound_val
);
10620 high_bound
= value_as_long (high_bound_val
);
10622 if (noside
== EVAL_SKIP
)
10625 /* If this is a reference to an aligner type, then remove all
10627 if (value_type (array
)->code () == TYPE_CODE_REF
10628 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10629 TYPE_TARGET_TYPE (value_type (array
)) =
10630 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10632 if (ada_is_any_packed_array_type (value_type (array
)))
10633 error (_("cannot slice a packed array"));
10635 /* If this is a reference to an array or an array lvalue,
10636 convert to a pointer. */
10637 if (value_type (array
)->code () == TYPE_CODE_REF
10638 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10639 && VALUE_LVAL (array
) == lval_memory
))
10640 array
= value_addr (array
);
10642 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10643 && ada_is_array_descriptor_type (ada_check_typedef
10644 (value_type (array
))))
10645 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10648 array
= ada_coerce_to_simple_array_ptr (array
);
10650 /* If we have more than one level of pointer indirection,
10651 dereference the value until we get only one level. */
10652 while (value_type (array
)->code () == TYPE_CODE_PTR
10653 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10655 array
= value_ind (array
);
10657 /* Make sure we really do have an array type before going further,
10658 to avoid a SEGV when trying to get the index type or the target
10659 type later down the road if the debug info generated by
10660 the compiler is incorrect or incomplete. */
10661 if (!ada_is_simple_array_type (value_type (array
)))
10662 error (_("cannot take slice of non-array"));
10664 if (ada_check_typedef (value_type (array
))->code ()
10667 struct type
*type0
= ada_check_typedef (value_type (array
));
10669 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10670 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10673 struct type
*arr_type0
=
10674 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10676 return ada_value_slice_from_ptr (array
, arr_type0
,
10677 longest_to_int (low_bound
),
10678 longest_to_int (high_bound
));
10681 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10683 else if (high_bound
< low_bound
)
10684 return empty_array (value_type (array
), low_bound
, high_bound
);
10686 return ada_value_slice (array
, longest_to_int (low_bound
),
10687 longest_to_int (high_bound
));
10690 case UNOP_IN_RANGE
:
10692 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10693 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10695 if (noside
== EVAL_SKIP
)
10698 switch (type
->code ())
10701 lim_warning (_("Membership test incompletely implemented; "
10702 "always returns true"));
10703 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10704 return value_from_longest (type
, (LONGEST
) 1);
10706 case TYPE_CODE_RANGE
:
10707 arg2
= value_from_longest (type
,
10708 type
->bounds ()->low
.const_val ());
10709 arg3
= value_from_longest (type
,
10710 type
->bounds ()->high
.const_val ());
10711 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10712 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10713 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10715 value_from_longest (type
,
10716 (value_less (arg1
, arg3
)
10717 || value_equal (arg1
, arg3
))
10718 && (value_less (arg2
, arg1
)
10719 || value_equal (arg2
, arg1
)));
10722 case BINOP_IN_BOUNDS
:
10724 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10725 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10727 if (noside
== EVAL_SKIP
)
10730 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10732 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10733 return value_zero (type
, not_lval
);
10736 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10738 type
= ada_index_type (value_type (arg2
), tem
, "range");
10740 type
= value_type (arg1
);
10742 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10743 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10745 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10746 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10747 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10749 value_from_longest (type
,
10750 (value_less (arg1
, arg3
)
10751 || value_equal (arg1
, arg3
))
10752 && (value_less (arg2
, arg1
)
10753 || value_equal (arg2
, arg1
)));
10755 case TERNOP_IN_RANGE
:
10756 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10757 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10758 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10760 if (noside
== EVAL_SKIP
)
10763 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10764 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10765 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10767 value_from_longest (type
,
10768 (value_less (arg1
, arg3
)
10769 || value_equal (arg1
, arg3
))
10770 && (value_less (arg2
, arg1
)
10771 || value_equal (arg2
, arg1
)));
10775 case OP_ATR_LENGTH
:
10777 struct type
*type_arg
;
10779 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10781 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10783 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10787 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10791 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10792 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10793 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10796 if (noside
== EVAL_SKIP
)
10798 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10800 if (type_arg
== NULL
)
10801 type_arg
= value_type (arg1
);
10803 if (ada_is_constrained_packed_array_type (type_arg
))
10804 type_arg
= decode_constrained_packed_array_type (type_arg
);
10806 if (!discrete_type_p (type_arg
))
10810 default: /* Should never happen. */
10811 error (_("unexpected attribute encountered"));
10814 type_arg
= ada_index_type (type_arg
, tem
,
10815 ada_attribute_name (op
));
10817 case OP_ATR_LENGTH
:
10818 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10823 return value_zero (type_arg
, not_lval
);
10825 else if (type_arg
== NULL
)
10827 arg1
= ada_coerce_ref (arg1
);
10829 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10830 arg1
= ada_coerce_to_simple_array (arg1
);
10832 if (op
== OP_ATR_LENGTH
)
10833 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10836 type
= ada_index_type (value_type (arg1
), tem
,
10837 ada_attribute_name (op
));
10839 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10844 default: /* Should never happen. */
10845 error (_("unexpected attribute encountered"));
10847 return value_from_longest
10848 (type
, ada_array_bound (arg1
, tem
, 0));
10850 return value_from_longest
10851 (type
, ada_array_bound (arg1
, tem
, 1));
10852 case OP_ATR_LENGTH
:
10853 return value_from_longest
10854 (type
, ada_array_length (arg1
, tem
));
10857 else if (discrete_type_p (type_arg
))
10859 struct type
*range_type
;
10860 const char *name
= ada_type_name (type_arg
);
10863 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10864 range_type
= to_fixed_range_type (type_arg
, NULL
);
10865 if (range_type
== NULL
)
10866 range_type
= type_arg
;
10870 error (_("unexpected attribute encountered"));
10872 return value_from_longest
10873 (range_type
, ada_discrete_type_low_bound (range_type
));
10875 return value_from_longest
10876 (range_type
, ada_discrete_type_high_bound (range_type
));
10877 case OP_ATR_LENGTH
:
10878 error (_("the 'length attribute applies only to array types"));
10881 else if (type_arg
->code () == TYPE_CODE_FLT
)
10882 error (_("unimplemented type attribute"));
10887 if (ada_is_constrained_packed_array_type (type_arg
))
10888 type_arg
= decode_constrained_packed_array_type (type_arg
);
10890 if (op
== OP_ATR_LENGTH
)
10891 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10894 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10896 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10902 error (_("unexpected attribute encountered"));
10904 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10905 return value_from_longest (type
, low
);
10907 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10908 return value_from_longest (type
, high
);
10909 case OP_ATR_LENGTH
:
10910 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10911 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10912 return value_from_longest (type
, high
- low
+ 1);
10918 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10919 if (noside
== EVAL_SKIP
)
10922 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10923 return value_zero (ada_tag_type (arg1
), not_lval
);
10925 return ada_value_tag (arg1
);
10929 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10930 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10931 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10932 if (noside
== EVAL_SKIP
)
10934 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10935 return value_zero (value_type (arg1
), not_lval
);
10938 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10939 return value_binop (arg1
, arg2
,
10940 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10943 case OP_ATR_MODULUS
:
10945 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10947 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10948 if (noside
== EVAL_SKIP
)
10951 if (!ada_is_modular_type (type_arg
))
10952 error (_("'modulus must be applied to modular type"));
10954 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10955 ada_modulus (type_arg
));
10960 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10961 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10962 if (noside
== EVAL_SKIP
)
10964 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10965 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10966 return value_zero (type
, not_lval
);
10968 return value_pos_atr (type
, arg1
);
10971 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10972 type
= value_type (arg1
);
10974 /* If the argument is a reference, then dereference its type, since
10975 the user is really asking for the size of the actual object,
10976 not the size of the pointer. */
10977 if (type
->code () == TYPE_CODE_REF
)
10978 type
= TYPE_TARGET_TYPE (type
);
10980 if (noside
== EVAL_SKIP
)
10982 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10983 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10985 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10986 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10989 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10990 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10991 type
= exp
->elts
[pc
+ 2].type
;
10992 if (noside
== EVAL_SKIP
)
10994 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10995 return value_zero (type
, not_lval
);
10997 return value_val_atr (type
, arg1
);
11000 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11001 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11002 if (noside
== EVAL_SKIP
)
11004 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11005 return value_zero (value_type (arg1
), not_lval
);
11008 /* For integer exponentiation operations,
11009 only promote the first argument. */
11010 if (is_integral_type (value_type (arg2
)))
11011 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11013 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11015 return value_binop (arg1
, arg2
, op
);
11019 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11020 if (noside
== EVAL_SKIP
)
11026 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11027 if (noside
== EVAL_SKIP
)
11029 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11030 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11031 return value_neg (arg1
);
11036 preeval_pos
= *pos
;
11037 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11038 if (noside
== EVAL_SKIP
)
11040 type
= ada_check_typedef (value_type (arg1
));
11041 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11043 if (ada_is_array_descriptor_type (type
))
11044 /* GDB allows dereferencing GNAT array descriptors. */
11046 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11048 if (arrType
== NULL
)
11049 error (_("Attempt to dereference null array pointer."));
11050 return value_at_lazy (arrType
, 0);
11052 else if (type
->code () == TYPE_CODE_PTR
11053 || type
->code () == TYPE_CODE_REF
11054 /* In C you can dereference an array to get the 1st elt. */
11055 || type
->code () == TYPE_CODE_ARRAY
)
11057 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11058 only be determined by inspecting the object's tag.
11059 This means that we need to evaluate completely the
11060 expression in order to get its type. */
11062 if ((type
->code () == TYPE_CODE_REF
11063 || type
->code () == TYPE_CODE_PTR
)
11064 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11067 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11068 type
= value_type (ada_value_ind (arg1
));
11072 type
= to_static_fixed_type
11074 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11076 ada_ensure_varsize_limit (type
);
11077 return value_zero (type
, lval_memory
);
11079 else if (type
->code () == TYPE_CODE_INT
)
11081 /* GDB allows dereferencing an int. */
11082 if (expect_type
== NULL
)
11083 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11088 to_static_fixed_type (ada_aligned_type (expect_type
));
11089 return value_zero (expect_type
, lval_memory
);
11093 error (_("Attempt to take contents of a non-pointer value."));
11095 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11096 type
= ada_check_typedef (value_type (arg1
));
11098 if (type
->code () == TYPE_CODE_INT
)
11099 /* GDB allows dereferencing an int. If we were given
11100 the expect_type, then use that as the target type.
11101 Otherwise, assume that the target type is an int. */
11103 if (expect_type
!= NULL
)
11104 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11107 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11108 (CORE_ADDR
) value_as_address (arg1
));
11111 if (ada_is_array_descriptor_type (type
))
11112 /* GDB allows dereferencing GNAT array descriptors. */
11113 return ada_coerce_to_simple_array (arg1
);
11115 return ada_value_ind (arg1
);
11117 case STRUCTOP_STRUCT
:
11118 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11119 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11120 preeval_pos
= *pos
;
11121 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11122 if (noside
== EVAL_SKIP
)
11124 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11126 struct type
*type1
= value_type (arg1
);
11128 if (ada_is_tagged_type (type1
, 1))
11130 type
= ada_lookup_struct_elt_type (type1
,
11131 &exp
->elts
[pc
+ 2].string
,
11134 /* If the field is not found, check if it exists in the
11135 extension of this object's type. This means that we
11136 need to evaluate completely the expression. */
11141 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11142 arg1
= ada_value_struct_elt (arg1
,
11143 &exp
->elts
[pc
+ 2].string
,
11145 arg1
= unwrap_value (arg1
);
11146 type
= value_type (ada_to_fixed_value (arg1
));
11151 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11154 return value_zero (ada_aligned_type (type
), lval_memory
);
11158 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11159 arg1
= unwrap_value (arg1
);
11160 return ada_to_fixed_value (arg1
);
11164 /* The value is not supposed to be used. This is here to make it
11165 easier to accommodate expressions that contain types. */
11167 if (noside
== EVAL_SKIP
)
11169 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11170 return allocate_value (exp
->elts
[pc
+ 1].type
);
11172 error (_("Attempt to use a type name as an expression"));
11177 case OP_DISCRETE_RANGE
:
11178 case OP_POSITIONAL
:
11180 if (noside
== EVAL_NORMAL
)
11184 error (_("Undefined name, ambiguous name, or renaming used in "
11185 "component association: %s."), &exp
->elts
[pc
+2].string
);
11187 error (_("Aggregates only allowed on the right of an assignment"));
11189 internal_error (__FILE__
, __LINE__
,
11190 _("aggregate apparently mangled"));
11193 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11195 for (tem
= 0; tem
< nargs
; tem
+= 1)
11196 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11201 return eval_skip_value (exp
);
11207 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11208 type name that encodes the 'small and 'delta information.
11209 Otherwise, return NULL. */
11211 static const char *
11212 gnat_encoded_fixed_point_type_info (struct type
*type
)
11214 const char *name
= ada_type_name (type
);
11215 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11217 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11219 const char *tail
= strstr (name
, "___XF_");
11226 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11227 return gnat_encoded_fixed_point_type_info (TYPE_TARGET_TYPE (type
));
11232 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11235 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11237 return gnat_encoded_fixed_point_type_info (type
) != NULL
;
11240 /* Return non-zero iff TYPE represents a System.Address type. */
11243 ada_is_system_address_type (struct type
*type
)
11245 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11248 /* Assuming that TYPE is the representation of an Ada fixed-point
11249 type, return the target floating-point type to be used to represent
11250 of this type during internal computation. */
11252 static struct type
*
11253 ada_scaling_type (struct type
*type
)
11255 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11258 /* Assuming that TYPE is the representation of an Ada fixed-point
11259 type, return its delta, or NULL if the type is malformed and the
11260 delta cannot be determined. */
11263 gnat_encoded_fixed_point_delta (struct type
*type
)
11265 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11266 struct type
*scale_type
= ada_scaling_type (type
);
11268 long long num
, den
;
11270 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11273 return value_binop (value_from_longest (scale_type
, num
),
11274 value_from_longest (scale_type
, den
), BINOP_DIV
);
11277 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11278 the scaling factor ('SMALL value) associated with the type. */
11281 gnat_encoded_fixed_point_scaling_factor (struct type
*type
)
11283 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11284 struct type
*scale_type
= ada_scaling_type (type
);
11286 long long num0
, den0
, num1
, den1
;
11289 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11290 &num0
, &den0
, &num1
, &den1
);
11293 return value_from_longest (scale_type
, 1);
11295 return value_binop (value_from_longest (scale_type
, num1
),
11296 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11298 return value_binop (value_from_longest (scale_type
, num0
),
11299 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11306 /* Scan STR beginning at position K for a discriminant name, and
11307 return the value of that discriminant field of DVAL in *PX. If
11308 PNEW_K is not null, put the position of the character beyond the
11309 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11310 not alter *PX and *PNEW_K if unsuccessful. */
11313 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11316 static char *bound_buffer
= NULL
;
11317 static size_t bound_buffer_len
= 0;
11318 const char *pstart
, *pend
, *bound
;
11319 struct value
*bound_val
;
11321 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11325 pend
= strstr (pstart
, "__");
11329 k
+= strlen (bound
);
11333 int len
= pend
- pstart
;
11335 /* Strip __ and beyond. */
11336 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11337 strncpy (bound_buffer
, pstart
, len
);
11338 bound_buffer
[len
] = '\0';
11340 bound
= bound_buffer
;
11344 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11345 if (bound_val
== NULL
)
11348 *px
= value_as_long (bound_val
);
11349 if (pnew_k
!= NULL
)
11354 /* Value of variable named NAME in the current environment. If
11355 no such variable found, then if ERR_MSG is null, returns 0, and
11356 otherwise causes an error with message ERR_MSG. */
11358 static struct value
*
11359 get_var_value (const char *name
, const char *err_msg
)
11361 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11363 std::vector
<struct block_symbol
> syms
;
11364 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11365 get_selected_block (0),
11366 VAR_DOMAIN
, &syms
, 1);
11370 if (err_msg
== NULL
)
11373 error (("%s"), err_msg
);
11376 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11379 /* Value of integer variable named NAME in the current environment.
11380 If no such variable is found, returns false. Otherwise, sets VALUE
11381 to the variable's value and returns true. */
11384 get_int_var_value (const char *name
, LONGEST
&value
)
11386 struct value
*var_val
= get_var_value (name
, 0);
11391 value
= value_as_long (var_val
);
11396 /* Return a range type whose base type is that of the range type named
11397 NAME in the current environment, and whose bounds are calculated
11398 from NAME according to the GNAT range encoding conventions.
11399 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11400 corresponding range type from debug information; fall back to using it
11401 if symbol lookup fails. If a new type must be created, allocate it
11402 like ORIG_TYPE was. The bounds information, in general, is encoded
11403 in NAME, the base type given in the named range type. */
11405 static struct type
*
11406 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11409 struct type
*base_type
;
11410 const char *subtype_info
;
11412 gdb_assert (raw_type
!= NULL
);
11413 gdb_assert (raw_type
->name () != NULL
);
11415 if (raw_type
->code () == TYPE_CODE_RANGE
)
11416 base_type
= TYPE_TARGET_TYPE (raw_type
);
11418 base_type
= raw_type
;
11420 name
= raw_type
->name ();
11421 subtype_info
= strstr (name
, "___XD");
11422 if (subtype_info
== NULL
)
11424 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11425 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11427 if (L
< INT_MIN
|| U
> INT_MAX
)
11430 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11435 static char *name_buf
= NULL
;
11436 static size_t name_len
= 0;
11437 int prefix_len
= subtype_info
- name
;
11440 const char *bounds_str
;
11443 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11444 strncpy (name_buf
, name
, prefix_len
);
11445 name_buf
[prefix_len
] = '\0';
11448 bounds_str
= strchr (subtype_info
, '_');
11451 if (*subtype_info
== 'L')
11453 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11454 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11456 if (bounds_str
[n
] == '_')
11458 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11464 strcpy (name_buf
+ prefix_len
, "___L");
11465 if (!get_int_var_value (name_buf
, L
))
11467 lim_warning (_("Unknown lower bound, using 1."));
11472 if (*subtype_info
== 'U')
11474 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11475 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11480 strcpy (name_buf
+ prefix_len
, "___U");
11481 if (!get_int_var_value (name_buf
, U
))
11483 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11488 type
= create_static_range_type (alloc_type_copy (raw_type
),
11490 /* create_static_range_type alters the resulting type's length
11491 to match the size of the base_type, which is not what we want.
11492 Set it back to the original range type's length. */
11493 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11494 type
->set_name (name
);
11499 /* True iff NAME is the name of a range type. */
11502 ada_is_range_type_name (const char *name
)
11504 return (name
!= NULL
&& strstr (name
, "___XD"));
11508 /* Modular types */
11510 /* True iff TYPE is an Ada modular type. */
11513 ada_is_modular_type (struct type
*type
)
11515 struct type
*subranged_type
= get_base_type (type
);
11517 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11518 && subranged_type
->code () == TYPE_CODE_INT
11519 && subranged_type
->is_unsigned ());
11522 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11525 ada_modulus (struct type
*type
)
11527 const dynamic_prop
&high
= type
->bounds ()->high
;
11529 if (high
.kind () == PROP_CONST
)
11530 return (ULONGEST
) high
.const_val () + 1;
11532 /* If TYPE is unresolved, the high bound might be a location list. Return
11533 0, for lack of a better value to return. */
11538 /* Ada exception catchpoint support:
11539 ---------------------------------
11541 We support 3 kinds of exception catchpoints:
11542 . catchpoints on Ada exceptions
11543 . catchpoints on unhandled Ada exceptions
11544 . catchpoints on failed assertions
11546 Exceptions raised during failed assertions, or unhandled exceptions
11547 could perfectly be caught with the general catchpoint on Ada exceptions.
11548 However, we can easily differentiate these two special cases, and having
11549 the option to distinguish these two cases from the rest can be useful
11550 to zero-in on certain situations.
11552 Exception catchpoints are a specialized form of breakpoint,
11553 since they rely on inserting breakpoints inside known routines
11554 of the GNAT runtime. The implementation therefore uses a standard
11555 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11558 Support in the runtime for exception catchpoints have been changed
11559 a few times already, and these changes affect the implementation
11560 of these catchpoints. In order to be able to support several
11561 variants of the runtime, we use a sniffer that will determine
11562 the runtime variant used by the program being debugged. */
11564 /* Ada's standard exceptions.
11566 The Ada 83 standard also defined Numeric_Error. But there so many
11567 situations where it was unclear from the Ada 83 Reference Manual
11568 (RM) whether Constraint_Error or Numeric_Error should be raised,
11569 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11570 Interpretation saying that anytime the RM says that Numeric_Error
11571 should be raised, the implementation may raise Constraint_Error.
11572 Ada 95 went one step further and pretty much removed Numeric_Error
11573 from the list of standard exceptions (it made it a renaming of
11574 Constraint_Error, to help preserve compatibility when compiling
11575 an Ada83 compiler). As such, we do not include Numeric_Error from
11576 this list of standard exceptions. */
11578 static const char * const standard_exc
[] = {
11579 "constraint_error",
11585 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11587 /* A structure that describes how to support exception catchpoints
11588 for a given executable. */
11590 struct exception_support_info
11592 /* The name of the symbol to break on in order to insert
11593 a catchpoint on exceptions. */
11594 const char *catch_exception_sym
;
11596 /* The name of the symbol to break on in order to insert
11597 a catchpoint on unhandled exceptions. */
11598 const char *catch_exception_unhandled_sym
;
11600 /* The name of the symbol to break on in order to insert
11601 a catchpoint on failed assertions. */
11602 const char *catch_assert_sym
;
11604 /* The name of the symbol to break on in order to insert
11605 a catchpoint on exception handling. */
11606 const char *catch_handlers_sym
;
11608 /* Assuming that the inferior just triggered an unhandled exception
11609 catchpoint, this function is responsible for returning the address
11610 in inferior memory where the name of that exception is stored.
11611 Return zero if the address could not be computed. */
11612 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11615 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11616 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11618 /* The following exception support info structure describes how to
11619 implement exception catchpoints with the latest version of the
11620 Ada runtime (as of 2019-08-??). */
11622 static const struct exception_support_info default_exception_support_info
=
11624 "__gnat_debug_raise_exception", /* catch_exception_sym */
11625 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11626 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11627 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11628 ada_unhandled_exception_name_addr
11631 /* The following exception support info structure describes how to
11632 implement exception catchpoints with an earlier version of the
11633 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11635 static const struct exception_support_info exception_support_info_v0
=
11637 "__gnat_debug_raise_exception", /* catch_exception_sym */
11638 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11639 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11640 "__gnat_begin_handler", /* catch_handlers_sym */
11641 ada_unhandled_exception_name_addr
11644 /* The following exception support info structure describes how to
11645 implement exception catchpoints with a slightly older version
11646 of the Ada runtime. */
11648 static const struct exception_support_info exception_support_info_fallback
=
11650 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11651 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11652 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11653 "__gnat_begin_handler", /* catch_handlers_sym */
11654 ada_unhandled_exception_name_addr_from_raise
11657 /* Return nonzero if we can detect the exception support routines
11658 described in EINFO.
11660 This function errors out if an abnormal situation is detected
11661 (for instance, if we find the exception support routines, but
11662 that support is found to be incomplete). */
11665 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11667 struct symbol
*sym
;
11669 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11670 that should be compiled with debugging information. As a result, we
11671 expect to find that symbol in the symtabs. */
11673 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11676 /* Perhaps we did not find our symbol because the Ada runtime was
11677 compiled without debugging info, or simply stripped of it.
11678 It happens on some GNU/Linux distributions for instance, where
11679 users have to install a separate debug package in order to get
11680 the runtime's debugging info. In that situation, let the user
11681 know why we cannot insert an Ada exception catchpoint.
11683 Note: Just for the purpose of inserting our Ada exception
11684 catchpoint, we could rely purely on the associated minimal symbol.
11685 But we would be operating in degraded mode anyway, since we are
11686 still lacking the debugging info needed later on to extract
11687 the name of the exception being raised (this name is printed in
11688 the catchpoint message, and is also used when trying to catch
11689 a specific exception). We do not handle this case for now. */
11690 struct bound_minimal_symbol msym
11691 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11693 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11694 error (_("Your Ada runtime appears to be missing some debugging "
11695 "information.\nCannot insert Ada exception catchpoint "
11696 "in this configuration."));
11701 /* Make sure that the symbol we found corresponds to a function. */
11703 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11705 error (_("Symbol \"%s\" is not a function (class = %d)"),
11706 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11710 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11713 struct bound_minimal_symbol msym
11714 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11716 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11717 error (_("Your Ada runtime appears to be missing some debugging "
11718 "information.\nCannot insert Ada exception catchpoint "
11719 "in this configuration."));
11724 /* Make sure that the symbol we found corresponds to a function. */
11726 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11728 error (_("Symbol \"%s\" is not a function (class = %d)"),
11729 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11736 /* Inspect the Ada runtime and determine which exception info structure
11737 should be used to provide support for exception catchpoints.
11739 This function will always set the per-inferior exception_info,
11740 or raise an error. */
11743 ada_exception_support_info_sniffer (void)
11745 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11747 /* If the exception info is already known, then no need to recompute it. */
11748 if (data
->exception_info
!= NULL
)
11751 /* Check the latest (default) exception support info. */
11752 if (ada_has_this_exception_support (&default_exception_support_info
))
11754 data
->exception_info
= &default_exception_support_info
;
11758 /* Try the v0 exception suport info. */
11759 if (ada_has_this_exception_support (&exception_support_info_v0
))
11761 data
->exception_info
= &exception_support_info_v0
;
11765 /* Try our fallback exception suport info. */
11766 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11768 data
->exception_info
= &exception_support_info_fallback
;
11772 /* Sometimes, it is normal for us to not be able to find the routine
11773 we are looking for. This happens when the program is linked with
11774 the shared version of the GNAT runtime, and the program has not been
11775 started yet. Inform the user of these two possible causes if
11778 if (ada_update_initial_language (language_unknown
) != language_ada
)
11779 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11781 /* If the symbol does not exist, then check that the program is
11782 already started, to make sure that shared libraries have been
11783 loaded. If it is not started, this may mean that the symbol is
11784 in a shared library. */
11786 if (inferior_ptid
.pid () == 0)
11787 error (_("Unable to insert catchpoint. Try to start the program first."));
11789 /* At this point, we know that we are debugging an Ada program and
11790 that the inferior has been started, but we still are not able to
11791 find the run-time symbols. That can mean that we are in
11792 configurable run time mode, or that a-except as been optimized
11793 out by the linker... In any case, at this point it is not worth
11794 supporting this feature. */
11796 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11799 /* True iff FRAME is very likely to be that of a function that is
11800 part of the runtime system. This is all very heuristic, but is
11801 intended to be used as advice as to what frames are uninteresting
11805 is_known_support_routine (struct frame_info
*frame
)
11807 enum language func_lang
;
11809 const char *fullname
;
11811 /* If this code does not have any debugging information (no symtab),
11812 This cannot be any user code. */
11814 symtab_and_line sal
= find_frame_sal (frame
);
11815 if (sal
.symtab
== NULL
)
11818 /* If there is a symtab, but the associated source file cannot be
11819 located, then assume this is not user code: Selecting a frame
11820 for which we cannot display the code would not be very helpful
11821 for the user. This should also take care of case such as VxWorks
11822 where the kernel has some debugging info provided for a few units. */
11824 fullname
= symtab_to_fullname (sal
.symtab
);
11825 if (access (fullname
, R_OK
) != 0)
11828 /* Check the unit filename against the Ada runtime file naming.
11829 We also check the name of the objfile against the name of some
11830 known system libraries that sometimes come with debugging info
11833 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11835 re_comp (known_runtime_file_name_patterns
[i
]);
11836 if (re_exec (lbasename (sal
.symtab
->filename
)))
11838 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11839 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11843 /* Check whether the function is a GNAT-generated entity. */
11845 gdb::unique_xmalloc_ptr
<char> func_name
11846 = find_frame_funname (frame
, &func_lang
, NULL
);
11847 if (func_name
== NULL
)
11850 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11852 re_comp (known_auxiliary_function_name_patterns
[i
]);
11853 if (re_exec (func_name
.get ()))
11860 /* Find the first frame that contains debugging information and that is not
11861 part of the Ada run-time, starting from FI and moving upward. */
11864 ada_find_printable_frame (struct frame_info
*fi
)
11866 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11868 if (!is_known_support_routine (fi
))
11877 /* Assuming that the inferior just triggered an unhandled exception
11878 catchpoint, return the address in inferior memory where the name
11879 of the exception is stored.
11881 Return zero if the address could not be computed. */
11884 ada_unhandled_exception_name_addr (void)
11886 return parse_and_eval_address ("e.full_name");
11889 /* Same as ada_unhandled_exception_name_addr, except that this function
11890 should be used when the inferior uses an older version of the runtime,
11891 where the exception name needs to be extracted from a specific frame
11892 several frames up in the callstack. */
11895 ada_unhandled_exception_name_addr_from_raise (void)
11898 struct frame_info
*fi
;
11899 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11901 /* To determine the name of this exception, we need to select
11902 the frame corresponding to RAISE_SYM_NAME. This frame is
11903 at least 3 levels up, so we simply skip the first 3 frames
11904 without checking the name of their associated function. */
11905 fi
= get_current_frame ();
11906 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11908 fi
= get_prev_frame (fi
);
11912 enum language func_lang
;
11914 gdb::unique_xmalloc_ptr
<char> func_name
11915 = find_frame_funname (fi
, &func_lang
, NULL
);
11916 if (func_name
!= NULL
)
11918 if (strcmp (func_name
.get (),
11919 data
->exception_info
->catch_exception_sym
) == 0)
11920 break; /* We found the frame we were looking for... */
11922 fi
= get_prev_frame (fi
);
11929 return parse_and_eval_address ("id.full_name");
11932 /* Assuming the inferior just triggered an Ada exception catchpoint
11933 (of any type), return the address in inferior memory where the name
11934 of the exception is stored, if applicable.
11936 Assumes the selected frame is the current frame.
11938 Return zero if the address could not be computed, or if not relevant. */
11941 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11942 struct breakpoint
*b
)
11944 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11948 case ada_catch_exception
:
11949 return (parse_and_eval_address ("e.full_name"));
11952 case ada_catch_exception_unhandled
:
11953 return data
->exception_info
->unhandled_exception_name_addr ();
11956 case ada_catch_handlers
:
11957 return 0; /* The runtimes does not provide access to the exception
11961 case ada_catch_assert
:
11962 return 0; /* Exception name is not relevant in this case. */
11966 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11970 return 0; /* Should never be reached. */
11973 /* Assuming the inferior is stopped at an exception catchpoint,
11974 return the message which was associated to the exception, if
11975 available. Return NULL if the message could not be retrieved.
11977 Note: The exception message can be associated to an exception
11978 either through the use of the Raise_Exception function, or
11979 more simply (Ada 2005 and later), via:
11981 raise Exception_Name with "exception message";
11985 static gdb::unique_xmalloc_ptr
<char>
11986 ada_exception_message_1 (void)
11988 struct value
*e_msg_val
;
11991 /* For runtimes that support this feature, the exception message
11992 is passed as an unbounded string argument called "message". */
11993 e_msg_val
= parse_and_eval ("message");
11994 if (e_msg_val
== NULL
)
11995 return NULL
; /* Exception message not supported. */
11997 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11998 gdb_assert (e_msg_val
!= NULL
);
11999 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12001 /* If the message string is empty, then treat it as if there was
12002 no exception message. */
12003 if (e_msg_len
<= 0)
12006 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12007 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
12009 e_msg
.get ()[e_msg_len
] = '\0';
12014 /* Same as ada_exception_message_1, except that all exceptions are
12015 contained here (returning NULL instead). */
12017 static gdb::unique_xmalloc_ptr
<char>
12018 ada_exception_message (void)
12020 gdb::unique_xmalloc_ptr
<char> e_msg
;
12024 e_msg
= ada_exception_message_1 ();
12026 catch (const gdb_exception_error
&e
)
12028 e_msg
.reset (nullptr);
12034 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12035 any error that ada_exception_name_addr_1 might cause to be thrown.
12036 When an error is intercepted, a warning with the error message is printed,
12037 and zero is returned. */
12040 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12041 struct breakpoint
*b
)
12043 CORE_ADDR result
= 0;
12047 result
= ada_exception_name_addr_1 (ex
, b
);
12050 catch (const gdb_exception_error
&e
)
12052 warning (_("failed to get exception name: %s"), e
.what ());
12059 static std::string ada_exception_catchpoint_cond_string
12060 (const char *excep_string
,
12061 enum ada_exception_catchpoint_kind ex
);
12063 /* Ada catchpoints.
12065 In the case of catchpoints on Ada exceptions, the catchpoint will
12066 stop the target on every exception the program throws. When a user
12067 specifies the name of a specific exception, we translate this
12068 request into a condition expression (in text form), and then parse
12069 it into an expression stored in each of the catchpoint's locations.
12070 We then use this condition to check whether the exception that was
12071 raised is the one the user is interested in. If not, then the
12072 target is resumed again. We store the name of the requested
12073 exception, in order to be able to re-set the condition expression
12074 when symbols change. */
12076 /* An instance of this type is used to represent an Ada catchpoint
12077 breakpoint location. */
12079 class ada_catchpoint_location
: public bp_location
12082 ada_catchpoint_location (breakpoint
*owner
)
12083 : bp_location (owner
, bp_loc_software_breakpoint
)
12086 /* The condition that checks whether the exception that was raised
12087 is the specific exception the user specified on catchpoint
12089 expression_up excep_cond_expr
;
12092 /* An instance of this type is used to represent an Ada catchpoint. */
12094 struct ada_catchpoint
: public breakpoint
12096 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12101 /* The name of the specific exception the user specified. */
12102 std::string excep_string
;
12104 /* What kind of catchpoint this is. */
12105 enum ada_exception_catchpoint_kind m_kind
;
12108 /* Parse the exception condition string in the context of each of the
12109 catchpoint's locations, and store them for later evaluation. */
12112 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12113 enum ada_exception_catchpoint_kind ex
)
12115 struct bp_location
*bl
;
12117 /* Nothing to do if there's no specific exception to catch. */
12118 if (c
->excep_string
.empty ())
12121 /* Same if there are no locations... */
12122 if (c
->loc
== NULL
)
12125 /* Compute the condition expression in text form, from the specific
12126 expection we want to catch. */
12127 std::string cond_string
12128 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12130 /* Iterate over all the catchpoint's locations, and parse an
12131 expression for each. */
12132 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12134 struct ada_catchpoint_location
*ada_loc
12135 = (struct ada_catchpoint_location
*) bl
;
12138 if (!bl
->shlib_disabled
)
12142 s
= cond_string
.c_str ();
12145 exp
= parse_exp_1 (&s
, bl
->address
,
12146 block_for_pc (bl
->address
),
12149 catch (const gdb_exception_error
&e
)
12151 warning (_("failed to reevaluate internal exception condition "
12152 "for catchpoint %d: %s"),
12153 c
->number
, e
.what ());
12157 ada_loc
->excep_cond_expr
= std::move (exp
);
12161 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12162 structure for all exception catchpoint kinds. */
12164 static struct bp_location
*
12165 allocate_location_exception (struct breakpoint
*self
)
12167 return new ada_catchpoint_location (self
);
12170 /* Implement the RE_SET method in the breakpoint_ops structure for all
12171 exception catchpoint kinds. */
12174 re_set_exception (struct breakpoint
*b
)
12176 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12178 /* Call the base class's method. This updates the catchpoint's
12180 bkpt_breakpoint_ops
.re_set (b
);
12182 /* Reparse the exception conditional expressions. One for each
12184 create_excep_cond_exprs (c
, c
->m_kind
);
12187 /* Returns true if we should stop for this breakpoint hit. If the
12188 user specified a specific exception, we only want to cause a stop
12189 if the program thrown that exception. */
12192 should_stop_exception (const struct bp_location
*bl
)
12194 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12195 const struct ada_catchpoint_location
*ada_loc
12196 = (const struct ada_catchpoint_location
*) bl
;
12199 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12200 if (c
->m_kind
== ada_catch_assert
)
12201 clear_internalvar (var
);
12208 if (c
->m_kind
== ada_catch_handlers
)
12209 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12210 ".all.occurrence.id");
12214 struct value
*exc
= parse_and_eval (expr
);
12215 set_internalvar (var
, exc
);
12217 catch (const gdb_exception_error
&ex
)
12219 clear_internalvar (var
);
12223 /* With no specific exception, should always stop. */
12224 if (c
->excep_string
.empty ())
12227 if (ada_loc
->excep_cond_expr
== NULL
)
12229 /* We will have a NULL expression if back when we were creating
12230 the expressions, this location's had failed to parse. */
12237 struct value
*mark
;
12239 mark
= value_mark ();
12240 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12241 value_free_to_mark (mark
);
12243 catch (const gdb_exception
&ex
)
12245 exception_fprintf (gdb_stderr
, ex
,
12246 _("Error in testing exception condition:\n"));
12252 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12253 for all exception catchpoint kinds. */
12256 check_status_exception (bpstat bs
)
12258 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12261 /* Implement the PRINT_IT method in the breakpoint_ops structure
12262 for all exception catchpoint kinds. */
12264 static enum print_stop_action
12265 print_it_exception (bpstat bs
)
12267 struct ui_out
*uiout
= current_uiout
;
12268 struct breakpoint
*b
= bs
->breakpoint_at
;
12270 annotate_catchpoint (b
->number
);
12272 if (uiout
->is_mi_like_p ())
12274 uiout
->field_string ("reason",
12275 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12276 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12279 uiout
->text (b
->disposition
== disp_del
12280 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12281 uiout
->field_signed ("bkptno", b
->number
);
12282 uiout
->text (", ");
12284 /* ada_exception_name_addr relies on the selected frame being the
12285 current frame. Need to do this here because this function may be
12286 called more than once when printing a stop, and below, we'll
12287 select the first frame past the Ada run-time (see
12288 ada_find_printable_frame). */
12289 select_frame (get_current_frame ());
12291 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12294 case ada_catch_exception
:
12295 case ada_catch_exception_unhandled
:
12296 case ada_catch_handlers
:
12298 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12299 char exception_name
[256];
12303 read_memory (addr
, (gdb_byte
*) exception_name
,
12304 sizeof (exception_name
) - 1);
12305 exception_name
[sizeof (exception_name
) - 1] = '\0';
12309 /* For some reason, we were unable to read the exception
12310 name. This could happen if the Runtime was compiled
12311 without debugging info, for instance. In that case,
12312 just replace the exception name by the generic string
12313 "exception" - it will read as "an exception" in the
12314 notification we are about to print. */
12315 memcpy (exception_name
, "exception", sizeof ("exception"));
12317 /* In the case of unhandled exception breakpoints, we print
12318 the exception name as "unhandled EXCEPTION_NAME", to make
12319 it clearer to the user which kind of catchpoint just got
12320 hit. We used ui_out_text to make sure that this extra
12321 info does not pollute the exception name in the MI case. */
12322 if (c
->m_kind
== ada_catch_exception_unhandled
)
12323 uiout
->text ("unhandled ");
12324 uiout
->field_string ("exception-name", exception_name
);
12327 case ada_catch_assert
:
12328 /* In this case, the name of the exception is not really
12329 important. Just print "failed assertion" to make it clearer
12330 that his program just hit an assertion-failure catchpoint.
12331 We used ui_out_text because this info does not belong in
12333 uiout
->text ("failed assertion");
12337 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12338 if (exception_message
!= NULL
)
12340 uiout
->text (" (");
12341 uiout
->field_string ("exception-message", exception_message
.get ());
12345 uiout
->text (" at ");
12346 ada_find_printable_frame (get_current_frame ());
12348 return PRINT_SRC_AND_LOC
;
12351 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12352 for all exception catchpoint kinds. */
12355 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12357 struct ui_out
*uiout
= current_uiout
;
12358 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12359 struct value_print_options opts
;
12361 get_user_print_options (&opts
);
12363 if (opts
.addressprint
)
12364 uiout
->field_skip ("addr");
12366 annotate_field (5);
12369 case ada_catch_exception
:
12370 if (!c
->excep_string
.empty ())
12372 std::string msg
= string_printf (_("`%s' Ada exception"),
12373 c
->excep_string
.c_str ());
12375 uiout
->field_string ("what", msg
);
12378 uiout
->field_string ("what", "all Ada exceptions");
12382 case ada_catch_exception_unhandled
:
12383 uiout
->field_string ("what", "unhandled Ada exceptions");
12386 case ada_catch_handlers
:
12387 if (!c
->excep_string
.empty ())
12389 uiout
->field_fmt ("what",
12390 _("`%s' Ada exception handlers"),
12391 c
->excep_string
.c_str ());
12394 uiout
->field_string ("what", "all Ada exceptions handlers");
12397 case ada_catch_assert
:
12398 uiout
->field_string ("what", "failed Ada assertions");
12402 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12407 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12408 for all exception catchpoint kinds. */
12411 print_mention_exception (struct breakpoint
*b
)
12413 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12414 struct ui_out
*uiout
= current_uiout
;
12416 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12417 : _("Catchpoint "));
12418 uiout
->field_signed ("bkptno", b
->number
);
12419 uiout
->text (": ");
12423 case ada_catch_exception
:
12424 if (!c
->excep_string
.empty ())
12426 std::string info
= string_printf (_("`%s' Ada exception"),
12427 c
->excep_string
.c_str ());
12428 uiout
->text (info
.c_str ());
12431 uiout
->text (_("all Ada exceptions"));
12434 case ada_catch_exception_unhandled
:
12435 uiout
->text (_("unhandled Ada exceptions"));
12438 case ada_catch_handlers
:
12439 if (!c
->excep_string
.empty ())
12442 = string_printf (_("`%s' Ada exception handlers"),
12443 c
->excep_string
.c_str ());
12444 uiout
->text (info
.c_str ());
12447 uiout
->text (_("all Ada exceptions handlers"));
12450 case ada_catch_assert
:
12451 uiout
->text (_("failed Ada assertions"));
12455 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12460 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12461 for all exception catchpoint kinds. */
12464 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12466 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12470 case ada_catch_exception
:
12471 fprintf_filtered (fp
, "catch exception");
12472 if (!c
->excep_string
.empty ())
12473 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12476 case ada_catch_exception_unhandled
:
12477 fprintf_filtered (fp
, "catch exception unhandled");
12480 case ada_catch_handlers
:
12481 fprintf_filtered (fp
, "catch handlers");
12484 case ada_catch_assert
:
12485 fprintf_filtered (fp
, "catch assert");
12489 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12491 print_recreate_thread (b
, fp
);
12494 /* Virtual tables for various breakpoint types. */
12495 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12496 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12497 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12498 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12500 /* See ada-lang.h. */
12503 is_ada_exception_catchpoint (breakpoint
*bp
)
12505 return (bp
->ops
== &catch_exception_breakpoint_ops
12506 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12507 || bp
->ops
== &catch_assert_breakpoint_ops
12508 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12511 /* Split the arguments specified in a "catch exception" command.
12512 Set EX to the appropriate catchpoint type.
12513 Set EXCEP_STRING to the name of the specific exception if
12514 specified by the user.
12515 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12516 "catch handlers" command. False otherwise.
12517 If a condition is found at the end of the arguments, the condition
12518 expression is stored in COND_STRING (memory must be deallocated
12519 after use). Otherwise COND_STRING is set to NULL. */
12522 catch_ada_exception_command_split (const char *args
,
12523 bool is_catch_handlers_cmd
,
12524 enum ada_exception_catchpoint_kind
*ex
,
12525 std::string
*excep_string
,
12526 std::string
*cond_string
)
12528 std::string exception_name
;
12530 exception_name
= extract_arg (&args
);
12531 if (exception_name
== "if")
12533 /* This is not an exception name; this is the start of a condition
12534 expression for a catchpoint on all exceptions. So, "un-get"
12535 this token, and set exception_name to NULL. */
12536 exception_name
.clear ();
12540 /* Check to see if we have a condition. */
12542 args
= skip_spaces (args
);
12543 if (startswith (args
, "if")
12544 && (isspace (args
[2]) || args
[2] == '\0'))
12547 args
= skip_spaces (args
);
12549 if (args
[0] == '\0')
12550 error (_("Condition missing after `if' keyword"));
12551 *cond_string
= args
;
12553 args
+= strlen (args
);
12556 /* Check that we do not have any more arguments. Anything else
12559 if (args
[0] != '\0')
12560 error (_("Junk at end of expression"));
12562 if (is_catch_handlers_cmd
)
12564 /* Catch handling of exceptions. */
12565 *ex
= ada_catch_handlers
;
12566 *excep_string
= exception_name
;
12568 else if (exception_name
.empty ())
12570 /* Catch all exceptions. */
12571 *ex
= ada_catch_exception
;
12572 excep_string
->clear ();
12574 else if (exception_name
== "unhandled")
12576 /* Catch unhandled exceptions. */
12577 *ex
= ada_catch_exception_unhandled
;
12578 excep_string
->clear ();
12582 /* Catch a specific exception. */
12583 *ex
= ada_catch_exception
;
12584 *excep_string
= exception_name
;
12588 /* Return the name of the symbol on which we should break in order to
12589 implement a catchpoint of the EX kind. */
12591 static const char *
12592 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12594 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12596 gdb_assert (data
->exception_info
!= NULL
);
12600 case ada_catch_exception
:
12601 return (data
->exception_info
->catch_exception_sym
);
12603 case ada_catch_exception_unhandled
:
12604 return (data
->exception_info
->catch_exception_unhandled_sym
);
12606 case ada_catch_assert
:
12607 return (data
->exception_info
->catch_assert_sym
);
12609 case ada_catch_handlers
:
12610 return (data
->exception_info
->catch_handlers_sym
);
12613 internal_error (__FILE__
, __LINE__
,
12614 _("unexpected catchpoint kind (%d)"), ex
);
12618 /* Return the breakpoint ops "virtual table" used for catchpoints
12621 static const struct breakpoint_ops
*
12622 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12626 case ada_catch_exception
:
12627 return (&catch_exception_breakpoint_ops
);
12629 case ada_catch_exception_unhandled
:
12630 return (&catch_exception_unhandled_breakpoint_ops
);
12632 case ada_catch_assert
:
12633 return (&catch_assert_breakpoint_ops
);
12635 case ada_catch_handlers
:
12636 return (&catch_handlers_breakpoint_ops
);
12639 internal_error (__FILE__
, __LINE__
,
12640 _("unexpected catchpoint kind (%d)"), ex
);
12644 /* Return the condition that will be used to match the current exception
12645 being raised with the exception that the user wants to catch. This
12646 assumes that this condition is used when the inferior just triggered
12647 an exception catchpoint.
12648 EX: the type of catchpoints used for catching Ada exceptions. */
12651 ada_exception_catchpoint_cond_string (const char *excep_string
,
12652 enum ada_exception_catchpoint_kind ex
)
12655 bool is_standard_exc
= false;
12656 std::string result
;
12658 if (ex
== ada_catch_handlers
)
12660 /* For exception handlers catchpoints, the condition string does
12661 not use the same parameter as for the other exceptions. */
12662 result
= ("long_integer (GNAT_GCC_exception_Access"
12663 "(gcc_exception).all.occurrence.id)");
12666 result
= "long_integer (e)";
12668 /* The standard exceptions are a special case. They are defined in
12669 runtime units that have been compiled without debugging info; if
12670 EXCEP_STRING is the not-fully-qualified name of a standard
12671 exception (e.g. "constraint_error") then, during the evaluation
12672 of the condition expression, the symbol lookup on this name would
12673 *not* return this standard exception. The catchpoint condition
12674 may then be set only on user-defined exceptions which have the
12675 same not-fully-qualified name (e.g. my_package.constraint_error).
12677 To avoid this unexcepted behavior, these standard exceptions are
12678 systematically prefixed by "standard". This means that "catch
12679 exception constraint_error" is rewritten into "catch exception
12680 standard.constraint_error".
12682 If an exception named constraint_error is defined in another package of
12683 the inferior program, then the only way to specify this exception as a
12684 breakpoint condition is to use its fully-qualified named:
12685 e.g. my_package.constraint_error. */
12687 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12689 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12691 is_standard_exc
= true;
12698 if (is_standard_exc
)
12699 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12701 string_appendf (result
, "long_integer (&%s)", excep_string
);
12706 /* Return the symtab_and_line that should be used to insert an exception
12707 catchpoint of the TYPE kind.
12709 ADDR_STRING returns the name of the function where the real
12710 breakpoint that implements the catchpoints is set, depending on the
12711 type of catchpoint we need to create. */
12713 static struct symtab_and_line
12714 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12715 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12717 const char *sym_name
;
12718 struct symbol
*sym
;
12720 /* First, find out which exception support info to use. */
12721 ada_exception_support_info_sniffer ();
12723 /* Then lookup the function on which we will break in order to catch
12724 the Ada exceptions requested by the user. */
12725 sym_name
= ada_exception_sym_name (ex
);
12726 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12729 error (_("Catchpoint symbol not found: %s"), sym_name
);
12731 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12732 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12734 /* Set ADDR_STRING. */
12735 *addr_string
= sym_name
;
12738 *ops
= ada_exception_breakpoint_ops (ex
);
12740 return find_function_start_sal (sym
, 1);
12743 /* Create an Ada exception catchpoint.
12745 EX_KIND is the kind of exception catchpoint to be created.
12747 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12748 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12749 of the exception to which this catchpoint applies.
12751 COND_STRING, if not empty, is the catchpoint condition.
12753 TEMPFLAG, if nonzero, means that the underlying breakpoint
12754 should be temporary.
12756 FROM_TTY is the usual argument passed to all commands implementations. */
12759 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12760 enum ada_exception_catchpoint_kind ex_kind
,
12761 const std::string
&excep_string
,
12762 const std::string
&cond_string
,
12767 std::string addr_string
;
12768 const struct breakpoint_ops
*ops
= NULL
;
12769 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12771 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12772 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12773 ops
, tempflag
, disabled
, from_tty
);
12774 c
->excep_string
= excep_string
;
12775 create_excep_cond_exprs (c
.get (), ex_kind
);
12776 if (!cond_string
.empty ())
12777 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12778 install_breakpoint (0, std::move (c
), 1);
12781 /* Implement the "catch exception" command. */
12784 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12785 struct cmd_list_element
*command
)
12787 const char *arg
= arg_entry
;
12788 struct gdbarch
*gdbarch
= get_current_arch ();
12790 enum ada_exception_catchpoint_kind ex_kind
;
12791 std::string excep_string
;
12792 std::string cond_string
;
12794 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12798 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12800 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12801 excep_string
, cond_string
,
12802 tempflag
, 1 /* enabled */,
12806 /* Implement the "catch handlers" command. */
12809 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12810 struct cmd_list_element
*command
)
12812 const char *arg
= arg_entry
;
12813 struct gdbarch
*gdbarch
= get_current_arch ();
12815 enum ada_exception_catchpoint_kind ex_kind
;
12816 std::string excep_string
;
12817 std::string cond_string
;
12819 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12823 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12825 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12826 excep_string
, cond_string
,
12827 tempflag
, 1 /* enabled */,
12831 /* Completion function for the Ada "catch" commands. */
12834 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12835 const char *text
, const char *word
)
12837 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12839 for (const ada_exc_info
&info
: exceptions
)
12841 if (startswith (info
.name
, word
))
12842 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12846 /* Split the arguments specified in a "catch assert" command.
12848 ARGS contains the command's arguments (or the empty string if
12849 no arguments were passed).
12851 If ARGS contains a condition, set COND_STRING to that condition
12852 (the memory needs to be deallocated after use). */
12855 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12857 args
= skip_spaces (args
);
12859 /* Check whether a condition was provided. */
12860 if (startswith (args
, "if")
12861 && (isspace (args
[2]) || args
[2] == '\0'))
12864 args
= skip_spaces (args
);
12865 if (args
[0] == '\0')
12866 error (_("condition missing after `if' keyword"));
12867 cond_string
.assign (args
);
12870 /* Otherwise, there should be no other argument at the end of
12872 else if (args
[0] != '\0')
12873 error (_("Junk at end of arguments."));
12876 /* Implement the "catch assert" command. */
12879 catch_assert_command (const char *arg_entry
, int from_tty
,
12880 struct cmd_list_element
*command
)
12882 const char *arg
= arg_entry
;
12883 struct gdbarch
*gdbarch
= get_current_arch ();
12885 std::string cond_string
;
12887 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12891 catch_ada_assert_command_split (arg
, cond_string
);
12892 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12894 tempflag
, 1 /* enabled */,
12898 /* Return non-zero if the symbol SYM is an Ada exception object. */
12901 ada_is_exception_sym (struct symbol
*sym
)
12903 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12905 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12906 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12907 && SYMBOL_CLASS (sym
) != LOC_CONST
12908 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12909 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12912 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12913 Ada exception object. This matches all exceptions except the ones
12914 defined by the Ada language. */
12917 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12921 if (!ada_is_exception_sym (sym
))
12924 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12925 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12926 return 0; /* A standard exception. */
12928 /* Numeric_Error is also a standard exception, so exclude it.
12929 See the STANDARD_EXC description for more details as to why
12930 this exception is not listed in that array. */
12931 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12937 /* A helper function for std::sort, comparing two struct ada_exc_info
12940 The comparison is determined first by exception name, and then
12941 by exception address. */
12944 ada_exc_info::operator< (const ada_exc_info
&other
) const
12948 result
= strcmp (name
, other
.name
);
12951 if (result
== 0 && addr
< other
.addr
)
12957 ada_exc_info::operator== (const ada_exc_info
&other
) const
12959 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12962 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12963 routine, but keeping the first SKIP elements untouched.
12965 All duplicates are also removed. */
12968 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12971 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12972 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12973 exceptions
->end ());
12976 /* Add all exceptions defined by the Ada standard whose name match
12977 a regular expression.
12979 If PREG is not NULL, then this regexp_t object is used to
12980 perform the symbol name matching. Otherwise, no name-based
12981 filtering is performed.
12983 EXCEPTIONS is a vector of exceptions to which matching exceptions
12987 ada_add_standard_exceptions (compiled_regex
*preg
,
12988 std::vector
<ada_exc_info
> *exceptions
)
12992 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12995 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12997 struct bound_minimal_symbol msymbol
12998 = ada_lookup_simple_minsym (standard_exc
[i
]);
13000 if (msymbol
.minsym
!= NULL
)
13002 struct ada_exc_info info
13003 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13005 exceptions
->push_back (info
);
13011 /* Add all Ada exceptions defined locally and accessible from the given
13014 If PREG is not NULL, then this regexp_t object is used to
13015 perform the symbol name matching. Otherwise, no name-based
13016 filtering is performed.
13018 EXCEPTIONS is a vector of exceptions to which matching exceptions
13022 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13023 struct frame_info
*frame
,
13024 std::vector
<ada_exc_info
> *exceptions
)
13026 const struct block
*block
= get_frame_block (frame
, 0);
13030 struct block_iterator iter
;
13031 struct symbol
*sym
;
13033 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13035 switch (SYMBOL_CLASS (sym
))
13042 if (ada_is_exception_sym (sym
))
13044 struct ada_exc_info info
= {sym
->print_name (),
13045 SYMBOL_VALUE_ADDRESS (sym
)};
13047 exceptions
->push_back (info
);
13051 if (BLOCK_FUNCTION (block
) != NULL
)
13053 block
= BLOCK_SUPERBLOCK (block
);
13057 /* Return true if NAME matches PREG or if PREG is NULL. */
13060 name_matches_regex (const char *name
, compiled_regex
*preg
)
13062 return (preg
== NULL
13063 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13066 /* Add all exceptions defined globally whose name name match
13067 a regular expression, excluding standard exceptions.
13069 The reason we exclude standard exceptions is that they need
13070 to be handled separately: Standard exceptions are defined inside
13071 a runtime unit which is normally not compiled with debugging info,
13072 and thus usually do not show up in our symbol search. However,
13073 if the unit was in fact built with debugging info, we need to
13074 exclude them because they would duplicate the entry we found
13075 during the special loop that specifically searches for those
13076 standard exceptions.
13078 If PREG is not NULL, then this regexp_t object is used to
13079 perform the symbol name matching. Otherwise, no name-based
13080 filtering is performed.
13082 EXCEPTIONS is a vector of exceptions to which matching exceptions
13086 ada_add_global_exceptions (compiled_regex
*preg
,
13087 std::vector
<ada_exc_info
> *exceptions
)
13089 /* In Ada, the symbol "search name" is a linkage name, whereas the
13090 regular expression used to do the matching refers to the natural
13091 name. So match against the decoded name. */
13092 expand_symtabs_matching (NULL
,
13093 lookup_name_info::match_any (),
13094 [&] (const char *search_name
)
13096 std::string decoded
= ada_decode (search_name
);
13097 return name_matches_regex (decoded
.c_str (), preg
);
13102 for (objfile
*objfile
: current_program_space
->objfiles ())
13104 for (compunit_symtab
*s
: objfile
->compunits ())
13106 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13109 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13111 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13112 struct block_iterator iter
;
13113 struct symbol
*sym
;
13115 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13116 if (ada_is_non_standard_exception_sym (sym
)
13117 && name_matches_regex (sym
->natural_name (), preg
))
13119 struct ada_exc_info info
13120 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13122 exceptions
->push_back (info
);
13129 /* Implements ada_exceptions_list with the regular expression passed
13130 as a regex_t, rather than a string.
13132 If not NULL, PREG is used to filter out exceptions whose names
13133 do not match. Otherwise, all exceptions are listed. */
13135 static std::vector
<ada_exc_info
>
13136 ada_exceptions_list_1 (compiled_regex
*preg
)
13138 std::vector
<ada_exc_info
> result
;
13141 /* First, list the known standard exceptions. These exceptions
13142 need to be handled separately, as they are usually defined in
13143 runtime units that have been compiled without debugging info. */
13145 ada_add_standard_exceptions (preg
, &result
);
13147 /* Next, find all exceptions whose scope is local and accessible
13148 from the currently selected frame. */
13150 if (has_stack_frames ())
13152 prev_len
= result
.size ();
13153 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13155 if (result
.size () > prev_len
)
13156 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13159 /* Add all exceptions whose scope is global. */
13161 prev_len
= result
.size ();
13162 ada_add_global_exceptions (preg
, &result
);
13163 if (result
.size () > prev_len
)
13164 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13169 /* Return a vector of ada_exc_info.
13171 If REGEXP is NULL, all exceptions are included in the result.
13172 Otherwise, it should contain a valid regular expression,
13173 and only the exceptions whose names match that regular expression
13174 are included in the result.
13176 The exceptions are sorted in the following order:
13177 - Standard exceptions (defined by the Ada language), in
13178 alphabetical order;
13179 - Exceptions only visible from the current frame, in
13180 alphabetical order;
13181 - Exceptions whose scope is global, in alphabetical order. */
13183 std::vector
<ada_exc_info
>
13184 ada_exceptions_list (const char *regexp
)
13186 if (regexp
== NULL
)
13187 return ada_exceptions_list_1 (NULL
);
13189 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13190 return ada_exceptions_list_1 (®
);
13193 /* Implement the "info exceptions" command. */
13196 info_exceptions_command (const char *regexp
, int from_tty
)
13198 struct gdbarch
*gdbarch
= get_current_arch ();
13200 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13202 if (regexp
!= NULL
)
13204 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13206 printf_filtered (_("All defined Ada exceptions:\n"));
13208 for (const ada_exc_info
&info
: exceptions
)
13209 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13213 /* Information about operators given special treatment in functions
13215 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13217 #define ADA_OPERATORS \
13218 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13219 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13220 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13221 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13222 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13223 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13224 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13225 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13226 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13227 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13228 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13229 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13230 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13231 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13232 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13233 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13234 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13235 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13236 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13239 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13242 switch (exp
->elts
[pc
- 1].opcode
)
13245 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13248 #define OP_DEFN(op, len, args, binop) \
13249 case op: *oplenp = len; *argsp = args; break;
13255 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13260 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13265 /* Implementation of the exp_descriptor method operator_check. */
13268 ada_operator_check (struct expression
*exp
, int pos
,
13269 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13272 const union exp_element
*const elts
= exp
->elts
;
13273 struct type
*type
= NULL
;
13275 switch (elts
[pos
].opcode
)
13277 case UNOP_IN_RANGE
:
13279 type
= elts
[pos
+ 1].type
;
13283 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13286 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13288 if (type
&& TYPE_OBJFILE (type
)
13289 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13295 /* As for operator_length, but assumes PC is pointing at the first
13296 element of the operator, and gives meaningful results only for the
13297 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13300 ada_forward_operator_length (struct expression
*exp
, int pc
,
13301 int *oplenp
, int *argsp
)
13303 switch (exp
->elts
[pc
].opcode
)
13306 *oplenp
= *argsp
= 0;
13309 #define OP_DEFN(op, len, args, binop) \
13310 case op: *oplenp = len; *argsp = args; break;
13316 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13321 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13327 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13329 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13337 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13339 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13344 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13348 /* Ada attributes ('Foo). */
13351 case OP_ATR_LENGTH
:
13355 case OP_ATR_MODULUS
:
13362 case UNOP_IN_RANGE
:
13364 /* XXX: gdb_sprint_host_address, type_sprint */
13365 fprintf_filtered (stream
, _("Type @"));
13366 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13367 fprintf_filtered (stream
, " (");
13368 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13369 fprintf_filtered (stream
, ")");
13371 case BINOP_IN_BOUNDS
:
13372 fprintf_filtered (stream
, " (%d)",
13373 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13375 case TERNOP_IN_RANGE
:
13380 case OP_DISCRETE_RANGE
:
13381 case OP_POSITIONAL
:
13388 char *name
= &exp
->elts
[elt
+ 2].string
;
13389 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13391 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13396 return dump_subexp_body_standard (exp
, stream
, elt
);
13400 for (i
= 0; i
< nargs
; i
+= 1)
13401 elt
= dump_subexp (exp
, stream
, elt
);
13406 /* The Ada extension of print_subexp (q.v.). */
13409 ada_print_subexp (struct expression
*exp
, int *pos
,
13410 struct ui_file
*stream
, enum precedence prec
)
13412 int oplen
, nargs
, i
;
13414 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13416 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13423 print_subexp_standard (exp
, pos
, stream
, prec
);
13427 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13430 case BINOP_IN_BOUNDS
:
13431 /* XXX: sprint_subexp */
13432 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13433 fputs_filtered (" in ", stream
);
13434 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13435 fputs_filtered ("'range", stream
);
13436 if (exp
->elts
[pc
+ 1].longconst
> 1)
13437 fprintf_filtered (stream
, "(%ld)",
13438 (long) exp
->elts
[pc
+ 1].longconst
);
13441 case TERNOP_IN_RANGE
:
13442 if (prec
>= PREC_EQUAL
)
13443 fputs_filtered ("(", stream
);
13444 /* XXX: sprint_subexp */
13445 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13446 fputs_filtered (" in ", stream
);
13447 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13448 fputs_filtered (" .. ", stream
);
13449 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13450 if (prec
>= PREC_EQUAL
)
13451 fputs_filtered (")", stream
);
13456 case OP_ATR_LENGTH
:
13460 case OP_ATR_MODULUS
:
13465 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13467 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13468 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13469 &type_print_raw_options
);
13473 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13474 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13479 for (tem
= 1; tem
< nargs
; tem
+= 1)
13481 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13482 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13484 fputs_filtered (")", stream
);
13489 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13490 fputs_filtered ("'(", stream
);
13491 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13492 fputs_filtered (")", stream
);
13495 case UNOP_IN_RANGE
:
13496 /* XXX: sprint_subexp */
13497 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13498 fputs_filtered (" in ", stream
);
13499 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13500 &type_print_raw_options
);
13503 case OP_DISCRETE_RANGE
:
13504 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13505 fputs_filtered ("..", stream
);
13506 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13510 fputs_filtered ("others => ", stream
);
13511 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13515 for (i
= 0; i
< nargs
-1; i
+= 1)
13518 fputs_filtered ("|", stream
);
13519 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13521 fputs_filtered (" => ", stream
);
13522 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13525 case OP_POSITIONAL
:
13526 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13530 fputs_filtered ("(", stream
);
13531 for (i
= 0; i
< nargs
; i
+= 1)
13534 fputs_filtered (", ", stream
);
13535 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13537 fputs_filtered (")", stream
);
13542 /* Table mapping opcodes into strings for printing operators
13543 and precedences of the operators. */
13545 static const struct op_print ada_op_print_tab
[] = {
13546 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13547 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13548 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13549 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13550 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13551 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13552 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13553 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13554 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13555 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13556 {">", BINOP_GTR
, PREC_ORDER
, 0},
13557 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13558 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13559 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13560 {"+", BINOP_ADD
, PREC_ADD
, 0},
13561 {"-", BINOP_SUB
, PREC_ADD
, 0},
13562 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13563 {"*", BINOP_MUL
, PREC_MUL
, 0},
13564 {"/", BINOP_DIV
, PREC_MUL
, 0},
13565 {"rem", BINOP_REM
, PREC_MUL
, 0},
13566 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13567 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13568 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13569 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13570 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13571 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13572 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13573 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13574 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13575 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13576 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13577 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13580 /* Language vector */
13582 static const struct exp_descriptor ada_exp_descriptor
= {
13584 ada_operator_length
,
13585 ada_operator_check
,
13586 ada_dump_subexp_body
,
13587 ada_evaluate_subexp
13590 /* symbol_name_matcher_ftype adapter for wild_match. */
13593 do_wild_match (const char *symbol_search_name
,
13594 const lookup_name_info
&lookup_name
,
13595 completion_match_result
*comp_match_res
)
13597 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13600 /* symbol_name_matcher_ftype adapter for full_match. */
13603 do_full_match (const char *symbol_search_name
,
13604 const lookup_name_info
&lookup_name
,
13605 completion_match_result
*comp_match_res
)
13607 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13610 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13613 do_exact_match (const char *symbol_search_name
,
13614 const lookup_name_info
&lookup_name
,
13615 completion_match_result
*comp_match_res
)
13617 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13620 /* Build the Ada lookup name for LOOKUP_NAME. */
13622 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13624 gdb::string_view user_name
= lookup_name
.name ();
13626 if (user_name
[0] == '<')
13628 if (user_name
.back () == '>')
13630 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13633 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13634 m_encoded_p
= true;
13635 m_verbatim_p
= true;
13636 m_wild_match_p
= false;
13637 m_standard_p
= false;
13641 m_verbatim_p
= false;
13643 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13647 const char *folded
= ada_fold_name (user_name
);
13648 m_encoded_name
= ada_encode_1 (folded
, false);
13649 if (m_encoded_name
.empty ())
13650 m_encoded_name
= gdb::to_string (user_name
);
13653 m_encoded_name
= gdb::to_string (user_name
);
13655 /* Handle the 'package Standard' special case. See description
13656 of m_standard_p. */
13657 if (startswith (m_encoded_name
.c_str (), "standard__"))
13659 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13660 m_standard_p
= true;
13663 m_standard_p
= false;
13665 /* If the name contains a ".", then the user is entering a fully
13666 qualified entity name, and the match must not be done in wild
13667 mode. Similarly, if the user wants to complete what looks
13668 like an encoded name, the match must not be done in wild
13669 mode. Also, in the standard__ special case always do
13670 non-wild matching. */
13672 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13675 && user_name
.find ('.') == std::string::npos
);
13679 /* symbol_name_matcher_ftype method for Ada. This only handles
13680 completion mode. */
13683 ada_symbol_name_matches (const char *symbol_search_name
,
13684 const lookup_name_info
&lookup_name
,
13685 completion_match_result
*comp_match_res
)
13687 return lookup_name
.ada ().matches (symbol_search_name
,
13688 lookup_name
.match_type (),
13692 /* A name matcher that matches the symbol name exactly, with
13696 literal_symbol_name_matcher (const char *symbol_search_name
,
13697 const lookup_name_info
&lookup_name
,
13698 completion_match_result
*comp_match_res
)
13700 gdb::string_view name_view
= lookup_name
.name ();
13702 if (lookup_name
.completion_mode ()
13703 ? (strncmp (symbol_search_name
, name_view
.data (),
13704 name_view
.size ()) == 0)
13705 : symbol_search_name
== name_view
)
13707 if (comp_match_res
!= NULL
)
13708 comp_match_res
->set_match (symbol_search_name
);
13715 /* Implement the "get_symbol_name_matcher" language_defn method for
13718 static symbol_name_matcher_ftype
*
13719 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13721 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13722 return literal_symbol_name_matcher
;
13724 if (lookup_name
.completion_mode ())
13725 return ada_symbol_name_matches
;
13728 if (lookup_name
.ada ().wild_match_p ())
13729 return do_wild_match
;
13730 else if (lookup_name
.ada ().verbatim_p ())
13731 return do_exact_match
;
13733 return do_full_match
;
13737 /* Class representing the Ada language. */
13739 class ada_language
: public language_defn
13743 : language_defn (language_ada
)
13746 /* See language.h. */
13748 const char *name () const override
13751 /* See language.h. */
13753 const char *natural_name () const override
13756 /* See language.h. */
13758 const std::vector
<const char *> &filename_extensions () const override
13760 static const std::vector
<const char *> extensions
13761 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13765 /* Print an array element index using the Ada syntax. */
13767 void print_array_index (struct type
*index_type
,
13769 struct ui_file
*stream
,
13770 const value_print_options
*options
) const override
13772 struct value
*index_value
= val_atr (index_type
, index
);
13774 value_print (index_value
, stream
, options
);
13775 fprintf_filtered (stream
, " => ");
13778 /* Implement the "read_var_value" language_defn method for Ada. */
13780 struct value
*read_var_value (struct symbol
*var
,
13781 const struct block
*var_block
,
13782 struct frame_info
*frame
) const override
13784 /* The only case where default_read_var_value is not sufficient
13785 is when VAR is a renaming... */
13786 if (frame
!= nullptr)
13788 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13789 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13790 return ada_read_renaming_var_value (var
, frame_block
);
13793 /* This is a typical case where we expect the default_read_var_value
13794 function to work. */
13795 return language_defn::read_var_value (var
, var_block
, frame
);
13798 /* See language.h. */
13799 void language_arch_info (struct gdbarch
*gdbarch
,
13800 struct language_arch_info
*lai
) const override
13802 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13804 /* Helper function to allow shorter lines below. */
13805 auto add
= [&] (struct type
*t
)
13807 lai
->add_primitive_type (t
);
13810 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13812 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13813 0, "long_integer"));
13814 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13815 0, "short_integer"));
13816 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13818 lai
->set_string_char_type (char_type
);
13820 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13821 "float", gdbarch_float_format (gdbarch
)));
13822 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13823 "long_float", gdbarch_double_format (gdbarch
)));
13824 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13825 0, "long_long_integer"));
13826 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13828 gdbarch_long_double_format (gdbarch
)));
13829 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13831 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13833 add (builtin
->builtin_void
);
13835 struct type
*system_addr_ptr
13836 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13838 system_addr_ptr
->set_name ("system__address");
13839 add (system_addr_ptr
);
13841 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13842 type. This is a signed integral type whose size is the same as
13843 the size of addresses. */
13844 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13845 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13846 "storage_offset"));
13848 lai
->set_bool_type (builtin
->builtin_bool
);
13851 /* See language.h. */
13853 bool iterate_over_symbols
13854 (const struct block
*block
, const lookup_name_info
&name
,
13855 domain_enum domain
,
13856 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13858 std::vector
<struct block_symbol
> results
;
13860 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13861 for (block_symbol
&sym
: results
)
13863 if (!callback (&sym
))
13870 /* See language.h. */
13871 bool sniff_from_mangled_name (const char *mangled
,
13872 char **out
) const override
13874 std::string demangled
= ada_decode (mangled
);
13878 if (demangled
!= mangled
&& demangled
[0] != '<')
13880 /* Set the gsymbol language to Ada, but still return 0.
13881 Two reasons for that:
13883 1. For Ada, we prefer computing the symbol's decoded name
13884 on the fly rather than pre-compute it, in order to save
13885 memory (Ada projects are typically very large).
13887 2. There are some areas in the definition of the GNAT
13888 encoding where, with a bit of bad luck, we might be able
13889 to decode a non-Ada symbol, generating an incorrect
13890 demangled name (Eg: names ending with "TB" for instance
13891 are identified as task bodies and so stripped from
13892 the decoded name returned).
13894 Returning true, here, but not setting *DEMANGLED, helps us get
13895 a little bit of the best of both worlds. Because we're last,
13896 we should not affect any of the other languages that were
13897 able to demangle the symbol before us; we get to correctly
13898 tag Ada symbols as such; and even if we incorrectly tagged a
13899 non-Ada symbol, which should be rare, any routing through the
13900 Ada language should be transparent (Ada tries to behave much
13901 like C/C++ with non-Ada symbols). */
13908 /* See language.h. */
13910 char *demangle_symbol (const char *mangled
, int options
) const override
13912 return ada_la_decode (mangled
, options
);
13915 /* See language.h. */
13917 void print_type (struct type
*type
, const char *varstring
,
13918 struct ui_file
*stream
, int show
, int level
,
13919 const struct type_print_options
*flags
) const override
13921 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13924 /* See language.h. */
13926 const char *word_break_characters (void) const override
13928 return ada_completer_word_break_characters
;
13931 /* See language.h. */
13933 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13934 complete_symbol_mode mode
,
13935 symbol_name_match_type name_match_type
,
13936 const char *text
, const char *word
,
13937 enum type_code code
) const override
13939 struct symbol
*sym
;
13940 const struct block
*b
, *surrounding_static_block
= 0;
13941 struct block_iterator iter
;
13943 gdb_assert (code
== TYPE_CODE_UNDEF
);
13945 lookup_name_info
lookup_name (text
, name_match_type
, true);
13947 /* First, look at the partial symtab symbols. */
13948 expand_symtabs_matching (NULL
,
13954 /* At this point scan through the misc symbol vectors and add each
13955 symbol you find to the list. Eventually we want to ignore
13956 anything that isn't a text symbol (everything else will be
13957 handled by the psymtab code above). */
13959 for (objfile
*objfile
: current_program_space
->objfiles ())
13961 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13965 if (completion_skip_symbol (mode
, msymbol
))
13968 language symbol_language
= msymbol
->language ();
13970 /* Ada minimal symbols won't have their language set to Ada. If
13971 we let completion_list_add_name compare using the
13972 default/C-like matcher, then when completing e.g., symbols in a
13973 package named "pck", we'd match internal Ada symbols like
13974 "pckS", which are invalid in an Ada expression, unless you wrap
13975 them in '<' '>' to request a verbatim match.
13977 Unfortunately, some Ada encoded names successfully demangle as
13978 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13979 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13980 with the wrong language set. Paper over that issue here. */
13981 if (symbol_language
== language_auto
13982 || symbol_language
== language_cplus
)
13983 symbol_language
= language_ada
;
13985 completion_list_add_name (tracker
,
13987 msymbol
->linkage_name (),
13988 lookup_name
, text
, word
);
13992 /* Search upwards from currently selected frame (so that we can
13993 complete on local vars. */
13995 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13997 if (!BLOCK_SUPERBLOCK (b
))
13998 surrounding_static_block
= b
; /* For elmin of dups */
14000 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14002 if (completion_skip_symbol (mode
, sym
))
14005 completion_list_add_name (tracker
,
14007 sym
->linkage_name (),
14008 lookup_name
, text
, word
);
14012 /* Go through the symtabs and check the externs and statics for
14013 symbols which match. */
14015 for (objfile
*objfile
: current_program_space
->objfiles ())
14017 for (compunit_symtab
*s
: objfile
->compunits ())
14020 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14021 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14023 if (completion_skip_symbol (mode
, sym
))
14026 completion_list_add_name (tracker
,
14028 sym
->linkage_name (),
14029 lookup_name
, text
, word
);
14034 for (objfile
*objfile
: current_program_space
->objfiles ())
14036 for (compunit_symtab
*s
: objfile
->compunits ())
14039 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14040 /* Don't do this block twice. */
14041 if (b
== surrounding_static_block
)
14043 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14045 if (completion_skip_symbol (mode
, sym
))
14048 completion_list_add_name (tracker
,
14050 sym
->linkage_name (),
14051 lookup_name
, text
, word
);
14057 /* See language.h. */
14059 gdb::unique_xmalloc_ptr
<char> watch_location_expression
14060 (struct type
*type
, CORE_ADDR addr
) const override
14062 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
14063 std::string name
= type_to_string (type
);
14064 return gdb::unique_xmalloc_ptr
<char>
14065 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
14068 /* See language.h. */
14070 void value_print (struct value
*val
, struct ui_file
*stream
,
14071 const struct value_print_options
*options
) const override
14073 return ada_value_print (val
, stream
, options
);
14076 /* See language.h. */
14078 void value_print_inner
14079 (struct value
*val
, struct ui_file
*stream
, int recurse
,
14080 const struct value_print_options
*options
) const override
14082 return ada_value_print_inner (val
, stream
, recurse
, options
);
14085 /* See language.h. */
14087 struct block_symbol lookup_symbol_nonlocal
14088 (const char *name
, const struct block
*block
,
14089 const domain_enum domain
) const override
14091 struct block_symbol sym
;
14093 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
14094 if (sym
.symbol
!= NULL
)
14097 /* If we haven't found a match at this point, try the primitive
14098 types. In other languages, this search is performed before
14099 searching for global symbols in order to short-circuit that
14100 global-symbol search if it happens that the name corresponds
14101 to a primitive type. But we cannot do the same in Ada, because
14102 it is perfectly legitimate for a program to declare a type which
14103 has the same name as a standard type. If looking up a type in
14104 that situation, we have traditionally ignored the primitive type
14105 in favor of user-defined types. This is why, unlike most other
14106 languages, we search the primitive types this late and only after
14107 having searched the global symbols without success. */
14109 if (domain
== VAR_DOMAIN
)
14111 struct gdbarch
*gdbarch
;
14114 gdbarch
= target_gdbarch ();
14116 gdbarch
= block_gdbarch (block
);
14118 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
14119 if (sym
.symbol
!= NULL
)
14126 /* See language.h. */
14128 int parser (struct parser_state
*ps
) const override
14130 warnings_issued
= 0;
14131 return ada_parse (ps
);
14136 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
14137 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
14138 namespace) and converts operators that are user-defined into
14139 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
14140 a preferred result type [at the moment, only type void has any
14141 effect---causing procedures to be preferred over functions in calls].
14142 A null CONTEXT_TYPE indicates that a non-void return type is
14143 preferred. May change (expand) *EXP. */
14145 void post_parser (expression_up
*expp
, int void_context_p
, int completing
,
14146 innermost_block_tracker
*tracker
) const override
14148 struct type
*context_type
= NULL
;
14151 if (void_context_p
)
14152 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14154 resolve_subexp (expp
, &pc
, 1, context_type
, completing
, tracker
);
14157 /* See language.h. */
14159 void emitchar (int ch
, struct type
*chtype
,
14160 struct ui_file
*stream
, int quoter
) const override
14162 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14165 /* See language.h. */
14167 void printchar (int ch
, struct type
*chtype
,
14168 struct ui_file
*stream
) const override
14170 ada_printchar (ch
, chtype
, stream
);
14173 /* See language.h. */
14175 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14176 const gdb_byte
*string
, unsigned int length
,
14177 const char *encoding
, int force_ellipses
,
14178 const struct value_print_options
*options
) const override
14180 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14181 force_ellipses
, options
);
14184 /* See language.h. */
14186 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14187 struct ui_file
*stream
) const override
14189 ada_print_typedef (type
, new_symbol
, stream
);
14192 /* See language.h. */
14194 bool is_string_type_p (struct type
*type
) const override
14196 return ada_is_string_type (type
);
14199 /* See language.h. */
14201 const char *struct_too_deep_ellipsis () const override
14202 { return "(...)"; }
14204 /* See language.h. */
14206 bool c_style_arrays_p () const override
14209 /* See language.h. */
14211 bool store_sym_names_in_linkage_form_p () const override
14214 /* See language.h. */
14216 const struct lang_varobj_ops
*varobj_ops () const override
14217 { return &ada_varobj_ops
; }
14219 /* See language.h. */
14221 const struct exp_descriptor
*expression_ops () const override
14222 { return &ada_exp_descriptor
; }
14224 /* See language.h. */
14226 const struct op_print
*opcode_print_table () const override
14227 { return ada_op_print_tab
; }
14230 /* See language.h. */
14232 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14233 (const lookup_name_info
&lookup_name
) const override
14235 return ada_get_symbol_name_matcher (lookup_name
);
14239 /* Single instance of the Ada language class. */
14241 static ada_language ada_language_defn
;
14243 /* Command-list for the "set/show ada" prefix command. */
14244 static struct cmd_list_element
*set_ada_list
;
14245 static struct cmd_list_element
*show_ada_list
;
14248 initialize_ada_catchpoint_ops (void)
14250 struct breakpoint_ops
*ops
;
14252 initialize_breakpoint_ops ();
14254 ops
= &catch_exception_breakpoint_ops
;
14255 *ops
= bkpt_breakpoint_ops
;
14256 ops
->allocate_location
= allocate_location_exception
;
14257 ops
->re_set
= re_set_exception
;
14258 ops
->check_status
= check_status_exception
;
14259 ops
->print_it
= print_it_exception
;
14260 ops
->print_one
= print_one_exception
;
14261 ops
->print_mention
= print_mention_exception
;
14262 ops
->print_recreate
= print_recreate_exception
;
14264 ops
= &catch_exception_unhandled_breakpoint_ops
;
14265 *ops
= bkpt_breakpoint_ops
;
14266 ops
->allocate_location
= allocate_location_exception
;
14267 ops
->re_set
= re_set_exception
;
14268 ops
->check_status
= check_status_exception
;
14269 ops
->print_it
= print_it_exception
;
14270 ops
->print_one
= print_one_exception
;
14271 ops
->print_mention
= print_mention_exception
;
14272 ops
->print_recreate
= print_recreate_exception
;
14274 ops
= &catch_assert_breakpoint_ops
;
14275 *ops
= bkpt_breakpoint_ops
;
14276 ops
->allocate_location
= allocate_location_exception
;
14277 ops
->re_set
= re_set_exception
;
14278 ops
->check_status
= check_status_exception
;
14279 ops
->print_it
= print_it_exception
;
14280 ops
->print_one
= print_one_exception
;
14281 ops
->print_mention
= print_mention_exception
;
14282 ops
->print_recreate
= print_recreate_exception
;
14284 ops
= &catch_handlers_breakpoint_ops
;
14285 *ops
= bkpt_breakpoint_ops
;
14286 ops
->allocate_location
= allocate_location_exception
;
14287 ops
->re_set
= re_set_exception
;
14288 ops
->check_status
= check_status_exception
;
14289 ops
->print_it
= print_it_exception
;
14290 ops
->print_one
= print_one_exception
;
14291 ops
->print_mention
= print_mention_exception
;
14292 ops
->print_recreate
= print_recreate_exception
;
14295 /* This module's 'new_objfile' observer. */
14298 ada_new_objfile_observer (struct objfile
*objfile
)
14300 ada_clear_symbol_cache ();
14303 /* This module's 'free_objfile' observer. */
14306 ada_free_objfile_observer (struct objfile
*objfile
)
14308 ada_clear_symbol_cache ();
14311 void _initialize_ada_language ();
14313 _initialize_ada_language ()
14315 initialize_ada_catchpoint_ops ();
14317 add_basic_prefix_cmd ("ada", no_class
,
14318 _("Prefix command for changing Ada-specific settings."),
14319 &set_ada_list
, "set ada ", 0, &setlist
);
14321 add_show_prefix_cmd ("ada", no_class
,
14322 _("Generic command for showing Ada-specific settings."),
14323 &show_ada_list
, "show ada ", 0, &showlist
);
14325 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14326 &trust_pad_over_xvs
, _("\
14327 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14328 Show whether an optimization trusting PAD types over XVS types is activated."),
14330 This is related to the encoding used by the GNAT compiler. The debugger\n\
14331 should normally trust the contents of PAD types, but certain older versions\n\
14332 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14333 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14334 work around this bug. It is always safe to turn this option \"off\", but\n\
14335 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14336 this option to \"off\" unless necessary."),
14337 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14339 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14340 &print_signatures
, _("\
14341 Enable or disable the output of formal and return types for functions in the \
14342 overloads selection menu."), _("\
14343 Show whether the output of formal and return types for functions in the \
14344 overloads selection menu is activated."),
14345 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14347 add_catch_command ("exception", _("\
14348 Catch Ada exceptions, when raised.\n\
14349 Usage: catch exception [ARG] [if CONDITION]\n\
14350 Without any argument, stop when any Ada exception is raised.\n\
14351 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14352 being raised does not have a handler (and will therefore lead to the task's\n\
14354 Otherwise, the catchpoint only stops when the name of the exception being\n\
14355 raised is the same as ARG.\n\
14356 CONDITION is a boolean expression that is evaluated to see whether the\n\
14357 exception should cause a stop."),
14358 catch_ada_exception_command
,
14359 catch_ada_completer
,
14363 add_catch_command ("handlers", _("\
14364 Catch Ada exceptions, when handled.\n\
14365 Usage: catch handlers [ARG] [if CONDITION]\n\
14366 Without any argument, stop when any Ada exception is handled.\n\
14367 With an argument, catch only exceptions with the given name.\n\
14368 CONDITION is a boolean expression that is evaluated to see whether the\n\
14369 exception should cause a stop."),
14370 catch_ada_handlers_command
,
14371 catch_ada_completer
,
14374 add_catch_command ("assert", _("\
14375 Catch failed Ada assertions, when raised.\n\
14376 Usage: catch assert [if CONDITION]\n\
14377 CONDITION is a boolean expression that is evaluated to see whether the\n\
14378 exception should cause a stop."),
14379 catch_assert_command
,
14384 varsize_limit
= 65536;
14385 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14386 &varsize_limit
, _("\
14387 Set the maximum number of bytes allowed in a variable-size object."), _("\
14388 Show the maximum number of bytes allowed in a variable-size object."), _("\
14389 Attempts to access an object whose size is not a compile-time constant\n\
14390 and exceeds this limit will cause an error."),
14391 NULL
, NULL
, &setlist
, &showlist
);
14393 add_info ("exceptions", info_exceptions_command
,
14395 List all Ada exception names.\n\
14396 Usage: info exceptions [REGEXP]\n\
14397 If a regular expression is passed as an argument, only those matching\n\
14398 the regular expression are listed."));
14400 add_basic_prefix_cmd ("ada", class_maintenance
,
14401 _("Set Ada maintenance-related variables."),
14402 &maint_set_ada_cmdlist
, "maintenance set ada ",
14403 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14405 add_show_prefix_cmd ("ada", class_maintenance
,
14406 _("Show Ada maintenance-related variables."),
14407 &maint_show_ada_cmdlist
, "maintenance show ada ",
14408 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14410 add_setshow_boolean_cmd
14411 ("ignore-descriptive-types", class_maintenance
,
14412 &ada_ignore_descriptive_types_p
,
14413 _("Set whether descriptive types generated by GNAT should be ignored."),
14414 _("Show whether descriptive types generated by GNAT should be ignored."),
14416 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14417 DWARF attribute."),
14418 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14420 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14421 NULL
, xcalloc
, xfree
);
14423 /* The ada-lang observers. */
14424 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14425 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14426 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);