1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2020 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 #include "gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdb_obstack.h"
40 #include "completer.h"
47 #include "observable.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 static struct type
*desc_base_type (struct type
*);
71 static struct type
*desc_bounds_type (struct type
*);
73 static struct value
*desc_bounds (struct value
*);
75 static int fat_pntr_bounds_bitpos (struct type
*);
77 static int fat_pntr_bounds_bitsize (struct type
*);
79 static struct type
*desc_data_target_type (struct type
*);
81 static struct value
*desc_data (struct value
*);
83 static int fat_pntr_data_bitpos (struct type
*);
85 static int fat_pntr_data_bitsize (struct type
*);
87 static struct value
*desc_one_bound (struct value
*, int, int);
89 static int desc_bound_bitpos (struct type
*, int, int);
91 static int desc_bound_bitsize (struct type
*, int, int);
93 static struct type
*desc_index_type (struct type
*, int);
95 static int desc_arity (struct type
*);
97 static int ada_type_match (struct type
*, struct type
*, int);
99 static int ada_args_match (struct symbol
*, struct value
**, int);
101 static struct value
*make_array_descriptor (struct type
*, struct value
*);
103 static void ada_add_block_symbols (struct obstack
*,
104 const struct block
*,
105 const lookup_name_info
&lookup_name
,
106 domain_enum
, struct objfile
*);
108 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
109 const lookup_name_info
&lookup_name
,
110 domain_enum
, int, int *);
112 static int is_nonfunction (struct block_symbol
*, int);
114 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
115 const struct block
*);
117 static int num_defns_collected (struct obstack
*);
119 static struct block_symbol
*defns_collected (struct obstack
*, int);
121 static struct value
*resolve_subexp (expression_up
*, int *, int,
123 innermost_block_tracker
*);
125 static void replace_operator_with_call (expression_up
*, int, int, int,
126 struct symbol
*, const struct block
*);
128 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
130 static const char *ada_decoded_op_name (enum exp_opcode
);
132 static int numeric_type_p (struct type
*);
134 static int integer_type_p (struct type
*);
136 static int scalar_type_p (struct type
*);
138 static int discrete_type_p (struct type
*);
140 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
143 static struct value
*evaluate_subexp_type (struct expression
*, int *);
145 static struct type
*ada_find_parallel_type_with_name (struct type
*,
148 static int is_dynamic_field (struct type
*, int);
150 static struct type
*to_fixed_variant_branch_type (struct type
*,
152 CORE_ADDR
, struct value
*);
154 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
156 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
158 static struct type
*to_static_fixed_type (struct type
*);
159 static struct type
*static_unwrap_type (struct type
*type
);
161 static struct value
*unwrap_value (struct value
*);
163 static struct type
*constrained_packed_array_type (struct type
*, long *);
165 static struct type
*decode_constrained_packed_array_type (struct type
*);
167 static long decode_packed_array_bitsize (struct type
*);
169 static struct value
*decode_constrained_packed_array (struct value
*);
171 static int ada_is_unconstrained_packed_array_type (struct type
*);
173 static struct value
*value_subscript_packed (struct value
*, int,
176 static struct value
*coerce_unspec_val_to_type (struct value
*,
179 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
181 static int equiv_types (struct type
*, struct type
*);
183 static int is_name_suffix (const char *);
185 static int advance_wild_match (const char **, const char *, char);
187 static bool wild_match (const char *name
, const char *patn
);
189 static struct value
*ada_coerce_ref (struct value
*);
191 static LONGEST
pos_atr (struct value
*);
193 static struct value
*value_pos_atr (struct type
*, struct value
*);
195 static struct value
*val_atr (struct type
*, LONGEST
);
197 static struct value
*value_val_atr (struct type
*, struct value
*);
199 static struct symbol
*standard_lookup (const char *, const struct block
*,
202 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
205 static int find_struct_field (const char *, struct type
*, int,
206 struct type
**, int *, int *, int *, int *);
208 static int ada_resolve_function (struct block_symbol
*, int,
209 struct value
**, int, const char *,
212 static int ada_is_direct_array_type (struct type
*);
214 static struct value
*ada_index_struct_field (int, struct value
*, int,
217 static struct value
*assign_aggregate (struct value
*, struct value
*,
221 static void aggregate_assign_from_choices (struct value
*, struct value
*,
223 int *, LONGEST
*, int *,
224 int, LONGEST
, LONGEST
);
226 static void aggregate_assign_positional (struct value
*, struct value
*,
228 int *, LONGEST
*, int *, int,
232 static void aggregate_assign_others (struct value
*, struct value
*,
234 int *, LONGEST
*, int, LONGEST
, LONGEST
);
237 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
240 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
243 static void ada_forward_operator_length (struct expression
*, int, int *,
246 static struct type
*ada_find_any_type (const char *name
);
248 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
249 (const lookup_name_info
&lookup_name
);
253 /* The result of a symbol lookup to be stored in our symbol cache. */
257 /* The name used to perform the lookup. */
259 /* The namespace used during the lookup. */
261 /* The symbol returned by the lookup, or NULL if no matching symbol
264 /* The block where the symbol was found, or NULL if no matching
266 const struct block
*block
;
267 /* A pointer to the next entry with the same hash. */
268 struct cache_entry
*next
;
271 /* The Ada symbol cache, used to store the result of Ada-mode symbol
272 lookups in the course of executing the user's commands.
274 The cache is implemented using a simple, fixed-sized hash.
275 The size is fixed on the grounds that there are not likely to be
276 all that many symbols looked up during any given session, regardless
277 of the size of the symbol table. If we decide to go to a resizable
278 table, let's just use the stuff from libiberty instead. */
280 #define HASH_SIZE 1009
282 struct ada_symbol_cache
284 /* An obstack used to store the entries in our cache. */
285 struct obstack cache_space
;
287 /* The root of the hash table used to implement our symbol cache. */
288 struct cache_entry
*root
[HASH_SIZE
];
291 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
293 /* Maximum-sized dynamic type. */
294 static unsigned int varsize_limit
;
296 static const char ada_completer_word_break_characters
[] =
298 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
300 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
303 /* The name of the symbol to use to get the name of the main subprogram. */
304 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
305 = "__gnat_ada_main_program_name";
307 /* Limit on the number of warnings to raise per expression evaluation. */
308 static int warning_limit
= 2;
310 /* Number of warning messages issued; reset to 0 by cleanups after
311 expression evaluation. */
312 static int warnings_issued
= 0;
314 static const char * const known_runtime_file_name_patterns
[] = {
315 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
318 static const char * const known_auxiliary_function_name_patterns
[] = {
319 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
322 /* Maintenance-related settings for this module. */
324 static struct cmd_list_element
*maint_set_ada_cmdlist
;
325 static struct cmd_list_element
*maint_show_ada_cmdlist
;
327 /* The "maintenance ada set/show ignore-descriptive-type" value. */
329 static bool ada_ignore_descriptive_types_p
= false;
331 /* Inferior-specific data. */
333 /* Per-inferior data for this module. */
335 struct ada_inferior_data
337 /* The ada__tags__type_specific_data type, which is used when decoding
338 tagged types. With older versions of GNAT, this type was directly
339 accessible through a component ("tsd") in the object tag. But this
340 is no longer the case, so we cache it for each inferior. */
341 struct type
*tsd_type
= nullptr;
343 /* The exception_support_info data. This data is used to determine
344 how to implement support for Ada exception catchpoints in a given
346 const struct exception_support_info
*exception_info
= nullptr;
349 /* Our key to this module's inferior data. */
350 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
352 /* Return our inferior data for the given inferior (INF).
354 This function always returns a valid pointer to an allocated
355 ada_inferior_data structure. If INF's inferior data has not
356 been previously set, this functions creates a new one with all
357 fields set to zero, sets INF's inferior to it, and then returns
358 a pointer to that newly allocated ada_inferior_data. */
360 static struct ada_inferior_data
*
361 get_ada_inferior_data (struct inferior
*inf
)
363 struct ada_inferior_data
*data
;
365 data
= ada_inferior_data
.get (inf
);
367 data
= ada_inferior_data
.emplace (inf
);
372 /* Perform all necessary cleanups regarding our module's inferior data
373 that is required after the inferior INF just exited. */
376 ada_inferior_exit (struct inferior
*inf
)
378 ada_inferior_data
.clear (inf
);
382 /* program-space-specific data. */
384 /* This module's per-program-space data. */
385 struct ada_pspace_data
389 if (sym_cache
!= NULL
)
390 ada_free_symbol_cache (sym_cache
);
393 /* The Ada symbol cache. */
394 struct ada_symbol_cache
*sym_cache
= nullptr;
397 /* Key to our per-program-space data. */
398 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
400 /* Return this module's data for the given program space (PSPACE).
401 If not is found, add a zero'ed one now.
403 This function always returns a valid object. */
405 static struct ada_pspace_data
*
406 get_ada_pspace_data (struct program_space
*pspace
)
408 struct ada_pspace_data
*data
;
410 data
= ada_pspace_data_handle
.get (pspace
);
412 data
= ada_pspace_data_handle
.emplace (pspace
);
419 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
420 all typedef layers have been peeled. Otherwise, return TYPE.
422 Normally, we really expect a typedef type to only have 1 typedef layer.
423 In other words, we really expect the target type of a typedef type to be
424 a non-typedef type. This is particularly true for Ada units, because
425 the language does not have a typedef vs not-typedef distinction.
426 In that respect, the Ada compiler has been trying to eliminate as many
427 typedef definitions in the debugging information, since they generally
428 do not bring any extra information (we still use typedef under certain
429 circumstances related mostly to the GNAT encoding).
431 Unfortunately, we have seen situations where the debugging information
432 generated by the compiler leads to such multiple typedef layers. For
433 instance, consider the following example with stabs:
435 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
436 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
438 This is an error in the debugging information which causes type
439 pck__float_array___XUP to be defined twice, and the second time,
440 it is defined as a typedef of a typedef.
442 This is on the fringe of legality as far as debugging information is
443 concerned, and certainly unexpected. But it is easy to handle these
444 situations correctly, so we can afford to be lenient in this case. */
447 ada_typedef_target_type (struct type
*type
)
449 while (type
->code () == TYPE_CODE_TYPEDEF
)
450 type
= TYPE_TARGET_TYPE (type
);
454 /* Given DECODED_NAME a string holding a symbol name in its
455 decoded form (ie using the Ada dotted notation), returns
456 its unqualified name. */
459 ada_unqualified_name (const char *decoded_name
)
463 /* If the decoded name starts with '<', it means that the encoded
464 name does not follow standard naming conventions, and thus that
465 it is not your typical Ada symbol name. Trying to unqualify it
466 is therefore pointless and possibly erroneous. */
467 if (decoded_name
[0] == '<')
470 result
= strrchr (decoded_name
, '.');
472 result
++; /* Skip the dot... */
474 result
= decoded_name
;
479 /* Return a string starting with '<', followed by STR, and '>'. */
482 add_angle_brackets (const char *str
)
484 return string_printf ("<%s>", str
);
487 /* Assuming V points to an array of S objects, make sure that it contains at
488 least M objects, updating V and S as necessary. */
490 #define GROW_VECT(v, s, m) \
491 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
493 /* Assuming VECT points to an array of *SIZE objects of size
494 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
495 updating *SIZE as necessary and returning the (new) array. */
498 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
500 if (*size
< min_size
)
503 if (*size
< min_size
)
505 vect
= xrealloc (vect
, *size
* element_size
);
510 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
511 suffix of FIELD_NAME beginning "___". */
514 field_name_match (const char *field_name
, const char *target
)
516 int len
= strlen (target
);
519 (strncmp (field_name
, target
, len
) == 0
520 && (field_name
[len
] == '\0'
521 || (startswith (field_name
+ len
, "___")
522 && strcmp (field_name
+ strlen (field_name
) - 6,
527 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
528 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
529 and return its index. This function also handles fields whose name
530 have ___ suffixes because the compiler sometimes alters their name
531 by adding such a suffix to represent fields with certain constraints.
532 If the field could not be found, return a negative number if
533 MAYBE_MISSING is set. Otherwise raise an error. */
536 ada_get_field_index (const struct type
*type
, const char *field_name
,
540 struct type
*struct_type
= check_typedef ((struct type
*) type
);
542 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
543 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
547 error (_("Unable to find field %s in struct %s. Aborting"),
548 field_name
, struct_type
->name ());
553 /* The length of the prefix of NAME prior to any "___" suffix. */
556 ada_name_prefix_len (const char *name
)
562 const char *p
= strstr (name
, "___");
565 return strlen (name
);
571 /* Return non-zero if SUFFIX is a suffix of STR.
572 Return zero if STR is null. */
575 is_suffix (const char *str
, const char *suffix
)
582 len2
= strlen (suffix
);
583 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
586 /* The contents of value VAL, treated as a value of type TYPE. The
587 result is an lval in memory if VAL is. */
589 static struct value
*
590 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
592 type
= ada_check_typedef (type
);
593 if (value_type (val
) == type
)
597 struct value
*result
;
599 /* Make sure that the object size is not unreasonable before
600 trying to allocate some memory for it. */
601 ada_ensure_varsize_limit (type
);
604 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
605 result
= allocate_value_lazy (type
);
608 result
= allocate_value (type
);
609 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
611 set_value_component_location (result
, val
);
612 set_value_bitsize (result
, value_bitsize (val
));
613 set_value_bitpos (result
, value_bitpos (val
));
614 if (VALUE_LVAL (result
) == lval_memory
)
615 set_value_address (result
, value_address (val
));
620 static const gdb_byte
*
621 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
626 return valaddr
+ offset
;
630 cond_offset_target (CORE_ADDR address
, long offset
)
635 return address
+ offset
;
638 /* Issue a warning (as for the definition of warning in utils.c, but
639 with exactly one argument rather than ...), unless the limit on the
640 number of warnings has passed during the evaluation of the current
643 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
644 provided by "complaint". */
645 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
648 lim_warning (const char *format
, ...)
652 va_start (args
, format
);
653 warnings_issued
+= 1;
654 if (warnings_issued
<= warning_limit
)
655 vwarning (format
, args
);
660 /* Issue an error if the size of an object of type T is unreasonable,
661 i.e. if it would be a bad idea to allocate a value of this type in
665 ada_ensure_varsize_limit (const struct type
*type
)
667 if (TYPE_LENGTH (type
) > varsize_limit
)
668 error (_("object size is larger than varsize-limit"));
671 /* Maximum value of a SIZE-byte signed integer type. */
673 max_of_size (int size
)
675 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
677 return top_bit
| (top_bit
- 1);
680 /* Minimum value of a SIZE-byte signed integer type. */
682 min_of_size (int size
)
684 return -max_of_size (size
) - 1;
687 /* Maximum value of a SIZE-byte unsigned integer type. */
689 umax_of_size (int size
)
691 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
693 return top_bit
| (top_bit
- 1);
696 /* Maximum value of integral type T, as a signed quantity. */
698 max_of_type (struct type
*t
)
700 if (t
->is_unsigned ())
701 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
703 return max_of_size (TYPE_LENGTH (t
));
706 /* Minimum value of integral type T, as a signed quantity. */
708 min_of_type (struct type
*t
)
710 if (t
->is_unsigned ())
713 return min_of_size (TYPE_LENGTH (t
));
716 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
718 ada_discrete_type_high_bound (struct type
*type
)
720 type
= resolve_dynamic_type (type
, {}, 0);
721 switch (type
->code ())
723 case TYPE_CODE_RANGE
:
725 const dynamic_prop
&high
= type
->bounds ()->high
;
727 if (high
.kind () == PROP_CONST
)
728 return high
.const_val ();
731 gdb_assert (high
.kind () == PROP_UNDEFINED
);
733 /* This happens when trying to evaluate a type's dynamic bound
734 without a live target. There is nothing relevant for us to
735 return here, so return 0. */
740 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
745 return max_of_type (type
);
747 error (_("Unexpected type in ada_discrete_type_high_bound."));
751 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
753 ada_discrete_type_low_bound (struct type
*type
)
755 type
= resolve_dynamic_type (type
, {}, 0);
756 switch (type
->code ())
758 case TYPE_CODE_RANGE
:
760 const dynamic_prop
&low
= type
->bounds ()->low
;
762 if (low
.kind () == PROP_CONST
)
763 return low
.const_val ();
766 gdb_assert (low
.kind () == PROP_UNDEFINED
);
768 /* This happens when trying to evaluate a type's dynamic bound
769 without a live target. There is nothing relevant for us to
770 return here, so return 0. */
775 return TYPE_FIELD_ENUMVAL (type
, 0);
780 return min_of_type (type
);
782 error (_("Unexpected type in ada_discrete_type_low_bound."));
786 /* The identity on non-range types. For range types, the underlying
787 non-range scalar type. */
790 get_base_type (struct type
*type
)
792 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
794 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
796 type
= TYPE_TARGET_TYPE (type
);
801 /* Return a decoded version of the given VALUE. This means returning
802 a value whose type is obtained by applying all the GNAT-specific
803 encodings, making the resulting type a static but standard description
804 of the initial type. */
807 ada_get_decoded_value (struct value
*value
)
809 struct type
*type
= ada_check_typedef (value_type (value
));
811 if (ada_is_array_descriptor_type (type
)
812 || (ada_is_constrained_packed_array_type (type
)
813 && type
->code () != TYPE_CODE_PTR
))
815 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
816 value
= ada_coerce_to_simple_array_ptr (value
);
818 value
= ada_coerce_to_simple_array (value
);
821 value
= ada_to_fixed_value (value
);
826 /* Same as ada_get_decoded_value, but with the given TYPE.
827 Because there is no associated actual value for this type,
828 the resulting type might be a best-effort approximation in
829 the case of dynamic types. */
832 ada_get_decoded_type (struct type
*type
)
834 type
= to_static_fixed_type (type
);
835 if (ada_is_constrained_packed_array_type (type
))
836 type
= ada_coerce_to_simple_array_type (type
);
842 /* Language Selection */
844 /* If the main program is in Ada, return language_ada, otherwise return LANG
845 (the main program is in Ada iif the adainit symbol is found). */
848 ada_update_initial_language (enum language lang
)
850 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
856 /* If the main procedure is written in Ada, then return its name.
857 The result is good until the next call. Return NULL if the main
858 procedure doesn't appear to be in Ada. */
863 struct bound_minimal_symbol msym
;
864 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
866 /* For Ada, the name of the main procedure is stored in a specific
867 string constant, generated by the binder. Look for that symbol,
868 extract its address, and then read that string. If we didn't find
869 that string, then most probably the main procedure is not written
871 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
873 if (msym
.minsym
!= NULL
)
875 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
876 if (main_program_name_addr
== 0)
877 error (_("Invalid address for Ada main program name."));
879 main_program_name
= target_read_string (main_program_name_addr
, 1024);
880 return main_program_name
.get ();
883 /* The main procedure doesn't seem to be in Ada. */
889 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
892 const struct ada_opname_map ada_opname_table
[] = {
893 {"Oadd", "\"+\"", BINOP_ADD
},
894 {"Osubtract", "\"-\"", BINOP_SUB
},
895 {"Omultiply", "\"*\"", BINOP_MUL
},
896 {"Odivide", "\"/\"", BINOP_DIV
},
897 {"Omod", "\"mod\"", BINOP_MOD
},
898 {"Orem", "\"rem\"", BINOP_REM
},
899 {"Oexpon", "\"**\"", BINOP_EXP
},
900 {"Olt", "\"<\"", BINOP_LESS
},
901 {"Ole", "\"<=\"", BINOP_LEQ
},
902 {"Ogt", "\">\"", BINOP_GTR
},
903 {"Oge", "\">=\"", BINOP_GEQ
},
904 {"Oeq", "\"=\"", BINOP_EQUAL
},
905 {"One", "\"/=\"", BINOP_NOTEQUAL
},
906 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
907 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
908 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
909 {"Oconcat", "\"&\"", BINOP_CONCAT
},
910 {"Oabs", "\"abs\"", UNOP_ABS
},
911 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
912 {"Oadd", "\"+\"", UNOP_PLUS
},
913 {"Osubtract", "\"-\"", UNOP_NEG
},
917 /* The "encoded" form of DECODED, according to GNAT conventions. If
918 THROW_ERRORS, throw an error if invalid operator name is found.
919 Otherwise, return the empty string in that case. */
922 ada_encode_1 (const char *decoded
, bool throw_errors
)
927 std::string encoding_buffer
;
928 for (const char *p
= decoded
; *p
!= '\0'; p
+= 1)
931 encoding_buffer
.append ("__");
934 const struct ada_opname_map
*mapping
;
936 for (mapping
= ada_opname_table
;
937 mapping
->encoded
!= NULL
938 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
940 if (mapping
->encoded
== NULL
)
943 error (_("invalid Ada operator name: %s"), p
);
947 encoding_buffer
.append (mapping
->encoded
);
951 encoding_buffer
.push_back (*p
);
954 return encoding_buffer
;
957 /* The "encoded" form of DECODED, according to GNAT conventions. */
960 ada_encode (const char *decoded
)
962 return ada_encode_1 (decoded
, true);
965 /* Return NAME folded to lower case, or, if surrounded by single
966 quotes, unfolded, but with the quotes stripped away. Result good
970 ada_fold_name (gdb::string_view name
)
972 static char *fold_buffer
= NULL
;
973 static size_t fold_buffer_size
= 0;
975 int len
= name
.size ();
976 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
980 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
981 fold_buffer
[len
- 2] = '\000';
987 for (i
= 0; i
<= len
; i
+= 1)
988 fold_buffer
[i
] = tolower (name
[i
]);
994 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
997 is_lower_alphanum (const char c
)
999 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1002 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1003 This function saves in LEN the length of that same symbol name but
1004 without either of these suffixes:
1010 These are suffixes introduced by the compiler for entities such as
1011 nested subprogram for instance, in order to avoid name clashes.
1012 They do not serve any purpose for the debugger. */
1015 ada_remove_trailing_digits (const char *encoded
, int *len
)
1017 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1021 while (i
> 0 && isdigit (encoded
[i
]))
1023 if (i
>= 0 && encoded
[i
] == '.')
1025 else if (i
>= 0 && encoded
[i
] == '$')
1027 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1029 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1034 /* Remove the suffix introduced by the compiler for protected object
1038 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1040 /* Remove trailing N. */
1042 /* Protected entry subprograms are broken into two
1043 separate subprograms: The first one is unprotected, and has
1044 a 'N' suffix; the second is the protected version, and has
1045 the 'P' suffix. The second calls the first one after handling
1046 the protection. Since the P subprograms are internally generated,
1047 we leave these names undecoded, giving the user a clue that this
1048 entity is internal. */
1051 && encoded
[*len
- 1] == 'N'
1052 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1056 /* If ENCODED follows the GNAT entity encoding conventions, then return
1057 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1058 replaced by ENCODED. */
1061 ada_decode (const char *encoded
)
1067 std::string decoded
;
1069 /* With function descriptors on PPC64, the value of a symbol named
1070 ".FN", if it exists, is the entry point of the function "FN". */
1071 if (encoded
[0] == '.')
1074 /* The name of the Ada main procedure starts with "_ada_".
1075 This prefix is not part of the decoded name, so skip this part
1076 if we see this prefix. */
1077 if (startswith (encoded
, "_ada_"))
1080 /* If the name starts with '_', then it is not a properly encoded
1081 name, so do not attempt to decode it. Similarly, if the name
1082 starts with '<', the name should not be decoded. */
1083 if (encoded
[0] == '_' || encoded
[0] == '<')
1086 len0
= strlen (encoded
);
1088 ada_remove_trailing_digits (encoded
, &len0
);
1089 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1091 /* Remove the ___X.* suffix if present. Do not forget to verify that
1092 the suffix is located before the current "end" of ENCODED. We want
1093 to avoid re-matching parts of ENCODED that have previously been
1094 marked as discarded (by decrementing LEN0). */
1095 p
= strstr (encoded
, "___");
1096 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1104 /* Remove any trailing TKB suffix. It tells us that this symbol
1105 is for the body of a task, but that information does not actually
1106 appear in the decoded name. */
1108 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1111 /* Remove any trailing TB suffix. The TB suffix is slightly different
1112 from the TKB suffix because it is used for non-anonymous task
1115 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1118 /* Remove trailing "B" suffixes. */
1119 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1121 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1124 /* Make decoded big enough for possible expansion by operator name. */
1126 decoded
.resize (2 * len0
+ 1, 'X');
1128 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1130 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1133 while ((i
>= 0 && isdigit (encoded
[i
]))
1134 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1136 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1138 else if (encoded
[i
] == '$')
1142 /* The first few characters that are not alphabetic are not part
1143 of any encoding we use, so we can copy them over verbatim. */
1145 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1146 decoded
[j
] = encoded
[i
];
1151 /* Is this a symbol function? */
1152 if (at_start_name
&& encoded
[i
] == 'O')
1156 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1158 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1159 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1161 && !isalnum (encoded
[i
+ op_len
]))
1163 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1166 j
+= strlen (ada_opname_table
[k
].decoded
);
1170 if (ada_opname_table
[k
].encoded
!= NULL
)
1175 /* Replace "TK__" with "__", which will eventually be translated
1176 into "." (just below). */
1178 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1181 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1182 be translated into "." (just below). These are internal names
1183 generated for anonymous blocks inside which our symbol is nested. */
1185 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1186 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1187 && isdigit (encoded
[i
+4]))
1191 while (k
< len0
&& isdigit (encoded
[k
]))
1192 k
++; /* Skip any extra digit. */
1194 /* Double-check that the "__B_{DIGITS}+" sequence we found
1195 is indeed followed by "__". */
1196 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1200 /* Remove _E{DIGITS}+[sb] */
1202 /* Just as for protected object subprograms, there are 2 categories
1203 of subprograms created by the compiler for each entry. The first
1204 one implements the actual entry code, and has a suffix following
1205 the convention above; the second one implements the barrier and
1206 uses the same convention as above, except that the 'E' is replaced
1209 Just as above, we do not decode the name of barrier functions
1210 to give the user a clue that the code he is debugging has been
1211 internally generated. */
1213 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1214 && isdigit (encoded
[i
+2]))
1218 while (k
< len0
&& isdigit (encoded
[k
]))
1222 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1225 /* Just as an extra precaution, make sure that if this
1226 suffix is followed by anything else, it is a '_'.
1227 Otherwise, we matched this sequence by accident. */
1229 || (k
< len0
&& encoded
[k
] == '_'))
1234 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1235 the GNAT front-end in protected object subprograms. */
1238 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1240 /* Backtrack a bit up until we reach either the begining of
1241 the encoded name, or "__". Make sure that we only find
1242 digits or lowercase characters. */
1243 const char *ptr
= encoded
+ i
- 1;
1245 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1248 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1252 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1254 /* This is a X[bn]* sequence not separated from the previous
1255 part of the name with a non-alpha-numeric character (in other
1256 words, immediately following an alpha-numeric character), then
1257 verify that it is placed at the end of the encoded name. If
1258 not, then the encoding is not valid and we should abort the
1259 decoding. Otherwise, just skip it, it is used in body-nested
1263 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1267 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1269 /* Replace '__' by '.'. */
1277 /* It's a character part of the decoded name, so just copy it
1279 decoded
[j
] = encoded
[i
];
1286 /* Decoded names should never contain any uppercase character.
1287 Double-check this, and abort the decoding if we find one. */
1289 for (i
= 0; i
< decoded
.length(); ++i
)
1290 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1296 if (encoded
[0] == '<')
1299 decoded
= '<' + std::string(encoded
) + '>';
1304 /* Table for keeping permanent unique copies of decoded names. Once
1305 allocated, names in this table are never released. While this is a
1306 storage leak, it should not be significant unless there are massive
1307 changes in the set of decoded names in successive versions of a
1308 symbol table loaded during a single session. */
1309 static struct htab
*decoded_names_store
;
1311 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1312 in the language-specific part of GSYMBOL, if it has not been
1313 previously computed. Tries to save the decoded name in the same
1314 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1315 in any case, the decoded symbol has a lifetime at least that of
1317 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1318 const, but nevertheless modified to a semantically equivalent form
1319 when a decoded name is cached in it. */
1322 ada_decode_symbol (const struct general_symbol_info
*arg
)
1324 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1325 const char **resultp
=
1326 &gsymbol
->language_specific
.demangled_name
;
1328 if (!gsymbol
->ada_mangled
)
1330 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1331 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1333 gsymbol
->ada_mangled
= 1;
1335 if (obstack
!= NULL
)
1336 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1339 /* Sometimes, we can't find a corresponding objfile, in
1340 which case, we put the result on the heap. Since we only
1341 decode when needed, we hope this usually does not cause a
1342 significant memory leak (FIXME). */
1344 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1345 decoded
.c_str (), INSERT
);
1348 *slot
= xstrdup (decoded
.c_str ());
1357 ada_la_decode (const char *encoded
, int options
)
1359 return xstrdup (ada_decode (encoded
).c_str ());
1366 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1367 generated by the GNAT compiler to describe the index type used
1368 for each dimension of an array, check whether it follows the latest
1369 known encoding. If not, fix it up to conform to the latest encoding.
1370 Otherwise, do nothing. This function also does nothing if
1371 INDEX_DESC_TYPE is NULL.
1373 The GNAT encoding used to describe the array index type evolved a bit.
1374 Initially, the information would be provided through the name of each
1375 field of the structure type only, while the type of these fields was
1376 described as unspecified and irrelevant. The debugger was then expected
1377 to perform a global type lookup using the name of that field in order
1378 to get access to the full index type description. Because these global
1379 lookups can be very expensive, the encoding was later enhanced to make
1380 the global lookup unnecessary by defining the field type as being
1381 the full index type description.
1383 The purpose of this routine is to allow us to support older versions
1384 of the compiler by detecting the use of the older encoding, and by
1385 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1386 we essentially replace each field's meaningless type by the associated
1390 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1394 if (index_desc_type
== NULL
)
1396 gdb_assert (index_desc_type
->num_fields () > 0);
1398 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1399 to check one field only, no need to check them all). If not, return
1402 If our INDEX_DESC_TYPE was generated using the older encoding,
1403 the field type should be a meaningless integer type whose name
1404 is not equal to the field name. */
1405 if (index_desc_type
->field (0).type ()->name () != NULL
1406 && strcmp (index_desc_type
->field (0).type ()->name (),
1407 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1410 /* Fixup each field of INDEX_DESC_TYPE. */
1411 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1413 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1414 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1417 index_desc_type
->field (i
).set_type (raw_type
);
1421 /* The desc_* routines return primitive portions of array descriptors
1424 /* The descriptor or array type, if any, indicated by TYPE; removes
1425 level of indirection, if needed. */
1427 static struct type
*
1428 desc_base_type (struct type
*type
)
1432 type
= ada_check_typedef (type
);
1433 if (type
->code () == TYPE_CODE_TYPEDEF
)
1434 type
= ada_typedef_target_type (type
);
1437 && (type
->code () == TYPE_CODE_PTR
1438 || type
->code () == TYPE_CODE_REF
))
1439 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1444 /* True iff TYPE indicates a "thin" array pointer type. */
1447 is_thin_pntr (struct type
*type
)
1450 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1451 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1454 /* The descriptor type for thin pointer type TYPE. */
1456 static struct type
*
1457 thin_descriptor_type (struct type
*type
)
1459 struct type
*base_type
= desc_base_type (type
);
1461 if (base_type
== NULL
)
1463 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1467 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1469 if (alt_type
== NULL
)
1476 /* A pointer to the array data for thin-pointer value VAL. */
1478 static struct value
*
1479 thin_data_pntr (struct value
*val
)
1481 struct type
*type
= ada_check_typedef (value_type (val
));
1482 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1484 data_type
= lookup_pointer_type (data_type
);
1486 if (type
->code () == TYPE_CODE_PTR
)
1487 return value_cast (data_type
, value_copy (val
));
1489 return value_from_longest (data_type
, value_address (val
));
1492 /* True iff TYPE indicates a "thick" array pointer type. */
1495 is_thick_pntr (struct type
*type
)
1497 type
= desc_base_type (type
);
1498 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1499 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1502 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1503 pointer to one, the type of its bounds data; otherwise, NULL. */
1505 static struct type
*
1506 desc_bounds_type (struct type
*type
)
1510 type
= desc_base_type (type
);
1514 else if (is_thin_pntr (type
))
1516 type
= thin_descriptor_type (type
);
1519 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1521 return ada_check_typedef (r
);
1523 else if (type
->code () == TYPE_CODE_STRUCT
)
1525 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1527 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1532 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1533 one, a pointer to its bounds data. Otherwise NULL. */
1535 static struct value
*
1536 desc_bounds (struct value
*arr
)
1538 struct type
*type
= ada_check_typedef (value_type (arr
));
1540 if (is_thin_pntr (type
))
1542 struct type
*bounds_type
=
1543 desc_bounds_type (thin_descriptor_type (type
));
1546 if (bounds_type
== NULL
)
1547 error (_("Bad GNAT array descriptor"));
1549 /* NOTE: The following calculation is not really kosher, but
1550 since desc_type is an XVE-encoded type (and shouldn't be),
1551 the correct calculation is a real pain. FIXME (and fix GCC). */
1552 if (type
->code () == TYPE_CODE_PTR
)
1553 addr
= value_as_long (arr
);
1555 addr
= value_address (arr
);
1558 value_from_longest (lookup_pointer_type (bounds_type
),
1559 addr
- TYPE_LENGTH (bounds_type
));
1562 else if (is_thick_pntr (type
))
1564 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1565 _("Bad GNAT array descriptor"));
1566 struct type
*p_bounds_type
= value_type (p_bounds
);
1569 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1571 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1573 if (target_type
->is_stub ())
1574 p_bounds
= value_cast (lookup_pointer_type
1575 (ada_check_typedef (target_type
)),
1579 error (_("Bad GNAT array descriptor"));
1587 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1588 position of the field containing the address of the bounds data. */
1591 fat_pntr_bounds_bitpos (struct type
*type
)
1593 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1596 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1597 size of the field containing the address of the bounds data. */
1600 fat_pntr_bounds_bitsize (struct type
*type
)
1602 type
= desc_base_type (type
);
1604 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1605 return TYPE_FIELD_BITSIZE (type
, 1);
1607 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1610 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1611 pointer to one, the type of its array data (a array-with-no-bounds type);
1612 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1615 static struct type
*
1616 desc_data_target_type (struct type
*type
)
1618 type
= desc_base_type (type
);
1620 /* NOTE: The following is bogus; see comment in desc_bounds. */
1621 if (is_thin_pntr (type
))
1622 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1623 else if (is_thick_pntr (type
))
1625 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1628 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1629 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1635 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1638 static struct value
*
1639 desc_data (struct value
*arr
)
1641 struct type
*type
= value_type (arr
);
1643 if (is_thin_pntr (type
))
1644 return thin_data_pntr (arr
);
1645 else if (is_thick_pntr (type
))
1646 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1647 _("Bad GNAT array descriptor"));
1653 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1654 position of the field containing the address of the data. */
1657 fat_pntr_data_bitpos (struct type
*type
)
1659 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1662 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1663 size of the field containing the address of the data. */
1666 fat_pntr_data_bitsize (struct type
*type
)
1668 type
= desc_base_type (type
);
1670 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1671 return TYPE_FIELD_BITSIZE (type
, 0);
1673 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1676 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1677 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1678 bound, if WHICH is 1. The first bound is I=1. */
1680 static struct value
*
1681 desc_one_bound (struct value
*bounds
, int i
, int which
)
1683 char bound_name
[20];
1684 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1685 which
? 'U' : 'L', i
- 1);
1686 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1687 _("Bad GNAT array descriptor bounds"));
1690 /* If BOUNDS is an array-bounds structure type, return the bit position
1691 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1692 bound, if WHICH is 1. The first bound is I=1. */
1695 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1697 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1700 /* If BOUNDS is an array-bounds structure type, return the bit field size
1701 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1702 bound, if WHICH is 1. The first bound is I=1. */
1705 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1707 type
= desc_base_type (type
);
1709 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1710 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1712 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1715 /* If TYPE is the type of an array-bounds structure, the type of its
1716 Ith bound (numbering from 1). Otherwise, NULL. */
1718 static struct type
*
1719 desc_index_type (struct type
*type
, int i
)
1721 type
= desc_base_type (type
);
1723 if (type
->code () == TYPE_CODE_STRUCT
)
1725 char bound_name
[20];
1726 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1727 return lookup_struct_elt_type (type
, bound_name
, 1);
1733 /* The number of index positions in the array-bounds type TYPE.
1734 Return 0 if TYPE is NULL. */
1737 desc_arity (struct type
*type
)
1739 type
= desc_base_type (type
);
1742 return type
->num_fields () / 2;
1746 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1747 an array descriptor type (representing an unconstrained array
1751 ada_is_direct_array_type (struct type
*type
)
1755 type
= ada_check_typedef (type
);
1756 return (type
->code () == TYPE_CODE_ARRAY
1757 || ada_is_array_descriptor_type (type
));
1760 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1764 ada_is_array_type (struct type
*type
)
1767 && (type
->code () == TYPE_CODE_PTR
1768 || type
->code () == TYPE_CODE_REF
))
1769 type
= TYPE_TARGET_TYPE (type
);
1770 return ada_is_direct_array_type (type
);
1773 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1776 ada_is_simple_array_type (struct type
*type
)
1780 type
= ada_check_typedef (type
);
1781 return (type
->code () == TYPE_CODE_ARRAY
1782 || (type
->code () == TYPE_CODE_PTR
1783 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1784 == TYPE_CODE_ARRAY
)));
1787 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1790 ada_is_array_descriptor_type (struct type
*type
)
1792 struct type
*data_type
= desc_data_target_type (type
);
1796 type
= ada_check_typedef (type
);
1797 return (data_type
!= NULL
1798 && data_type
->code () == TYPE_CODE_ARRAY
1799 && desc_arity (desc_bounds_type (type
)) > 0);
1802 /* Non-zero iff type is a partially mal-formed GNAT array
1803 descriptor. FIXME: This is to compensate for some problems with
1804 debugging output from GNAT. Re-examine periodically to see if it
1808 ada_is_bogus_array_descriptor (struct type
*type
)
1812 && type
->code () == TYPE_CODE_STRUCT
1813 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1814 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1815 && !ada_is_array_descriptor_type (type
);
1819 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1820 (fat pointer) returns the type of the array data described---specifically,
1821 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1822 in from the descriptor; otherwise, they are left unspecified. If
1823 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1824 returns NULL. The result is simply the type of ARR if ARR is not
1827 static struct type
*
1828 ada_type_of_array (struct value
*arr
, int bounds
)
1830 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1831 return decode_constrained_packed_array_type (value_type (arr
));
1833 if (!ada_is_array_descriptor_type (value_type (arr
)))
1834 return value_type (arr
);
1838 struct type
*array_type
=
1839 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1841 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1842 TYPE_FIELD_BITSIZE (array_type
, 0) =
1843 decode_packed_array_bitsize (value_type (arr
));
1849 struct type
*elt_type
;
1851 struct value
*descriptor
;
1853 elt_type
= ada_array_element_type (value_type (arr
), -1);
1854 arity
= ada_array_arity (value_type (arr
));
1856 if (elt_type
== NULL
|| arity
== 0)
1857 return ada_check_typedef (value_type (arr
));
1859 descriptor
= desc_bounds (arr
);
1860 if (value_as_long (descriptor
) == 0)
1864 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1865 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1866 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1867 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1870 create_static_range_type (range_type
, value_type (low
),
1871 longest_to_int (value_as_long (low
)),
1872 longest_to_int (value_as_long (high
)));
1873 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1875 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1877 /* We need to store the element packed bitsize, as well as
1878 recompute the array size, because it was previously
1879 computed based on the unpacked element size. */
1880 LONGEST lo
= value_as_long (low
);
1881 LONGEST hi
= value_as_long (high
);
1883 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1884 decode_packed_array_bitsize (value_type (arr
));
1885 /* If the array has no element, then the size is already
1886 zero, and does not need to be recomputed. */
1890 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1892 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1897 return lookup_pointer_type (elt_type
);
1901 /* If ARR does not represent an array, returns ARR unchanged.
1902 Otherwise, returns either a standard GDB array with bounds set
1903 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1904 GDB array. Returns NULL if ARR is a null fat pointer. */
1907 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1909 if (ada_is_array_descriptor_type (value_type (arr
)))
1911 struct type
*arrType
= ada_type_of_array (arr
, 1);
1913 if (arrType
== NULL
)
1915 return value_cast (arrType
, value_copy (desc_data (arr
)));
1917 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1918 return decode_constrained_packed_array (arr
);
1923 /* If ARR does not represent an array, returns ARR unchanged.
1924 Otherwise, returns a standard GDB array describing ARR (which may
1925 be ARR itself if it already is in the proper form). */
1928 ada_coerce_to_simple_array (struct value
*arr
)
1930 if (ada_is_array_descriptor_type (value_type (arr
)))
1932 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1935 error (_("Bounds unavailable for null array pointer."));
1936 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1937 return value_ind (arrVal
);
1939 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1940 return decode_constrained_packed_array (arr
);
1945 /* If TYPE represents a GNAT array type, return it translated to an
1946 ordinary GDB array type (possibly with BITSIZE fields indicating
1947 packing). For other types, is the identity. */
1950 ada_coerce_to_simple_array_type (struct type
*type
)
1952 if (ada_is_constrained_packed_array_type (type
))
1953 return decode_constrained_packed_array_type (type
);
1955 if (ada_is_array_descriptor_type (type
))
1956 return ada_check_typedef (desc_data_target_type (type
));
1961 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1964 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
1968 type
= desc_base_type (type
);
1969 type
= ada_check_typedef (type
);
1971 ada_type_name (type
) != NULL
1972 && strstr (ada_type_name (type
), "___XP") != NULL
;
1975 /* Non-zero iff TYPE represents a standard GNAT constrained
1976 packed-array type. */
1979 ada_is_constrained_packed_array_type (struct type
*type
)
1981 return ada_is_gnat_encoded_packed_array_type (type
)
1982 && !ada_is_array_descriptor_type (type
);
1985 /* Non-zero iff TYPE represents an array descriptor for a
1986 unconstrained packed-array type. */
1989 ada_is_unconstrained_packed_array_type (struct type
*type
)
1991 if (!ada_is_array_descriptor_type (type
))
1994 if (ada_is_gnat_encoded_packed_array_type (type
))
1997 /* If we saw GNAT encodings, then the above code is sufficient.
1998 However, with minimal encodings, we will just have a thick
2000 if (is_thick_pntr (type
))
2002 type
= desc_base_type (type
);
2003 /* The structure's first field is a pointer to an array, so this
2004 fetches the array type. */
2005 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2006 /* Now we can see if the array elements are packed. */
2007 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
2013 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2014 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2017 ada_is_any_packed_array_type (struct type
*type
)
2019 return (ada_is_constrained_packed_array_type (type
)
2020 || (type
->code () == TYPE_CODE_ARRAY
2021 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
2024 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2025 return the size of its elements in bits. */
2028 decode_packed_array_bitsize (struct type
*type
)
2030 const char *raw_name
;
2034 /* Access to arrays implemented as fat pointers are encoded as a typedef
2035 of the fat pointer type. We need the name of the fat pointer type
2036 to do the decoding, so strip the typedef layer. */
2037 if (type
->code () == TYPE_CODE_TYPEDEF
)
2038 type
= ada_typedef_target_type (type
);
2040 raw_name
= ada_type_name (ada_check_typedef (type
));
2042 raw_name
= ada_type_name (desc_base_type (type
));
2047 tail
= strstr (raw_name
, "___XP");
2048 if (tail
== nullptr)
2050 gdb_assert (is_thick_pntr (type
));
2051 /* The structure's first field is a pointer to an array, so this
2052 fetches the array type. */
2053 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2054 /* Now we can see if the array elements are packed. */
2055 return TYPE_FIELD_BITSIZE (type
, 0);
2058 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2061 (_("could not understand bit size information on packed array"));
2068 /* Given that TYPE is a standard GDB array type with all bounds filled
2069 in, and that the element size of its ultimate scalar constituents
2070 (that is, either its elements, or, if it is an array of arrays, its
2071 elements' elements, etc.) is *ELT_BITS, return an identical type,
2072 but with the bit sizes of its elements (and those of any
2073 constituent arrays) recorded in the BITSIZE components of its
2074 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2077 Note that, for arrays whose index type has an XA encoding where
2078 a bound references a record discriminant, getting that discriminant,
2079 and therefore the actual value of that bound, is not possible
2080 because none of the given parameters gives us access to the record.
2081 This function assumes that it is OK in the context where it is being
2082 used to return an array whose bounds are still dynamic and where
2083 the length is arbitrary. */
2085 static struct type
*
2086 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2088 struct type
*new_elt_type
;
2089 struct type
*new_type
;
2090 struct type
*index_type_desc
;
2091 struct type
*index_type
;
2092 LONGEST low_bound
, high_bound
;
2094 type
= ada_check_typedef (type
);
2095 if (type
->code () != TYPE_CODE_ARRAY
)
2098 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2099 if (index_type_desc
)
2100 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2103 index_type
= type
->index_type ();
2105 new_type
= alloc_type_copy (type
);
2107 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2109 create_array_type (new_type
, new_elt_type
, index_type
);
2110 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2111 new_type
->set_name (ada_type_name (type
));
2113 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2114 && is_dynamic_type (check_typedef (index_type
)))
2115 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2116 low_bound
= high_bound
= 0;
2117 if (high_bound
< low_bound
)
2118 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2121 *elt_bits
*= (high_bound
- low_bound
+ 1);
2122 TYPE_LENGTH (new_type
) =
2123 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2126 new_type
->set_is_fixed_instance (true);
2130 /* The array type encoded by TYPE, where
2131 ada_is_constrained_packed_array_type (TYPE). */
2133 static struct type
*
2134 decode_constrained_packed_array_type (struct type
*type
)
2136 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2139 struct type
*shadow_type
;
2143 raw_name
= ada_type_name (desc_base_type (type
));
2148 name
= (char *) alloca (strlen (raw_name
) + 1);
2149 tail
= strstr (raw_name
, "___XP");
2150 type
= desc_base_type (type
);
2152 memcpy (name
, raw_name
, tail
- raw_name
);
2153 name
[tail
- raw_name
] = '\000';
2155 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2157 if (shadow_type
== NULL
)
2159 lim_warning (_("could not find bounds information on packed array"));
2162 shadow_type
= check_typedef (shadow_type
);
2164 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2166 lim_warning (_("could not understand bounds "
2167 "information on packed array"));
2171 bits
= decode_packed_array_bitsize (type
);
2172 return constrained_packed_array_type (shadow_type
, &bits
);
2175 /* Helper function for decode_constrained_packed_array. Set the field
2176 bitsize on a series of packed arrays. Returns the number of
2177 elements in TYPE. */
2180 recursively_update_array_bitsize (struct type
*type
)
2182 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2185 if (get_discrete_bounds (type
->index_type (), &low
, &high
) < 0
2188 LONGEST our_len
= high
- low
+ 1;
2190 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
2191 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2193 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2194 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2195 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2197 TYPE_LENGTH (type
) = ((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2204 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2205 array, returns a simple array that denotes that array. Its type is a
2206 standard GDB array type except that the BITSIZEs of the array
2207 target types are set to the number of bits in each element, and the
2208 type length is set appropriately. */
2210 static struct value
*
2211 decode_constrained_packed_array (struct value
*arr
)
2215 /* If our value is a pointer, then dereference it. Likewise if
2216 the value is a reference. Make sure that this operation does not
2217 cause the target type to be fixed, as this would indirectly cause
2218 this array to be decoded. The rest of the routine assumes that
2219 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2220 and "value_ind" routines to perform the dereferencing, as opposed
2221 to using "ada_coerce_ref" or "ada_value_ind". */
2222 arr
= coerce_ref (arr
);
2223 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2224 arr
= value_ind (arr
);
2226 type
= decode_constrained_packed_array_type (value_type (arr
));
2229 error (_("can't unpack array"));
2233 /* Decoding the packed array type could not correctly set the field
2234 bitsizes for any dimension except the innermost, because the
2235 bounds may be variable and were not passed to that function. So,
2236 we further resolve the array bounds here and then update the
2238 const gdb_byte
*valaddr
= value_contents_for_printing (arr
);
2239 CORE_ADDR address
= value_address (arr
);
2240 gdb::array_view
<const gdb_byte
> view
2241 = gdb::make_array_view (valaddr
, TYPE_LENGTH (type
));
2242 type
= resolve_dynamic_type (type
, view
, address
);
2243 recursively_update_array_bitsize (type
);
2245 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2246 && ada_is_modular_type (value_type (arr
)))
2248 /* This is a (right-justified) modular type representing a packed
2249 array with no wrapper. In order to interpret the value through
2250 the (left-justified) packed array type we just built, we must
2251 first left-justify it. */
2252 int bit_size
, bit_pos
;
2255 mod
= ada_modulus (value_type (arr
)) - 1;
2262 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2263 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2264 bit_pos
/ HOST_CHAR_BIT
,
2265 bit_pos
% HOST_CHAR_BIT
,
2270 return coerce_unspec_val_to_type (arr
, type
);
2274 /* The value of the element of packed array ARR at the ARITY indices
2275 given in IND. ARR must be a simple array. */
2277 static struct value
*
2278 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2281 int bits
, elt_off
, bit_off
;
2282 long elt_total_bit_offset
;
2283 struct type
*elt_type
;
2287 elt_total_bit_offset
= 0;
2288 elt_type
= ada_check_typedef (value_type (arr
));
2289 for (i
= 0; i
< arity
; i
+= 1)
2291 if (elt_type
->code () != TYPE_CODE_ARRAY
2292 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2294 (_("attempt to do packed indexing of "
2295 "something other than a packed array"));
2298 struct type
*range_type
= elt_type
->index_type ();
2299 LONGEST lowerbound
, upperbound
;
2302 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2304 lim_warning (_("don't know bounds of array"));
2305 lowerbound
= upperbound
= 0;
2308 idx
= pos_atr (ind
[i
]);
2309 if (idx
< lowerbound
|| idx
> upperbound
)
2310 lim_warning (_("packed array index %ld out of bounds"),
2312 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2313 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2314 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2317 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2318 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2320 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2325 /* Non-zero iff TYPE includes negative integer values. */
2328 has_negatives (struct type
*type
)
2330 switch (type
->code ())
2335 return !type
->is_unsigned ();
2336 case TYPE_CODE_RANGE
:
2337 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2341 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2342 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2343 the unpacked buffer.
2345 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2346 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2348 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2351 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2353 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2356 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2357 gdb_byte
*unpacked
, int unpacked_len
,
2358 int is_big_endian
, int is_signed_type
,
2361 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2362 int src_idx
; /* Index into the source area */
2363 int src_bytes_left
; /* Number of source bytes left to process. */
2364 int srcBitsLeft
; /* Number of source bits left to move */
2365 int unusedLS
; /* Number of bits in next significant
2366 byte of source that are unused */
2368 int unpacked_idx
; /* Index into the unpacked buffer */
2369 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2371 unsigned long accum
; /* Staging area for bits being transferred */
2372 int accumSize
; /* Number of meaningful bits in accum */
2375 /* Transmit bytes from least to most significant; delta is the direction
2376 the indices move. */
2377 int delta
= is_big_endian
? -1 : 1;
2379 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2381 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2382 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2383 bit_size
, unpacked_len
);
2385 srcBitsLeft
= bit_size
;
2386 src_bytes_left
= src_len
;
2387 unpacked_bytes_left
= unpacked_len
;
2392 src_idx
= src_len
- 1;
2394 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2398 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2404 unpacked_idx
= unpacked_len
- 1;
2408 /* Non-scalar values must be aligned at a byte boundary... */
2410 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2411 /* ... And are placed at the beginning (most-significant) bytes
2413 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2414 unpacked_bytes_left
= unpacked_idx
+ 1;
2419 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2421 src_idx
= unpacked_idx
= 0;
2422 unusedLS
= bit_offset
;
2425 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2430 while (src_bytes_left
> 0)
2432 /* Mask for removing bits of the next source byte that are not
2433 part of the value. */
2434 unsigned int unusedMSMask
=
2435 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2437 /* Sign-extend bits for this byte. */
2438 unsigned int signMask
= sign
& ~unusedMSMask
;
2441 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2442 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2443 if (accumSize
>= HOST_CHAR_BIT
)
2445 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2446 accumSize
-= HOST_CHAR_BIT
;
2447 accum
>>= HOST_CHAR_BIT
;
2448 unpacked_bytes_left
-= 1;
2449 unpacked_idx
+= delta
;
2451 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2453 src_bytes_left
-= 1;
2456 while (unpacked_bytes_left
> 0)
2458 accum
|= sign
<< accumSize
;
2459 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2460 accumSize
-= HOST_CHAR_BIT
;
2463 accum
>>= HOST_CHAR_BIT
;
2464 unpacked_bytes_left
-= 1;
2465 unpacked_idx
+= delta
;
2469 /* Create a new value of type TYPE from the contents of OBJ starting
2470 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2471 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2472 assigning through the result will set the field fetched from.
2473 VALADDR is ignored unless OBJ is NULL, in which case,
2474 VALADDR+OFFSET must address the start of storage containing the
2475 packed value. The value returned in this case is never an lval.
2476 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2479 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2480 long offset
, int bit_offset
, int bit_size
,
2484 const gdb_byte
*src
; /* First byte containing data to unpack */
2486 const int is_scalar
= is_scalar_type (type
);
2487 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2488 gdb::byte_vector staging
;
2490 type
= ada_check_typedef (type
);
2493 src
= valaddr
+ offset
;
2495 src
= value_contents (obj
) + offset
;
2497 if (is_dynamic_type (type
))
2499 /* The length of TYPE might by dynamic, so we need to resolve
2500 TYPE in order to know its actual size, which we then use
2501 to create the contents buffer of the value we return.
2502 The difficulty is that the data containing our object is
2503 packed, and therefore maybe not at a byte boundary. So, what
2504 we do, is unpack the data into a byte-aligned buffer, and then
2505 use that buffer as our object's value for resolving the type. */
2506 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2507 staging
.resize (staging_len
);
2509 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2510 staging
.data (), staging
.size (),
2511 is_big_endian
, has_negatives (type
),
2513 type
= resolve_dynamic_type (type
, staging
, 0);
2514 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2516 /* This happens when the length of the object is dynamic,
2517 and is actually smaller than the space reserved for it.
2518 For instance, in an array of variant records, the bit_size
2519 we're given is the array stride, which is constant and
2520 normally equal to the maximum size of its element.
2521 But, in reality, each element only actually spans a portion
2523 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2529 v
= allocate_value (type
);
2530 src
= valaddr
+ offset
;
2532 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2534 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2537 v
= value_at (type
, value_address (obj
) + offset
);
2538 buf
= (gdb_byte
*) alloca (src_len
);
2539 read_memory (value_address (v
), buf
, src_len
);
2544 v
= allocate_value (type
);
2545 src
= value_contents (obj
) + offset
;
2550 long new_offset
= offset
;
2552 set_value_component_location (v
, obj
);
2553 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2554 set_value_bitsize (v
, bit_size
);
2555 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2558 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2560 set_value_offset (v
, new_offset
);
2562 /* Also set the parent value. This is needed when trying to
2563 assign a new value (in inferior memory). */
2564 set_value_parent (v
, obj
);
2567 set_value_bitsize (v
, bit_size
);
2568 unpacked
= value_contents_writeable (v
);
2572 memset (unpacked
, 0, TYPE_LENGTH (type
));
2576 if (staging
.size () == TYPE_LENGTH (type
))
2578 /* Small short-cut: If we've unpacked the data into a buffer
2579 of the same size as TYPE's length, then we can reuse that,
2580 instead of doing the unpacking again. */
2581 memcpy (unpacked
, staging
.data (), staging
.size ());
2584 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2585 unpacked
, TYPE_LENGTH (type
),
2586 is_big_endian
, has_negatives (type
), is_scalar
);
2591 /* Store the contents of FROMVAL into the location of TOVAL.
2592 Return a new value with the location of TOVAL and contents of
2593 FROMVAL. Handles assignment into packed fields that have
2594 floating-point or non-scalar types. */
2596 static struct value
*
2597 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2599 struct type
*type
= value_type (toval
);
2600 int bits
= value_bitsize (toval
);
2602 toval
= ada_coerce_ref (toval
);
2603 fromval
= ada_coerce_ref (fromval
);
2605 if (ada_is_direct_array_type (value_type (toval
)))
2606 toval
= ada_coerce_to_simple_array (toval
);
2607 if (ada_is_direct_array_type (value_type (fromval
)))
2608 fromval
= ada_coerce_to_simple_array (fromval
);
2610 if (!deprecated_value_modifiable (toval
))
2611 error (_("Left operand of assignment is not a modifiable lvalue."));
2613 if (VALUE_LVAL (toval
) == lval_memory
2615 && (type
->code () == TYPE_CODE_FLT
2616 || type
->code () == TYPE_CODE_STRUCT
))
2618 int len
= (value_bitpos (toval
)
2619 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2621 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2623 CORE_ADDR to_addr
= value_address (toval
);
2625 if (type
->code () == TYPE_CODE_FLT
)
2626 fromval
= value_cast (type
, fromval
);
2628 read_memory (to_addr
, buffer
, len
);
2629 from_size
= value_bitsize (fromval
);
2631 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2633 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2634 ULONGEST from_offset
= 0;
2635 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2636 from_offset
= from_size
- bits
;
2637 copy_bitwise (buffer
, value_bitpos (toval
),
2638 value_contents (fromval
), from_offset
,
2639 bits
, is_big_endian
);
2640 write_memory_with_notification (to_addr
, buffer
, len
);
2642 val
= value_copy (toval
);
2643 memcpy (value_contents_raw (val
), value_contents (fromval
),
2644 TYPE_LENGTH (type
));
2645 deprecated_set_value_type (val
, type
);
2650 return value_assign (toval
, fromval
);
2654 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2655 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2656 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2657 COMPONENT, and not the inferior's memory. The current contents
2658 of COMPONENT are ignored.
2660 Although not part of the initial design, this function also works
2661 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2662 had a null address, and COMPONENT had an address which is equal to
2663 its offset inside CONTAINER. */
2666 value_assign_to_component (struct value
*container
, struct value
*component
,
2669 LONGEST offset_in_container
=
2670 (LONGEST
) (value_address (component
) - value_address (container
));
2671 int bit_offset_in_container
=
2672 value_bitpos (component
) - value_bitpos (container
);
2675 val
= value_cast (value_type (component
), val
);
2677 if (value_bitsize (component
) == 0)
2678 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2680 bits
= value_bitsize (component
);
2682 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2686 if (is_scalar_type (check_typedef (value_type (component
))))
2688 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2691 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2692 value_bitpos (container
) + bit_offset_in_container
,
2693 value_contents (val
), src_offset
, bits
, 1);
2696 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2697 value_bitpos (container
) + bit_offset_in_container
,
2698 value_contents (val
), 0, bits
, 0);
2701 /* Determine if TYPE is an access to an unconstrained array. */
2704 ada_is_access_to_unconstrained_array (struct type
*type
)
2706 return (type
->code () == TYPE_CODE_TYPEDEF
2707 && is_thick_pntr (ada_typedef_target_type (type
)));
2710 /* The value of the element of array ARR at the ARITY indices given in IND.
2711 ARR may be either a simple array, GNAT array descriptor, or pointer
2715 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2719 struct type
*elt_type
;
2721 elt
= ada_coerce_to_simple_array (arr
);
2723 elt_type
= ada_check_typedef (value_type (elt
));
2724 if (elt_type
->code () == TYPE_CODE_ARRAY
2725 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2726 return value_subscript_packed (elt
, arity
, ind
);
2728 for (k
= 0; k
< arity
; k
+= 1)
2730 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2732 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2733 error (_("too many subscripts (%d expected)"), k
);
2735 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2737 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2738 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2740 /* The element is a typedef to an unconstrained array,
2741 except that the value_subscript call stripped the
2742 typedef layer. The typedef layer is GNAT's way to
2743 specify that the element is, at the source level, an
2744 access to the unconstrained array, rather than the
2745 unconstrained array. So, we need to restore that
2746 typedef layer, which we can do by forcing the element's
2747 type back to its original type. Otherwise, the returned
2748 value is going to be printed as the array, rather
2749 than as an access. Another symptom of the same issue
2750 would be that an expression trying to dereference the
2751 element would also be improperly rejected. */
2752 deprecated_set_value_type (elt
, saved_elt_type
);
2755 elt_type
= ada_check_typedef (value_type (elt
));
2761 /* Assuming ARR is a pointer to a GDB array, the value of the element
2762 of *ARR at the ARITY indices given in IND.
2763 Does not read the entire array into memory.
2765 Note: Unlike what one would expect, this function is used instead of
2766 ada_value_subscript for basically all non-packed array types. The reason
2767 for this is that a side effect of doing our own pointer arithmetics instead
2768 of relying on value_subscript is that there is no implicit typedef peeling.
2769 This is important for arrays of array accesses, where it allows us to
2770 preserve the fact that the array's element is an array access, where the
2771 access part os encoded in a typedef layer. */
2773 static struct value
*
2774 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2777 struct value
*array_ind
= ada_value_ind (arr
);
2779 = check_typedef (value_enclosing_type (array_ind
));
2781 if (type
->code () == TYPE_CODE_ARRAY
2782 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2783 return value_subscript_packed (array_ind
, arity
, ind
);
2785 for (k
= 0; k
< arity
; k
+= 1)
2789 if (type
->code () != TYPE_CODE_ARRAY
)
2790 error (_("too many subscripts (%d expected)"), k
);
2791 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2793 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2794 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2795 type
= TYPE_TARGET_TYPE (type
);
2798 return value_ind (arr
);
2801 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2802 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2803 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2804 this array is LOW, as per Ada rules. */
2805 static struct value
*
2806 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2809 struct type
*type0
= ada_check_typedef (type
);
2810 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2811 struct type
*index_type
2812 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2813 struct type
*slice_type
= create_array_type_with_stride
2814 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2815 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2816 TYPE_FIELD_BITSIZE (type0
, 0));
2817 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2818 gdb::optional
<LONGEST
> base_low_pos
, low_pos
;
2821 low_pos
= discrete_position (base_index_type
, low
);
2822 base_low_pos
= discrete_position (base_index_type
, base_low
);
2824 if (!low_pos
.has_value () || !base_low_pos
.has_value ())
2826 warning (_("unable to get positions in slice, use bounds instead"));
2828 base_low_pos
= base_low
;
2831 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
2833 stride
= TYPE_LENGTH (TYPE_TARGET_TYPE (type0
));
2835 base
= value_as_address (array_ptr
) + (*low_pos
- *base_low_pos
) * stride
;
2836 return value_at_lazy (slice_type
, base
);
2840 static struct value
*
2841 ada_value_slice (struct value
*array
, int low
, int high
)
2843 struct type
*type
= ada_check_typedef (value_type (array
));
2844 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2845 struct type
*index_type
2846 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2847 struct type
*slice_type
= create_array_type_with_stride
2848 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2849 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2850 TYPE_FIELD_BITSIZE (type
, 0));
2851 gdb::optional
<LONGEST
> low_pos
, high_pos
;
2854 low_pos
= discrete_position (base_index_type
, low
);
2855 high_pos
= discrete_position (base_index_type
, high
);
2857 if (!low_pos
.has_value () || !high_pos
.has_value ())
2859 warning (_("unable to get positions in slice, use bounds instead"));
2864 return value_cast (slice_type
,
2865 value_slice (array
, low
, *high_pos
- *low_pos
+ 1));
2868 /* If type is a record type in the form of a standard GNAT array
2869 descriptor, returns the number of dimensions for type. If arr is a
2870 simple array, returns the number of "array of"s that prefix its
2871 type designation. Otherwise, returns 0. */
2874 ada_array_arity (struct type
*type
)
2881 type
= desc_base_type (type
);
2884 if (type
->code () == TYPE_CODE_STRUCT
)
2885 return desc_arity (desc_bounds_type (type
));
2887 while (type
->code () == TYPE_CODE_ARRAY
)
2890 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2896 /* If TYPE is a record type in the form of a standard GNAT array
2897 descriptor or a simple array type, returns the element type for
2898 TYPE after indexing by NINDICES indices, or by all indices if
2899 NINDICES is -1. Otherwise, returns NULL. */
2902 ada_array_element_type (struct type
*type
, int nindices
)
2904 type
= desc_base_type (type
);
2906 if (type
->code () == TYPE_CODE_STRUCT
)
2909 struct type
*p_array_type
;
2911 p_array_type
= desc_data_target_type (type
);
2913 k
= ada_array_arity (type
);
2917 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2918 if (nindices
>= 0 && k
> nindices
)
2920 while (k
> 0 && p_array_type
!= NULL
)
2922 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2925 return p_array_type
;
2927 else if (type
->code () == TYPE_CODE_ARRAY
)
2929 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2931 type
= TYPE_TARGET_TYPE (type
);
2940 /* The type of nth index in arrays of given type (n numbering from 1).
2941 Does not examine memory. Throws an error if N is invalid or TYPE
2942 is not an array type. NAME is the name of the Ada attribute being
2943 evaluated ('range, 'first, 'last, or 'length); it is used in building
2944 the error message. */
2946 static struct type
*
2947 ada_index_type (struct type
*type
, int n
, const char *name
)
2949 struct type
*result_type
;
2951 type
= desc_base_type (type
);
2953 if (n
< 0 || n
> ada_array_arity (type
))
2954 error (_("invalid dimension number to '%s"), name
);
2956 if (ada_is_simple_array_type (type
))
2960 for (i
= 1; i
< n
; i
+= 1)
2961 type
= TYPE_TARGET_TYPE (type
);
2962 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2963 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2964 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2965 perhaps stabsread.c would make more sense. */
2966 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2971 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2972 if (result_type
== NULL
)
2973 error (_("attempt to take bound of something that is not an array"));
2979 /* Given that arr is an array type, returns the lower bound of the
2980 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2981 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2982 array-descriptor type. It works for other arrays with bounds supplied
2983 by run-time quantities other than discriminants. */
2986 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2988 struct type
*type
, *index_type_desc
, *index_type
;
2991 gdb_assert (which
== 0 || which
== 1);
2993 if (ada_is_constrained_packed_array_type (arr_type
))
2994 arr_type
= decode_constrained_packed_array_type (arr_type
);
2996 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2997 return (LONGEST
) - which
;
2999 if (arr_type
->code () == TYPE_CODE_PTR
)
3000 type
= TYPE_TARGET_TYPE (arr_type
);
3004 if (type
->is_fixed_instance ())
3006 /* The array has already been fixed, so we do not need to
3007 check the parallel ___XA type again. That encoding has
3008 already been applied, so ignore it now. */
3009 index_type_desc
= NULL
;
3013 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3014 ada_fixup_array_indexes_type (index_type_desc
);
3017 if (index_type_desc
!= NULL
)
3018 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
3022 struct type
*elt_type
= check_typedef (type
);
3024 for (i
= 1; i
< n
; i
++)
3025 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3027 index_type
= elt_type
->index_type ();
3031 (LONGEST
) (which
== 0
3032 ? ada_discrete_type_low_bound (index_type
)
3033 : ada_discrete_type_high_bound (index_type
));
3036 /* Given that arr is an array value, returns the lower bound of the
3037 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3038 WHICH is 1. This routine will also work for arrays with bounds
3039 supplied by run-time quantities other than discriminants. */
3042 ada_array_bound (struct value
*arr
, int n
, int which
)
3044 struct type
*arr_type
;
3046 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3047 arr
= value_ind (arr
);
3048 arr_type
= value_enclosing_type (arr
);
3050 if (ada_is_constrained_packed_array_type (arr_type
))
3051 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3052 else if (ada_is_simple_array_type (arr_type
))
3053 return ada_array_bound_from_type (arr_type
, n
, which
);
3055 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3058 /* Given that arr is an array value, returns the length of the
3059 nth index. This routine will also work for arrays with bounds
3060 supplied by run-time quantities other than discriminants.
3061 Does not work for arrays indexed by enumeration types with representation
3062 clauses at the moment. */
3065 ada_array_length (struct value
*arr
, int n
)
3067 struct type
*arr_type
, *index_type
;
3070 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3071 arr
= value_ind (arr
);
3072 arr_type
= value_enclosing_type (arr
);
3074 if (ada_is_constrained_packed_array_type (arr_type
))
3075 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3077 if (ada_is_simple_array_type (arr_type
))
3079 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3080 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3084 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3085 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3088 arr_type
= check_typedef (arr_type
);
3089 index_type
= ada_index_type (arr_type
, n
, "length");
3090 if (index_type
!= NULL
)
3092 struct type
*base_type
;
3093 if (index_type
->code () == TYPE_CODE_RANGE
)
3094 base_type
= TYPE_TARGET_TYPE (index_type
);
3096 base_type
= index_type
;
3098 low
= pos_atr (value_from_longest (base_type
, low
));
3099 high
= pos_atr (value_from_longest (base_type
, high
));
3101 return high
- low
+ 1;
3104 /* An array whose type is that of ARR_TYPE (an array type), with
3105 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3106 less than LOW, then LOW-1 is used. */
3108 static struct value
*
3109 empty_array (struct type
*arr_type
, int low
, int high
)
3111 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3112 struct type
*index_type
3113 = create_static_range_type
3114 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3115 high
< low
? low
- 1 : high
);
3116 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3118 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3122 /* Name resolution */
3124 /* The "decoded" name for the user-definable Ada operator corresponding
3128 ada_decoded_op_name (enum exp_opcode op
)
3132 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3134 if (ada_opname_table
[i
].op
== op
)
3135 return ada_opname_table
[i
].decoded
;
3137 error (_("Could not find operator name for opcode"));
3140 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3141 in a listing of choices during disambiguation (see sort_choices, below).
3142 The idea is that overloadings of a subprogram name from the
3143 same package should sort in their source order. We settle for ordering
3144 such symbols by their trailing number (__N or $N). */
3147 encoded_ordered_before (const char *N0
, const char *N1
)
3151 else if (N0
== NULL
)
3157 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3159 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3161 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3162 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3167 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3170 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3172 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3173 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3175 return (strcmp (N0
, N1
) < 0);
3179 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3183 sort_choices (struct block_symbol syms
[], int nsyms
)
3187 for (i
= 1; i
< nsyms
; i
+= 1)
3189 struct block_symbol sym
= syms
[i
];
3192 for (j
= i
- 1; j
>= 0; j
-= 1)
3194 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3195 sym
.symbol
->linkage_name ()))
3197 syms
[j
+ 1] = syms
[j
];
3203 /* Whether GDB should display formals and return types for functions in the
3204 overloads selection menu. */
3205 static bool print_signatures
= true;
3207 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3208 all but functions, the signature is just the name of the symbol. For
3209 functions, this is the name of the function, the list of types for formals
3210 and the return type (if any). */
3213 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3214 const struct type_print_options
*flags
)
3216 struct type
*type
= SYMBOL_TYPE (sym
);
3218 fprintf_filtered (stream
, "%s", sym
->print_name ());
3219 if (!print_signatures
3221 || type
->code () != TYPE_CODE_FUNC
)
3224 if (type
->num_fields () > 0)
3228 fprintf_filtered (stream
, " (");
3229 for (i
= 0; i
< type
->num_fields (); ++i
)
3232 fprintf_filtered (stream
, "; ");
3233 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3236 fprintf_filtered (stream
, ")");
3238 if (TYPE_TARGET_TYPE (type
) != NULL
3239 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3241 fprintf_filtered (stream
, " return ");
3242 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3246 /* Read and validate a set of numeric choices from the user in the
3247 range 0 .. N_CHOICES-1. Place the results in increasing
3248 order in CHOICES[0 .. N-1], and return N.
3250 The user types choices as a sequence of numbers on one line
3251 separated by blanks, encoding them as follows:
3253 + A choice of 0 means to cancel the selection, throwing an error.
3254 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3255 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3257 The user is not allowed to choose more than MAX_RESULTS values.
3259 ANNOTATION_SUFFIX, if present, is used to annotate the input
3260 prompts (for use with the -f switch). */
3263 get_selections (int *choices
, int n_choices
, int max_results
,
3264 int is_all_choice
, const char *annotation_suffix
)
3269 int first_choice
= is_all_choice
? 2 : 1;
3271 prompt
= getenv ("PS2");
3275 args
= command_line_input (prompt
, annotation_suffix
);
3278 error_no_arg (_("one or more choice numbers"));
3282 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3283 order, as given in args. Choices are validated. */
3289 args
= skip_spaces (args
);
3290 if (*args
== '\0' && n_chosen
== 0)
3291 error_no_arg (_("one or more choice numbers"));
3292 else if (*args
== '\0')
3295 choice
= strtol (args
, &args2
, 10);
3296 if (args
== args2
|| choice
< 0
3297 || choice
> n_choices
+ first_choice
- 1)
3298 error (_("Argument must be choice number"));
3302 error (_("cancelled"));
3304 if (choice
< first_choice
)
3306 n_chosen
= n_choices
;
3307 for (j
= 0; j
< n_choices
; j
+= 1)
3311 choice
-= first_choice
;
3313 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3317 if (j
< 0 || choice
!= choices
[j
])
3321 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3322 choices
[k
+ 1] = choices
[k
];
3323 choices
[j
+ 1] = choice
;
3328 if (n_chosen
> max_results
)
3329 error (_("Select no more than %d of the above"), max_results
);
3334 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3335 by asking the user (if necessary), returning the number selected,
3336 and setting the first elements of SYMS items. Error if no symbols
3339 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3340 to be re-integrated one of these days. */
3343 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3346 int *chosen
= XALLOCAVEC (int , nsyms
);
3348 int first_choice
= (max_results
== 1) ? 1 : 2;
3349 const char *select_mode
= multiple_symbols_select_mode ();
3351 if (max_results
< 1)
3352 error (_("Request to select 0 symbols!"));
3356 if (select_mode
== multiple_symbols_cancel
)
3358 canceled because the command is ambiguous\n\
3359 See set/show multiple-symbol."));
3361 /* If select_mode is "all", then return all possible symbols.
3362 Only do that if more than one symbol can be selected, of course.
3363 Otherwise, display the menu as usual. */
3364 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3367 printf_filtered (_("[0] cancel\n"));
3368 if (max_results
> 1)
3369 printf_filtered (_("[1] all\n"));
3371 sort_choices (syms
, nsyms
);
3373 for (i
= 0; i
< nsyms
; i
+= 1)
3375 if (syms
[i
].symbol
== NULL
)
3378 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3380 struct symtab_and_line sal
=
3381 find_function_start_sal (syms
[i
].symbol
, 1);
3383 printf_filtered ("[%d] ", i
+ first_choice
);
3384 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3385 &type_print_raw_options
);
3386 if (sal
.symtab
== NULL
)
3387 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3388 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3392 styled_string (file_name_style
.style (),
3393 symtab_to_filename_for_display (sal
.symtab
)),
3400 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3401 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3402 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3403 struct symtab
*symtab
= NULL
;
3405 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3406 symtab
= symbol_symtab (syms
[i
].symbol
);
3408 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3410 printf_filtered ("[%d] ", i
+ first_choice
);
3411 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3412 &type_print_raw_options
);
3413 printf_filtered (_(" at %s:%d\n"),
3414 symtab_to_filename_for_display (symtab
),
3415 SYMBOL_LINE (syms
[i
].symbol
));
3417 else if (is_enumeral
3418 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3420 printf_filtered (("[%d] "), i
+ first_choice
);
3421 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3422 gdb_stdout
, -1, 0, &type_print_raw_options
);
3423 printf_filtered (_("'(%s) (enumeral)\n"),
3424 syms
[i
].symbol
->print_name ());
3428 printf_filtered ("[%d] ", i
+ first_choice
);
3429 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3430 &type_print_raw_options
);
3433 printf_filtered (is_enumeral
3434 ? _(" in %s (enumeral)\n")
3436 symtab_to_filename_for_display (symtab
));
3438 printf_filtered (is_enumeral
3439 ? _(" (enumeral)\n")
3445 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3448 for (i
= 0; i
< n_chosen
; i
+= 1)
3449 syms
[i
] = syms
[chosen
[i
]];
3454 /* Resolve the operator of the subexpression beginning at
3455 position *POS of *EXPP. "Resolving" consists of replacing
3456 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3457 with their resolutions, replacing built-in operators with
3458 function calls to user-defined operators, where appropriate, and,
3459 when DEPROCEDURE_P is non-zero, converting function-valued variables
3460 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3461 are as in ada_resolve, above. */
3463 static struct value
*
3464 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3465 struct type
*context_type
, int parse_completion
,
3466 innermost_block_tracker
*tracker
)
3470 struct expression
*exp
; /* Convenience: == *expp. */
3471 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3472 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3473 int nargs
; /* Number of operands. */
3480 /* Pass one: resolve operands, saving their types and updating *pos,
3485 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3486 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3491 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3493 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3498 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3503 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3504 parse_completion
, tracker
);
3507 case OP_ATR_MODULUS
:
3517 case TERNOP_IN_RANGE
:
3518 case BINOP_IN_BOUNDS
:
3524 case OP_DISCRETE_RANGE
:
3526 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3535 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3537 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3539 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3557 case BINOP_LOGICAL_AND
:
3558 case BINOP_LOGICAL_OR
:
3559 case BINOP_BITWISE_AND
:
3560 case BINOP_BITWISE_IOR
:
3561 case BINOP_BITWISE_XOR
:
3564 case BINOP_NOTEQUAL
:
3571 case BINOP_SUBSCRIPT
:
3579 case UNOP_LOGICAL_NOT
:
3589 case OP_VAR_MSYM_VALUE
:
3596 case OP_INTERNALVAR
:
3606 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3609 case STRUCTOP_STRUCT
:
3610 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3623 error (_("Unexpected operator during name resolution"));
3626 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3627 for (i
= 0; i
< nargs
; i
+= 1)
3628 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3633 /* Pass two: perform any resolution on principal operator. */
3640 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3642 std::vector
<struct block_symbol
> candidates
;
3646 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3647 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3650 if (n_candidates
> 1)
3652 /* Types tend to get re-introduced locally, so if there
3653 are any local symbols that are not types, first filter
3656 for (j
= 0; j
< n_candidates
; j
+= 1)
3657 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3662 case LOC_REGPARM_ADDR
:
3670 if (j
< n_candidates
)
3673 while (j
< n_candidates
)
3675 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3677 candidates
[j
] = candidates
[n_candidates
- 1];
3686 if (n_candidates
== 0)
3687 error (_("No definition found for %s"),
3688 exp
->elts
[pc
+ 2].symbol
->print_name ());
3689 else if (n_candidates
== 1)
3691 else if (deprocedure_p
3692 && !is_nonfunction (candidates
.data (), n_candidates
))
3694 i
= ada_resolve_function
3695 (candidates
.data (), n_candidates
, NULL
, 0,
3696 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3697 context_type
, parse_completion
);
3699 error (_("Could not find a match for %s"),
3700 exp
->elts
[pc
+ 2].symbol
->print_name ());
3704 printf_filtered (_("Multiple matches for %s\n"),
3705 exp
->elts
[pc
+ 2].symbol
->print_name ());
3706 user_select_syms (candidates
.data (), n_candidates
, 1);
3710 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3711 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3712 tracker
->update (candidates
[i
]);
3716 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3719 replace_operator_with_call (expp
, pc
, 0, 4,
3720 exp
->elts
[pc
+ 2].symbol
,
3721 exp
->elts
[pc
+ 1].block
);
3728 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3729 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3731 std::vector
<struct block_symbol
> candidates
;
3735 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3736 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3739 if (n_candidates
== 1)
3743 i
= ada_resolve_function
3744 (candidates
.data (), n_candidates
,
3746 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3747 context_type
, parse_completion
);
3749 error (_("Could not find a match for %s"),
3750 exp
->elts
[pc
+ 5].symbol
->print_name ());
3753 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3754 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3755 tracker
->update (candidates
[i
]);
3766 case BINOP_BITWISE_AND
:
3767 case BINOP_BITWISE_IOR
:
3768 case BINOP_BITWISE_XOR
:
3770 case BINOP_NOTEQUAL
:
3778 case UNOP_LOGICAL_NOT
:
3780 if (possible_user_operator_p (op
, argvec
))
3782 std::vector
<struct block_symbol
> candidates
;
3786 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3790 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3791 nargs
, ada_decoded_op_name (op
), NULL
,
3796 replace_operator_with_call (expp
, pc
, nargs
, 1,
3797 candidates
[i
].symbol
,
3798 candidates
[i
].block
);
3809 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3810 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3811 exp
->elts
[pc
+ 1].objfile
,
3812 exp
->elts
[pc
+ 2].msymbol
);
3814 return evaluate_subexp_type (exp
, pos
);
3817 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3818 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3820 /* The term "match" here is rather loose. The match is heuristic and
3824 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3826 ftype
= ada_check_typedef (ftype
);
3827 atype
= ada_check_typedef (atype
);
3829 if (ftype
->code () == TYPE_CODE_REF
)
3830 ftype
= TYPE_TARGET_TYPE (ftype
);
3831 if (atype
->code () == TYPE_CODE_REF
)
3832 atype
= TYPE_TARGET_TYPE (atype
);
3834 switch (ftype
->code ())
3837 return ftype
->code () == atype
->code ();
3839 if (atype
->code () == TYPE_CODE_PTR
)
3840 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3841 TYPE_TARGET_TYPE (atype
), 0);
3844 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3846 case TYPE_CODE_ENUM
:
3847 case TYPE_CODE_RANGE
:
3848 switch (atype
->code ())
3851 case TYPE_CODE_ENUM
:
3852 case TYPE_CODE_RANGE
:
3858 case TYPE_CODE_ARRAY
:
3859 return (atype
->code () == TYPE_CODE_ARRAY
3860 || ada_is_array_descriptor_type (atype
));
3862 case TYPE_CODE_STRUCT
:
3863 if (ada_is_array_descriptor_type (ftype
))
3864 return (atype
->code () == TYPE_CODE_ARRAY
3865 || ada_is_array_descriptor_type (atype
));
3867 return (atype
->code () == TYPE_CODE_STRUCT
3868 && !ada_is_array_descriptor_type (atype
));
3870 case TYPE_CODE_UNION
:
3872 return (atype
->code () == ftype
->code ());
3876 /* Return non-zero if the formals of FUNC "sufficiently match" the
3877 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3878 may also be an enumeral, in which case it is treated as a 0-
3879 argument function. */
3882 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3885 struct type
*func_type
= SYMBOL_TYPE (func
);
3887 if (SYMBOL_CLASS (func
) == LOC_CONST
3888 && func_type
->code () == TYPE_CODE_ENUM
)
3889 return (n_actuals
== 0);
3890 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3893 if (func_type
->num_fields () != n_actuals
)
3896 for (i
= 0; i
< n_actuals
; i
+= 1)
3898 if (actuals
[i
] == NULL
)
3902 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3903 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3905 if (!ada_type_match (ftype
, atype
, 1))
3912 /* False iff function type FUNC_TYPE definitely does not produce a value
3913 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3914 FUNC_TYPE is not a valid function type with a non-null return type
3915 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3918 return_match (struct type
*func_type
, struct type
*context_type
)
3920 struct type
*return_type
;
3922 if (func_type
== NULL
)
3925 if (func_type
->code () == TYPE_CODE_FUNC
)
3926 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3928 return_type
= get_base_type (func_type
);
3929 if (return_type
== NULL
)
3932 context_type
= get_base_type (context_type
);
3934 if (return_type
->code () == TYPE_CODE_ENUM
)
3935 return context_type
== NULL
|| return_type
== context_type
;
3936 else if (context_type
== NULL
)
3937 return return_type
->code () != TYPE_CODE_VOID
;
3939 return return_type
->code () == context_type
->code ();
3943 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3944 function (if any) that matches the types of the NARGS arguments in
3945 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3946 that returns that type, then eliminate matches that don't. If
3947 CONTEXT_TYPE is void and there is at least one match that does not
3948 return void, eliminate all matches that do.
3950 Asks the user if there is more than one match remaining. Returns -1
3951 if there is no such symbol or none is selected. NAME is used
3952 solely for messages. May re-arrange and modify SYMS in
3953 the process; the index returned is for the modified vector. */
3956 ada_resolve_function (struct block_symbol syms
[],
3957 int nsyms
, struct value
**args
, int nargs
,
3958 const char *name
, struct type
*context_type
,
3959 int parse_completion
)
3963 int m
; /* Number of hits */
3966 /* In the first pass of the loop, we only accept functions matching
3967 context_type. If none are found, we add a second pass of the loop
3968 where every function is accepted. */
3969 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3971 for (k
= 0; k
< nsyms
; k
+= 1)
3973 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3975 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3976 && (fallback
|| return_match (type
, context_type
)))
3984 /* If we got multiple matches, ask the user which one to use. Don't do this
3985 interactive thing during completion, though, as the purpose of the
3986 completion is providing a list of all possible matches. Prompting the
3987 user to filter it down would be completely unexpected in this case. */
3990 else if (m
> 1 && !parse_completion
)
3992 printf_filtered (_("Multiple matches for %s\n"), name
);
3993 user_select_syms (syms
, m
, 1);
3999 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4000 on the function identified by SYM and BLOCK, and taking NARGS
4001 arguments. Update *EXPP as needed to hold more space. */
4004 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4005 int oplen
, struct symbol
*sym
,
4006 const struct block
*block
)
4008 /* We want to add 6 more elements (3 for funcall, 4 for function
4009 symbol, -OPLEN for operator being replaced) to the
4011 struct expression
*exp
= expp
->get ();
4012 int save_nelts
= exp
->nelts
;
4013 int extra_elts
= 7 - oplen
;
4014 exp
->nelts
+= extra_elts
;
4017 exp
->resize (exp
->nelts
);
4018 memmove (exp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4019 EXP_ELEM_TO_BYTES (save_nelts
- pc
- oplen
));
4021 exp
->resize (exp
->nelts
);
4023 exp
->elts
[pc
].opcode
= exp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4024 exp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4026 exp
->elts
[pc
+ 3].opcode
= exp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4027 exp
->elts
[pc
+ 4].block
= block
;
4028 exp
->elts
[pc
+ 5].symbol
= sym
;
4031 /* Type-class predicates */
4033 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4037 numeric_type_p (struct type
*type
)
4043 switch (type
->code ())
4048 case TYPE_CODE_RANGE
:
4049 return (type
== TYPE_TARGET_TYPE (type
)
4050 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4057 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4060 integer_type_p (struct type
*type
)
4066 switch (type
->code ())
4070 case TYPE_CODE_RANGE
:
4071 return (type
== TYPE_TARGET_TYPE (type
)
4072 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4079 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4082 scalar_type_p (struct type
*type
)
4088 switch (type
->code ())
4091 case TYPE_CODE_RANGE
:
4092 case TYPE_CODE_ENUM
:
4101 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4104 discrete_type_p (struct type
*type
)
4110 switch (type
->code ())
4113 case TYPE_CODE_RANGE
:
4114 case TYPE_CODE_ENUM
:
4115 case TYPE_CODE_BOOL
:
4123 /* Returns non-zero if OP with operands in the vector ARGS could be
4124 a user-defined function. Errs on the side of pre-defined operators
4125 (i.e., result 0). */
4128 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4130 struct type
*type0
=
4131 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4132 struct type
*type1
=
4133 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4147 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4151 case BINOP_BITWISE_AND
:
4152 case BINOP_BITWISE_IOR
:
4153 case BINOP_BITWISE_XOR
:
4154 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4157 case BINOP_NOTEQUAL
:
4162 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4165 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4168 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4172 case UNOP_LOGICAL_NOT
:
4174 return (!numeric_type_p (type0
));
4183 1. In the following, we assume that a renaming type's name may
4184 have an ___XD suffix. It would be nice if this went away at some
4186 2. We handle both the (old) purely type-based representation of
4187 renamings and the (new) variable-based encoding. At some point,
4188 it is devoutly to be hoped that the former goes away
4189 (FIXME: hilfinger-2007-07-09).
4190 3. Subprogram renamings are not implemented, although the XRS
4191 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4193 /* If SYM encodes a renaming,
4195 <renaming> renames <renamed entity>,
4197 sets *LEN to the length of the renamed entity's name,
4198 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4199 the string describing the subcomponent selected from the renamed
4200 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4201 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4202 are undefined). Otherwise, returns a value indicating the category
4203 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4204 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4205 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4206 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4207 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4208 may be NULL, in which case they are not assigned.
4210 [Currently, however, GCC does not generate subprogram renamings.] */
4212 enum ada_renaming_category
4213 ada_parse_renaming (struct symbol
*sym
,
4214 const char **renamed_entity
, int *len
,
4215 const char **renaming_expr
)
4217 enum ada_renaming_category kind
;
4222 return ADA_NOT_RENAMING
;
4223 switch (SYMBOL_CLASS (sym
))
4226 return ADA_NOT_RENAMING
;
4230 case LOC_OPTIMIZED_OUT
:
4231 info
= strstr (sym
->linkage_name (), "___XR");
4233 return ADA_NOT_RENAMING
;
4237 kind
= ADA_OBJECT_RENAMING
;
4241 kind
= ADA_EXCEPTION_RENAMING
;
4245 kind
= ADA_PACKAGE_RENAMING
;
4249 kind
= ADA_SUBPROGRAM_RENAMING
;
4253 return ADA_NOT_RENAMING
;
4257 if (renamed_entity
!= NULL
)
4258 *renamed_entity
= info
;
4259 suffix
= strstr (info
, "___XE");
4260 if (suffix
== NULL
|| suffix
== info
)
4261 return ADA_NOT_RENAMING
;
4263 *len
= strlen (info
) - strlen (suffix
);
4265 if (renaming_expr
!= NULL
)
4266 *renaming_expr
= suffix
;
4270 /* Compute the value of the given RENAMING_SYM, which is expected to
4271 be a symbol encoding a renaming expression. BLOCK is the block
4272 used to evaluate the renaming. */
4274 static struct value
*
4275 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4276 const struct block
*block
)
4278 const char *sym_name
;
4280 sym_name
= renaming_sym
->linkage_name ();
4281 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4282 return evaluate_expression (expr
.get ());
4286 /* Evaluation: Function Calls */
4288 /* Return an lvalue containing the value VAL. This is the identity on
4289 lvalues, and otherwise has the side-effect of allocating memory
4290 in the inferior where a copy of the value contents is copied. */
4292 static struct value
*
4293 ensure_lval (struct value
*val
)
4295 if (VALUE_LVAL (val
) == not_lval
4296 || VALUE_LVAL (val
) == lval_internalvar
)
4298 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4299 const CORE_ADDR addr
=
4300 value_as_long (value_allocate_space_in_inferior (len
));
4302 VALUE_LVAL (val
) = lval_memory
;
4303 set_value_address (val
, addr
);
4304 write_memory (addr
, value_contents (val
), len
);
4310 /* Given ARG, a value of type (pointer or reference to a)*
4311 structure/union, extract the component named NAME from the ultimate
4312 target structure/union and return it as a value with its
4315 The routine searches for NAME among all members of the structure itself
4316 and (recursively) among all members of any wrapper members
4319 If NO_ERR, then simply return NULL in case of error, rather than
4322 static struct value
*
4323 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4325 struct type
*t
, *t1
;
4330 t1
= t
= ada_check_typedef (value_type (arg
));
4331 if (t
->code () == TYPE_CODE_REF
)
4333 t1
= TYPE_TARGET_TYPE (t
);
4336 t1
= ada_check_typedef (t1
);
4337 if (t1
->code () == TYPE_CODE_PTR
)
4339 arg
= coerce_ref (arg
);
4344 while (t
->code () == TYPE_CODE_PTR
)
4346 t1
= TYPE_TARGET_TYPE (t
);
4349 t1
= ada_check_typedef (t1
);
4350 if (t1
->code () == TYPE_CODE_PTR
)
4352 arg
= value_ind (arg
);
4359 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4363 v
= ada_search_struct_field (name
, arg
, 0, t
);
4366 int bit_offset
, bit_size
, byte_offset
;
4367 struct type
*field_type
;
4370 if (t
->code () == TYPE_CODE_PTR
)
4371 address
= value_address (ada_value_ind (arg
));
4373 address
= value_address (ada_coerce_ref (arg
));
4375 /* Check to see if this is a tagged type. We also need to handle
4376 the case where the type is a reference to a tagged type, but
4377 we have to be careful to exclude pointers to tagged types.
4378 The latter should be shown as usual (as a pointer), whereas
4379 a reference should mostly be transparent to the user. */
4381 if (ada_is_tagged_type (t1
, 0)
4382 || (t1
->code () == TYPE_CODE_REF
4383 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4385 /* We first try to find the searched field in the current type.
4386 If not found then let's look in the fixed type. */
4388 if (!find_struct_field (name
, t1
, 0,
4389 &field_type
, &byte_offset
, &bit_offset
,
4398 /* Convert to fixed type in all cases, so that we have proper
4399 offsets to each field in unconstrained record types. */
4400 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4401 address
, NULL
, check_tag
);
4403 /* Resolve the dynamic type as well. */
4404 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4405 t1
= value_type (arg
);
4407 if (find_struct_field (name
, t1
, 0,
4408 &field_type
, &byte_offset
, &bit_offset
,
4413 if (t
->code () == TYPE_CODE_REF
)
4414 arg
= ada_coerce_ref (arg
);
4416 arg
= ada_value_ind (arg
);
4417 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4418 bit_offset
, bit_size
,
4422 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4426 if (v
!= NULL
|| no_err
)
4429 error (_("There is no member named %s."), name
);
4435 error (_("Attempt to extract a component of "
4436 "a value that is not a record."));
4439 /* Return the value ACTUAL, converted to be an appropriate value for a
4440 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4441 allocating any necessary descriptors (fat pointers), or copies of
4442 values not residing in memory, updating it as needed. */
4445 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4447 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4448 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4449 struct type
*formal_target
=
4450 formal_type
->code () == TYPE_CODE_PTR
4451 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4452 struct type
*actual_target
=
4453 actual_type
->code () == TYPE_CODE_PTR
4454 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4456 if (ada_is_array_descriptor_type (formal_target
)
4457 && actual_target
->code () == TYPE_CODE_ARRAY
)
4458 return make_array_descriptor (formal_type
, actual
);
4459 else if (formal_type
->code () == TYPE_CODE_PTR
4460 || formal_type
->code () == TYPE_CODE_REF
)
4462 struct value
*result
;
4464 if (formal_target
->code () == TYPE_CODE_ARRAY
4465 && ada_is_array_descriptor_type (actual_target
))
4466 result
= desc_data (actual
);
4467 else if (formal_type
->code () != TYPE_CODE_PTR
)
4469 if (VALUE_LVAL (actual
) != lval_memory
)
4473 actual_type
= ada_check_typedef (value_type (actual
));
4474 val
= allocate_value (actual_type
);
4475 memcpy ((char *) value_contents_raw (val
),
4476 (char *) value_contents (actual
),
4477 TYPE_LENGTH (actual_type
));
4478 actual
= ensure_lval (val
);
4480 result
= value_addr (actual
);
4484 return value_cast_pointers (formal_type
, result
, 0);
4486 else if (actual_type
->code () == TYPE_CODE_PTR
)
4487 return ada_value_ind (actual
);
4488 else if (ada_is_aligner_type (formal_type
))
4490 /* We need to turn this parameter into an aligner type
4492 struct value
*aligner
= allocate_value (formal_type
);
4493 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4495 value_assign_to_component (aligner
, component
, actual
);
4502 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4503 type TYPE. This is usually an inefficient no-op except on some targets
4504 (such as AVR) where the representation of a pointer and an address
4508 value_pointer (struct value
*value
, struct type
*type
)
4510 struct gdbarch
*gdbarch
= get_type_arch (type
);
4511 unsigned len
= TYPE_LENGTH (type
);
4512 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4515 addr
= value_address (value
);
4516 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4517 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4522 /* Push a descriptor of type TYPE for array value ARR on the stack at
4523 *SP, updating *SP to reflect the new descriptor. Return either
4524 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4525 to-descriptor type rather than a descriptor type), a struct value *
4526 representing a pointer to this descriptor. */
4528 static struct value
*
4529 make_array_descriptor (struct type
*type
, struct value
*arr
)
4531 struct type
*bounds_type
= desc_bounds_type (type
);
4532 struct type
*desc_type
= desc_base_type (type
);
4533 struct value
*descriptor
= allocate_value (desc_type
);
4534 struct value
*bounds
= allocate_value (bounds_type
);
4537 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4540 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4541 ada_array_bound (arr
, i
, 0),
4542 desc_bound_bitpos (bounds_type
, i
, 0),
4543 desc_bound_bitsize (bounds_type
, i
, 0));
4544 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4545 ada_array_bound (arr
, i
, 1),
4546 desc_bound_bitpos (bounds_type
, i
, 1),
4547 desc_bound_bitsize (bounds_type
, i
, 1));
4550 bounds
= ensure_lval (bounds
);
4552 modify_field (value_type (descriptor
),
4553 value_contents_writeable (descriptor
),
4554 value_pointer (ensure_lval (arr
),
4555 desc_type
->field (0).type ()),
4556 fat_pntr_data_bitpos (desc_type
),
4557 fat_pntr_data_bitsize (desc_type
));
4559 modify_field (value_type (descriptor
),
4560 value_contents_writeable (descriptor
),
4561 value_pointer (bounds
,
4562 desc_type
->field (1).type ()),
4563 fat_pntr_bounds_bitpos (desc_type
),
4564 fat_pntr_bounds_bitsize (desc_type
));
4566 descriptor
= ensure_lval (descriptor
);
4568 if (type
->code () == TYPE_CODE_PTR
)
4569 return value_addr (descriptor
);
4574 /* Symbol Cache Module */
4576 /* Performance measurements made as of 2010-01-15 indicate that
4577 this cache does bring some noticeable improvements. Depending
4578 on the type of entity being printed, the cache can make it as much
4579 as an order of magnitude faster than without it.
4581 The descriptive type DWARF extension has significantly reduced
4582 the need for this cache, at least when DWARF is being used. However,
4583 even in this case, some expensive name-based symbol searches are still
4584 sometimes necessary - to find an XVZ variable, mostly. */
4586 /* Initialize the contents of SYM_CACHE. */
4589 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4591 obstack_init (&sym_cache
->cache_space
);
4592 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4595 /* Free the memory used by SYM_CACHE. */
4598 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4600 obstack_free (&sym_cache
->cache_space
, NULL
);
4604 /* Return the symbol cache associated to the given program space PSPACE.
4605 If not allocated for this PSPACE yet, allocate and initialize one. */
4607 static struct ada_symbol_cache
*
4608 ada_get_symbol_cache (struct program_space
*pspace
)
4610 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4612 if (pspace_data
->sym_cache
== NULL
)
4614 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4615 ada_init_symbol_cache (pspace_data
->sym_cache
);
4618 return pspace_data
->sym_cache
;
4621 /* Clear all entries from the symbol cache. */
4624 ada_clear_symbol_cache (void)
4626 struct ada_symbol_cache
*sym_cache
4627 = ada_get_symbol_cache (current_program_space
);
4629 obstack_free (&sym_cache
->cache_space
, NULL
);
4630 ada_init_symbol_cache (sym_cache
);
4633 /* Search our cache for an entry matching NAME and DOMAIN.
4634 Return it if found, or NULL otherwise. */
4636 static struct cache_entry
**
4637 find_entry (const char *name
, domain_enum domain
)
4639 struct ada_symbol_cache
*sym_cache
4640 = ada_get_symbol_cache (current_program_space
);
4641 int h
= msymbol_hash (name
) % HASH_SIZE
;
4642 struct cache_entry
**e
;
4644 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4646 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4652 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4653 Return 1 if found, 0 otherwise.
4655 If an entry was found and SYM is not NULL, set *SYM to the entry's
4656 SYM. Same principle for BLOCK if not NULL. */
4659 lookup_cached_symbol (const char *name
, domain_enum domain
,
4660 struct symbol
**sym
, const struct block
**block
)
4662 struct cache_entry
**e
= find_entry (name
, domain
);
4669 *block
= (*e
)->block
;
4673 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4674 in domain DOMAIN, save this result in our symbol cache. */
4677 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4678 const struct block
*block
)
4680 struct ada_symbol_cache
*sym_cache
4681 = ada_get_symbol_cache (current_program_space
);
4683 struct cache_entry
*e
;
4685 /* Symbols for builtin types don't have a block.
4686 For now don't cache such symbols. */
4687 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4690 /* If the symbol is a local symbol, then do not cache it, as a search
4691 for that symbol depends on the context. To determine whether
4692 the symbol is local or not, we check the block where we found it
4693 against the global and static blocks of its associated symtab. */
4695 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4696 GLOBAL_BLOCK
) != block
4697 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4698 STATIC_BLOCK
) != block
)
4701 h
= msymbol_hash (name
) % HASH_SIZE
;
4702 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4703 e
->next
= sym_cache
->root
[h
];
4704 sym_cache
->root
[h
] = e
;
4705 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4713 /* Return the symbol name match type that should be used used when
4714 searching for all symbols matching LOOKUP_NAME.
4716 LOOKUP_NAME is expected to be a symbol name after transformation
4719 static symbol_name_match_type
4720 name_match_type_from_name (const char *lookup_name
)
4722 return (strstr (lookup_name
, "__") == NULL
4723 ? symbol_name_match_type::WILD
4724 : symbol_name_match_type::FULL
);
4727 /* Return the result of a standard (literal, C-like) lookup of NAME in
4728 given DOMAIN, visible from lexical block BLOCK. */
4730 static struct symbol
*
4731 standard_lookup (const char *name
, const struct block
*block
,
4734 /* Initialize it just to avoid a GCC false warning. */
4735 struct block_symbol sym
= {};
4737 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4739 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4740 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4745 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4746 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4747 since they contend in overloading in the same way. */
4749 is_nonfunction (struct block_symbol syms
[], int n
)
4753 for (i
= 0; i
< n
; i
+= 1)
4754 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4755 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4756 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4762 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4763 struct types. Otherwise, they may not. */
4766 equiv_types (struct type
*type0
, struct type
*type1
)
4770 if (type0
== NULL
|| type1
== NULL
4771 || type0
->code () != type1
->code ())
4773 if ((type0
->code () == TYPE_CODE_STRUCT
4774 || type0
->code () == TYPE_CODE_ENUM
)
4775 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4776 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4782 /* True iff SYM0 represents the same entity as SYM1, or one that is
4783 no more defined than that of SYM1. */
4786 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4790 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4791 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4794 switch (SYMBOL_CLASS (sym0
))
4800 struct type
*type0
= SYMBOL_TYPE (sym0
);
4801 struct type
*type1
= SYMBOL_TYPE (sym1
);
4802 const char *name0
= sym0
->linkage_name ();
4803 const char *name1
= sym1
->linkage_name ();
4804 int len0
= strlen (name0
);
4807 type0
->code () == type1
->code ()
4808 && (equiv_types (type0
, type1
)
4809 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4810 && startswith (name1
+ len0
, "___XV")));
4813 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4814 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4818 const char *name0
= sym0
->linkage_name ();
4819 const char *name1
= sym1
->linkage_name ();
4820 return (strcmp (name0
, name1
) == 0
4821 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4829 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4830 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4833 add_defn_to_vec (struct obstack
*obstackp
,
4835 const struct block
*block
)
4838 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4840 /* Do not try to complete stub types, as the debugger is probably
4841 already scanning all symbols matching a certain name at the
4842 time when this function is called. Trying to replace the stub
4843 type by its associated full type will cause us to restart a scan
4844 which may lead to an infinite recursion. Instead, the client
4845 collecting the matching symbols will end up collecting several
4846 matches, with at least one of them complete. It can then filter
4847 out the stub ones if needed. */
4849 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4851 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4853 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4855 prevDefns
[i
].symbol
= sym
;
4856 prevDefns
[i
].block
= block
;
4862 struct block_symbol info
;
4866 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4870 /* Number of block_symbol structures currently collected in current vector in
4874 num_defns_collected (struct obstack
*obstackp
)
4876 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4879 /* Vector of block_symbol structures currently collected in current vector in
4880 OBSTACKP. If FINISH, close off the vector and return its final address. */
4882 static struct block_symbol
*
4883 defns_collected (struct obstack
*obstackp
, int finish
)
4886 return (struct block_symbol
*) obstack_finish (obstackp
);
4888 return (struct block_symbol
*) obstack_base (obstackp
);
4891 /* Return a bound minimal symbol matching NAME according to Ada
4892 decoding rules. Returns an invalid symbol if there is no such
4893 minimal symbol. Names prefixed with "standard__" are handled
4894 specially: "standard__" is first stripped off, and only static and
4895 global symbols are searched. */
4897 struct bound_minimal_symbol
4898 ada_lookup_simple_minsym (const char *name
)
4900 struct bound_minimal_symbol result
;
4902 memset (&result
, 0, sizeof (result
));
4904 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4905 lookup_name_info
lookup_name (name
, match_type
);
4907 symbol_name_matcher_ftype
*match_name
4908 = ada_get_symbol_name_matcher (lookup_name
);
4910 for (objfile
*objfile
: current_program_space
->objfiles ())
4912 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4914 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4915 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4917 result
.minsym
= msymbol
;
4918 result
.objfile
= objfile
;
4927 /* For all subprograms that statically enclose the subprogram of the
4928 selected frame, add symbols matching identifier NAME in DOMAIN
4929 and their blocks to the list of data in OBSTACKP, as for
4930 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4931 with a wildcard prefix. */
4934 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4935 const lookup_name_info
&lookup_name
,
4940 /* True if TYPE is definitely an artificial type supplied to a symbol
4941 for which no debugging information was given in the symbol file. */
4944 is_nondebugging_type (struct type
*type
)
4946 const char *name
= ada_type_name (type
);
4948 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4951 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4952 that are deemed "identical" for practical purposes.
4954 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4955 types and that their number of enumerals is identical (in other
4956 words, type1->num_fields () == type2->num_fields ()). */
4959 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4963 /* The heuristic we use here is fairly conservative. We consider
4964 that 2 enumerate types are identical if they have the same
4965 number of enumerals and that all enumerals have the same
4966 underlying value and name. */
4968 /* All enums in the type should have an identical underlying value. */
4969 for (i
= 0; i
< type1
->num_fields (); i
++)
4970 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4973 /* All enumerals should also have the same name (modulo any numerical
4975 for (i
= 0; i
< type1
->num_fields (); i
++)
4977 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4978 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4979 int len_1
= strlen (name_1
);
4980 int len_2
= strlen (name_2
);
4982 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4983 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4985 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4986 TYPE_FIELD_NAME (type2
, i
),
4994 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4995 that are deemed "identical" for practical purposes. Sometimes,
4996 enumerals are not strictly identical, but their types are so similar
4997 that they can be considered identical.
4999 For instance, consider the following code:
5001 type Color is (Black, Red, Green, Blue, White);
5002 type RGB_Color is new Color range Red .. Blue;
5004 Type RGB_Color is a subrange of an implicit type which is a copy
5005 of type Color. If we call that implicit type RGB_ColorB ("B" is
5006 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5007 As a result, when an expression references any of the enumeral
5008 by name (Eg. "print green"), the expression is technically
5009 ambiguous and the user should be asked to disambiguate. But
5010 doing so would only hinder the user, since it wouldn't matter
5011 what choice he makes, the outcome would always be the same.
5012 So, for practical purposes, we consider them as the same. */
5015 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5019 /* Before performing a thorough comparison check of each type,
5020 we perform a series of inexpensive checks. We expect that these
5021 checks will quickly fail in the vast majority of cases, and thus
5022 help prevent the unnecessary use of a more expensive comparison.
5023 Said comparison also expects us to make some of these checks
5024 (see ada_identical_enum_types_p). */
5026 /* Quick check: All symbols should have an enum type. */
5027 for (i
= 0; i
< syms
.size (); i
++)
5028 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
5031 /* Quick check: They should all have the same value. */
5032 for (i
= 1; i
< syms
.size (); i
++)
5033 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5036 /* Quick check: They should all have the same number of enumerals. */
5037 for (i
= 1; i
< syms
.size (); i
++)
5038 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
5039 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
5042 /* All the sanity checks passed, so we might have a set of
5043 identical enumeration types. Perform a more complete
5044 comparison of the type of each symbol. */
5045 for (i
= 1; i
< syms
.size (); i
++)
5046 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5047 SYMBOL_TYPE (syms
[0].symbol
)))
5053 /* Remove any non-debugging symbols in SYMS that definitely
5054 duplicate other symbols in the list (The only case I know of where
5055 this happens is when object files containing stabs-in-ecoff are
5056 linked with files containing ordinary ecoff debugging symbols (or no
5057 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5058 Returns the number of items in the modified list. */
5061 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5065 /* We should never be called with less than 2 symbols, as there
5066 cannot be any extra symbol in that case. But it's easy to
5067 handle, since we have nothing to do in that case. */
5068 if (syms
->size () < 2)
5069 return syms
->size ();
5072 while (i
< syms
->size ())
5076 /* If two symbols have the same name and one of them is a stub type,
5077 the get rid of the stub. */
5079 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
5080 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5082 for (j
= 0; j
< syms
->size (); j
++)
5085 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
5086 && (*syms
)[j
].symbol
->linkage_name () != NULL
5087 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5088 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5093 /* Two symbols with the same name, same class and same address
5094 should be identical. */
5096 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5097 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5098 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5100 for (j
= 0; j
< syms
->size (); j
+= 1)
5103 && (*syms
)[j
].symbol
->linkage_name () != NULL
5104 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5105 (*syms
)[j
].symbol
->linkage_name ()) == 0
5106 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5107 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5108 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5109 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5115 syms
->erase (syms
->begin () + i
);
5120 /* If all the remaining symbols are identical enumerals, then
5121 just keep the first one and discard the rest.
5123 Unlike what we did previously, we do not discard any entry
5124 unless they are ALL identical. This is because the symbol
5125 comparison is not a strict comparison, but rather a practical
5126 comparison. If all symbols are considered identical, then
5127 we can just go ahead and use the first one and discard the rest.
5128 But if we cannot reduce the list to a single element, we have
5129 to ask the user to disambiguate anyways. And if we have to
5130 present a multiple-choice menu, it's less confusing if the list
5131 isn't missing some choices that were identical and yet distinct. */
5132 if (symbols_are_identical_enums (*syms
))
5135 return syms
->size ();
5138 /* Given a type that corresponds to a renaming entity, use the type name
5139 to extract the scope (package name or function name, fully qualified,
5140 and following the GNAT encoding convention) where this renaming has been
5144 xget_renaming_scope (struct type
*renaming_type
)
5146 /* The renaming types adhere to the following convention:
5147 <scope>__<rename>___<XR extension>.
5148 So, to extract the scope, we search for the "___XR" extension,
5149 and then backtrack until we find the first "__". */
5151 const char *name
= renaming_type
->name ();
5152 const char *suffix
= strstr (name
, "___XR");
5155 /* Now, backtrack a bit until we find the first "__". Start looking
5156 at suffix - 3, as the <rename> part is at least one character long. */
5158 for (last
= suffix
- 3; last
> name
; last
--)
5159 if (last
[0] == '_' && last
[1] == '_')
5162 /* Make a copy of scope and return it. */
5163 return std::string (name
, last
);
5166 /* Return nonzero if NAME corresponds to a package name. */
5169 is_package_name (const char *name
)
5171 /* Here, We take advantage of the fact that no symbols are generated
5172 for packages, while symbols are generated for each function.
5173 So the condition for NAME represent a package becomes equivalent
5174 to NAME not existing in our list of symbols. There is only one
5175 small complication with library-level functions (see below). */
5177 /* If it is a function that has not been defined at library level,
5178 then we should be able to look it up in the symbols. */
5179 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5182 /* Library-level function names start with "_ada_". See if function
5183 "_ada_" followed by NAME can be found. */
5185 /* Do a quick check that NAME does not contain "__", since library-level
5186 functions names cannot contain "__" in them. */
5187 if (strstr (name
, "__") != NULL
)
5190 std::string fun_name
= string_printf ("_ada_%s", name
);
5192 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5195 /* Return nonzero if SYM corresponds to a renaming entity that is
5196 not visible from FUNCTION_NAME. */
5199 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5201 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5204 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5206 /* If the rename has been defined in a package, then it is visible. */
5207 if (is_package_name (scope
.c_str ()))
5210 /* Check that the rename is in the current function scope by checking
5211 that its name starts with SCOPE. */
5213 /* If the function name starts with "_ada_", it means that it is
5214 a library-level function. Strip this prefix before doing the
5215 comparison, as the encoding for the renaming does not contain
5217 if (startswith (function_name
, "_ada_"))
5220 return !startswith (function_name
, scope
.c_str ());
5223 /* Remove entries from SYMS that corresponds to a renaming entity that
5224 is not visible from the function associated with CURRENT_BLOCK or
5225 that is superfluous due to the presence of more specific renaming
5226 information. Places surviving symbols in the initial entries of
5227 SYMS and returns the number of surviving symbols.
5230 First, in cases where an object renaming is implemented as a
5231 reference variable, GNAT may produce both the actual reference
5232 variable and the renaming encoding. In this case, we discard the
5235 Second, GNAT emits a type following a specified encoding for each renaming
5236 entity. Unfortunately, STABS currently does not support the definition
5237 of types that are local to a given lexical block, so all renamings types
5238 are emitted at library level. As a consequence, if an application
5239 contains two renaming entities using the same name, and a user tries to
5240 print the value of one of these entities, the result of the ada symbol
5241 lookup will also contain the wrong renaming type.
5243 This function partially covers for this limitation by attempting to
5244 remove from the SYMS list renaming symbols that should be visible
5245 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5246 method with the current information available. The implementation
5247 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5249 - When the user tries to print a rename in a function while there
5250 is another rename entity defined in a package: Normally, the
5251 rename in the function has precedence over the rename in the
5252 package, so the latter should be removed from the list. This is
5253 currently not the case.
5255 - This function will incorrectly remove valid renames if
5256 the CURRENT_BLOCK corresponds to a function which symbol name
5257 has been changed by an "Export" pragma. As a consequence,
5258 the user will be unable to print such rename entities. */
5261 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5262 const struct block
*current_block
)
5264 struct symbol
*current_function
;
5265 const char *current_function_name
;
5267 int is_new_style_renaming
;
5269 /* If there is both a renaming foo___XR... encoded as a variable and
5270 a simple variable foo in the same block, discard the latter.
5271 First, zero out such symbols, then compress. */
5272 is_new_style_renaming
= 0;
5273 for (i
= 0; i
< syms
->size (); i
+= 1)
5275 struct symbol
*sym
= (*syms
)[i
].symbol
;
5276 const struct block
*block
= (*syms
)[i
].block
;
5280 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5282 name
= sym
->linkage_name ();
5283 suffix
= strstr (name
, "___XR");
5287 int name_len
= suffix
- name
;
5290 is_new_style_renaming
= 1;
5291 for (j
= 0; j
< syms
->size (); j
+= 1)
5292 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5293 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5295 && block
== (*syms
)[j
].block
)
5296 (*syms
)[j
].symbol
= NULL
;
5299 if (is_new_style_renaming
)
5303 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5304 if ((*syms
)[j
].symbol
!= NULL
)
5306 (*syms
)[k
] = (*syms
)[j
];
5312 /* Extract the function name associated to CURRENT_BLOCK.
5313 Abort if unable to do so. */
5315 if (current_block
== NULL
)
5316 return syms
->size ();
5318 current_function
= block_linkage_function (current_block
);
5319 if (current_function
== NULL
)
5320 return syms
->size ();
5322 current_function_name
= current_function
->linkage_name ();
5323 if (current_function_name
== NULL
)
5324 return syms
->size ();
5326 /* Check each of the symbols, and remove it from the list if it is
5327 a type corresponding to a renaming that is out of the scope of
5328 the current block. */
5331 while (i
< syms
->size ())
5333 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5334 == ADA_OBJECT_RENAMING
5335 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5336 current_function_name
))
5337 syms
->erase (syms
->begin () + i
);
5342 return syms
->size ();
5345 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5346 whose name and domain match NAME and DOMAIN respectively.
5347 If no match was found, then extend the search to "enclosing"
5348 routines (in other words, if we're inside a nested function,
5349 search the symbols defined inside the enclosing functions).
5350 If WILD_MATCH_P is nonzero, perform the naming matching in
5351 "wild" mode (see function "wild_match" for more info).
5353 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5356 ada_add_local_symbols (struct obstack
*obstackp
,
5357 const lookup_name_info
&lookup_name
,
5358 const struct block
*block
, domain_enum domain
)
5360 int block_depth
= 0;
5362 while (block
!= NULL
)
5365 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5367 /* If we found a non-function match, assume that's the one. */
5368 if (is_nonfunction (defns_collected (obstackp
, 0),
5369 num_defns_collected (obstackp
)))
5372 block
= BLOCK_SUPERBLOCK (block
);
5375 /* If no luck so far, try to find NAME as a local symbol in some lexically
5376 enclosing subprogram. */
5377 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5378 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5381 /* An object of this type is used as the user_data argument when
5382 calling the map_matching_symbols method. */
5386 struct objfile
*objfile
;
5387 struct obstack
*obstackp
;
5388 struct symbol
*arg_sym
;
5392 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5393 to a list of symbols. DATA is a pointer to a struct match_data *
5394 containing the obstack that collects the symbol list, the file that SYM
5395 must come from, a flag indicating whether a non-argument symbol has
5396 been found in the current block, and the last argument symbol
5397 passed in SYM within the current block (if any). When SYM is null,
5398 marking the end of a block, the argument symbol is added if no
5399 other has been found. */
5402 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5403 struct match_data
*data
)
5405 const struct block
*block
= bsym
->block
;
5406 struct symbol
*sym
= bsym
->symbol
;
5410 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5411 add_defn_to_vec (data
->obstackp
,
5412 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5414 data
->found_sym
= 0;
5415 data
->arg_sym
= NULL
;
5419 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5421 else if (SYMBOL_IS_ARGUMENT (sym
))
5422 data
->arg_sym
= sym
;
5425 data
->found_sym
= 1;
5426 add_defn_to_vec (data
->obstackp
,
5427 fixup_symbol_section (sym
, data
->objfile
),
5434 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5435 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5436 symbols to OBSTACKP. Return whether we found such symbols. */
5439 ada_add_block_renamings (struct obstack
*obstackp
,
5440 const struct block
*block
,
5441 const lookup_name_info
&lookup_name
,
5444 struct using_direct
*renaming
;
5445 int defns_mark
= num_defns_collected (obstackp
);
5447 symbol_name_matcher_ftype
*name_match
5448 = ada_get_symbol_name_matcher (lookup_name
);
5450 for (renaming
= block_using (block
);
5452 renaming
= renaming
->next
)
5456 /* Avoid infinite recursions: skip this renaming if we are actually
5457 already traversing it.
5459 Currently, symbol lookup in Ada don't use the namespace machinery from
5460 C++/Fortran support: skip namespace imports that use them. */
5461 if (renaming
->searched
5462 || (renaming
->import_src
!= NULL
5463 && renaming
->import_src
[0] != '\0')
5464 || (renaming
->import_dest
!= NULL
5465 && renaming
->import_dest
[0] != '\0'))
5467 renaming
->searched
= 1;
5469 /* TODO: here, we perform another name-based symbol lookup, which can
5470 pull its own multiple overloads. In theory, we should be able to do
5471 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5472 not a simple name. But in order to do this, we would need to enhance
5473 the DWARF reader to associate a symbol to this renaming, instead of a
5474 name. So, for now, we do something simpler: re-use the C++/Fortran
5475 namespace machinery. */
5476 r_name
= (renaming
->alias
!= NULL
5478 : renaming
->declaration
);
5479 if (name_match (r_name
, lookup_name
, NULL
))
5481 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5482 lookup_name
.match_type ());
5483 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5486 renaming
->searched
= 0;
5488 return num_defns_collected (obstackp
) != defns_mark
;
5491 /* Implements compare_names, but only applying the comparision using
5492 the given CASING. */
5495 compare_names_with_case (const char *string1
, const char *string2
,
5496 enum case_sensitivity casing
)
5498 while (*string1
!= '\0' && *string2
!= '\0')
5502 if (isspace (*string1
) || isspace (*string2
))
5503 return strcmp_iw_ordered (string1
, string2
);
5505 if (casing
== case_sensitive_off
)
5507 c1
= tolower (*string1
);
5508 c2
= tolower (*string2
);
5525 return strcmp_iw_ordered (string1
, string2
);
5527 if (*string2
== '\0')
5529 if (is_name_suffix (string1
))
5536 if (*string2
== '(')
5537 return strcmp_iw_ordered (string1
, string2
);
5540 if (casing
== case_sensitive_off
)
5541 return tolower (*string1
) - tolower (*string2
);
5543 return *string1
- *string2
;
5548 /* Compare STRING1 to STRING2, with results as for strcmp.
5549 Compatible with strcmp_iw_ordered in that...
5551 strcmp_iw_ordered (STRING1, STRING2) <= 0
5555 compare_names (STRING1, STRING2) <= 0
5557 (they may differ as to what symbols compare equal). */
5560 compare_names (const char *string1
, const char *string2
)
5564 /* Similar to what strcmp_iw_ordered does, we need to perform
5565 a case-insensitive comparison first, and only resort to
5566 a second, case-sensitive, comparison if the first one was
5567 not sufficient to differentiate the two strings. */
5569 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5571 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5576 /* Convenience function to get at the Ada encoded lookup name for
5577 LOOKUP_NAME, as a C string. */
5580 ada_lookup_name (const lookup_name_info
&lookup_name
)
5582 return lookup_name
.ada ().lookup_name ().c_str ();
5585 /* Add to OBSTACKP all non-local symbols whose name and domain match
5586 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5587 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5588 symbols otherwise. */
5591 add_nonlocal_symbols (struct obstack
*obstackp
,
5592 const lookup_name_info
&lookup_name
,
5593 domain_enum domain
, int global
)
5595 struct match_data data
;
5597 memset (&data
, 0, sizeof data
);
5598 data
.obstackp
= obstackp
;
5600 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5602 auto callback
= [&] (struct block_symbol
*bsym
)
5604 return aux_add_nonlocal_symbols (bsym
, &data
);
5607 for (objfile
*objfile
: current_program_space
->objfiles ())
5609 data
.objfile
= objfile
;
5611 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5612 domain
, global
, callback
,
5614 ? NULL
: compare_names
));
5616 for (compunit_symtab
*cu
: objfile
->compunits ())
5618 const struct block
*global_block
5619 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5621 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5627 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5629 const char *name
= ada_lookup_name (lookup_name
);
5630 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5631 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5633 for (objfile
*objfile
: current_program_space
->objfiles ())
5635 data
.objfile
= objfile
;
5636 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5637 domain
, global
, callback
,
5643 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5644 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5645 returning the number of matches. Add these to OBSTACKP.
5647 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5648 symbol match within the nest of blocks whose innermost member is BLOCK,
5649 is the one match returned (no other matches in that or
5650 enclosing blocks is returned). If there are any matches in or
5651 surrounding BLOCK, then these alone are returned.
5653 Names prefixed with "standard__" are handled specially:
5654 "standard__" is first stripped off (by the lookup_name
5655 constructor), and only static and global symbols are searched.
5657 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5658 to lookup global symbols. */
5661 ada_add_all_symbols (struct obstack
*obstackp
,
5662 const struct block
*block
,
5663 const lookup_name_info
&lookup_name
,
5666 int *made_global_lookup_p
)
5670 if (made_global_lookup_p
)
5671 *made_global_lookup_p
= 0;
5673 /* Special case: If the user specifies a symbol name inside package
5674 Standard, do a non-wild matching of the symbol name without
5675 the "standard__" prefix. This was primarily introduced in order
5676 to allow the user to specifically access the standard exceptions
5677 using, for instance, Standard.Constraint_Error when Constraint_Error
5678 is ambiguous (due to the user defining its own Constraint_Error
5679 entity inside its program). */
5680 if (lookup_name
.ada ().standard_p ())
5683 /* Check the non-global symbols. If we have ANY match, then we're done. */
5688 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5691 /* In the !full_search case we're are being called by
5692 iterate_over_symbols, and we don't want to search
5694 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5696 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5700 /* No non-global symbols found. Check our cache to see if we have
5701 already performed this search before. If we have, then return
5704 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5705 domain
, &sym
, &block
))
5708 add_defn_to_vec (obstackp
, sym
, block
);
5712 if (made_global_lookup_p
)
5713 *made_global_lookup_p
= 1;
5715 /* Search symbols from all global blocks. */
5717 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5719 /* Now add symbols from all per-file blocks if we've gotten no hits
5720 (not strictly correct, but perhaps better than an error). */
5722 if (num_defns_collected (obstackp
) == 0)
5723 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5726 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5727 is non-zero, enclosing scope and in global scopes, returning the number of
5729 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5730 found and the blocks and symbol tables (if any) in which they were
5733 When full_search is non-zero, any non-function/non-enumeral
5734 symbol match within the nest of blocks whose innermost member is BLOCK,
5735 is the one match returned (no other matches in that or
5736 enclosing blocks is returned). If there are any matches in or
5737 surrounding BLOCK, then these alone are returned.
5739 Names prefixed with "standard__" are handled specially: "standard__"
5740 is first stripped off, and only static and global symbols are searched. */
5743 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5744 const struct block
*block
,
5746 std::vector
<struct block_symbol
> *results
,
5749 int syms_from_global_search
;
5751 auto_obstack obstack
;
5753 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5754 domain
, full_search
, &syms_from_global_search
);
5756 ndefns
= num_defns_collected (&obstack
);
5758 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5759 for (int i
= 0; i
< ndefns
; ++i
)
5760 results
->push_back (base
[i
]);
5762 ndefns
= remove_extra_symbols (results
);
5764 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5765 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5767 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5768 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5769 (*results
)[0].symbol
, (*results
)[0].block
);
5771 ndefns
= remove_irrelevant_renamings (results
, block
);
5776 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5777 in global scopes, returning the number of matches, and filling *RESULTS
5778 with (SYM,BLOCK) tuples.
5780 See ada_lookup_symbol_list_worker for further details. */
5783 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5785 std::vector
<struct block_symbol
> *results
)
5787 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5788 lookup_name_info
lookup_name (name
, name_match_type
);
5790 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5793 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5794 to 1, but choosing the first symbol found if there are multiple
5797 The result is stored in *INFO, which must be non-NULL.
5798 If no match is found, INFO->SYM is set to NULL. */
5801 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5803 struct block_symbol
*info
)
5805 /* Since we already have an encoded name, wrap it in '<>' to force a
5806 verbatim match. Otherwise, if the name happens to not look like
5807 an encoded name (because it doesn't include a "__"),
5808 ada_lookup_name_info would re-encode/fold it again, and that
5809 would e.g., incorrectly lowercase object renaming names like
5810 "R28b" -> "r28b". */
5811 std::string verbatim
= std::string ("<") + name
+ '>';
5813 gdb_assert (info
!= NULL
);
5814 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5817 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5818 scope and in global scopes, or NULL if none. NAME is folded and
5819 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5820 choosing the first symbol if there are multiple choices. */
5823 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5826 std::vector
<struct block_symbol
> candidates
;
5829 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5831 if (n_candidates
== 0)
5834 block_symbol info
= candidates
[0];
5835 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5840 /* True iff STR is a possible encoded suffix of a normal Ada name
5841 that is to be ignored for matching purposes. Suffixes of parallel
5842 names (e.g., XVE) are not included here. Currently, the possible suffixes
5843 are given by any of the regular expressions:
5845 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5846 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5847 TKB [subprogram suffix for task bodies]
5848 _E[0-9]+[bs]$ [protected object entry suffixes]
5849 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5851 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5852 match is performed. This sequence is used to differentiate homonyms,
5853 is an optional part of a valid name suffix. */
5856 is_name_suffix (const char *str
)
5859 const char *matching
;
5860 const int len
= strlen (str
);
5862 /* Skip optional leading __[0-9]+. */
5864 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5867 while (isdigit (str
[0]))
5873 if (str
[0] == '.' || str
[0] == '$')
5876 while (isdigit (matching
[0]))
5878 if (matching
[0] == '\0')
5884 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5887 while (isdigit (matching
[0]))
5889 if (matching
[0] == '\0')
5893 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5895 if (strcmp (str
, "TKB") == 0)
5899 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5900 with a N at the end. Unfortunately, the compiler uses the same
5901 convention for other internal types it creates. So treating
5902 all entity names that end with an "N" as a name suffix causes
5903 some regressions. For instance, consider the case of an enumerated
5904 type. To support the 'Image attribute, it creates an array whose
5906 Having a single character like this as a suffix carrying some
5907 information is a bit risky. Perhaps we should change the encoding
5908 to be something like "_N" instead. In the meantime, do not do
5909 the following check. */
5910 /* Protected Object Subprograms */
5911 if (len
== 1 && str
[0] == 'N')
5916 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5919 while (isdigit (matching
[0]))
5921 if ((matching
[0] == 'b' || matching
[0] == 's')
5922 && matching
[1] == '\0')
5926 /* ??? We should not modify STR directly, as we are doing below. This
5927 is fine in this case, but may become problematic later if we find
5928 that this alternative did not work, and want to try matching
5929 another one from the begining of STR. Since we modified it, we
5930 won't be able to find the begining of the string anymore! */
5934 while (str
[0] != '_' && str
[0] != '\0')
5936 if (str
[0] != 'n' && str
[0] != 'b')
5942 if (str
[0] == '\000')
5947 if (str
[1] != '_' || str
[2] == '\000')
5951 if (strcmp (str
+ 3, "JM") == 0)
5953 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5954 the LJM suffix in favor of the JM one. But we will
5955 still accept LJM as a valid suffix for a reasonable
5956 amount of time, just to allow ourselves to debug programs
5957 compiled using an older version of GNAT. */
5958 if (strcmp (str
+ 3, "LJM") == 0)
5962 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5963 || str
[4] == 'U' || str
[4] == 'P')
5965 if (str
[4] == 'R' && str
[5] != 'T')
5969 if (!isdigit (str
[2]))
5971 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5972 if (!isdigit (str
[k
]) && str
[k
] != '_')
5976 if (str
[0] == '$' && isdigit (str
[1]))
5978 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5979 if (!isdigit (str
[k
]) && str
[k
] != '_')
5986 /* Return non-zero if the string starting at NAME and ending before
5987 NAME_END contains no capital letters. */
5990 is_valid_name_for_wild_match (const char *name0
)
5992 std::string decoded_name
= ada_decode (name0
);
5995 /* If the decoded name starts with an angle bracket, it means that
5996 NAME0 does not follow the GNAT encoding format. It should then
5997 not be allowed as a possible wild match. */
5998 if (decoded_name
[0] == '<')
6001 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6002 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6008 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
6009 character which could start a simple name. Assumes that *NAMEP points
6010 somewhere inside the string beginning at NAME0. */
6013 advance_wild_match (const char **namep
, const char *name0
, char target0
)
6015 const char *name
= *namep
;
6025 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6028 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6033 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6034 || name
[2] == target0
))
6042 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6052 /* Return true iff NAME encodes a name of the form prefix.PATN.
6053 Ignores any informational suffixes of NAME (i.e., for which
6054 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6058 wild_match (const char *name
, const char *patn
)
6061 const char *name0
= name
;
6065 const char *match
= name
;
6069 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6072 if (*p
== '\0' && is_name_suffix (name
))
6073 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6075 if (name
[-1] == '_')
6078 if (!advance_wild_match (&name
, name0
, *patn
))
6083 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6084 any trailing suffixes that encode debugging information or leading
6085 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6086 information that is ignored). */
6089 full_match (const char *sym_name
, const char *search_name
)
6091 size_t search_name_len
= strlen (search_name
);
6093 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6094 && is_name_suffix (sym_name
+ search_name_len
))
6097 if (startswith (sym_name
, "_ada_")
6098 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6099 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6105 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6106 *defn_symbols, updating the list of symbols in OBSTACKP (if
6107 necessary). OBJFILE is the section containing BLOCK. */
6110 ada_add_block_symbols (struct obstack
*obstackp
,
6111 const struct block
*block
,
6112 const lookup_name_info
&lookup_name
,
6113 domain_enum domain
, struct objfile
*objfile
)
6115 struct block_iterator iter
;
6116 /* A matching argument symbol, if any. */
6117 struct symbol
*arg_sym
;
6118 /* Set true when we find a matching non-argument symbol. */
6124 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6126 sym
= block_iter_match_next (lookup_name
, &iter
))
6128 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6130 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6132 if (SYMBOL_IS_ARGUMENT (sym
))
6137 add_defn_to_vec (obstackp
,
6138 fixup_symbol_section (sym
, objfile
),
6145 /* Handle renamings. */
6147 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6150 if (!found_sym
&& arg_sym
!= NULL
)
6152 add_defn_to_vec (obstackp
,
6153 fixup_symbol_section (arg_sym
, objfile
),
6157 if (!lookup_name
.ada ().wild_match_p ())
6161 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6162 const char *name
= ada_lookup_name
.c_str ();
6163 size_t name_len
= ada_lookup_name
.size ();
6165 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6167 if (symbol_matches_domain (sym
->language (),
6168 SYMBOL_DOMAIN (sym
), domain
))
6172 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6175 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6177 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6182 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6184 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6186 if (SYMBOL_IS_ARGUMENT (sym
))
6191 add_defn_to_vec (obstackp
,
6192 fixup_symbol_section (sym
, objfile
),
6200 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6201 They aren't parameters, right? */
6202 if (!found_sym
&& arg_sym
!= NULL
)
6204 add_defn_to_vec (obstackp
,
6205 fixup_symbol_section (arg_sym
, objfile
),
6212 /* Symbol Completion */
6217 ada_lookup_name_info::matches
6218 (const char *sym_name
,
6219 symbol_name_match_type match_type
,
6220 completion_match_result
*comp_match_res
) const
6223 const char *text
= m_encoded_name
.c_str ();
6224 size_t text_len
= m_encoded_name
.size ();
6226 /* First, test against the fully qualified name of the symbol. */
6228 if (strncmp (sym_name
, text
, text_len
) == 0)
6231 std::string decoded_name
= ada_decode (sym_name
);
6232 if (match
&& !m_encoded_p
)
6234 /* One needed check before declaring a positive match is to verify
6235 that iff we are doing a verbatim match, the decoded version
6236 of the symbol name starts with '<'. Otherwise, this symbol name
6237 is not a suitable completion. */
6239 bool has_angle_bracket
= (decoded_name
[0] == '<');
6240 match
= (has_angle_bracket
== m_verbatim_p
);
6243 if (match
&& !m_verbatim_p
)
6245 /* When doing non-verbatim match, another check that needs to
6246 be done is to verify that the potentially matching symbol name
6247 does not include capital letters, because the ada-mode would
6248 not be able to understand these symbol names without the
6249 angle bracket notation. */
6252 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6257 /* Second: Try wild matching... */
6259 if (!match
&& m_wild_match_p
)
6261 /* Since we are doing wild matching, this means that TEXT
6262 may represent an unqualified symbol name. We therefore must
6263 also compare TEXT against the unqualified name of the symbol. */
6264 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6266 if (strncmp (sym_name
, text
, text_len
) == 0)
6270 /* Finally: If we found a match, prepare the result to return. */
6275 if (comp_match_res
!= NULL
)
6277 std::string
&match_str
= comp_match_res
->match
.storage ();
6280 match_str
= ada_decode (sym_name
);
6284 match_str
= add_angle_brackets (sym_name
);
6286 match_str
= sym_name
;
6290 comp_match_res
->set_match (match_str
.c_str ());
6298 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6299 for tagged types. */
6302 ada_is_dispatch_table_ptr_type (struct type
*type
)
6306 if (type
->code () != TYPE_CODE_PTR
)
6309 name
= TYPE_TARGET_TYPE (type
)->name ();
6313 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6316 /* Return non-zero if TYPE is an interface tag. */
6319 ada_is_interface_tag (struct type
*type
)
6321 const char *name
= type
->name ();
6326 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6329 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6330 to be invisible to users. */
6333 ada_is_ignored_field (struct type
*type
, int field_num
)
6335 if (field_num
< 0 || field_num
> type
->num_fields ())
6338 /* Check the name of that field. */
6340 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6342 /* Anonymous field names should not be printed.
6343 brobecker/2007-02-20: I don't think this can actually happen
6344 but we don't want to print the value of anonymous fields anyway. */
6348 /* Normally, fields whose name start with an underscore ("_")
6349 are fields that have been internally generated by the compiler,
6350 and thus should not be printed. The "_parent" field is special,
6351 however: This is a field internally generated by the compiler
6352 for tagged types, and it contains the components inherited from
6353 the parent type. This field should not be printed as is, but
6354 should not be ignored either. */
6355 if (name
[0] == '_' && !startswith (name
, "_parent"))
6359 /* If this is the dispatch table of a tagged type or an interface tag,
6361 if (ada_is_tagged_type (type
, 1)
6362 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6363 || ada_is_interface_tag (type
->field (field_num
).type ())))
6366 /* Not a special field, so it should not be ignored. */
6370 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6371 pointer or reference type whose ultimate target has a tag field. */
6374 ada_is_tagged_type (struct type
*type
, int refok
)
6376 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6379 /* True iff TYPE represents the type of X'Tag */
6382 ada_is_tag_type (struct type
*type
)
6384 type
= ada_check_typedef (type
);
6386 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6390 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6392 return (name
!= NULL
6393 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6397 /* The type of the tag on VAL. */
6399 static struct type
*
6400 ada_tag_type (struct value
*val
)
6402 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6405 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6406 retired at Ada 05). */
6409 is_ada95_tag (struct value
*tag
)
6411 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6414 /* The value of the tag on VAL. */
6416 static struct value
*
6417 ada_value_tag (struct value
*val
)
6419 return ada_value_struct_elt (val
, "_tag", 0);
6422 /* The value of the tag on the object of type TYPE whose contents are
6423 saved at VALADDR, if it is non-null, or is at memory address
6426 static struct value
*
6427 value_tag_from_contents_and_address (struct type
*type
,
6428 const gdb_byte
*valaddr
,
6431 int tag_byte_offset
;
6432 struct type
*tag_type
;
6434 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6437 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6439 : valaddr
+ tag_byte_offset
);
6440 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6442 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6447 static struct type
*
6448 type_from_tag (struct value
*tag
)
6450 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6452 if (type_name
!= NULL
)
6453 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6457 /* Given a value OBJ of a tagged type, return a value of this
6458 type at the base address of the object. The base address, as
6459 defined in Ada.Tags, it is the address of the primary tag of
6460 the object, and therefore where the field values of its full
6461 view can be fetched. */
6464 ada_tag_value_at_base_address (struct value
*obj
)
6467 LONGEST offset_to_top
= 0;
6468 struct type
*ptr_type
, *obj_type
;
6470 CORE_ADDR base_address
;
6472 obj_type
= value_type (obj
);
6474 /* It is the responsability of the caller to deref pointers. */
6476 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6479 tag
= ada_value_tag (obj
);
6483 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6485 if (is_ada95_tag (tag
))
6488 ptr_type
= language_lookup_primitive_type
6489 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6490 ptr_type
= lookup_pointer_type (ptr_type
);
6491 val
= value_cast (ptr_type
, tag
);
6495 /* It is perfectly possible that an exception be raised while
6496 trying to determine the base address, just like for the tag;
6497 see ada_tag_name for more details. We do not print the error
6498 message for the same reason. */
6502 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6505 catch (const gdb_exception_error
&e
)
6510 /* If offset is null, nothing to do. */
6512 if (offset_to_top
== 0)
6515 /* -1 is a special case in Ada.Tags; however, what should be done
6516 is not quite clear from the documentation. So do nothing for
6519 if (offset_to_top
== -1)
6522 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6523 from the base address. This was however incompatible with
6524 C++ dispatch table: C++ uses a *negative* value to *add*
6525 to the base address. Ada's convention has therefore been
6526 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6527 use the same convention. Here, we support both cases by
6528 checking the sign of OFFSET_TO_TOP. */
6530 if (offset_to_top
> 0)
6531 offset_to_top
= -offset_to_top
;
6533 base_address
= value_address (obj
) + offset_to_top
;
6534 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6536 /* Make sure that we have a proper tag at the new address.
6537 Otherwise, offset_to_top is bogus (which can happen when
6538 the object is not initialized yet). */
6543 obj_type
= type_from_tag (tag
);
6548 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6551 /* Return the "ada__tags__type_specific_data" type. */
6553 static struct type
*
6554 ada_get_tsd_type (struct inferior
*inf
)
6556 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6558 if (data
->tsd_type
== 0)
6559 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6560 return data
->tsd_type
;
6563 /* Return the TSD (type-specific data) associated to the given TAG.
6564 TAG is assumed to be the tag of a tagged-type entity.
6566 May return NULL if we are unable to get the TSD. */
6568 static struct value
*
6569 ada_get_tsd_from_tag (struct value
*tag
)
6574 /* First option: The TSD is simply stored as a field of our TAG.
6575 Only older versions of GNAT would use this format, but we have
6576 to test it first, because there are no visible markers for
6577 the current approach except the absence of that field. */
6579 val
= ada_value_struct_elt (tag
, "tsd", 1);
6583 /* Try the second representation for the dispatch table (in which
6584 there is no explicit 'tsd' field in the referent of the tag pointer,
6585 and instead the tsd pointer is stored just before the dispatch
6588 type
= ada_get_tsd_type (current_inferior());
6591 type
= lookup_pointer_type (lookup_pointer_type (type
));
6592 val
= value_cast (type
, tag
);
6595 return value_ind (value_ptradd (val
, -1));
6598 /* Given the TSD of a tag (type-specific data), return a string
6599 containing the name of the associated type.
6601 May return NULL if we are unable to determine the tag name. */
6603 static gdb::unique_xmalloc_ptr
<char>
6604 ada_tag_name_from_tsd (struct value
*tsd
)
6609 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6612 gdb::unique_xmalloc_ptr
<char> buffer
6613 = target_read_string (value_as_address (val
), INT_MAX
);
6614 if (buffer
== nullptr)
6617 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6626 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6629 Return NULL if the TAG is not an Ada tag, or if we were unable to
6630 determine the name of that tag. */
6632 gdb::unique_xmalloc_ptr
<char>
6633 ada_tag_name (struct value
*tag
)
6635 gdb::unique_xmalloc_ptr
<char> name
;
6637 if (!ada_is_tag_type (value_type (tag
)))
6640 /* It is perfectly possible that an exception be raised while trying
6641 to determine the TAG's name, even under normal circumstances:
6642 The associated variable may be uninitialized or corrupted, for
6643 instance. We do not let any exception propagate past this point.
6644 instead we return NULL.
6646 We also do not print the error message either (which often is very
6647 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6648 the caller print a more meaningful message if necessary. */
6651 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6654 name
= ada_tag_name_from_tsd (tsd
);
6656 catch (const gdb_exception_error
&e
)
6663 /* The parent type of TYPE, or NULL if none. */
6666 ada_parent_type (struct type
*type
)
6670 type
= ada_check_typedef (type
);
6672 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6675 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6676 if (ada_is_parent_field (type
, i
))
6678 struct type
*parent_type
= type
->field (i
).type ();
6680 /* If the _parent field is a pointer, then dereference it. */
6681 if (parent_type
->code () == TYPE_CODE_PTR
)
6682 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6683 /* If there is a parallel XVS type, get the actual base type. */
6684 parent_type
= ada_get_base_type (parent_type
);
6686 return ada_check_typedef (parent_type
);
6692 /* True iff field number FIELD_NUM of structure type TYPE contains the
6693 parent-type (inherited) fields of a derived type. Assumes TYPE is
6694 a structure type with at least FIELD_NUM+1 fields. */
6697 ada_is_parent_field (struct type
*type
, int field_num
)
6699 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6701 return (name
!= NULL
6702 && (startswith (name
, "PARENT")
6703 || startswith (name
, "_parent")));
6706 /* True iff field number FIELD_NUM of structure type TYPE is a
6707 transparent wrapper field (which should be silently traversed when doing
6708 field selection and flattened when printing). Assumes TYPE is a
6709 structure type with at least FIELD_NUM+1 fields. Such fields are always
6713 ada_is_wrapper_field (struct type
*type
, int field_num
)
6715 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6717 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6719 /* This happens in functions with "out" or "in out" parameters
6720 which are passed by copy. For such functions, GNAT describes
6721 the function's return type as being a struct where the return
6722 value is in a field called RETVAL, and where the other "out"
6723 or "in out" parameters are fields of that struct. This is not
6728 return (name
!= NULL
6729 && (startswith (name
, "PARENT")
6730 || strcmp (name
, "REP") == 0
6731 || startswith (name
, "_parent")
6732 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6735 /* True iff field number FIELD_NUM of structure or union type TYPE
6736 is a variant wrapper. Assumes TYPE is a structure type with at least
6737 FIELD_NUM+1 fields. */
6740 ada_is_variant_part (struct type
*type
, int field_num
)
6742 /* Only Ada types are eligible. */
6743 if (!ADA_TYPE_P (type
))
6746 struct type
*field_type
= type
->field (field_num
).type ();
6748 return (field_type
->code () == TYPE_CODE_UNION
6749 || (is_dynamic_field (type
, field_num
)
6750 && (TYPE_TARGET_TYPE (field_type
)->code ()
6751 == TYPE_CODE_UNION
)));
6754 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6755 whose discriminants are contained in the record type OUTER_TYPE,
6756 returns the type of the controlling discriminant for the variant.
6757 May return NULL if the type could not be found. */
6760 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6762 const char *name
= ada_variant_discrim_name (var_type
);
6764 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6767 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6768 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6769 represents a 'when others' clause; otherwise 0. */
6772 ada_is_others_clause (struct type
*type
, int field_num
)
6774 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6776 return (name
!= NULL
&& name
[0] == 'O');
6779 /* Assuming that TYPE0 is the type of the variant part of a record,
6780 returns the name of the discriminant controlling the variant.
6781 The value is valid until the next call to ada_variant_discrim_name. */
6784 ada_variant_discrim_name (struct type
*type0
)
6786 static char *result
= NULL
;
6787 static size_t result_len
= 0;
6790 const char *discrim_end
;
6791 const char *discrim_start
;
6793 if (type0
->code () == TYPE_CODE_PTR
)
6794 type
= TYPE_TARGET_TYPE (type0
);
6798 name
= ada_type_name (type
);
6800 if (name
== NULL
|| name
[0] == '\000')
6803 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6806 if (startswith (discrim_end
, "___XVN"))
6809 if (discrim_end
== name
)
6812 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6815 if (discrim_start
== name
+ 1)
6817 if ((discrim_start
> name
+ 3
6818 && startswith (discrim_start
- 3, "___"))
6819 || discrim_start
[-1] == '.')
6823 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6824 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6825 result
[discrim_end
- discrim_start
] = '\0';
6829 /* Scan STR for a subtype-encoded number, beginning at position K.
6830 Put the position of the character just past the number scanned in
6831 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6832 Return 1 if there was a valid number at the given position, and 0
6833 otherwise. A "subtype-encoded" number consists of the absolute value
6834 in decimal, followed by the letter 'm' to indicate a negative number.
6835 Assumes 0m does not occur. */
6838 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6842 if (!isdigit (str
[k
]))
6845 /* Do it the hard way so as not to make any assumption about
6846 the relationship of unsigned long (%lu scan format code) and
6849 while (isdigit (str
[k
]))
6851 RU
= RU
* 10 + (str
[k
] - '0');
6858 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6864 /* NOTE on the above: Technically, C does not say what the results of
6865 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6866 number representable as a LONGEST (although either would probably work
6867 in most implementations). When RU>0, the locution in the then branch
6868 above is always equivalent to the negative of RU. */
6875 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6876 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6877 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6880 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6882 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6896 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6906 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6907 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6909 if (val
>= L
&& val
<= U
)
6921 /* FIXME: Lots of redundancy below. Try to consolidate. */
6923 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6924 ARG_TYPE, extract and return the value of one of its (non-static)
6925 fields. FIELDNO says which field. Differs from value_primitive_field
6926 only in that it can handle packed values of arbitrary type. */
6929 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6930 struct type
*arg_type
)
6934 arg_type
= ada_check_typedef (arg_type
);
6935 type
= arg_type
->field (fieldno
).type ();
6937 /* Handle packed fields. It might be that the field is not packed
6938 relative to its containing structure, but the structure itself is
6939 packed; in this case we must take the bit-field path. */
6940 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6942 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6943 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6945 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6946 offset
+ bit_pos
/ 8,
6947 bit_pos
% 8, bit_size
, type
);
6950 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6953 /* Find field with name NAME in object of type TYPE. If found,
6954 set the following for each argument that is non-null:
6955 - *FIELD_TYPE_P to the field's type;
6956 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6957 an object of that type;
6958 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6959 - *BIT_SIZE_P to its size in bits if the field is packed, and
6961 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6962 fields up to but not including the desired field, or by the total
6963 number of fields if not found. A NULL value of NAME never
6964 matches; the function just counts visible fields in this case.
6966 Notice that we need to handle when a tagged record hierarchy
6967 has some components with the same name, like in this scenario:
6969 type Top_T is tagged record
6975 type Middle_T is new Top.Top_T with record
6976 N : Character := 'a';
6980 type Bottom_T is new Middle.Middle_T with record
6982 C : Character := '5';
6984 A : Character := 'J';
6987 Let's say we now have a variable declared and initialized as follow:
6989 TC : Top_A := new Bottom_T;
6991 And then we use this variable to call this function
6993 procedure Assign (Obj: in out Top_T; TV : Integer);
6997 Assign (Top_T (B), 12);
6999 Now, we're in the debugger, and we're inside that procedure
7000 then and we want to print the value of obj.c:
7002 Usually, the tagged record or one of the parent type owns the
7003 component to print and there's no issue but in this particular
7004 case, what does it mean to ask for Obj.C? Since the actual
7005 type for object is type Bottom_T, it could mean two things: type
7006 component C from the Middle_T view, but also component C from
7007 Bottom_T. So in that "undefined" case, when the component is
7008 not found in the non-resolved type (which includes all the
7009 components of the parent type), then resolve it and see if we
7010 get better luck once expanded.
7012 In the case of homonyms in the derived tagged type, we don't
7013 guaranty anything, and pick the one that's easiest for us
7016 Returns 1 if found, 0 otherwise. */
7019 find_struct_field (const char *name
, struct type
*type
, int offset
,
7020 struct type
**field_type_p
,
7021 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7025 int parent_offset
= -1;
7027 type
= ada_check_typedef (type
);
7029 if (field_type_p
!= NULL
)
7030 *field_type_p
= NULL
;
7031 if (byte_offset_p
!= NULL
)
7033 if (bit_offset_p
!= NULL
)
7035 if (bit_size_p
!= NULL
)
7038 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7040 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7041 int fld_offset
= offset
+ bit_pos
/ 8;
7042 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7044 if (t_field_name
== NULL
)
7047 else if (ada_is_parent_field (type
, i
))
7049 /* This is a field pointing us to the parent type of a tagged
7050 type. As hinted in this function's documentation, we give
7051 preference to fields in the current record first, so what
7052 we do here is just record the index of this field before
7053 we skip it. If it turns out we couldn't find our field
7054 in the current record, then we'll get back to it and search
7055 inside it whether the field might exist in the parent. */
7061 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7063 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7065 if (field_type_p
!= NULL
)
7066 *field_type_p
= type
->field (i
).type ();
7067 if (byte_offset_p
!= NULL
)
7068 *byte_offset_p
= fld_offset
;
7069 if (bit_offset_p
!= NULL
)
7070 *bit_offset_p
= bit_pos
% 8;
7071 if (bit_size_p
!= NULL
)
7072 *bit_size_p
= bit_size
;
7075 else if (ada_is_wrapper_field (type
, i
))
7077 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7078 field_type_p
, byte_offset_p
, bit_offset_p
,
7079 bit_size_p
, index_p
))
7082 else if (ada_is_variant_part (type
, i
))
7084 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7087 struct type
*field_type
7088 = ada_check_typedef (type
->field (i
).type ());
7090 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7092 if (find_struct_field (name
, field_type
->field (j
).type (),
7094 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7095 field_type_p
, byte_offset_p
,
7096 bit_offset_p
, bit_size_p
, index_p
))
7100 else if (index_p
!= NULL
)
7104 /* Field not found so far. If this is a tagged type which
7105 has a parent, try finding that field in the parent now. */
7107 if (parent_offset
!= -1)
7109 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7110 int fld_offset
= offset
+ bit_pos
/ 8;
7112 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7113 fld_offset
, field_type_p
, byte_offset_p
,
7114 bit_offset_p
, bit_size_p
, index_p
))
7121 /* Number of user-visible fields in record type TYPE. */
7124 num_visible_fields (struct type
*type
)
7129 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7133 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7134 and search in it assuming it has (class) type TYPE.
7135 If found, return value, else return NULL.
7137 Searches recursively through wrapper fields (e.g., '_parent').
7139 In the case of homonyms in the tagged types, please refer to the
7140 long explanation in find_struct_field's function documentation. */
7142 static struct value
*
7143 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7147 int parent_offset
= -1;
7149 type
= ada_check_typedef (type
);
7150 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7152 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7154 if (t_field_name
== NULL
)
7157 else if (ada_is_parent_field (type
, i
))
7159 /* This is a field pointing us to the parent type of a tagged
7160 type. As hinted in this function's documentation, we give
7161 preference to fields in the current record first, so what
7162 we do here is just record the index of this field before
7163 we skip it. If it turns out we couldn't find our field
7164 in the current record, then we'll get back to it and search
7165 inside it whether the field might exist in the parent. */
7171 else if (field_name_match (t_field_name
, name
))
7172 return ada_value_primitive_field (arg
, offset
, i
, type
);
7174 else if (ada_is_wrapper_field (type
, i
))
7176 struct value
*v
= /* Do not let indent join lines here. */
7177 ada_search_struct_field (name
, arg
,
7178 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7179 type
->field (i
).type ());
7185 else if (ada_is_variant_part (type
, i
))
7187 /* PNH: Do we ever get here? See find_struct_field. */
7189 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7190 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7192 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7194 struct value
*v
= ada_search_struct_field
/* Force line
7197 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7198 field_type
->field (j
).type ());
7206 /* Field not found so far. If this is a tagged type which
7207 has a parent, try finding that field in the parent now. */
7209 if (parent_offset
!= -1)
7211 struct value
*v
= ada_search_struct_field (
7212 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7213 type
->field (parent_offset
).type ());
7222 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7223 int, struct type
*);
7226 /* Return field #INDEX in ARG, where the index is that returned by
7227 * find_struct_field through its INDEX_P argument. Adjust the address
7228 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7229 * If found, return value, else return NULL. */
7231 static struct value
*
7232 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7235 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7239 /* Auxiliary function for ada_index_struct_field. Like
7240 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7243 static struct value
*
7244 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7248 type
= ada_check_typedef (type
);
7250 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7252 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7254 else if (ada_is_wrapper_field (type
, i
))
7256 struct value
*v
= /* Do not let indent join lines here. */
7257 ada_index_struct_field_1 (index_p
, arg
,
7258 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7259 type
->field (i
).type ());
7265 else if (ada_is_variant_part (type
, i
))
7267 /* PNH: Do we ever get here? See ada_search_struct_field,
7268 find_struct_field. */
7269 error (_("Cannot assign this kind of variant record"));
7271 else if (*index_p
== 0)
7272 return ada_value_primitive_field (arg
, offset
, i
, type
);
7279 /* Return a string representation of type TYPE. */
7282 type_as_string (struct type
*type
)
7284 string_file tmp_stream
;
7286 type_print (type
, "", &tmp_stream
, -1);
7288 return std::move (tmp_stream
.string ());
7291 /* Given a type TYPE, look up the type of the component of type named NAME.
7292 If DISPP is non-null, add its byte displacement from the beginning of a
7293 structure (pointed to by a value) of type TYPE to *DISPP (does not
7294 work for packed fields).
7296 Matches any field whose name has NAME as a prefix, possibly
7299 TYPE can be either a struct or union. If REFOK, TYPE may also
7300 be a (pointer or reference)+ to a struct or union, and the
7301 ultimate target type will be searched.
7303 Looks recursively into variant clauses and parent types.
7305 In the case of homonyms in the tagged types, please refer to the
7306 long explanation in find_struct_field's function documentation.
7308 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7309 TYPE is not a type of the right kind. */
7311 static struct type
*
7312 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7316 int parent_offset
= -1;
7321 if (refok
&& type
!= NULL
)
7324 type
= ada_check_typedef (type
);
7325 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7327 type
= TYPE_TARGET_TYPE (type
);
7331 || (type
->code () != TYPE_CODE_STRUCT
7332 && type
->code () != TYPE_CODE_UNION
))
7337 error (_("Type %s is not a structure or union type"),
7338 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7341 type
= to_static_fixed_type (type
);
7343 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7345 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7348 if (t_field_name
== NULL
)
7351 else if (ada_is_parent_field (type
, i
))
7353 /* This is a field pointing us to the parent type of a tagged
7354 type. As hinted in this function's documentation, we give
7355 preference to fields in the current record first, so what
7356 we do here is just record the index of this field before
7357 we skip it. If it turns out we couldn't find our field
7358 in the current record, then we'll get back to it and search
7359 inside it whether the field might exist in the parent. */
7365 else if (field_name_match (t_field_name
, name
))
7366 return type
->field (i
).type ();
7368 else if (ada_is_wrapper_field (type
, i
))
7370 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7376 else if (ada_is_variant_part (type
, i
))
7379 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7381 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7383 /* FIXME pnh 2008/01/26: We check for a field that is
7384 NOT wrapped in a struct, since the compiler sometimes
7385 generates these for unchecked variant types. Revisit
7386 if the compiler changes this practice. */
7387 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7389 if (v_field_name
!= NULL
7390 && field_name_match (v_field_name
, name
))
7391 t
= field_type
->field (j
).type ();
7393 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7403 /* Field not found so far. If this is a tagged type which
7404 has a parent, try finding that field in the parent now. */
7406 if (parent_offset
!= -1)
7410 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7419 const char *name_str
= name
!= NULL
? name
: _("<null>");
7421 error (_("Type %s has no component named %s"),
7422 type_as_string (type
).c_str (), name_str
);
7428 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7429 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7430 represents an unchecked union (that is, the variant part of a
7431 record that is named in an Unchecked_Union pragma). */
7434 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7436 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7438 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7442 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7443 within OUTER, determine which variant clause (field number in VAR_TYPE,
7444 numbering from 0) is applicable. Returns -1 if none are. */
7447 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7451 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7452 struct value
*discrim
;
7453 LONGEST discrim_val
;
7455 /* Using plain value_from_contents_and_address here causes problems
7456 because we will end up trying to resolve a type that is currently
7457 being constructed. */
7458 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7459 if (discrim
== NULL
)
7461 discrim_val
= value_as_long (discrim
);
7464 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7466 if (ada_is_others_clause (var_type
, i
))
7468 else if (ada_in_variant (discrim_val
, var_type
, i
))
7472 return others_clause
;
7477 /* Dynamic-Sized Records */
7479 /* Strategy: The type ostensibly attached to a value with dynamic size
7480 (i.e., a size that is not statically recorded in the debugging
7481 data) does not accurately reflect the size or layout of the value.
7482 Our strategy is to convert these values to values with accurate,
7483 conventional types that are constructed on the fly. */
7485 /* There is a subtle and tricky problem here. In general, we cannot
7486 determine the size of dynamic records without its data. However,
7487 the 'struct value' data structure, which GDB uses to represent
7488 quantities in the inferior process (the target), requires the size
7489 of the type at the time of its allocation in order to reserve space
7490 for GDB's internal copy of the data. That's why the
7491 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7492 rather than struct value*s.
7494 However, GDB's internal history variables ($1, $2, etc.) are
7495 struct value*s containing internal copies of the data that are not, in
7496 general, the same as the data at their corresponding addresses in
7497 the target. Fortunately, the types we give to these values are all
7498 conventional, fixed-size types (as per the strategy described
7499 above), so that we don't usually have to perform the
7500 'to_fixed_xxx_type' conversions to look at their values.
7501 Unfortunately, there is one exception: if one of the internal
7502 history variables is an array whose elements are unconstrained
7503 records, then we will need to create distinct fixed types for each
7504 element selected. */
7506 /* The upshot of all of this is that many routines take a (type, host
7507 address, target address) triple as arguments to represent a value.
7508 The host address, if non-null, is supposed to contain an internal
7509 copy of the relevant data; otherwise, the program is to consult the
7510 target at the target address. */
7512 /* Assuming that VAL0 represents a pointer value, the result of
7513 dereferencing it. Differs from value_ind in its treatment of
7514 dynamic-sized types. */
7517 ada_value_ind (struct value
*val0
)
7519 struct value
*val
= value_ind (val0
);
7521 if (ada_is_tagged_type (value_type (val
), 0))
7522 val
= ada_tag_value_at_base_address (val
);
7524 return ada_to_fixed_value (val
);
7527 /* The value resulting from dereferencing any "reference to"
7528 qualifiers on VAL0. */
7530 static struct value
*
7531 ada_coerce_ref (struct value
*val0
)
7533 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7535 struct value
*val
= val0
;
7537 val
= coerce_ref (val
);
7539 if (ada_is_tagged_type (value_type (val
), 0))
7540 val
= ada_tag_value_at_base_address (val
);
7542 return ada_to_fixed_value (val
);
7548 /* Return the bit alignment required for field #F of template type TYPE. */
7551 field_alignment (struct type
*type
, int f
)
7553 const char *name
= TYPE_FIELD_NAME (type
, f
);
7557 /* The field name should never be null, unless the debugging information
7558 is somehow malformed. In this case, we assume the field does not
7559 require any alignment. */
7563 len
= strlen (name
);
7565 if (!isdigit (name
[len
- 1]))
7568 if (isdigit (name
[len
- 2]))
7569 align_offset
= len
- 2;
7571 align_offset
= len
- 1;
7573 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7574 return TARGET_CHAR_BIT
;
7576 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7579 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7581 static struct symbol
*
7582 ada_find_any_type_symbol (const char *name
)
7586 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7587 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7590 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7594 /* Find a type named NAME. Ignores ambiguity. This routine will look
7595 solely for types defined by debug info, it will not search the GDB
7598 static struct type
*
7599 ada_find_any_type (const char *name
)
7601 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7604 return SYMBOL_TYPE (sym
);
7609 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7610 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7611 symbol, in which case it is returned. Otherwise, this looks for
7612 symbols whose name is that of NAME_SYM suffixed with "___XR".
7613 Return symbol if found, and NULL otherwise. */
7616 ada_is_renaming_symbol (struct symbol
*name_sym
)
7618 const char *name
= name_sym
->linkage_name ();
7619 return strstr (name
, "___XR") != NULL
;
7622 /* Because of GNAT encoding conventions, several GDB symbols may match a
7623 given type name. If the type denoted by TYPE0 is to be preferred to
7624 that of TYPE1 for purposes of type printing, return non-zero;
7625 otherwise return 0. */
7628 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7632 else if (type0
== NULL
)
7634 else if (type1
->code () == TYPE_CODE_VOID
)
7636 else if (type0
->code () == TYPE_CODE_VOID
)
7638 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7640 else if (ada_is_constrained_packed_array_type (type0
))
7642 else if (ada_is_array_descriptor_type (type0
)
7643 && !ada_is_array_descriptor_type (type1
))
7647 const char *type0_name
= type0
->name ();
7648 const char *type1_name
= type1
->name ();
7650 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7651 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7657 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7661 ada_type_name (struct type
*type
)
7665 return type
->name ();
7668 /* Search the list of "descriptive" types associated to TYPE for a type
7669 whose name is NAME. */
7671 static struct type
*
7672 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7674 struct type
*result
, *tmp
;
7676 if (ada_ignore_descriptive_types_p
)
7679 /* If there no descriptive-type info, then there is no parallel type
7681 if (!HAVE_GNAT_AUX_INFO (type
))
7684 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7685 while (result
!= NULL
)
7687 const char *result_name
= ada_type_name (result
);
7689 if (result_name
== NULL
)
7691 warning (_("unexpected null name on descriptive type"));
7695 /* If the names match, stop. */
7696 if (strcmp (result_name
, name
) == 0)
7699 /* Otherwise, look at the next item on the list, if any. */
7700 if (HAVE_GNAT_AUX_INFO (result
))
7701 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7705 /* If not found either, try after having resolved the typedef. */
7710 result
= check_typedef (result
);
7711 if (HAVE_GNAT_AUX_INFO (result
))
7712 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7718 /* If we didn't find a match, see whether this is a packed array. With
7719 older compilers, the descriptive type information is either absent or
7720 irrelevant when it comes to packed arrays so the above lookup fails.
7721 Fall back to using a parallel lookup by name in this case. */
7722 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7723 return ada_find_any_type (name
);
7728 /* Find a parallel type to TYPE with the specified NAME, using the
7729 descriptive type taken from the debugging information, if available,
7730 and otherwise using the (slower) name-based method. */
7732 static struct type
*
7733 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7735 struct type
*result
= NULL
;
7737 if (HAVE_GNAT_AUX_INFO (type
))
7738 result
= find_parallel_type_by_descriptive_type (type
, name
);
7740 result
= ada_find_any_type (name
);
7745 /* Same as above, but specify the name of the parallel type by appending
7746 SUFFIX to the name of TYPE. */
7749 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7752 const char *type_name
= ada_type_name (type
);
7755 if (type_name
== NULL
)
7758 len
= strlen (type_name
);
7760 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7762 strcpy (name
, type_name
);
7763 strcpy (name
+ len
, suffix
);
7765 return ada_find_parallel_type_with_name (type
, name
);
7768 /* If TYPE is a variable-size record type, return the corresponding template
7769 type describing its fields. Otherwise, return NULL. */
7771 static struct type
*
7772 dynamic_template_type (struct type
*type
)
7774 type
= ada_check_typedef (type
);
7776 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7777 || ada_type_name (type
) == NULL
)
7781 int len
= strlen (ada_type_name (type
));
7783 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7786 return ada_find_parallel_type (type
, "___XVE");
7790 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7791 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7794 is_dynamic_field (struct type
*templ_type
, int field_num
)
7796 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7799 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7800 && strstr (name
, "___XVL") != NULL
;
7803 /* The index of the variant field of TYPE, or -1 if TYPE does not
7804 represent a variant record type. */
7807 variant_field_index (struct type
*type
)
7811 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7814 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7816 if (ada_is_variant_part (type
, f
))
7822 /* A record type with no fields. */
7824 static struct type
*
7825 empty_record (struct type
*templ
)
7827 struct type
*type
= alloc_type_copy (templ
);
7829 type
->set_code (TYPE_CODE_STRUCT
);
7830 INIT_NONE_SPECIFIC (type
);
7831 type
->set_name ("<empty>");
7832 TYPE_LENGTH (type
) = 0;
7836 /* An ordinary record type (with fixed-length fields) that describes
7837 the value of type TYPE at VALADDR or ADDRESS (see comments at
7838 the beginning of this section) VAL according to GNAT conventions.
7839 DVAL0 should describe the (portion of a) record that contains any
7840 necessary discriminants. It should be NULL if value_type (VAL) is
7841 an outer-level type (i.e., as opposed to a branch of a variant.) A
7842 variant field (unless unchecked) is replaced by a particular branch
7845 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7846 length are not statically known are discarded. As a consequence,
7847 VALADDR, ADDRESS and DVAL0 are ignored.
7849 NOTE: Limitations: For now, we assume that dynamic fields and
7850 variants occupy whole numbers of bytes. However, they need not be
7854 ada_template_to_fixed_record_type_1 (struct type
*type
,
7855 const gdb_byte
*valaddr
,
7856 CORE_ADDR address
, struct value
*dval0
,
7857 int keep_dynamic_fields
)
7859 struct value
*mark
= value_mark ();
7862 int nfields
, bit_len
;
7868 /* Compute the number of fields in this record type that are going
7869 to be processed: unless keep_dynamic_fields, this includes only
7870 fields whose position and length are static will be processed. */
7871 if (keep_dynamic_fields
)
7872 nfields
= type
->num_fields ();
7876 while (nfields
< type
->num_fields ()
7877 && !ada_is_variant_part (type
, nfields
)
7878 && !is_dynamic_field (type
, nfields
))
7882 rtype
= alloc_type_copy (type
);
7883 rtype
->set_code (TYPE_CODE_STRUCT
);
7884 INIT_NONE_SPECIFIC (rtype
);
7885 rtype
->set_num_fields (nfields
);
7887 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7888 rtype
->set_name (ada_type_name (type
));
7889 rtype
->set_is_fixed_instance (true);
7895 for (f
= 0; f
< nfields
; f
+= 1)
7897 off
= align_up (off
, field_alignment (type
, f
))
7898 + TYPE_FIELD_BITPOS (type
, f
);
7899 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7900 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7902 if (ada_is_variant_part (type
, f
))
7907 else if (is_dynamic_field (type
, f
))
7909 const gdb_byte
*field_valaddr
= valaddr
;
7910 CORE_ADDR field_address
= address
;
7911 struct type
*field_type
=
7912 TYPE_TARGET_TYPE (type
->field (f
).type ());
7916 /* rtype's length is computed based on the run-time
7917 value of discriminants. If the discriminants are not
7918 initialized, the type size may be completely bogus and
7919 GDB may fail to allocate a value for it. So check the
7920 size first before creating the value. */
7921 ada_ensure_varsize_limit (rtype
);
7922 /* Using plain value_from_contents_and_address here
7923 causes problems because we will end up trying to
7924 resolve a type that is currently being
7926 dval
= value_from_contents_and_address_unresolved (rtype
,
7929 rtype
= value_type (dval
);
7934 /* If the type referenced by this field is an aligner type, we need
7935 to unwrap that aligner type, because its size might not be set.
7936 Keeping the aligner type would cause us to compute the wrong
7937 size for this field, impacting the offset of the all the fields
7938 that follow this one. */
7939 if (ada_is_aligner_type (field_type
))
7941 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7943 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7944 field_address
= cond_offset_target (field_address
, field_offset
);
7945 field_type
= ada_aligned_type (field_type
);
7948 field_valaddr
= cond_offset_host (field_valaddr
,
7949 off
/ TARGET_CHAR_BIT
);
7950 field_address
= cond_offset_target (field_address
,
7951 off
/ TARGET_CHAR_BIT
);
7953 /* Get the fixed type of the field. Note that, in this case,
7954 we do not want to get the real type out of the tag: if
7955 the current field is the parent part of a tagged record,
7956 we will get the tag of the object. Clearly wrong: the real
7957 type of the parent is not the real type of the child. We
7958 would end up in an infinite loop. */
7959 field_type
= ada_get_base_type (field_type
);
7960 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7961 field_address
, dval
, 0);
7962 /* If the field size is already larger than the maximum
7963 object size, then the record itself will necessarily
7964 be larger than the maximum object size. We need to make
7965 this check now, because the size might be so ridiculously
7966 large (due to an uninitialized variable in the inferior)
7967 that it would cause an overflow when adding it to the
7969 ada_ensure_varsize_limit (field_type
);
7971 rtype
->field (f
).set_type (field_type
);
7972 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7973 /* The multiplication can potentially overflow. But because
7974 the field length has been size-checked just above, and
7975 assuming that the maximum size is a reasonable value,
7976 an overflow should not happen in practice. So rather than
7977 adding overflow recovery code to this already complex code,
7978 we just assume that it's not going to happen. */
7980 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7984 /* Note: If this field's type is a typedef, it is important
7985 to preserve the typedef layer.
7987 Otherwise, we might be transforming a typedef to a fat
7988 pointer (encoding a pointer to an unconstrained array),
7989 into a basic fat pointer (encoding an unconstrained
7990 array). As both types are implemented using the same
7991 structure, the typedef is the only clue which allows us
7992 to distinguish between the two options. Stripping it
7993 would prevent us from printing this field appropriately. */
7994 rtype
->field (f
).set_type (type
->field (f
).type ());
7995 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7996 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7998 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8001 struct type
*field_type
= type
->field (f
).type ();
8003 /* We need to be careful of typedefs when computing
8004 the length of our field. If this is a typedef,
8005 get the length of the target type, not the length
8007 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
8008 field_type
= ada_typedef_target_type (field_type
);
8011 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8014 if (off
+ fld_bit_len
> bit_len
)
8015 bit_len
= off
+ fld_bit_len
;
8017 TYPE_LENGTH (rtype
) =
8018 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8021 /* We handle the variant part, if any, at the end because of certain
8022 odd cases in which it is re-ordered so as NOT to be the last field of
8023 the record. This can happen in the presence of representation
8025 if (variant_field
>= 0)
8027 struct type
*branch_type
;
8029 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8033 /* Using plain value_from_contents_and_address here causes
8034 problems because we will end up trying to resolve a type
8035 that is currently being constructed. */
8036 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8038 rtype
= value_type (dval
);
8044 to_fixed_variant_branch_type
8045 (type
->field (variant_field
).type (),
8046 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8047 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8048 if (branch_type
== NULL
)
8050 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8051 rtype
->field (f
- 1) = rtype
->field (f
);
8052 rtype
->set_num_fields (rtype
->num_fields () - 1);
8056 rtype
->field (variant_field
).set_type (branch_type
);
8057 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8059 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8061 if (off
+ fld_bit_len
> bit_len
)
8062 bit_len
= off
+ fld_bit_len
;
8063 TYPE_LENGTH (rtype
) =
8064 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8068 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8069 should contain the alignment of that record, which should be a strictly
8070 positive value. If null or negative, then something is wrong, most
8071 probably in the debug info. In that case, we don't round up the size
8072 of the resulting type. If this record is not part of another structure,
8073 the current RTYPE length might be good enough for our purposes. */
8074 if (TYPE_LENGTH (type
) <= 0)
8077 warning (_("Invalid type size for `%s' detected: %s."),
8078 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8080 warning (_("Invalid type size for <unnamed> detected: %s."),
8081 pulongest (TYPE_LENGTH (type
)));
8085 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8086 TYPE_LENGTH (type
));
8089 value_free_to_mark (mark
);
8090 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8091 error (_("record type with dynamic size is larger than varsize-limit"));
8095 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8098 static struct type
*
8099 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8100 CORE_ADDR address
, struct value
*dval0
)
8102 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8106 /* An ordinary record type in which ___XVL-convention fields and
8107 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8108 static approximations, containing all possible fields. Uses
8109 no runtime values. Useless for use in values, but that's OK,
8110 since the results are used only for type determinations. Works on both
8111 structs and unions. Representation note: to save space, we memorize
8112 the result of this function in the TYPE_TARGET_TYPE of the
8115 static struct type
*
8116 template_to_static_fixed_type (struct type
*type0
)
8122 /* No need no do anything if the input type is already fixed. */
8123 if (type0
->is_fixed_instance ())
8126 /* Likewise if we already have computed the static approximation. */
8127 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8128 return TYPE_TARGET_TYPE (type0
);
8130 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8132 nfields
= type0
->num_fields ();
8134 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8135 recompute all over next time. */
8136 TYPE_TARGET_TYPE (type0
) = type
;
8138 for (f
= 0; f
< nfields
; f
+= 1)
8140 struct type
*field_type
= type0
->field (f
).type ();
8141 struct type
*new_type
;
8143 if (is_dynamic_field (type0
, f
))
8145 field_type
= ada_check_typedef (field_type
);
8146 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8149 new_type
= static_unwrap_type (field_type
);
8151 if (new_type
!= field_type
)
8153 /* Clone TYPE0 only the first time we get a new field type. */
8156 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8157 type
->set_code (type0
->code ());
8158 INIT_NONE_SPECIFIC (type
);
8159 type
->set_num_fields (nfields
);
8163 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8164 memcpy (fields
, type0
->fields (),
8165 sizeof (struct field
) * nfields
);
8166 type
->set_fields (fields
);
8168 type
->set_name (ada_type_name (type0
));
8169 type
->set_is_fixed_instance (true);
8170 TYPE_LENGTH (type
) = 0;
8172 type
->field (f
).set_type (new_type
);
8173 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8180 /* Given an object of type TYPE whose contents are at VALADDR and
8181 whose address in memory is ADDRESS, returns a revision of TYPE,
8182 which should be a non-dynamic-sized record, in which the variant
8183 part, if any, is replaced with the appropriate branch. Looks
8184 for discriminant values in DVAL0, which can be NULL if the record
8185 contains the necessary discriminant values. */
8187 static struct type
*
8188 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8189 CORE_ADDR address
, struct value
*dval0
)
8191 struct value
*mark
= value_mark ();
8194 struct type
*branch_type
;
8195 int nfields
= type
->num_fields ();
8196 int variant_field
= variant_field_index (type
);
8198 if (variant_field
== -1)
8203 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8204 type
= value_type (dval
);
8209 rtype
= alloc_type_copy (type
);
8210 rtype
->set_code (TYPE_CODE_STRUCT
);
8211 INIT_NONE_SPECIFIC (rtype
);
8212 rtype
->set_num_fields (nfields
);
8215 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8216 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8217 rtype
->set_fields (fields
);
8219 rtype
->set_name (ada_type_name (type
));
8220 rtype
->set_is_fixed_instance (true);
8221 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8223 branch_type
= to_fixed_variant_branch_type
8224 (type
->field (variant_field
).type (),
8225 cond_offset_host (valaddr
,
8226 TYPE_FIELD_BITPOS (type
, variant_field
)
8228 cond_offset_target (address
,
8229 TYPE_FIELD_BITPOS (type
, variant_field
)
8230 / TARGET_CHAR_BIT
), dval
);
8231 if (branch_type
== NULL
)
8235 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8236 rtype
->field (f
- 1) = rtype
->field (f
);
8237 rtype
->set_num_fields (rtype
->num_fields () - 1);
8241 rtype
->field (variant_field
).set_type (branch_type
);
8242 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8243 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8244 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8246 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8248 value_free_to_mark (mark
);
8252 /* An ordinary record type (with fixed-length fields) that describes
8253 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8254 beginning of this section]. Any necessary discriminants' values
8255 should be in DVAL, a record value; it may be NULL if the object
8256 at ADDR itself contains any necessary discriminant values.
8257 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8258 values from the record are needed. Except in the case that DVAL,
8259 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8260 unchecked) is replaced by a particular branch of the variant.
8262 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8263 is questionable and may be removed. It can arise during the
8264 processing of an unconstrained-array-of-record type where all the
8265 variant branches have exactly the same size. This is because in
8266 such cases, the compiler does not bother to use the XVS convention
8267 when encoding the record. I am currently dubious of this
8268 shortcut and suspect the compiler should be altered. FIXME. */
8270 static struct type
*
8271 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8272 CORE_ADDR address
, struct value
*dval
)
8274 struct type
*templ_type
;
8276 if (type0
->is_fixed_instance ())
8279 templ_type
= dynamic_template_type (type0
);
8281 if (templ_type
!= NULL
)
8282 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8283 else if (variant_field_index (type0
) >= 0)
8285 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8287 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8292 type0
->set_is_fixed_instance (true);
8298 /* An ordinary record type (with fixed-length fields) that describes
8299 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8300 union type. Any necessary discriminants' values should be in DVAL,
8301 a record value. That is, this routine selects the appropriate
8302 branch of the union at ADDR according to the discriminant value
8303 indicated in the union's type name. Returns VAR_TYPE0 itself if
8304 it represents a variant subject to a pragma Unchecked_Union. */
8306 static struct type
*
8307 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8308 CORE_ADDR address
, struct value
*dval
)
8311 struct type
*templ_type
;
8312 struct type
*var_type
;
8314 if (var_type0
->code () == TYPE_CODE_PTR
)
8315 var_type
= TYPE_TARGET_TYPE (var_type0
);
8317 var_type
= var_type0
;
8319 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8321 if (templ_type
!= NULL
)
8322 var_type
= templ_type
;
8324 if (is_unchecked_variant (var_type
, value_type (dval
)))
8326 which
= ada_which_variant_applies (var_type
, dval
);
8329 return empty_record (var_type
);
8330 else if (is_dynamic_field (var_type
, which
))
8331 return to_fixed_record_type
8332 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8333 valaddr
, address
, dval
);
8334 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8336 to_fixed_record_type
8337 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8339 return var_type
->field (which
).type ();
8342 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8343 ENCODING_TYPE, a type following the GNAT conventions for discrete
8344 type encodings, only carries redundant information. */
8347 ada_is_redundant_range_encoding (struct type
*range_type
,
8348 struct type
*encoding_type
)
8350 const char *bounds_str
;
8354 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8356 if (get_base_type (range_type
)->code ()
8357 != get_base_type (encoding_type
)->code ())
8359 /* The compiler probably used a simple base type to describe
8360 the range type instead of the range's actual base type,
8361 expecting us to get the real base type from the encoding
8362 anyway. In this situation, the encoding cannot be ignored
8367 if (is_dynamic_type (range_type
))
8370 if (encoding_type
->name () == NULL
)
8373 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8374 if (bounds_str
== NULL
)
8377 n
= 8; /* Skip "___XDLU_". */
8378 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8380 if (range_type
->bounds ()->low
.const_val () != lo
)
8383 n
+= 2; /* Skip the "__" separator between the two bounds. */
8384 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8386 if (range_type
->bounds ()->high
.const_val () != hi
)
8392 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8393 a type following the GNAT encoding for describing array type
8394 indices, only carries redundant information. */
8397 ada_is_redundant_index_type_desc (struct type
*array_type
,
8398 struct type
*desc_type
)
8400 struct type
*this_layer
= check_typedef (array_type
);
8403 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8405 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8406 desc_type
->field (i
).type ()))
8408 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8414 /* Assuming that TYPE0 is an array type describing the type of a value
8415 at ADDR, and that DVAL describes a record containing any
8416 discriminants used in TYPE0, returns a type for the value that
8417 contains no dynamic components (that is, no components whose sizes
8418 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8419 true, gives an error message if the resulting type's size is over
8422 static struct type
*
8423 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8426 struct type
*index_type_desc
;
8427 struct type
*result
;
8428 int constrained_packed_array_p
;
8429 static const char *xa_suffix
= "___XA";
8431 type0
= ada_check_typedef (type0
);
8432 if (type0
->is_fixed_instance ())
8435 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8436 if (constrained_packed_array_p
)
8438 type0
= decode_constrained_packed_array_type (type0
);
8439 if (type0
== nullptr)
8440 error (_("could not decode constrained packed array type"));
8443 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8445 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8446 encoding suffixed with 'P' may still be generated. If so,
8447 it should be used to find the XA type. */
8449 if (index_type_desc
== NULL
)
8451 const char *type_name
= ada_type_name (type0
);
8453 if (type_name
!= NULL
)
8455 const int len
= strlen (type_name
);
8456 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8458 if (type_name
[len
- 1] == 'P')
8460 strcpy (name
, type_name
);
8461 strcpy (name
+ len
- 1, xa_suffix
);
8462 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8467 ada_fixup_array_indexes_type (index_type_desc
);
8468 if (index_type_desc
!= NULL
8469 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8471 /* Ignore this ___XA parallel type, as it does not bring any
8472 useful information. This allows us to avoid creating fixed
8473 versions of the array's index types, which would be identical
8474 to the original ones. This, in turn, can also help avoid
8475 the creation of fixed versions of the array itself. */
8476 index_type_desc
= NULL
;
8479 if (index_type_desc
== NULL
)
8481 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8483 /* NOTE: elt_type---the fixed version of elt_type0---should never
8484 depend on the contents of the array in properly constructed
8486 /* Create a fixed version of the array element type.
8487 We're not providing the address of an element here,
8488 and thus the actual object value cannot be inspected to do
8489 the conversion. This should not be a problem, since arrays of
8490 unconstrained objects are not allowed. In particular, all
8491 the elements of an array of a tagged type should all be of
8492 the same type specified in the debugging info. No need to
8493 consult the object tag. */
8494 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8496 /* Make sure we always create a new array type when dealing with
8497 packed array types, since we're going to fix-up the array
8498 type length and element bitsize a little further down. */
8499 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8502 result
= create_array_type (alloc_type_copy (type0
),
8503 elt_type
, type0
->index_type ());
8508 struct type
*elt_type0
;
8511 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8512 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8514 /* NOTE: result---the fixed version of elt_type0---should never
8515 depend on the contents of the array in properly constructed
8517 /* Create a fixed version of the array element type.
8518 We're not providing the address of an element here,
8519 and thus the actual object value cannot be inspected to do
8520 the conversion. This should not be a problem, since arrays of
8521 unconstrained objects are not allowed. In particular, all
8522 the elements of an array of a tagged type should all be of
8523 the same type specified in the debugging info. No need to
8524 consult the object tag. */
8526 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8529 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8531 struct type
*range_type
=
8532 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8534 result
= create_array_type (alloc_type_copy (elt_type0
),
8535 result
, range_type
);
8536 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8538 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8539 error (_("array type with dynamic size is larger than varsize-limit"));
8542 /* We want to preserve the type name. This can be useful when
8543 trying to get the type name of a value that has already been
8544 printed (for instance, if the user did "print VAR; whatis $". */
8545 result
->set_name (type0
->name ());
8547 if (constrained_packed_array_p
)
8549 /* So far, the resulting type has been created as if the original
8550 type was a regular (non-packed) array type. As a result, the
8551 bitsize of the array elements needs to be set again, and the array
8552 length needs to be recomputed based on that bitsize. */
8553 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8554 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8556 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8557 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8558 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8559 TYPE_LENGTH (result
)++;
8562 result
->set_is_fixed_instance (true);
8567 /* A standard type (containing no dynamically sized components)
8568 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8569 DVAL describes a record containing any discriminants used in TYPE0,
8570 and may be NULL if there are none, or if the object of type TYPE at
8571 ADDRESS or in VALADDR contains these discriminants.
8573 If CHECK_TAG is not null, in the case of tagged types, this function
8574 attempts to locate the object's tag and use it to compute the actual
8575 type. However, when ADDRESS is null, we cannot use it to determine the
8576 location of the tag, and therefore compute the tagged type's actual type.
8577 So we return the tagged type without consulting the tag. */
8579 static struct type
*
8580 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8581 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8583 type
= ada_check_typedef (type
);
8585 /* Only un-fixed types need to be handled here. */
8586 if (!HAVE_GNAT_AUX_INFO (type
))
8589 switch (type
->code ())
8593 case TYPE_CODE_STRUCT
:
8595 struct type
*static_type
= to_static_fixed_type (type
);
8596 struct type
*fixed_record_type
=
8597 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8599 /* If STATIC_TYPE is a tagged type and we know the object's address,
8600 then we can determine its tag, and compute the object's actual
8601 type from there. Note that we have to use the fixed record
8602 type (the parent part of the record may have dynamic fields
8603 and the way the location of _tag is expressed may depend on
8606 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8609 value_tag_from_contents_and_address
8613 struct type
*real_type
= type_from_tag (tag
);
8615 value_from_contents_and_address (fixed_record_type
,
8618 fixed_record_type
= value_type (obj
);
8619 if (real_type
!= NULL
)
8620 return to_fixed_record_type
8622 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8625 /* Check to see if there is a parallel ___XVZ variable.
8626 If there is, then it provides the actual size of our type. */
8627 else if (ada_type_name (fixed_record_type
) != NULL
)
8629 const char *name
= ada_type_name (fixed_record_type
);
8631 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8632 bool xvz_found
= false;
8635 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8638 xvz_found
= get_int_var_value (xvz_name
, size
);
8640 catch (const gdb_exception_error
&except
)
8642 /* We found the variable, but somehow failed to read
8643 its value. Rethrow the same error, but with a little
8644 bit more information, to help the user understand
8645 what went wrong (Eg: the variable might have been
8647 throw_error (except
.error
,
8648 _("unable to read value of %s (%s)"),
8649 xvz_name
, except
.what ());
8652 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8654 fixed_record_type
= copy_type (fixed_record_type
);
8655 TYPE_LENGTH (fixed_record_type
) = size
;
8657 /* The FIXED_RECORD_TYPE may have be a stub. We have
8658 observed this when the debugging info is STABS, and
8659 apparently it is something that is hard to fix.
8661 In practice, we don't need the actual type definition
8662 at all, because the presence of the XVZ variable allows us
8663 to assume that there must be a XVS type as well, which we
8664 should be able to use later, when we need the actual type
8667 In the meantime, pretend that the "fixed" type we are
8668 returning is NOT a stub, because this can cause trouble
8669 when using this type to create new types targeting it.
8670 Indeed, the associated creation routines often check
8671 whether the target type is a stub and will try to replace
8672 it, thus using a type with the wrong size. This, in turn,
8673 might cause the new type to have the wrong size too.
8674 Consider the case of an array, for instance, where the size
8675 of the array is computed from the number of elements in
8676 our array multiplied by the size of its element. */
8677 fixed_record_type
->set_is_stub (false);
8680 return fixed_record_type
;
8682 case TYPE_CODE_ARRAY
:
8683 return to_fixed_array_type (type
, dval
, 1);
8684 case TYPE_CODE_UNION
:
8688 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8692 /* The same as ada_to_fixed_type_1, except that it preserves the type
8693 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8695 The typedef layer needs be preserved in order to differentiate between
8696 arrays and array pointers when both types are implemented using the same
8697 fat pointer. In the array pointer case, the pointer is encoded as
8698 a typedef of the pointer type. For instance, considering:
8700 type String_Access is access String;
8701 S1 : String_Access := null;
8703 To the debugger, S1 is defined as a typedef of type String. But
8704 to the user, it is a pointer. So if the user tries to print S1,
8705 we should not dereference the array, but print the array address
8708 If we didn't preserve the typedef layer, we would lose the fact that
8709 the type is to be presented as a pointer (needs de-reference before
8710 being printed). And we would also use the source-level type name. */
8713 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8714 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8717 struct type
*fixed_type
=
8718 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8720 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8721 then preserve the typedef layer.
8723 Implementation note: We can only check the main-type portion of
8724 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8725 from TYPE now returns a type that has the same instance flags
8726 as TYPE. For instance, if TYPE is a "typedef const", and its
8727 target type is a "struct", then the typedef elimination will return
8728 a "const" version of the target type. See check_typedef for more
8729 details about how the typedef layer elimination is done.
8731 brobecker/2010-11-19: It seems to me that the only case where it is
8732 useful to preserve the typedef layer is when dealing with fat pointers.
8733 Perhaps, we could add a check for that and preserve the typedef layer
8734 only in that situation. But this seems unnecessary so far, probably
8735 because we call check_typedef/ada_check_typedef pretty much everywhere.
8737 if (type
->code () == TYPE_CODE_TYPEDEF
8738 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8739 == TYPE_MAIN_TYPE (fixed_type
)))
8745 /* A standard (static-sized) type corresponding as well as possible to
8746 TYPE0, but based on no runtime data. */
8748 static struct type
*
8749 to_static_fixed_type (struct type
*type0
)
8756 if (type0
->is_fixed_instance ())
8759 type0
= ada_check_typedef (type0
);
8761 switch (type0
->code ())
8765 case TYPE_CODE_STRUCT
:
8766 type
= dynamic_template_type (type0
);
8768 return template_to_static_fixed_type (type
);
8770 return template_to_static_fixed_type (type0
);
8771 case TYPE_CODE_UNION
:
8772 type
= ada_find_parallel_type (type0
, "___XVU");
8774 return template_to_static_fixed_type (type
);
8776 return template_to_static_fixed_type (type0
);
8780 /* A static approximation of TYPE with all type wrappers removed. */
8782 static struct type
*
8783 static_unwrap_type (struct type
*type
)
8785 if (ada_is_aligner_type (type
))
8787 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8788 if (ada_type_name (type1
) == NULL
)
8789 type1
->set_name (ada_type_name (type
));
8791 return static_unwrap_type (type1
);
8795 struct type
*raw_real_type
= ada_get_base_type (type
);
8797 if (raw_real_type
== type
)
8800 return to_static_fixed_type (raw_real_type
);
8804 /* In some cases, incomplete and private types require
8805 cross-references that are not resolved as records (for example,
8807 type FooP is access Foo;
8809 type Foo is array ...;
8810 ). In these cases, since there is no mechanism for producing
8811 cross-references to such types, we instead substitute for FooP a
8812 stub enumeration type that is nowhere resolved, and whose tag is
8813 the name of the actual type. Call these types "non-record stubs". */
8815 /* A type equivalent to TYPE that is not a non-record stub, if one
8816 exists, otherwise TYPE. */
8819 ada_check_typedef (struct type
*type
)
8824 /* If our type is an access to an unconstrained array, which is encoded
8825 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8826 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8827 what allows us to distinguish between fat pointers that represent
8828 array types, and fat pointers that represent array access types
8829 (in both cases, the compiler implements them as fat pointers). */
8830 if (ada_is_access_to_unconstrained_array (type
))
8833 type
= check_typedef (type
);
8834 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8835 || !type
->is_stub ()
8836 || type
->name () == NULL
)
8840 const char *name
= type
->name ();
8841 struct type
*type1
= ada_find_any_type (name
);
8846 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8847 stubs pointing to arrays, as we don't create symbols for array
8848 types, only for the typedef-to-array types). If that's the case,
8849 strip the typedef layer. */
8850 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8851 type1
= ada_check_typedef (type1
);
8857 /* A value representing the data at VALADDR/ADDRESS as described by
8858 type TYPE0, but with a standard (static-sized) type that correctly
8859 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8860 type, then return VAL0 [this feature is simply to avoid redundant
8861 creation of struct values]. */
8863 static struct value
*
8864 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8867 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8869 if (type
== type0
&& val0
!= NULL
)
8872 if (VALUE_LVAL (val0
) != lval_memory
)
8874 /* Our value does not live in memory; it could be a convenience
8875 variable, for instance. Create a not_lval value using val0's
8877 return value_from_contents (type
, value_contents (val0
));
8880 return value_from_contents_and_address (type
, 0, address
);
8883 /* A value representing VAL, but with a standard (static-sized) type
8884 that correctly describes it. Does not necessarily create a new
8888 ada_to_fixed_value (struct value
*val
)
8890 val
= unwrap_value (val
);
8891 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8898 /* Table mapping attribute numbers to names.
8899 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8901 static const char * const attribute_names
[] = {
8919 ada_attribute_name (enum exp_opcode n
)
8921 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8922 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8924 return attribute_names
[0];
8927 /* Evaluate the 'POS attribute applied to ARG. */
8930 pos_atr (struct value
*arg
)
8932 struct value
*val
= coerce_ref (arg
);
8933 struct type
*type
= value_type (val
);
8935 if (!discrete_type_p (type
))
8936 error (_("'POS only defined on discrete types"));
8938 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8939 if (!result
.has_value ())
8940 error (_("enumeration value is invalid: can't find 'POS"));
8945 static struct value
*
8946 value_pos_atr (struct type
*type
, struct value
*arg
)
8948 return value_from_longest (type
, pos_atr (arg
));
8951 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8953 static struct value
*
8954 val_atr (struct type
*type
, LONGEST val
)
8956 gdb_assert (discrete_type_p (type
));
8957 if (type
->code () == TYPE_CODE_RANGE
)
8958 type
= TYPE_TARGET_TYPE (type
);
8959 if (type
->code () == TYPE_CODE_ENUM
)
8961 if (val
< 0 || val
>= type
->num_fields ())
8962 error (_("argument to 'VAL out of range"));
8963 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8965 return value_from_longest (type
, val
);
8968 static struct value
*
8969 value_val_atr (struct type
*type
, struct value
*arg
)
8971 if (!discrete_type_p (type
))
8972 error (_("'VAL only defined on discrete types"));
8973 if (!integer_type_p (value_type (arg
)))
8974 error (_("'VAL requires integral argument"));
8976 return val_atr (type
, value_as_long (arg
));
8982 /* True if TYPE appears to be an Ada character type.
8983 [At the moment, this is true only for Character and Wide_Character;
8984 It is a heuristic test that could stand improvement]. */
8987 ada_is_character_type (struct type
*type
)
8991 /* If the type code says it's a character, then assume it really is,
8992 and don't check any further. */
8993 if (type
->code () == TYPE_CODE_CHAR
)
8996 /* Otherwise, assume it's a character type iff it is a discrete type
8997 with a known character type name. */
8998 name
= ada_type_name (type
);
8999 return (name
!= NULL
9000 && (type
->code () == TYPE_CODE_INT
9001 || type
->code () == TYPE_CODE_RANGE
)
9002 && (strcmp (name
, "character") == 0
9003 || strcmp (name
, "wide_character") == 0
9004 || strcmp (name
, "wide_wide_character") == 0
9005 || strcmp (name
, "unsigned char") == 0));
9008 /* True if TYPE appears to be an Ada string type. */
9011 ada_is_string_type (struct type
*type
)
9013 type
= ada_check_typedef (type
);
9015 && type
->code () != TYPE_CODE_PTR
9016 && (ada_is_simple_array_type (type
)
9017 || ada_is_array_descriptor_type (type
))
9018 && ada_array_arity (type
) == 1)
9020 struct type
*elttype
= ada_array_element_type (type
, 1);
9022 return ada_is_character_type (elttype
);
9028 /* The compiler sometimes provides a parallel XVS type for a given
9029 PAD type. Normally, it is safe to follow the PAD type directly,
9030 but older versions of the compiler have a bug that causes the offset
9031 of its "F" field to be wrong. Following that field in that case
9032 would lead to incorrect results, but this can be worked around
9033 by ignoring the PAD type and using the associated XVS type instead.
9035 Set to True if the debugger should trust the contents of PAD types.
9036 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9037 static bool trust_pad_over_xvs
= true;
9039 /* True if TYPE is a struct type introduced by the compiler to force the
9040 alignment of a value. Such types have a single field with a
9041 distinctive name. */
9044 ada_is_aligner_type (struct type
*type
)
9046 type
= ada_check_typedef (type
);
9048 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9051 return (type
->code () == TYPE_CODE_STRUCT
9052 && type
->num_fields () == 1
9053 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9056 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9057 the parallel type. */
9060 ada_get_base_type (struct type
*raw_type
)
9062 struct type
*real_type_namer
;
9063 struct type
*raw_real_type
;
9065 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9068 if (ada_is_aligner_type (raw_type
))
9069 /* The encoding specifies that we should always use the aligner type.
9070 So, even if this aligner type has an associated XVS type, we should
9073 According to the compiler gurus, an XVS type parallel to an aligner
9074 type may exist because of a stabs limitation. In stabs, aligner
9075 types are empty because the field has a variable-sized type, and
9076 thus cannot actually be used as an aligner type. As a result,
9077 we need the associated parallel XVS type to decode the type.
9078 Since the policy in the compiler is to not change the internal
9079 representation based on the debugging info format, we sometimes
9080 end up having a redundant XVS type parallel to the aligner type. */
9083 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9084 if (real_type_namer
== NULL
9085 || real_type_namer
->code () != TYPE_CODE_STRUCT
9086 || real_type_namer
->num_fields () != 1)
9089 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9091 /* This is an older encoding form where the base type needs to be
9092 looked up by name. We prefer the newer encoding because it is
9094 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9095 if (raw_real_type
== NULL
)
9098 return raw_real_type
;
9101 /* The field in our XVS type is a reference to the base type. */
9102 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9105 /* The type of value designated by TYPE, with all aligners removed. */
9108 ada_aligned_type (struct type
*type
)
9110 if (ada_is_aligner_type (type
))
9111 return ada_aligned_type (type
->field (0).type ());
9113 return ada_get_base_type (type
);
9117 /* The address of the aligned value in an object at address VALADDR
9118 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9121 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9123 if (ada_is_aligner_type (type
))
9124 return ada_aligned_value_addr (type
->field (0).type (),
9126 TYPE_FIELD_BITPOS (type
,
9127 0) / TARGET_CHAR_BIT
);
9134 /* The printed representation of an enumeration literal with encoded
9135 name NAME. The value is good to the next call of ada_enum_name. */
9137 ada_enum_name (const char *name
)
9139 static char *result
;
9140 static size_t result_len
= 0;
9143 /* First, unqualify the enumeration name:
9144 1. Search for the last '.' character. If we find one, then skip
9145 all the preceding characters, the unqualified name starts
9146 right after that dot.
9147 2. Otherwise, we may be debugging on a target where the compiler
9148 translates dots into "__". Search forward for double underscores,
9149 but stop searching when we hit an overloading suffix, which is
9150 of the form "__" followed by digits. */
9152 tmp
= strrchr (name
, '.');
9157 while ((tmp
= strstr (name
, "__")) != NULL
)
9159 if (isdigit (tmp
[2]))
9170 if (name
[1] == 'U' || name
[1] == 'W')
9172 if (sscanf (name
+ 2, "%x", &v
) != 1)
9175 else if (((name
[1] >= '0' && name
[1] <= '9')
9176 || (name
[1] >= 'a' && name
[1] <= 'z'))
9179 GROW_VECT (result
, result_len
, 4);
9180 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9186 GROW_VECT (result
, result_len
, 16);
9187 if (isascii (v
) && isprint (v
))
9188 xsnprintf (result
, result_len
, "'%c'", v
);
9189 else if (name
[1] == 'U')
9190 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9192 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9198 tmp
= strstr (name
, "__");
9200 tmp
= strstr (name
, "$");
9203 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9204 strncpy (result
, name
, tmp
- name
);
9205 result
[tmp
- name
] = '\0';
9213 /* Evaluate the subexpression of EXP starting at *POS as for
9214 evaluate_type, updating *POS to point just past the evaluated
9217 static struct value
*
9218 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9220 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9223 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9226 static struct value
*
9227 unwrap_value (struct value
*val
)
9229 struct type
*type
= ada_check_typedef (value_type (val
));
9231 if (ada_is_aligner_type (type
))
9233 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9234 struct type
*val_type
= ada_check_typedef (value_type (v
));
9236 if (ada_type_name (val_type
) == NULL
)
9237 val_type
->set_name (ada_type_name (type
));
9239 return unwrap_value (v
);
9243 struct type
*raw_real_type
=
9244 ada_check_typedef (ada_get_base_type (type
));
9246 /* If there is no parallel XVS or XVE type, then the value is
9247 already unwrapped. Return it without further modification. */
9248 if ((type
== raw_real_type
)
9249 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9253 coerce_unspec_val_to_type
9254 (val
, ada_to_fixed_type (raw_real_type
, 0,
9255 value_address (val
),
9260 static struct value
*
9261 cast_from_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9264 = gnat_encoded_fixed_point_scaling_factor (value_type (arg
));
9265 arg
= value_cast (value_type (scale
), arg
);
9267 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9268 return value_cast (type
, arg
);
9271 static struct value
*
9272 cast_to_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9274 if (type
== value_type (arg
))
9277 struct value
*scale
= gnat_encoded_fixed_point_scaling_factor (type
);
9278 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9279 arg
= cast_from_gnat_encoded_fixed_point_type (value_type (scale
), arg
);
9281 arg
= value_cast (value_type (scale
), arg
);
9283 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9284 return value_cast (type
, arg
);
9287 /* Given two array types T1 and T2, return nonzero iff both arrays
9288 contain the same number of elements. */
9291 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9293 LONGEST lo1
, hi1
, lo2
, hi2
;
9295 /* Get the array bounds in order to verify that the size of
9296 the two arrays match. */
9297 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9298 || !get_array_bounds (t2
, &lo2
, &hi2
))
9299 error (_("unable to determine array bounds"));
9301 /* To make things easier for size comparison, normalize a bit
9302 the case of empty arrays by making sure that the difference
9303 between upper bound and lower bound is always -1. */
9309 return (hi1
- lo1
== hi2
- lo2
);
9312 /* Assuming that VAL is an array of integrals, and TYPE represents
9313 an array with the same number of elements, but with wider integral
9314 elements, return an array "casted" to TYPE. In practice, this
9315 means that the returned array is built by casting each element
9316 of the original array into TYPE's (wider) element type. */
9318 static struct value
*
9319 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9321 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9326 /* Verify that both val and type are arrays of scalars, and
9327 that the size of val's elements is smaller than the size
9328 of type's element. */
9329 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9330 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9331 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9332 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9333 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9334 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9336 if (!get_array_bounds (type
, &lo
, &hi
))
9337 error (_("unable to determine array bounds"));
9339 res
= allocate_value (type
);
9341 /* Promote each array element. */
9342 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9344 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9346 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9347 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9353 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9354 return the converted value. */
9356 static struct value
*
9357 coerce_for_assign (struct type
*type
, struct value
*val
)
9359 struct type
*type2
= value_type (val
);
9364 type2
= ada_check_typedef (type2
);
9365 type
= ada_check_typedef (type
);
9367 if (type2
->code () == TYPE_CODE_PTR
9368 && type
->code () == TYPE_CODE_ARRAY
)
9370 val
= ada_value_ind (val
);
9371 type2
= value_type (val
);
9374 if (type2
->code () == TYPE_CODE_ARRAY
9375 && type
->code () == TYPE_CODE_ARRAY
)
9377 if (!ada_same_array_size_p (type
, type2
))
9378 error (_("cannot assign arrays of different length"));
9380 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9381 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9382 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9383 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9385 /* Allow implicit promotion of the array elements to
9387 return ada_promote_array_of_integrals (type
, val
);
9390 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9391 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9392 error (_("Incompatible types in assignment"));
9393 deprecated_set_value_type (val
, type
);
9398 static struct value
*
9399 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9402 struct type
*type1
, *type2
;
9405 arg1
= coerce_ref (arg1
);
9406 arg2
= coerce_ref (arg2
);
9407 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9408 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9410 if (type1
->code () != TYPE_CODE_INT
9411 || type2
->code () != TYPE_CODE_INT
)
9412 return value_binop (arg1
, arg2
, op
);
9421 return value_binop (arg1
, arg2
, op
);
9424 v2
= value_as_long (arg2
);
9426 error (_("second operand of %s must not be zero."), op_string (op
));
9428 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9429 return value_binop (arg1
, arg2
, op
);
9431 v1
= value_as_long (arg1
);
9436 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9437 v
+= v
> 0 ? -1 : 1;
9445 /* Should not reach this point. */
9449 val
= allocate_value (type1
);
9450 store_unsigned_integer (value_contents_raw (val
),
9451 TYPE_LENGTH (value_type (val
)),
9452 type_byte_order (type1
), v
);
9457 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9459 if (ada_is_direct_array_type (value_type (arg1
))
9460 || ada_is_direct_array_type (value_type (arg2
)))
9462 struct type
*arg1_type
, *arg2_type
;
9464 /* Automatically dereference any array reference before
9465 we attempt to perform the comparison. */
9466 arg1
= ada_coerce_ref (arg1
);
9467 arg2
= ada_coerce_ref (arg2
);
9469 arg1
= ada_coerce_to_simple_array (arg1
);
9470 arg2
= ada_coerce_to_simple_array (arg2
);
9472 arg1_type
= ada_check_typedef (value_type (arg1
));
9473 arg2_type
= ada_check_typedef (value_type (arg2
));
9475 if (arg1_type
->code () != TYPE_CODE_ARRAY
9476 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9477 error (_("Attempt to compare array with non-array"));
9478 /* FIXME: The following works only for types whose
9479 representations use all bits (no padding or undefined bits)
9480 and do not have user-defined equality. */
9481 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9482 && memcmp (value_contents (arg1
), value_contents (arg2
),
9483 TYPE_LENGTH (arg1_type
)) == 0);
9485 return value_equal (arg1
, arg2
);
9488 /* Total number of component associations in the aggregate starting at
9489 index PC in EXP. Assumes that index PC is the start of an
9493 num_component_specs (struct expression
*exp
, int pc
)
9497 m
= exp
->elts
[pc
+ 1].longconst
;
9500 for (i
= 0; i
< m
; i
+= 1)
9502 switch (exp
->elts
[pc
].opcode
)
9508 n
+= exp
->elts
[pc
+ 1].longconst
;
9511 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9516 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9517 component of LHS (a simple array or a record), updating *POS past
9518 the expression, assuming that LHS is contained in CONTAINER. Does
9519 not modify the inferior's memory, nor does it modify LHS (unless
9520 LHS == CONTAINER). */
9523 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9524 struct expression
*exp
, int *pos
)
9526 struct value
*mark
= value_mark ();
9528 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9530 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9532 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9533 struct value
*index_val
= value_from_longest (index_type
, index
);
9535 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9539 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9540 elt
= ada_to_fixed_value (elt
);
9543 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9544 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9546 value_assign_to_component (container
, elt
,
9547 ada_evaluate_subexp (NULL
, exp
, pos
,
9550 value_free_to_mark (mark
);
9553 /* Assuming that LHS represents an lvalue having a record or array
9554 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9555 of that aggregate's value to LHS, advancing *POS past the
9556 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9557 lvalue containing LHS (possibly LHS itself). Does not modify
9558 the inferior's memory, nor does it modify the contents of
9559 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9561 static struct value
*
9562 assign_aggregate (struct value
*container
,
9563 struct value
*lhs
, struct expression
*exp
,
9564 int *pos
, enum noside noside
)
9566 struct type
*lhs_type
;
9567 int n
= exp
->elts
[*pos
+1].longconst
;
9568 LONGEST low_index
, high_index
;
9571 int max_indices
, num_indices
;
9575 if (noside
!= EVAL_NORMAL
)
9577 for (i
= 0; i
< n
; i
+= 1)
9578 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9582 container
= ada_coerce_ref (container
);
9583 if (ada_is_direct_array_type (value_type (container
)))
9584 container
= ada_coerce_to_simple_array (container
);
9585 lhs
= ada_coerce_ref (lhs
);
9586 if (!deprecated_value_modifiable (lhs
))
9587 error (_("Left operand of assignment is not a modifiable lvalue."));
9589 lhs_type
= check_typedef (value_type (lhs
));
9590 if (ada_is_direct_array_type (lhs_type
))
9592 lhs
= ada_coerce_to_simple_array (lhs
);
9593 lhs_type
= check_typedef (value_type (lhs
));
9594 low_index
= lhs_type
->bounds ()->low
.const_val ();
9595 high_index
= lhs_type
->bounds ()->high
.const_val ();
9597 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9600 high_index
= num_visible_fields (lhs_type
) - 1;
9603 error (_("Left-hand side must be array or record."));
9605 num_specs
= num_component_specs (exp
, *pos
- 3);
9606 max_indices
= 4 * num_specs
+ 4;
9607 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9608 indices
[0] = indices
[1] = low_index
- 1;
9609 indices
[2] = indices
[3] = high_index
+ 1;
9612 for (i
= 0; i
< n
; i
+= 1)
9614 switch (exp
->elts
[*pos
].opcode
)
9617 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9618 &num_indices
, max_indices
,
9619 low_index
, high_index
);
9622 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9623 &num_indices
, max_indices
,
9624 low_index
, high_index
);
9628 error (_("Misplaced 'others' clause"));
9629 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9630 num_indices
, low_index
, high_index
);
9633 error (_("Internal error: bad aggregate clause"));
9640 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9641 construct at *POS, updating *POS past the construct, given that
9642 the positions are relative to lower bound LOW, where HIGH is the
9643 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9644 updating *NUM_INDICES as needed. CONTAINER is as for
9645 assign_aggregate. */
9647 aggregate_assign_positional (struct value
*container
,
9648 struct value
*lhs
, struct expression
*exp
,
9649 int *pos
, LONGEST
*indices
, int *num_indices
,
9650 int max_indices
, LONGEST low
, LONGEST high
)
9652 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9654 if (ind
- 1 == high
)
9655 warning (_("Extra components in aggregate ignored."));
9658 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9660 assign_component (container
, lhs
, ind
, exp
, pos
);
9663 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9666 /* Assign into the components of LHS indexed by the OP_CHOICES
9667 construct at *POS, updating *POS past the construct, given that
9668 the allowable indices are LOW..HIGH. Record the indices assigned
9669 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9670 needed. CONTAINER is as for assign_aggregate. */
9672 aggregate_assign_from_choices (struct value
*container
,
9673 struct value
*lhs
, struct expression
*exp
,
9674 int *pos
, LONGEST
*indices
, int *num_indices
,
9675 int max_indices
, LONGEST low
, LONGEST high
)
9678 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9679 int choice_pos
, expr_pc
;
9680 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9682 choice_pos
= *pos
+= 3;
9684 for (j
= 0; j
< n_choices
; j
+= 1)
9685 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9687 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9689 for (j
= 0; j
< n_choices
; j
+= 1)
9691 LONGEST lower
, upper
;
9692 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9694 if (op
== OP_DISCRETE_RANGE
)
9697 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9699 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9704 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9716 name
= &exp
->elts
[choice_pos
+ 2].string
;
9719 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9722 error (_("Invalid record component association."));
9724 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9726 if (! find_struct_field (name
, value_type (lhs
), 0,
9727 NULL
, NULL
, NULL
, NULL
, &ind
))
9728 error (_("Unknown component name: %s."), name
);
9729 lower
= upper
= ind
;
9732 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9733 error (_("Index in component association out of bounds."));
9735 add_component_interval (lower
, upper
, indices
, num_indices
,
9737 while (lower
<= upper
)
9742 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9748 /* Assign the value of the expression in the OP_OTHERS construct in
9749 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9750 have not been previously assigned. The index intervals already assigned
9751 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9752 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9754 aggregate_assign_others (struct value
*container
,
9755 struct value
*lhs
, struct expression
*exp
,
9756 int *pos
, LONGEST
*indices
, int num_indices
,
9757 LONGEST low
, LONGEST high
)
9760 int expr_pc
= *pos
+ 1;
9762 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9766 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9771 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9774 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9777 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9778 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9779 modifying *SIZE as needed. It is an error if *SIZE exceeds
9780 MAX_SIZE. The resulting intervals do not overlap. */
9782 add_component_interval (LONGEST low
, LONGEST high
,
9783 LONGEST
* indices
, int *size
, int max_size
)
9787 for (i
= 0; i
< *size
; i
+= 2) {
9788 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9792 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9793 if (high
< indices
[kh
])
9795 if (low
< indices
[i
])
9797 indices
[i
+ 1] = indices
[kh
- 1];
9798 if (high
> indices
[i
+ 1])
9799 indices
[i
+ 1] = high
;
9800 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9801 *size
-= kh
- i
- 2;
9804 else if (high
< indices
[i
])
9808 if (*size
== max_size
)
9809 error (_("Internal error: miscounted aggregate components."));
9811 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9812 indices
[j
] = indices
[j
- 2];
9814 indices
[i
+ 1] = high
;
9817 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9820 static struct value
*
9821 ada_value_cast (struct type
*type
, struct value
*arg2
)
9823 if (type
== ada_check_typedef (value_type (arg2
)))
9826 if (ada_is_gnat_encoded_fixed_point_type (type
))
9827 return cast_to_gnat_encoded_fixed_point_type (type
, arg2
);
9829 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9830 return cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
9832 return value_cast (type
, arg2
);
9835 /* Evaluating Ada expressions, and printing their result.
9836 ------------------------------------------------------
9841 We usually evaluate an Ada expression in order to print its value.
9842 We also evaluate an expression in order to print its type, which
9843 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9844 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9845 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9846 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9849 Evaluating expressions is a little more complicated for Ada entities
9850 than it is for entities in languages such as C. The main reason for
9851 this is that Ada provides types whose definition might be dynamic.
9852 One example of such types is variant records. Or another example
9853 would be an array whose bounds can only be known at run time.
9855 The following description is a general guide as to what should be
9856 done (and what should NOT be done) in order to evaluate an expression
9857 involving such types, and when. This does not cover how the semantic
9858 information is encoded by GNAT as this is covered separatly. For the
9859 document used as the reference for the GNAT encoding, see exp_dbug.ads
9860 in the GNAT sources.
9862 Ideally, we should embed each part of this description next to its
9863 associated code. Unfortunately, the amount of code is so vast right
9864 now that it's hard to see whether the code handling a particular
9865 situation might be duplicated or not. One day, when the code is
9866 cleaned up, this guide might become redundant with the comments
9867 inserted in the code, and we might want to remove it.
9869 2. ``Fixing'' an Entity, the Simple Case:
9870 -----------------------------------------
9872 When evaluating Ada expressions, the tricky issue is that they may
9873 reference entities whose type contents and size are not statically
9874 known. Consider for instance a variant record:
9876 type Rec (Empty : Boolean := True) is record
9879 when False => Value : Integer;
9882 Yes : Rec := (Empty => False, Value => 1);
9883 No : Rec := (empty => True);
9885 The size and contents of that record depends on the value of the
9886 descriminant (Rec.Empty). At this point, neither the debugging
9887 information nor the associated type structure in GDB are able to
9888 express such dynamic types. So what the debugger does is to create
9889 "fixed" versions of the type that applies to the specific object.
9890 We also informally refer to this operation as "fixing" an object,
9891 which means creating its associated fixed type.
9893 Example: when printing the value of variable "Yes" above, its fixed
9894 type would look like this:
9901 On the other hand, if we printed the value of "No", its fixed type
9908 Things become a little more complicated when trying to fix an entity
9909 with a dynamic type that directly contains another dynamic type,
9910 such as an array of variant records, for instance. There are
9911 two possible cases: Arrays, and records.
9913 3. ``Fixing'' Arrays:
9914 ---------------------
9916 The type structure in GDB describes an array in terms of its bounds,
9917 and the type of its elements. By design, all elements in the array
9918 have the same type and we cannot represent an array of variant elements
9919 using the current type structure in GDB. When fixing an array,
9920 we cannot fix the array element, as we would potentially need one
9921 fixed type per element of the array. As a result, the best we can do
9922 when fixing an array is to produce an array whose bounds and size
9923 are correct (allowing us to read it from memory), but without having
9924 touched its element type. Fixing each element will be done later,
9925 when (if) necessary.
9927 Arrays are a little simpler to handle than records, because the same
9928 amount of memory is allocated for each element of the array, even if
9929 the amount of space actually used by each element differs from element
9930 to element. Consider for instance the following array of type Rec:
9932 type Rec_Array is array (1 .. 2) of Rec;
9934 The actual amount of memory occupied by each element might be different
9935 from element to element, depending on the value of their discriminant.
9936 But the amount of space reserved for each element in the array remains
9937 fixed regardless. So we simply need to compute that size using
9938 the debugging information available, from which we can then determine
9939 the array size (we multiply the number of elements of the array by
9940 the size of each element).
9942 The simplest case is when we have an array of a constrained element
9943 type. For instance, consider the following type declarations:
9945 type Bounded_String (Max_Size : Integer) is
9947 Buffer : String (1 .. Max_Size);
9949 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9951 In this case, the compiler describes the array as an array of
9952 variable-size elements (identified by its XVS suffix) for which
9953 the size can be read in the parallel XVZ variable.
9955 In the case of an array of an unconstrained element type, the compiler
9956 wraps the array element inside a private PAD type. This type should not
9957 be shown to the user, and must be "unwrap"'ed before printing. Note
9958 that we also use the adjective "aligner" in our code to designate
9959 these wrapper types.
9961 In some cases, the size allocated for each element is statically
9962 known. In that case, the PAD type already has the correct size,
9963 and the array element should remain unfixed.
9965 But there are cases when this size is not statically known.
9966 For instance, assuming that "Five" is an integer variable:
9968 type Dynamic is array (1 .. Five) of Integer;
9969 type Wrapper (Has_Length : Boolean := False) is record
9972 when True => Length : Integer;
9976 type Wrapper_Array is array (1 .. 2) of Wrapper;
9978 Hello : Wrapper_Array := (others => (Has_Length => True,
9979 Data => (others => 17),
9983 The debugging info would describe variable Hello as being an
9984 array of a PAD type. The size of that PAD type is not statically
9985 known, but can be determined using a parallel XVZ variable.
9986 In that case, a copy of the PAD type with the correct size should
9987 be used for the fixed array.
9989 3. ``Fixing'' record type objects:
9990 ----------------------------------
9992 Things are slightly different from arrays in the case of dynamic
9993 record types. In this case, in order to compute the associated
9994 fixed type, we need to determine the size and offset of each of
9995 its components. This, in turn, requires us to compute the fixed
9996 type of each of these components.
9998 Consider for instance the example:
10000 type Bounded_String (Max_Size : Natural) is record
10001 Str : String (1 .. Max_Size);
10004 My_String : Bounded_String (Max_Size => 10);
10006 In that case, the position of field "Length" depends on the size
10007 of field Str, which itself depends on the value of the Max_Size
10008 discriminant. In order to fix the type of variable My_String,
10009 we need to fix the type of field Str. Therefore, fixing a variant
10010 record requires us to fix each of its components.
10012 However, if a component does not have a dynamic size, the component
10013 should not be fixed. In particular, fields that use a PAD type
10014 should not fixed. Here is an example where this might happen
10015 (assuming type Rec above):
10017 type Container (Big : Boolean) is record
10021 when True => Another : Integer;
10022 when False => null;
10025 My_Container : Container := (Big => False,
10026 First => (Empty => True),
10029 In that example, the compiler creates a PAD type for component First,
10030 whose size is constant, and then positions the component After just
10031 right after it. The offset of component After is therefore constant
10034 The debugger computes the position of each field based on an algorithm
10035 that uses, among other things, the actual position and size of the field
10036 preceding it. Let's now imagine that the user is trying to print
10037 the value of My_Container. If the type fixing was recursive, we would
10038 end up computing the offset of field After based on the size of the
10039 fixed version of field First. And since in our example First has
10040 only one actual field, the size of the fixed type is actually smaller
10041 than the amount of space allocated to that field, and thus we would
10042 compute the wrong offset of field After.
10044 To make things more complicated, we need to watch out for dynamic
10045 components of variant records (identified by the ___XVL suffix in
10046 the component name). Even if the target type is a PAD type, the size
10047 of that type might not be statically known. So the PAD type needs
10048 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10049 we might end up with the wrong size for our component. This can be
10050 observed with the following type declarations:
10052 type Octal is new Integer range 0 .. 7;
10053 type Octal_Array is array (Positive range <>) of Octal;
10054 pragma Pack (Octal_Array);
10056 type Octal_Buffer (Size : Positive) is record
10057 Buffer : Octal_Array (1 .. Size);
10061 In that case, Buffer is a PAD type whose size is unset and needs
10062 to be computed by fixing the unwrapped type.
10064 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10065 ----------------------------------------------------------
10067 Lastly, when should the sub-elements of an entity that remained unfixed
10068 thus far, be actually fixed?
10070 The answer is: Only when referencing that element. For instance
10071 when selecting one component of a record, this specific component
10072 should be fixed at that point in time. Or when printing the value
10073 of a record, each component should be fixed before its value gets
10074 printed. Similarly for arrays, the element of the array should be
10075 fixed when printing each element of the array, or when extracting
10076 one element out of that array. On the other hand, fixing should
10077 not be performed on the elements when taking a slice of an array!
10079 Note that one of the side effects of miscomputing the offset and
10080 size of each field is that we end up also miscomputing the size
10081 of the containing type. This can have adverse results when computing
10082 the value of an entity. GDB fetches the value of an entity based
10083 on the size of its type, and thus a wrong size causes GDB to fetch
10084 the wrong amount of memory. In the case where the computed size is
10085 too small, GDB fetches too little data to print the value of our
10086 entity. Results in this case are unpredictable, as we usually read
10087 past the buffer containing the data =:-o. */
10089 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10090 for that subexpression cast to TO_TYPE. Advance *POS over the
10094 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10095 enum noside noside
, struct type
*to_type
)
10099 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10100 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10105 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10107 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10108 return value_zero (to_type
, not_lval
);
10110 val
= evaluate_var_msym_value (noside
,
10111 exp
->elts
[pc
+ 1].objfile
,
10112 exp
->elts
[pc
+ 2].msymbol
);
10115 val
= evaluate_var_value (noside
,
10116 exp
->elts
[pc
+ 1].block
,
10117 exp
->elts
[pc
+ 2].symbol
);
10119 if (noside
== EVAL_SKIP
)
10120 return eval_skip_value (exp
);
10122 val
= ada_value_cast (to_type
, val
);
10124 /* Follow the Ada language semantics that do not allow taking
10125 an address of the result of a cast (view conversion in Ada). */
10126 if (VALUE_LVAL (val
) == lval_memory
)
10128 if (value_lazy (val
))
10129 value_fetch_lazy (val
);
10130 VALUE_LVAL (val
) = not_lval
;
10135 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10136 if (noside
== EVAL_SKIP
)
10137 return eval_skip_value (exp
);
10138 return ada_value_cast (to_type
, val
);
10141 /* Implement the evaluate_exp routine in the exp_descriptor structure
10142 for the Ada language. */
10144 static struct value
*
10145 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10146 int *pos
, enum noside noside
)
10148 enum exp_opcode op
;
10152 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10155 struct value
**argvec
;
10159 op
= exp
->elts
[pc
].opcode
;
10165 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10167 if (noside
== EVAL_NORMAL
)
10168 arg1
= unwrap_value (arg1
);
10170 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10171 then we need to perform the conversion manually, because
10172 evaluate_subexp_standard doesn't do it. This conversion is
10173 necessary in Ada because the different kinds of float/fixed
10174 types in Ada have different representations.
10176 Similarly, we need to perform the conversion from OP_LONG
10178 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10179 arg1
= ada_value_cast (expect_type
, arg1
);
10185 struct value
*result
;
10188 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10189 /* The result type will have code OP_STRING, bashed there from
10190 OP_ARRAY. Bash it back. */
10191 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10192 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10198 type
= exp
->elts
[pc
+ 1].type
;
10199 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10203 type
= exp
->elts
[pc
+ 1].type
;
10204 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10207 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10208 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10210 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10211 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10213 return ada_value_assign (arg1
, arg1
);
10215 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10216 except if the lhs of our assignment is a convenience variable.
10217 In the case of assigning to a convenience variable, the lhs
10218 should be exactly the result of the evaluation of the rhs. */
10219 type
= value_type (arg1
);
10220 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10222 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10223 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10225 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10229 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10230 arg2
= cast_to_gnat_encoded_fixed_point_type (value_type (arg1
), arg2
);
10231 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10233 (_("Fixed-point values must be assigned to fixed-point variables"));
10235 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10236 return ada_value_assign (arg1
, arg2
);
10239 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10240 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10241 if (noside
== EVAL_SKIP
)
10243 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10244 return (value_from_longest
10245 (value_type (arg1
),
10246 value_as_long (arg1
) + value_as_long (arg2
)));
10247 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10248 return (value_from_longest
10249 (value_type (arg2
),
10250 value_as_long (arg1
) + value_as_long (arg2
)));
10251 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10252 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10253 && value_type (arg1
) != value_type (arg2
))
10254 error (_("Operands of fixed-point addition must have the same type"));
10255 /* Do the addition, and cast the result to the type of the first
10256 argument. We cannot cast the result to a reference type, so if
10257 ARG1 is a reference type, find its underlying type. */
10258 type
= value_type (arg1
);
10259 while (type
->code () == TYPE_CODE_REF
)
10260 type
= TYPE_TARGET_TYPE (type
);
10261 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10262 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10265 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10266 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10267 if (noside
== EVAL_SKIP
)
10269 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10270 return (value_from_longest
10271 (value_type (arg1
),
10272 value_as_long (arg1
) - value_as_long (arg2
)));
10273 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10274 return (value_from_longest
10275 (value_type (arg2
),
10276 value_as_long (arg1
) - value_as_long (arg2
)));
10277 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10278 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10279 && value_type (arg1
) != value_type (arg2
))
10280 error (_("Operands of fixed-point subtraction "
10281 "must have the same type"));
10282 /* Do the substraction, and cast the result to the type of the first
10283 argument. We cannot cast the result to a reference type, so if
10284 ARG1 is a reference type, find its underlying type. */
10285 type
= value_type (arg1
);
10286 while (type
->code () == TYPE_CODE_REF
)
10287 type
= TYPE_TARGET_TYPE (type
);
10288 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10289 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10295 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10296 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10297 if (noside
== EVAL_SKIP
)
10299 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10301 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10302 return value_zero (value_type (arg1
), not_lval
);
10306 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10307 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10308 arg1
= cast_from_gnat_encoded_fixed_point_type (type
, arg1
);
10309 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10310 arg2
= cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
10311 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10312 return ada_value_binop (arg1
, arg2
, op
);
10316 case BINOP_NOTEQUAL
:
10317 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10318 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10319 if (noside
== EVAL_SKIP
)
10321 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10325 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10326 tem
= ada_value_equal (arg1
, arg2
);
10328 if (op
== BINOP_NOTEQUAL
)
10330 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10331 return value_from_longest (type
, (LONGEST
) tem
);
10334 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10335 if (noside
== EVAL_SKIP
)
10337 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10338 return value_cast (value_type (arg1
), value_neg (arg1
));
10341 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10342 return value_neg (arg1
);
10345 case BINOP_LOGICAL_AND
:
10346 case BINOP_LOGICAL_OR
:
10347 case UNOP_LOGICAL_NOT
:
10352 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10353 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10354 return value_cast (type
, val
);
10357 case BINOP_BITWISE_AND
:
10358 case BINOP_BITWISE_IOR
:
10359 case BINOP_BITWISE_XOR
:
10363 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10365 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10367 return value_cast (value_type (arg1
), val
);
10373 if (noside
== EVAL_SKIP
)
10379 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10380 /* Only encountered when an unresolved symbol occurs in a
10381 context other than a function call, in which case, it is
10383 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10384 exp
->elts
[pc
+ 2].symbol
->print_name ());
10386 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10388 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10389 /* Check to see if this is a tagged type. We also need to handle
10390 the case where the type is a reference to a tagged type, but
10391 we have to be careful to exclude pointers to tagged types.
10392 The latter should be shown as usual (as a pointer), whereas
10393 a reference should mostly be transparent to the user. */
10394 if (ada_is_tagged_type (type
, 0)
10395 || (type
->code () == TYPE_CODE_REF
10396 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10398 /* Tagged types are a little special in the fact that the real
10399 type is dynamic and can only be determined by inspecting the
10400 object's tag. This means that we need to get the object's
10401 value first (EVAL_NORMAL) and then extract the actual object
10404 Note that we cannot skip the final step where we extract
10405 the object type from its tag, because the EVAL_NORMAL phase
10406 results in dynamic components being resolved into fixed ones.
10407 This can cause problems when trying to print the type
10408 description of tagged types whose parent has a dynamic size:
10409 We use the type name of the "_parent" component in order
10410 to print the name of the ancestor type in the type description.
10411 If that component had a dynamic size, the resolution into
10412 a fixed type would result in the loss of that type name,
10413 thus preventing us from printing the name of the ancestor
10414 type in the type description. */
10415 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10417 if (type
->code () != TYPE_CODE_REF
)
10419 struct type
*actual_type
;
10421 actual_type
= type_from_tag (ada_value_tag (arg1
));
10422 if (actual_type
== NULL
)
10423 /* If, for some reason, we were unable to determine
10424 the actual type from the tag, then use the static
10425 approximation that we just computed as a fallback.
10426 This can happen if the debugging information is
10427 incomplete, for instance. */
10428 actual_type
= type
;
10429 return value_zero (actual_type
, not_lval
);
10433 /* In the case of a ref, ada_coerce_ref takes care
10434 of determining the actual type. But the evaluation
10435 should return a ref as it should be valid to ask
10436 for its address; so rebuild a ref after coerce. */
10437 arg1
= ada_coerce_ref (arg1
);
10438 return value_ref (arg1
, TYPE_CODE_REF
);
10442 /* Records and unions for which GNAT encodings have been
10443 generated need to be statically fixed as well.
10444 Otherwise, non-static fixing produces a type where
10445 all dynamic properties are removed, which prevents "ptype"
10446 from being able to completely describe the type.
10447 For instance, a case statement in a variant record would be
10448 replaced by the relevant components based on the actual
10449 value of the discriminants. */
10450 if ((type
->code () == TYPE_CODE_STRUCT
10451 && dynamic_template_type (type
) != NULL
)
10452 || (type
->code () == TYPE_CODE_UNION
10453 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10456 return value_zero (to_static_fixed_type (type
), not_lval
);
10460 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10461 return ada_to_fixed_value (arg1
);
10466 /* Allocate arg vector, including space for the function to be
10467 called in argvec[0] and a terminating NULL. */
10468 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10469 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10471 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10472 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10473 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10474 exp
->elts
[pc
+ 5].symbol
->print_name ());
10477 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10478 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10481 if (noside
== EVAL_SKIP
)
10485 if (ada_is_constrained_packed_array_type
10486 (desc_base_type (value_type (argvec
[0]))))
10487 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10488 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10489 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10490 /* This is a packed array that has already been fixed, and
10491 therefore already coerced to a simple array. Nothing further
10494 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10496 /* Make sure we dereference references so that all the code below
10497 feels like it's really handling the referenced value. Wrapping
10498 types (for alignment) may be there, so make sure we strip them as
10500 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10502 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10503 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10504 argvec
[0] = value_addr (argvec
[0]);
10506 type
= ada_check_typedef (value_type (argvec
[0]));
10508 /* Ada allows us to implicitly dereference arrays when subscripting
10509 them. So, if this is an array typedef (encoding use for array
10510 access types encoded as fat pointers), strip it now. */
10511 if (type
->code () == TYPE_CODE_TYPEDEF
)
10512 type
= ada_typedef_target_type (type
);
10514 if (type
->code () == TYPE_CODE_PTR
)
10516 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10518 case TYPE_CODE_FUNC
:
10519 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10521 case TYPE_CODE_ARRAY
:
10523 case TYPE_CODE_STRUCT
:
10524 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10525 argvec
[0] = ada_value_ind (argvec
[0]);
10526 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10529 error (_("cannot subscript or call something of type `%s'"),
10530 ada_type_name (value_type (argvec
[0])));
10535 switch (type
->code ())
10537 case TYPE_CODE_FUNC
:
10538 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10540 if (TYPE_TARGET_TYPE (type
) == NULL
)
10541 error_call_unknown_return_type (NULL
);
10542 return allocate_value (TYPE_TARGET_TYPE (type
));
10544 return call_function_by_hand (argvec
[0], NULL
,
10545 gdb::make_array_view (argvec
+ 1,
10547 case TYPE_CODE_INTERNAL_FUNCTION
:
10548 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10549 /* We don't know anything about what the internal
10550 function might return, but we have to return
10552 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10555 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10556 argvec
[0], nargs
, argvec
+ 1);
10558 case TYPE_CODE_STRUCT
:
10562 arity
= ada_array_arity (type
);
10563 type
= ada_array_element_type (type
, nargs
);
10565 error (_("cannot subscript or call a record"));
10566 if (arity
!= nargs
)
10567 error (_("wrong number of subscripts; expecting %d"), arity
);
10568 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10569 return value_zero (ada_aligned_type (type
), lval_memory
);
10571 unwrap_value (ada_value_subscript
10572 (argvec
[0], nargs
, argvec
+ 1));
10574 case TYPE_CODE_ARRAY
:
10575 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10577 type
= ada_array_element_type (type
, nargs
);
10579 error (_("element type of array unknown"));
10581 return value_zero (ada_aligned_type (type
), lval_memory
);
10584 unwrap_value (ada_value_subscript
10585 (ada_coerce_to_simple_array (argvec
[0]),
10586 nargs
, argvec
+ 1));
10587 case TYPE_CODE_PTR
: /* Pointer to array */
10588 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10590 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10591 type
= ada_array_element_type (type
, nargs
);
10593 error (_("element type of array unknown"));
10595 return value_zero (ada_aligned_type (type
), lval_memory
);
10598 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10599 nargs
, argvec
+ 1));
10602 error (_("Attempt to index or call something other than an "
10603 "array or function"));
10608 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10609 struct value
*low_bound_val
10610 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10611 struct value
*high_bound_val
10612 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10614 LONGEST high_bound
;
10616 low_bound_val
= coerce_ref (low_bound_val
);
10617 high_bound_val
= coerce_ref (high_bound_val
);
10618 low_bound
= value_as_long (low_bound_val
);
10619 high_bound
= value_as_long (high_bound_val
);
10621 if (noside
== EVAL_SKIP
)
10624 /* If this is a reference to an aligner type, then remove all
10626 if (value_type (array
)->code () == TYPE_CODE_REF
10627 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10628 TYPE_TARGET_TYPE (value_type (array
)) =
10629 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10631 if (ada_is_any_packed_array_type (value_type (array
)))
10632 error (_("cannot slice a packed array"));
10634 /* If this is a reference to an array or an array lvalue,
10635 convert to a pointer. */
10636 if (value_type (array
)->code () == TYPE_CODE_REF
10637 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10638 && VALUE_LVAL (array
) == lval_memory
))
10639 array
= value_addr (array
);
10641 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10642 && ada_is_array_descriptor_type (ada_check_typedef
10643 (value_type (array
))))
10644 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10647 array
= ada_coerce_to_simple_array_ptr (array
);
10649 /* If we have more than one level of pointer indirection,
10650 dereference the value until we get only one level. */
10651 while (value_type (array
)->code () == TYPE_CODE_PTR
10652 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10654 array
= value_ind (array
);
10656 /* Make sure we really do have an array type before going further,
10657 to avoid a SEGV when trying to get the index type or the target
10658 type later down the road if the debug info generated by
10659 the compiler is incorrect or incomplete. */
10660 if (!ada_is_simple_array_type (value_type (array
)))
10661 error (_("cannot take slice of non-array"));
10663 if (ada_check_typedef (value_type (array
))->code ()
10666 struct type
*type0
= ada_check_typedef (value_type (array
));
10668 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10669 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10672 struct type
*arr_type0
=
10673 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10675 return ada_value_slice_from_ptr (array
, arr_type0
,
10676 longest_to_int (low_bound
),
10677 longest_to_int (high_bound
));
10680 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10682 else if (high_bound
< low_bound
)
10683 return empty_array (value_type (array
), low_bound
, high_bound
);
10685 return ada_value_slice (array
, longest_to_int (low_bound
),
10686 longest_to_int (high_bound
));
10689 case UNOP_IN_RANGE
:
10691 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10692 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10694 if (noside
== EVAL_SKIP
)
10697 switch (type
->code ())
10700 lim_warning (_("Membership test incompletely implemented; "
10701 "always returns true"));
10702 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10703 return value_from_longest (type
, (LONGEST
) 1);
10705 case TYPE_CODE_RANGE
:
10706 arg2
= value_from_longest (type
,
10707 type
->bounds ()->low
.const_val ());
10708 arg3
= value_from_longest (type
,
10709 type
->bounds ()->high
.const_val ());
10710 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10711 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10712 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10714 value_from_longest (type
,
10715 (value_less (arg1
, arg3
)
10716 || value_equal (arg1
, arg3
))
10717 && (value_less (arg2
, arg1
)
10718 || value_equal (arg2
, arg1
)));
10721 case BINOP_IN_BOUNDS
:
10723 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10724 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10726 if (noside
== EVAL_SKIP
)
10729 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10731 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10732 return value_zero (type
, not_lval
);
10735 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10737 type
= ada_index_type (value_type (arg2
), tem
, "range");
10739 type
= value_type (arg1
);
10741 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10742 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10744 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10745 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10746 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10748 value_from_longest (type
,
10749 (value_less (arg1
, arg3
)
10750 || value_equal (arg1
, arg3
))
10751 && (value_less (arg2
, arg1
)
10752 || value_equal (arg2
, arg1
)));
10754 case TERNOP_IN_RANGE
:
10755 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10756 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10757 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10759 if (noside
== EVAL_SKIP
)
10762 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10763 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10764 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10766 value_from_longest (type
,
10767 (value_less (arg1
, arg3
)
10768 || value_equal (arg1
, arg3
))
10769 && (value_less (arg2
, arg1
)
10770 || value_equal (arg2
, arg1
)));
10774 case OP_ATR_LENGTH
:
10776 struct type
*type_arg
;
10778 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10780 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10782 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10786 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10790 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10791 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10792 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10795 if (noside
== EVAL_SKIP
)
10797 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10799 if (type_arg
== NULL
)
10800 type_arg
= value_type (arg1
);
10802 if (ada_is_constrained_packed_array_type (type_arg
))
10803 type_arg
= decode_constrained_packed_array_type (type_arg
);
10805 if (!discrete_type_p (type_arg
))
10809 default: /* Should never happen. */
10810 error (_("unexpected attribute encountered"));
10813 type_arg
= ada_index_type (type_arg
, tem
,
10814 ada_attribute_name (op
));
10816 case OP_ATR_LENGTH
:
10817 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10822 return value_zero (type_arg
, not_lval
);
10824 else if (type_arg
== NULL
)
10826 arg1
= ada_coerce_ref (arg1
);
10828 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10829 arg1
= ada_coerce_to_simple_array (arg1
);
10831 if (op
== OP_ATR_LENGTH
)
10832 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10835 type
= ada_index_type (value_type (arg1
), tem
,
10836 ada_attribute_name (op
));
10838 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10843 default: /* Should never happen. */
10844 error (_("unexpected attribute encountered"));
10846 return value_from_longest
10847 (type
, ada_array_bound (arg1
, tem
, 0));
10849 return value_from_longest
10850 (type
, ada_array_bound (arg1
, tem
, 1));
10851 case OP_ATR_LENGTH
:
10852 return value_from_longest
10853 (type
, ada_array_length (arg1
, tem
));
10856 else if (discrete_type_p (type_arg
))
10858 struct type
*range_type
;
10859 const char *name
= ada_type_name (type_arg
);
10862 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10863 range_type
= to_fixed_range_type (type_arg
, NULL
);
10864 if (range_type
== NULL
)
10865 range_type
= type_arg
;
10869 error (_("unexpected attribute encountered"));
10871 return value_from_longest
10872 (range_type
, ada_discrete_type_low_bound (range_type
));
10874 return value_from_longest
10875 (range_type
, ada_discrete_type_high_bound (range_type
));
10876 case OP_ATR_LENGTH
:
10877 error (_("the 'length attribute applies only to array types"));
10880 else if (type_arg
->code () == TYPE_CODE_FLT
)
10881 error (_("unimplemented type attribute"));
10886 if (ada_is_constrained_packed_array_type (type_arg
))
10887 type_arg
= decode_constrained_packed_array_type (type_arg
);
10889 if (op
== OP_ATR_LENGTH
)
10890 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10893 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10895 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10901 error (_("unexpected attribute encountered"));
10903 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10904 return value_from_longest (type
, low
);
10906 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10907 return value_from_longest (type
, high
);
10908 case OP_ATR_LENGTH
:
10909 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10910 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10911 return value_from_longest (type
, high
- low
+ 1);
10917 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10918 if (noside
== EVAL_SKIP
)
10921 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10922 return value_zero (ada_tag_type (arg1
), not_lval
);
10924 return ada_value_tag (arg1
);
10928 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10929 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10930 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10931 if (noside
== EVAL_SKIP
)
10933 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10934 return value_zero (value_type (arg1
), not_lval
);
10937 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10938 return value_binop (arg1
, arg2
,
10939 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10942 case OP_ATR_MODULUS
:
10944 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10946 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10947 if (noside
== EVAL_SKIP
)
10950 if (!ada_is_modular_type (type_arg
))
10951 error (_("'modulus must be applied to modular type"));
10953 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10954 ada_modulus (type_arg
));
10959 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10960 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10961 if (noside
== EVAL_SKIP
)
10963 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10964 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10965 return value_zero (type
, not_lval
);
10967 return value_pos_atr (type
, arg1
);
10970 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10971 type
= value_type (arg1
);
10973 /* If the argument is a reference, then dereference its type, since
10974 the user is really asking for the size of the actual object,
10975 not the size of the pointer. */
10976 if (type
->code () == TYPE_CODE_REF
)
10977 type
= TYPE_TARGET_TYPE (type
);
10979 if (noside
== EVAL_SKIP
)
10981 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10982 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10984 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10985 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10988 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10989 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10990 type
= exp
->elts
[pc
+ 2].type
;
10991 if (noside
== EVAL_SKIP
)
10993 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10994 return value_zero (type
, not_lval
);
10996 return value_val_atr (type
, arg1
);
10999 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11000 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11001 if (noside
== EVAL_SKIP
)
11003 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11004 return value_zero (value_type (arg1
), not_lval
);
11007 /* For integer exponentiation operations,
11008 only promote the first argument. */
11009 if (is_integral_type (value_type (arg2
)))
11010 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11012 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11014 return value_binop (arg1
, arg2
, op
);
11018 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11019 if (noside
== EVAL_SKIP
)
11025 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11026 if (noside
== EVAL_SKIP
)
11028 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11029 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11030 return value_neg (arg1
);
11035 preeval_pos
= *pos
;
11036 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11037 if (noside
== EVAL_SKIP
)
11039 type
= ada_check_typedef (value_type (arg1
));
11040 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11042 if (ada_is_array_descriptor_type (type
))
11043 /* GDB allows dereferencing GNAT array descriptors. */
11045 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11047 if (arrType
== NULL
)
11048 error (_("Attempt to dereference null array pointer."));
11049 return value_at_lazy (arrType
, 0);
11051 else if (type
->code () == TYPE_CODE_PTR
11052 || type
->code () == TYPE_CODE_REF
11053 /* In C you can dereference an array to get the 1st elt. */
11054 || type
->code () == TYPE_CODE_ARRAY
)
11056 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11057 only be determined by inspecting the object's tag.
11058 This means that we need to evaluate completely the
11059 expression in order to get its type. */
11061 if ((type
->code () == TYPE_CODE_REF
11062 || type
->code () == TYPE_CODE_PTR
)
11063 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11066 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11067 type
= value_type (ada_value_ind (arg1
));
11071 type
= to_static_fixed_type
11073 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11075 ada_ensure_varsize_limit (type
);
11076 return value_zero (type
, lval_memory
);
11078 else if (type
->code () == TYPE_CODE_INT
)
11080 /* GDB allows dereferencing an int. */
11081 if (expect_type
== NULL
)
11082 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11087 to_static_fixed_type (ada_aligned_type (expect_type
));
11088 return value_zero (expect_type
, lval_memory
);
11092 error (_("Attempt to take contents of a non-pointer value."));
11094 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11095 type
= ada_check_typedef (value_type (arg1
));
11097 if (type
->code () == TYPE_CODE_INT
)
11098 /* GDB allows dereferencing an int. If we were given
11099 the expect_type, then use that as the target type.
11100 Otherwise, assume that the target type is an int. */
11102 if (expect_type
!= NULL
)
11103 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11106 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11107 (CORE_ADDR
) value_as_address (arg1
));
11110 if (ada_is_array_descriptor_type (type
))
11111 /* GDB allows dereferencing GNAT array descriptors. */
11112 return ada_coerce_to_simple_array (arg1
);
11114 return ada_value_ind (arg1
);
11116 case STRUCTOP_STRUCT
:
11117 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11118 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11119 preeval_pos
= *pos
;
11120 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11121 if (noside
== EVAL_SKIP
)
11123 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11125 struct type
*type1
= value_type (arg1
);
11127 if (ada_is_tagged_type (type1
, 1))
11129 type
= ada_lookup_struct_elt_type (type1
,
11130 &exp
->elts
[pc
+ 2].string
,
11133 /* If the field is not found, check if it exists in the
11134 extension of this object's type. This means that we
11135 need to evaluate completely the expression. */
11140 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11141 arg1
= ada_value_struct_elt (arg1
,
11142 &exp
->elts
[pc
+ 2].string
,
11144 arg1
= unwrap_value (arg1
);
11145 type
= value_type (ada_to_fixed_value (arg1
));
11150 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11153 return value_zero (ada_aligned_type (type
), lval_memory
);
11157 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11158 arg1
= unwrap_value (arg1
);
11159 return ada_to_fixed_value (arg1
);
11163 /* The value is not supposed to be used. This is here to make it
11164 easier to accommodate expressions that contain types. */
11166 if (noside
== EVAL_SKIP
)
11168 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11169 return allocate_value (exp
->elts
[pc
+ 1].type
);
11171 error (_("Attempt to use a type name as an expression"));
11176 case OP_DISCRETE_RANGE
:
11177 case OP_POSITIONAL
:
11179 if (noside
== EVAL_NORMAL
)
11183 error (_("Undefined name, ambiguous name, or renaming used in "
11184 "component association: %s."), &exp
->elts
[pc
+2].string
);
11186 error (_("Aggregates only allowed on the right of an assignment"));
11188 internal_error (__FILE__
, __LINE__
,
11189 _("aggregate apparently mangled"));
11192 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11194 for (tem
= 0; tem
< nargs
; tem
+= 1)
11195 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11200 return eval_skip_value (exp
);
11206 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11207 type name that encodes the 'small and 'delta information.
11208 Otherwise, return NULL. */
11210 static const char *
11211 gnat_encoded_fixed_point_type_info (struct type
*type
)
11213 const char *name
= ada_type_name (type
);
11214 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11216 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11218 const char *tail
= strstr (name
, "___XF_");
11225 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11226 return gnat_encoded_fixed_point_type_info (TYPE_TARGET_TYPE (type
));
11231 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11234 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11236 return gnat_encoded_fixed_point_type_info (type
) != NULL
;
11239 /* Return non-zero iff TYPE represents a System.Address type. */
11242 ada_is_system_address_type (struct type
*type
)
11244 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11247 /* Assuming that TYPE is the representation of an Ada fixed-point
11248 type, return the target floating-point type to be used to represent
11249 of this type during internal computation. */
11251 static struct type
*
11252 ada_scaling_type (struct type
*type
)
11254 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11257 /* Assuming that TYPE is the representation of an Ada fixed-point
11258 type, return its delta, or NULL if the type is malformed and the
11259 delta cannot be determined. */
11262 gnat_encoded_fixed_point_delta (struct type
*type
)
11264 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11265 struct type
*scale_type
= ada_scaling_type (type
);
11267 long long num
, den
;
11269 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11272 return value_binop (value_from_longest (scale_type
, num
),
11273 value_from_longest (scale_type
, den
), BINOP_DIV
);
11276 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11277 the scaling factor ('SMALL value) associated with the type. */
11280 gnat_encoded_fixed_point_scaling_factor (struct type
*type
)
11282 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11283 struct type
*scale_type
= ada_scaling_type (type
);
11285 long long num0
, den0
, num1
, den1
;
11288 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11289 &num0
, &den0
, &num1
, &den1
);
11292 return value_from_longest (scale_type
, 1);
11294 return value_binop (value_from_longest (scale_type
, num1
),
11295 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11297 return value_binop (value_from_longest (scale_type
, num0
),
11298 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11305 /* Scan STR beginning at position K for a discriminant name, and
11306 return the value of that discriminant field of DVAL in *PX. If
11307 PNEW_K is not null, put the position of the character beyond the
11308 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11309 not alter *PX and *PNEW_K if unsuccessful. */
11312 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11315 static char *bound_buffer
= NULL
;
11316 static size_t bound_buffer_len
= 0;
11317 const char *pstart
, *pend
, *bound
;
11318 struct value
*bound_val
;
11320 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11324 pend
= strstr (pstart
, "__");
11328 k
+= strlen (bound
);
11332 int len
= pend
- pstart
;
11334 /* Strip __ and beyond. */
11335 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11336 strncpy (bound_buffer
, pstart
, len
);
11337 bound_buffer
[len
] = '\0';
11339 bound
= bound_buffer
;
11343 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11344 if (bound_val
== NULL
)
11347 *px
= value_as_long (bound_val
);
11348 if (pnew_k
!= NULL
)
11353 /* Value of variable named NAME in the current environment. If
11354 no such variable found, then if ERR_MSG is null, returns 0, and
11355 otherwise causes an error with message ERR_MSG. */
11357 static struct value
*
11358 get_var_value (const char *name
, const char *err_msg
)
11360 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11362 std::vector
<struct block_symbol
> syms
;
11363 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11364 get_selected_block (0),
11365 VAR_DOMAIN
, &syms
, 1);
11369 if (err_msg
== NULL
)
11372 error (("%s"), err_msg
);
11375 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11378 /* Value of integer variable named NAME in the current environment.
11379 If no such variable is found, returns false. Otherwise, sets VALUE
11380 to the variable's value and returns true. */
11383 get_int_var_value (const char *name
, LONGEST
&value
)
11385 struct value
*var_val
= get_var_value (name
, 0);
11390 value
= value_as_long (var_val
);
11395 /* Return a range type whose base type is that of the range type named
11396 NAME in the current environment, and whose bounds are calculated
11397 from NAME according to the GNAT range encoding conventions.
11398 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11399 corresponding range type from debug information; fall back to using it
11400 if symbol lookup fails. If a new type must be created, allocate it
11401 like ORIG_TYPE was. The bounds information, in general, is encoded
11402 in NAME, the base type given in the named range type. */
11404 static struct type
*
11405 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11408 struct type
*base_type
;
11409 const char *subtype_info
;
11411 gdb_assert (raw_type
!= NULL
);
11412 gdb_assert (raw_type
->name () != NULL
);
11414 if (raw_type
->code () == TYPE_CODE_RANGE
)
11415 base_type
= TYPE_TARGET_TYPE (raw_type
);
11417 base_type
= raw_type
;
11419 name
= raw_type
->name ();
11420 subtype_info
= strstr (name
, "___XD");
11421 if (subtype_info
== NULL
)
11423 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11424 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11426 if (L
< INT_MIN
|| U
> INT_MAX
)
11429 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11434 static char *name_buf
= NULL
;
11435 static size_t name_len
= 0;
11436 int prefix_len
= subtype_info
- name
;
11439 const char *bounds_str
;
11442 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11443 strncpy (name_buf
, name
, prefix_len
);
11444 name_buf
[prefix_len
] = '\0';
11447 bounds_str
= strchr (subtype_info
, '_');
11450 if (*subtype_info
== 'L')
11452 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11453 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11455 if (bounds_str
[n
] == '_')
11457 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11463 strcpy (name_buf
+ prefix_len
, "___L");
11464 if (!get_int_var_value (name_buf
, L
))
11466 lim_warning (_("Unknown lower bound, using 1."));
11471 if (*subtype_info
== 'U')
11473 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11474 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11479 strcpy (name_buf
+ prefix_len
, "___U");
11480 if (!get_int_var_value (name_buf
, U
))
11482 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11487 type
= create_static_range_type (alloc_type_copy (raw_type
),
11489 /* create_static_range_type alters the resulting type's length
11490 to match the size of the base_type, which is not what we want.
11491 Set it back to the original range type's length. */
11492 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11493 type
->set_name (name
);
11498 /* True iff NAME is the name of a range type. */
11501 ada_is_range_type_name (const char *name
)
11503 return (name
!= NULL
&& strstr (name
, "___XD"));
11507 /* Modular types */
11509 /* True iff TYPE is an Ada modular type. */
11512 ada_is_modular_type (struct type
*type
)
11514 struct type
*subranged_type
= get_base_type (type
);
11516 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11517 && subranged_type
->code () == TYPE_CODE_INT
11518 && subranged_type
->is_unsigned ());
11521 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11524 ada_modulus (struct type
*type
)
11526 const dynamic_prop
&high
= type
->bounds ()->high
;
11528 if (high
.kind () == PROP_CONST
)
11529 return (ULONGEST
) high
.const_val () + 1;
11531 /* If TYPE is unresolved, the high bound might be a location list. Return
11532 0, for lack of a better value to return. */
11537 /* Ada exception catchpoint support:
11538 ---------------------------------
11540 We support 3 kinds of exception catchpoints:
11541 . catchpoints on Ada exceptions
11542 . catchpoints on unhandled Ada exceptions
11543 . catchpoints on failed assertions
11545 Exceptions raised during failed assertions, or unhandled exceptions
11546 could perfectly be caught with the general catchpoint on Ada exceptions.
11547 However, we can easily differentiate these two special cases, and having
11548 the option to distinguish these two cases from the rest can be useful
11549 to zero-in on certain situations.
11551 Exception catchpoints are a specialized form of breakpoint,
11552 since they rely on inserting breakpoints inside known routines
11553 of the GNAT runtime. The implementation therefore uses a standard
11554 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11557 Support in the runtime for exception catchpoints have been changed
11558 a few times already, and these changes affect the implementation
11559 of these catchpoints. In order to be able to support several
11560 variants of the runtime, we use a sniffer that will determine
11561 the runtime variant used by the program being debugged. */
11563 /* Ada's standard exceptions.
11565 The Ada 83 standard also defined Numeric_Error. But there so many
11566 situations where it was unclear from the Ada 83 Reference Manual
11567 (RM) whether Constraint_Error or Numeric_Error should be raised,
11568 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11569 Interpretation saying that anytime the RM says that Numeric_Error
11570 should be raised, the implementation may raise Constraint_Error.
11571 Ada 95 went one step further and pretty much removed Numeric_Error
11572 from the list of standard exceptions (it made it a renaming of
11573 Constraint_Error, to help preserve compatibility when compiling
11574 an Ada83 compiler). As such, we do not include Numeric_Error from
11575 this list of standard exceptions. */
11577 static const char * const standard_exc
[] = {
11578 "constraint_error",
11584 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11586 /* A structure that describes how to support exception catchpoints
11587 for a given executable. */
11589 struct exception_support_info
11591 /* The name of the symbol to break on in order to insert
11592 a catchpoint on exceptions. */
11593 const char *catch_exception_sym
;
11595 /* The name of the symbol to break on in order to insert
11596 a catchpoint on unhandled exceptions. */
11597 const char *catch_exception_unhandled_sym
;
11599 /* The name of the symbol to break on in order to insert
11600 a catchpoint on failed assertions. */
11601 const char *catch_assert_sym
;
11603 /* The name of the symbol to break on in order to insert
11604 a catchpoint on exception handling. */
11605 const char *catch_handlers_sym
;
11607 /* Assuming that the inferior just triggered an unhandled exception
11608 catchpoint, this function is responsible for returning the address
11609 in inferior memory where the name of that exception is stored.
11610 Return zero if the address could not be computed. */
11611 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11614 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11615 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11617 /* The following exception support info structure describes how to
11618 implement exception catchpoints with the latest version of the
11619 Ada runtime (as of 2019-08-??). */
11621 static const struct exception_support_info default_exception_support_info
=
11623 "__gnat_debug_raise_exception", /* catch_exception_sym */
11624 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11625 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11626 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11627 ada_unhandled_exception_name_addr
11630 /* The following exception support info structure describes how to
11631 implement exception catchpoints with an earlier version of the
11632 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11634 static const struct exception_support_info exception_support_info_v0
=
11636 "__gnat_debug_raise_exception", /* catch_exception_sym */
11637 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11638 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11639 "__gnat_begin_handler", /* catch_handlers_sym */
11640 ada_unhandled_exception_name_addr
11643 /* The following exception support info structure describes how to
11644 implement exception catchpoints with a slightly older version
11645 of the Ada runtime. */
11647 static const struct exception_support_info exception_support_info_fallback
=
11649 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11650 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11651 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11652 "__gnat_begin_handler", /* catch_handlers_sym */
11653 ada_unhandled_exception_name_addr_from_raise
11656 /* Return nonzero if we can detect the exception support routines
11657 described in EINFO.
11659 This function errors out if an abnormal situation is detected
11660 (for instance, if we find the exception support routines, but
11661 that support is found to be incomplete). */
11664 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11666 struct symbol
*sym
;
11668 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11669 that should be compiled with debugging information. As a result, we
11670 expect to find that symbol in the symtabs. */
11672 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11675 /* Perhaps we did not find our symbol because the Ada runtime was
11676 compiled without debugging info, or simply stripped of it.
11677 It happens on some GNU/Linux distributions for instance, where
11678 users have to install a separate debug package in order to get
11679 the runtime's debugging info. In that situation, let the user
11680 know why we cannot insert an Ada exception catchpoint.
11682 Note: Just for the purpose of inserting our Ada exception
11683 catchpoint, we could rely purely on the associated minimal symbol.
11684 But we would be operating in degraded mode anyway, since we are
11685 still lacking the debugging info needed later on to extract
11686 the name of the exception being raised (this name is printed in
11687 the catchpoint message, and is also used when trying to catch
11688 a specific exception). We do not handle this case for now. */
11689 struct bound_minimal_symbol msym
11690 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11692 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11693 error (_("Your Ada runtime appears to be missing some debugging "
11694 "information.\nCannot insert Ada exception catchpoint "
11695 "in this configuration."));
11700 /* Make sure that the symbol we found corresponds to a function. */
11702 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11704 error (_("Symbol \"%s\" is not a function (class = %d)"),
11705 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11709 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11712 struct bound_minimal_symbol msym
11713 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11715 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11716 error (_("Your Ada runtime appears to be missing some debugging "
11717 "information.\nCannot insert Ada exception catchpoint "
11718 "in this configuration."));
11723 /* Make sure that the symbol we found corresponds to a function. */
11725 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11727 error (_("Symbol \"%s\" is not a function (class = %d)"),
11728 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11735 /* Inspect the Ada runtime and determine which exception info structure
11736 should be used to provide support for exception catchpoints.
11738 This function will always set the per-inferior exception_info,
11739 or raise an error. */
11742 ada_exception_support_info_sniffer (void)
11744 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11746 /* If the exception info is already known, then no need to recompute it. */
11747 if (data
->exception_info
!= NULL
)
11750 /* Check the latest (default) exception support info. */
11751 if (ada_has_this_exception_support (&default_exception_support_info
))
11753 data
->exception_info
= &default_exception_support_info
;
11757 /* Try the v0 exception suport info. */
11758 if (ada_has_this_exception_support (&exception_support_info_v0
))
11760 data
->exception_info
= &exception_support_info_v0
;
11764 /* Try our fallback exception suport info. */
11765 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11767 data
->exception_info
= &exception_support_info_fallback
;
11771 /* Sometimes, it is normal for us to not be able to find the routine
11772 we are looking for. This happens when the program is linked with
11773 the shared version of the GNAT runtime, and the program has not been
11774 started yet. Inform the user of these two possible causes if
11777 if (ada_update_initial_language (language_unknown
) != language_ada
)
11778 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11780 /* If the symbol does not exist, then check that the program is
11781 already started, to make sure that shared libraries have been
11782 loaded. If it is not started, this may mean that the symbol is
11783 in a shared library. */
11785 if (inferior_ptid
.pid () == 0)
11786 error (_("Unable to insert catchpoint. Try to start the program first."));
11788 /* At this point, we know that we are debugging an Ada program and
11789 that the inferior has been started, but we still are not able to
11790 find the run-time symbols. That can mean that we are in
11791 configurable run time mode, or that a-except as been optimized
11792 out by the linker... In any case, at this point it is not worth
11793 supporting this feature. */
11795 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11798 /* True iff FRAME is very likely to be that of a function that is
11799 part of the runtime system. This is all very heuristic, but is
11800 intended to be used as advice as to what frames are uninteresting
11804 is_known_support_routine (struct frame_info
*frame
)
11806 enum language func_lang
;
11808 const char *fullname
;
11810 /* If this code does not have any debugging information (no symtab),
11811 This cannot be any user code. */
11813 symtab_and_line sal
= find_frame_sal (frame
);
11814 if (sal
.symtab
== NULL
)
11817 /* If there is a symtab, but the associated source file cannot be
11818 located, then assume this is not user code: Selecting a frame
11819 for which we cannot display the code would not be very helpful
11820 for the user. This should also take care of case such as VxWorks
11821 where the kernel has some debugging info provided for a few units. */
11823 fullname
= symtab_to_fullname (sal
.symtab
);
11824 if (access (fullname
, R_OK
) != 0)
11827 /* Check the unit filename against the Ada runtime file naming.
11828 We also check the name of the objfile against the name of some
11829 known system libraries that sometimes come with debugging info
11832 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11834 re_comp (known_runtime_file_name_patterns
[i
]);
11835 if (re_exec (lbasename (sal
.symtab
->filename
)))
11837 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11838 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11842 /* Check whether the function is a GNAT-generated entity. */
11844 gdb::unique_xmalloc_ptr
<char> func_name
11845 = find_frame_funname (frame
, &func_lang
, NULL
);
11846 if (func_name
== NULL
)
11849 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11851 re_comp (known_auxiliary_function_name_patterns
[i
]);
11852 if (re_exec (func_name
.get ()))
11859 /* Find the first frame that contains debugging information and that is not
11860 part of the Ada run-time, starting from FI and moving upward. */
11863 ada_find_printable_frame (struct frame_info
*fi
)
11865 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11867 if (!is_known_support_routine (fi
))
11876 /* Assuming that the inferior just triggered an unhandled exception
11877 catchpoint, return the address in inferior memory where the name
11878 of the exception is stored.
11880 Return zero if the address could not be computed. */
11883 ada_unhandled_exception_name_addr (void)
11885 return parse_and_eval_address ("e.full_name");
11888 /* Same as ada_unhandled_exception_name_addr, except that this function
11889 should be used when the inferior uses an older version of the runtime,
11890 where the exception name needs to be extracted from a specific frame
11891 several frames up in the callstack. */
11894 ada_unhandled_exception_name_addr_from_raise (void)
11897 struct frame_info
*fi
;
11898 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11900 /* To determine the name of this exception, we need to select
11901 the frame corresponding to RAISE_SYM_NAME. This frame is
11902 at least 3 levels up, so we simply skip the first 3 frames
11903 without checking the name of their associated function. */
11904 fi
= get_current_frame ();
11905 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11907 fi
= get_prev_frame (fi
);
11911 enum language func_lang
;
11913 gdb::unique_xmalloc_ptr
<char> func_name
11914 = find_frame_funname (fi
, &func_lang
, NULL
);
11915 if (func_name
!= NULL
)
11917 if (strcmp (func_name
.get (),
11918 data
->exception_info
->catch_exception_sym
) == 0)
11919 break; /* We found the frame we were looking for... */
11921 fi
= get_prev_frame (fi
);
11928 return parse_and_eval_address ("id.full_name");
11931 /* Assuming the inferior just triggered an Ada exception catchpoint
11932 (of any type), return the address in inferior memory where the name
11933 of the exception is stored, if applicable.
11935 Assumes the selected frame is the current frame.
11937 Return zero if the address could not be computed, or if not relevant. */
11940 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11941 struct breakpoint
*b
)
11943 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11947 case ada_catch_exception
:
11948 return (parse_and_eval_address ("e.full_name"));
11951 case ada_catch_exception_unhandled
:
11952 return data
->exception_info
->unhandled_exception_name_addr ();
11955 case ada_catch_handlers
:
11956 return 0; /* The runtimes does not provide access to the exception
11960 case ada_catch_assert
:
11961 return 0; /* Exception name is not relevant in this case. */
11965 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11969 return 0; /* Should never be reached. */
11972 /* Assuming the inferior is stopped at an exception catchpoint,
11973 return the message which was associated to the exception, if
11974 available. Return NULL if the message could not be retrieved.
11976 Note: The exception message can be associated to an exception
11977 either through the use of the Raise_Exception function, or
11978 more simply (Ada 2005 and later), via:
11980 raise Exception_Name with "exception message";
11984 static gdb::unique_xmalloc_ptr
<char>
11985 ada_exception_message_1 (void)
11987 struct value
*e_msg_val
;
11990 /* For runtimes that support this feature, the exception message
11991 is passed as an unbounded string argument called "message". */
11992 e_msg_val
= parse_and_eval ("message");
11993 if (e_msg_val
== NULL
)
11994 return NULL
; /* Exception message not supported. */
11996 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11997 gdb_assert (e_msg_val
!= NULL
);
11998 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12000 /* If the message string is empty, then treat it as if there was
12001 no exception message. */
12002 if (e_msg_len
<= 0)
12005 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12006 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
12008 e_msg
.get ()[e_msg_len
] = '\0';
12013 /* Same as ada_exception_message_1, except that all exceptions are
12014 contained here (returning NULL instead). */
12016 static gdb::unique_xmalloc_ptr
<char>
12017 ada_exception_message (void)
12019 gdb::unique_xmalloc_ptr
<char> e_msg
;
12023 e_msg
= ada_exception_message_1 ();
12025 catch (const gdb_exception_error
&e
)
12027 e_msg
.reset (nullptr);
12033 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12034 any error that ada_exception_name_addr_1 might cause to be thrown.
12035 When an error is intercepted, a warning with the error message is printed,
12036 and zero is returned. */
12039 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12040 struct breakpoint
*b
)
12042 CORE_ADDR result
= 0;
12046 result
= ada_exception_name_addr_1 (ex
, b
);
12049 catch (const gdb_exception_error
&e
)
12051 warning (_("failed to get exception name: %s"), e
.what ());
12058 static std::string ada_exception_catchpoint_cond_string
12059 (const char *excep_string
,
12060 enum ada_exception_catchpoint_kind ex
);
12062 /* Ada catchpoints.
12064 In the case of catchpoints on Ada exceptions, the catchpoint will
12065 stop the target on every exception the program throws. When a user
12066 specifies the name of a specific exception, we translate this
12067 request into a condition expression (in text form), and then parse
12068 it into an expression stored in each of the catchpoint's locations.
12069 We then use this condition to check whether the exception that was
12070 raised is the one the user is interested in. If not, then the
12071 target is resumed again. We store the name of the requested
12072 exception, in order to be able to re-set the condition expression
12073 when symbols change. */
12075 /* An instance of this type is used to represent an Ada catchpoint
12076 breakpoint location. */
12078 class ada_catchpoint_location
: public bp_location
12081 ada_catchpoint_location (breakpoint
*owner
)
12082 : bp_location (owner
, bp_loc_software_breakpoint
)
12085 /* The condition that checks whether the exception that was raised
12086 is the specific exception the user specified on catchpoint
12088 expression_up excep_cond_expr
;
12091 /* An instance of this type is used to represent an Ada catchpoint. */
12093 struct ada_catchpoint
: public breakpoint
12095 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12100 /* The name of the specific exception the user specified. */
12101 std::string excep_string
;
12103 /* What kind of catchpoint this is. */
12104 enum ada_exception_catchpoint_kind m_kind
;
12107 /* Parse the exception condition string in the context of each of the
12108 catchpoint's locations, and store them for later evaluation. */
12111 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12112 enum ada_exception_catchpoint_kind ex
)
12114 struct bp_location
*bl
;
12116 /* Nothing to do if there's no specific exception to catch. */
12117 if (c
->excep_string
.empty ())
12120 /* Same if there are no locations... */
12121 if (c
->loc
== NULL
)
12124 /* Compute the condition expression in text form, from the specific
12125 expection we want to catch. */
12126 std::string cond_string
12127 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12129 /* Iterate over all the catchpoint's locations, and parse an
12130 expression for each. */
12131 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12133 struct ada_catchpoint_location
*ada_loc
12134 = (struct ada_catchpoint_location
*) bl
;
12137 if (!bl
->shlib_disabled
)
12141 s
= cond_string
.c_str ();
12144 exp
= parse_exp_1 (&s
, bl
->address
,
12145 block_for_pc (bl
->address
),
12148 catch (const gdb_exception_error
&e
)
12150 warning (_("failed to reevaluate internal exception condition "
12151 "for catchpoint %d: %s"),
12152 c
->number
, e
.what ());
12156 ada_loc
->excep_cond_expr
= std::move (exp
);
12160 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12161 structure for all exception catchpoint kinds. */
12163 static struct bp_location
*
12164 allocate_location_exception (struct breakpoint
*self
)
12166 return new ada_catchpoint_location (self
);
12169 /* Implement the RE_SET method in the breakpoint_ops structure for all
12170 exception catchpoint kinds. */
12173 re_set_exception (struct breakpoint
*b
)
12175 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12177 /* Call the base class's method. This updates the catchpoint's
12179 bkpt_breakpoint_ops
.re_set (b
);
12181 /* Reparse the exception conditional expressions. One for each
12183 create_excep_cond_exprs (c
, c
->m_kind
);
12186 /* Returns true if we should stop for this breakpoint hit. If the
12187 user specified a specific exception, we only want to cause a stop
12188 if the program thrown that exception. */
12191 should_stop_exception (const struct bp_location
*bl
)
12193 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12194 const struct ada_catchpoint_location
*ada_loc
12195 = (const struct ada_catchpoint_location
*) bl
;
12198 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12199 if (c
->m_kind
== ada_catch_assert
)
12200 clear_internalvar (var
);
12207 if (c
->m_kind
== ada_catch_handlers
)
12208 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12209 ".all.occurrence.id");
12213 struct value
*exc
= parse_and_eval (expr
);
12214 set_internalvar (var
, exc
);
12216 catch (const gdb_exception_error
&ex
)
12218 clear_internalvar (var
);
12222 /* With no specific exception, should always stop. */
12223 if (c
->excep_string
.empty ())
12226 if (ada_loc
->excep_cond_expr
== NULL
)
12228 /* We will have a NULL expression if back when we were creating
12229 the expressions, this location's had failed to parse. */
12236 struct value
*mark
;
12238 mark
= value_mark ();
12239 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12240 value_free_to_mark (mark
);
12242 catch (const gdb_exception
&ex
)
12244 exception_fprintf (gdb_stderr
, ex
,
12245 _("Error in testing exception condition:\n"));
12251 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12252 for all exception catchpoint kinds. */
12255 check_status_exception (bpstat bs
)
12257 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12260 /* Implement the PRINT_IT method in the breakpoint_ops structure
12261 for all exception catchpoint kinds. */
12263 static enum print_stop_action
12264 print_it_exception (bpstat bs
)
12266 struct ui_out
*uiout
= current_uiout
;
12267 struct breakpoint
*b
= bs
->breakpoint_at
;
12269 annotate_catchpoint (b
->number
);
12271 if (uiout
->is_mi_like_p ())
12273 uiout
->field_string ("reason",
12274 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12275 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12278 uiout
->text (b
->disposition
== disp_del
12279 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12280 uiout
->field_signed ("bkptno", b
->number
);
12281 uiout
->text (", ");
12283 /* ada_exception_name_addr relies on the selected frame being the
12284 current frame. Need to do this here because this function may be
12285 called more than once when printing a stop, and below, we'll
12286 select the first frame past the Ada run-time (see
12287 ada_find_printable_frame). */
12288 select_frame (get_current_frame ());
12290 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12293 case ada_catch_exception
:
12294 case ada_catch_exception_unhandled
:
12295 case ada_catch_handlers
:
12297 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12298 char exception_name
[256];
12302 read_memory (addr
, (gdb_byte
*) exception_name
,
12303 sizeof (exception_name
) - 1);
12304 exception_name
[sizeof (exception_name
) - 1] = '\0';
12308 /* For some reason, we were unable to read the exception
12309 name. This could happen if the Runtime was compiled
12310 without debugging info, for instance. In that case,
12311 just replace the exception name by the generic string
12312 "exception" - it will read as "an exception" in the
12313 notification we are about to print. */
12314 memcpy (exception_name
, "exception", sizeof ("exception"));
12316 /* In the case of unhandled exception breakpoints, we print
12317 the exception name as "unhandled EXCEPTION_NAME", to make
12318 it clearer to the user which kind of catchpoint just got
12319 hit. We used ui_out_text to make sure that this extra
12320 info does not pollute the exception name in the MI case. */
12321 if (c
->m_kind
== ada_catch_exception_unhandled
)
12322 uiout
->text ("unhandled ");
12323 uiout
->field_string ("exception-name", exception_name
);
12326 case ada_catch_assert
:
12327 /* In this case, the name of the exception is not really
12328 important. Just print "failed assertion" to make it clearer
12329 that his program just hit an assertion-failure catchpoint.
12330 We used ui_out_text because this info does not belong in
12332 uiout
->text ("failed assertion");
12336 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12337 if (exception_message
!= NULL
)
12339 uiout
->text (" (");
12340 uiout
->field_string ("exception-message", exception_message
.get ());
12344 uiout
->text (" at ");
12345 ada_find_printable_frame (get_current_frame ());
12347 return PRINT_SRC_AND_LOC
;
12350 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12351 for all exception catchpoint kinds. */
12354 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12356 struct ui_out
*uiout
= current_uiout
;
12357 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12358 struct value_print_options opts
;
12360 get_user_print_options (&opts
);
12362 if (opts
.addressprint
)
12363 uiout
->field_skip ("addr");
12365 annotate_field (5);
12368 case ada_catch_exception
:
12369 if (!c
->excep_string
.empty ())
12371 std::string msg
= string_printf (_("`%s' Ada exception"),
12372 c
->excep_string
.c_str ());
12374 uiout
->field_string ("what", msg
);
12377 uiout
->field_string ("what", "all Ada exceptions");
12381 case ada_catch_exception_unhandled
:
12382 uiout
->field_string ("what", "unhandled Ada exceptions");
12385 case ada_catch_handlers
:
12386 if (!c
->excep_string
.empty ())
12388 uiout
->field_fmt ("what",
12389 _("`%s' Ada exception handlers"),
12390 c
->excep_string
.c_str ());
12393 uiout
->field_string ("what", "all Ada exceptions handlers");
12396 case ada_catch_assert
:
12397 uiout
->field_string ("what", "failed Ada assertions");
12401 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12406 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12407 for all exception catchpoint kinds. */
12410 print_mention_exception (struct breakpoint
*b
)
12412 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12413 struct ui_out
*uiout
= current_uiout
;
12415 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12416 : _("Catchpoint "));
12417 uiout
->field_signed ("bkptno", b
->number
);
12418 uiout
->text (": ");
12422 case ada_catch_exception
:
12423 if (!c
->excep_string
.empty ())
12425 std::string info
= string_printf (_("`%s' Ada exception"),
12426 c
->excep_string
.c_str ());
12427 uiout
->text (info
.c_str ());
12430 uiout
->text (_("all Ada exceptions"));
12433 case ada_catch_exception_unhandled
:
12434 uiout
->text (_("unhandled Ada exceptions"));
12437 case ada_catch_handlers
:
12438 if (!c
->excep_string
.empty ())
12441 = string_printf (_("`%s' Ada exception handlers"),
12442 c
->excep_string
.c_str ());
12443 uiout
->text (info
.c_str ());
12446 uiout
->text (_("all Ada exceptions handlers"));
12449 case ada_catch_assert
:
12450 uiout
->text (_("failed Ada assertions"));
12454 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12459 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12460 for all exception catchpoint kinds. */
12463 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12465 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12469 case ada_catch_exception
:
12470 fprintf_filtered (fp
, "catch exception");
12471 if (!c
->excep_string
.empty ())
12472 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12475 case ada_catch_exception_unhandled
:
12476 fprintf_filtered (fp
, "catch exception unhandled");
12479 case ada_catch_handlers
:
12480 fprintf_filtered (fp
, "catch handlers");
12483 case ada_catch_assert
:
12484 fprintf_filtered (fp
, "catch assert");
12488 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12490 print_recreate_thread (b
, fp
);
12493 /* Virtual tables for various breakpoint types. */
12494 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12495 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12496 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12497 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12499 /* See ada-lang.h. */
12502 is_ada_exception_catchpoint (breakpoint
*bp
)
12504 return (bp
->ops
== &catch_exception_breakpoint_ops
12505 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12506 || bp
->ops
== &catch_assert_breakpoint_ops
12507 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12510 /* Split the arguments specified in a "catch exception" command.
12511 Set EX to the appropriate catchpoint type.
12512 Set EXCEP_STRING to the name of the specific exception if
12513 specified by the user.
12514 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12515 "catch handlers" command. False otherwise.
12516 If a condition is found at the end of the arguments, the condition
12517 expression is stored in COND_STRING (memory must be deallocated
12518 after use). Otherwise COND_STRING is set to NULL. */
12521 catch_ada_exception_command_split (const char *args
,
12522 bool is_catch_handlers_cmd
,
12523 enum ada_exception_catchpoint_kind
*ex
,
12524 std::string
*excep_string
,
12525 std::string
*cond_string
)
12527 std::string exception_name
;
12529 exception_name
= extract_arg (&args
);
12530 if (exception_name
== "if")
12532 /* This is not an exception name; this is the start of a condition
12533 expression for a catchpoint on all exceptions. So, "un-get"
12534 this token, and set exception_name to NULL. */
12535 exception_name
.clear ();
12539 /* Check to see if we have a condition. */
12541 args
= skip_spaces (args
);
12542 if (startswith (args
, "if")
12543 && (isspace (args
[2]) || args
[2] == '\0'))
12546 args
= skip_spaces (args
);
12548 if (args
[0] == '\0')
12549 error (_("Condition missing after `if' keyword"));
12550 *cond_string
= args
;
12552 args
+= strlen (args
);
12555 /* Check that we do not have any more arguments. Anything else
12558 if (args
[0] != '\0')
12559 error (_("Junk at end of expression"));
12561 if (is_catch_handlers_cmd
)
12563 /* Catch handling of exceptions. */
12564 *ex
= ada_catch_handlers
;
12565 *excep_string
= exception_name
;
12567 else if (exception_name
.empty ())
12569 /* Catch all exceptions. */
12570 *ex
= ada_catch_exception
;
12571 excep_string
->clear ();
12573 else if (exception_name
== "unhandled")
12575 /* Catch unhandled exceptions. */
12576 *ex
= ada_catch_exception_unhandled
;
12577 excep_string
->clear ();
12581 /* Catch a specific exception. */
12582 *ex
= ada_catch_exception
;
12583 *excep_string
= exception_name
;
12587 /* Return the name of the symbol on which we should break in order to
12588 implement a catchpoint of the EX kind. */
12590 static const char *
12591 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12593 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12595 gdb_assert (data
->exception_info
!= NULL
);
12599 case ada_catch_exception
:
12600 return (data
->exception_info
->catch_exception_sym
);
12602 case ada_catch_exception_unhandled
:
12603 return (data
->exception_info
->catch_exception_unhandled_sym
);
12605 case ada_catch_assert
:
12606 return (data
->exception_info
->catch_assert_sym
);
12608 case ada_catch_handlers
:
12609 return (data
->exception_info
->catch_handlers_sym
);
12612 internal_error (__FILE__
, __LINE__
,
12613 _("unexpected catchpoint kind (%d)"), ex
);
12617 /* Return the breakpoint ops "virtual table" used for catchpoints
12620 static const struct breakpoint_ops
*
12621 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12625 case ada_catch_exception
:
12626 return (&catch_exception_breakpoint_ops
);
12628 case ada_catch_exception_unhandled
:
12629 return (&catch_exception_unhandled_breakpoint_ops
);
12631 case ada_catch_assert
:
12632 return (&catch_assert_breakpoint_ops
);
12634 case ada_catch_handlers
:
12635 return (&catch_handlers_breakpoint_ops
);
12638 internal_error (__FILE__
, __LINE__
,
12639 _("unexpected catchpoint kind (%d)"), ex
);
12643 /* Return the condition that will be used to match the current exception
12644 being raised with the exception that the user wants to catch. This
12645 assumes that this condition is used when the inferior just triggered
12646 an exception catchpoint.
12647 EX: the type of catchpoints used for catching Ada exceptions. */
12650 ada_exception_catchpoint_cond_string (const char *excep_string
,
12651 enum ada_exception_catchpoint_kind ex
)
12654 bool is_standard_exc
= false;
12655 std::string result
;
12657 if (ex
== ada_catch_handlers
)
12659 /* For exception handlers catchpoints, the condition string does
12660 not use the same parameter as for the other exceptions. */
12661 result
= ("long_integer (GNAT_GCC_exception_Access"
12662 "(gcc_exception).all.occurrence.id)");
12665 result
= "long_integer (e)";
12667 /* The standard exceptions are a special case. They are defined in
12668 runtime units that have been compiled without debugging info; if
12669 EXCEP_STRING is the not-fully-qualified name of a standard
12670 exception (e.g. "constraint_error") then, during the evaluation
12671 of the condition expression, the symbol lookup on this name would
12672 *not* return this standard exception. The catchpoint condition
12673 may then be set only on user-defined exceptions which have the
12674 same not-fully-qualified name (e.g. my_package.constraint_error).
12676 To avoid this unexcepted behavior, these standard exceptions are
12677 systematically prefixed by "standard". This means that "catch
12678 exception constraint_error" is rewritten into "catch exception
12679 standard.constraint_error".
12681 If an exception named constraint_error is defined in another package of
12682 the inferior program, then the only way to specify this exception as a
12683 breakpoint condition is to use its fully-qualified named:
12684 e.g. my_package.constraint_error. */
12686 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12688 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12690 is_standard_exc
= true;
12697 if (is_standard_exc
)
12698 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12700 string_appendf (result
, "long_integer (&%s)", excep_string
);
12705 /* Return the symtab_and_line that should be used to insert an exception
12706 catchpoint of the TYPE kind.
12708 ADDR_STRING returns the name of the function where the real
12709 breakpoint that implements the catchpoints is set, depending on the
12710 type of catchpoint we need to create. */
12712 static struct symtab_and_line
12713 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12714 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12716 const char *sym_name
;
12717 struct symbol
*sym
;
12719 /* First, find out which exception support info to use. */
12720 ada_exception_support_info_sniffer ();
12722 /* Then lookup the function on which we will break in order to catch
12723 the Ada exceptions requested by the user. */
12724 sym_name
= ada_exception_sym_name (ex
);
12725 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12728 error (_("Catchpoint symbol not found: %s"), sym_name
);
12730 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12731 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12733 /* Set ADDR_STRING. */
12734 *addr_string
= sym_name
;
12737 *ops
= ada_exception_breakpoint_ops (ex
);
12739 return find_function_start_sal (sym
, 1);
12742 /* Create an Ada exception catchpoint.
12744 EX_KIND is the kind of exception catchpoint to be created.
12746 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12747 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12748 of the exception to which this catchpoint applies.
12750 COND_STRING, if not empty, is the catchpoint condition.
12752 TEMPFLAG, if nonzero, means that the underlying breakpoint
12753 should be temporary.
12755 FROM_TTY is the usual argument passed to all commands implementations. */
12758 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12759 enum ada_exception_catchpoint_kind ex_kind
,
12760 const std::string
&excep_string
,
12761 const std::string
&cond_string
,
12766 std::string addr_string
;
12767 const struct breakpoint_ops
*ops
= NULL
;
12768 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12770 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12771 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12772 ops
, tempflag
, disabled
, from_tty
);
12773 c
->excep_string
= excep_string
;
12774 create_excep_cond_exprs (c
.get (), ex_kind
);
12775 if (!cond_string
.empty ())
12776 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12777 install_breakpoint (0, std::move (c
), 1);
12780 /* Implement the "catch exception" command. */
12783 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12784 struct cmd_list_element
*command
)
12786 const char *arg
= arg_entry
;
12787 struct gdbarch
*gdbarch
= get_current_arch ();
12789 enum ada_exception_catchpoint_kind ex_kind
;
12790 std::string excep_string
;
12791 std::string cond_string
;
12793 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12797 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12799 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12800 excep_string
, cond_string
,
12801 tempflag
, 1 /* enabled */,
12805 /* Implement the "catch handlers" command. */
12808 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12809 struct cmd_list_element
*command
)
12811 const char *arg
= arg_entry
;
12812 struct gdbarch
*gdbarch
= get_current_arch ();
12814 enum ada_exception_catchpoint_kind ex_kind
;
12815 std::string excep_string
;
12816 std::string cond_string
;
12818 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12822 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12824 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12825 excep_string
, cond_string
,
12826 tempflag
, 1 /* enabled */,
12830 /* Completion function for the Ada "catch" commands. */
12833 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12834 const char *text
, const char *word
)
12836 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12838 for (const ada_exc_info
&info
: exceptions
)
12840 if (startswith (info
.name
, word
))
12841 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12845 /* Split the arguments specified in a "catch assert" command.
12847 ARGS contains the command's arguments (or the empty string if
12848 no arguments were passed).
12850 If ARGS contains a condition, set COND_STRING to that condition
12851 (the memory needs to be deallocated after use). */
12854 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12856 args
= skip_spaces (args
);
12858 /* Check whether a condition was provided. */
12859 if (startswith (args
, "if")
12860 && (isspace (args
[2]) || args
[2] == '\0'))
12863 args
= skip_spaces (args
);
12864 if (args
[0] == '\0')
12865 error (_("condition missing after `if' keyword"));
12866 cond_string
.assign (args
);
12869 /* Otherwise, there should be no other argument at the end of
12871 else if (args
[0] != '\0')
12872 error (_("Junk at end of arguments."));
12875 /* Implement the "catch assert" command. */
12878 catch_assert_command (const char *arg_entry
, int from_tty
,
12879 struct cmd_list_element
*command
)
12881 const char *arg
= arg_entry
;
12882 struct gdbarch
*gdbarch
= get_current_arch ();
12884 std::string cond_string
;
12886 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12890 catch_ada_assert_command_split (arg
, cond_string
);
12891 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12893 tempflag
, 1 /* enabled */,
12897 /* Return non-zero if the symbol SYM is an Ada exception object. */
12900 ada_is_exception_sym (struct symbol
*sym
)
12902 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12904 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12905 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12906 && SYMBOL_CLASS (sym
) != LOC_CONST
12907 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12908 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12911 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12912 Ada exception object. This matches all exceptions except the ones
12913 defined by the Ada language. */
12916 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12920 if (!ada_is_exception_sym (sym
))
12923 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12924 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12925 return 0; /* A standard exception. */
12927 /* Numeric_Error is also a standard exception, so exclude it.
12928 See the STANDARD_EXC description for more details as to why
12929 this exception is not listed in that array. */
12930 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12936 /* A helper function for std::sort, comparing two struct ada_exc_info
12939 The comparison is determined first by exception name, and then
12940 by exception address. */
12943 ada_exc_info::operator< (const ada_exc_info
&other
) const
12947 result
= strcmp (name
, other
.name
);
12950 if (result
== 0 && addr
< other
.addr
)
12956 ada_exc_info::operator== (const ada_exc_info
&other
) const
12958 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12961 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12962 routine, but keeping the first SKIP elements untouched.
12964 All duplicates are also removed. */
12967 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12970 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12971 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12972 exceptions
->end ());
12975 /* Add all exceptions defined by the Ada standard whose name match
12976 a regular expression.
12978 If PREG is not NULL, then this regexp_t object is used to
12979 perform the symbol name matching. Otherwise, no name-based
12980 filtering is performed.
12982 EXCEPTIONS is a vector of exceptions to which matching exceptions
12986 ada_add_standard_exceptions (compiled_regex
*preg
,
12987 std::vector
<ada_exc_info
> *exceptions
)
12991 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12994 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12996 struct bound_minimal_symbol msymbol
12997 = ada_lookup_simple_minsym (standard_exc
[i
]);
12999 if (msymbol
.minsym
!= NULL
)
13001 struct ada_exc_info info
13002 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13004 exceptions
->push_back (info
);
13010 /* Add all Ada exceptions defined locally and accessible from the given
13013 If PREG is not NULL, then this regexp_t object is used to
13014 perform the symbol name matching. Otherwise, no name-based
13015 filtering is performed.
13017 EXCEPTIONS is a vector of exceptions to which matching exceptions
13021 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13022 struct frame_info
*frame
,
13023 std::vector
<ada_exc_info
> *exceptions
)
13025 const struct block
*block
= get_frame_block (frame
, 0);
13029 struct block_iterator iter
;
13030 struct symbol
*sym
;
13032 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13034 switch (SYMBOL_CLASS (sym
))
13041 if (ada_is_exception_sym (sym
))
13043 struct ada_exc_info info
= {sym
->print_name (),
13044 SYMBOL_VALUE_ADDRESS (sym
)};
13046 exceptions
->push_back (info
);
13050 if (BLOCK_FUNCTION (block
) != NULL
)
13052 block
= BLOCK_SUPERBLOCK (block
);
13056 /* Return true if NAME matches PREG or if PREG is NULL. */
13059 name_matches_regex (const char *name
, compiled_regex
*preg
)
13061 return (preg
== NULL
13062 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13065 /* Add all exceptions defined globally whose name name match
13066 a regular expression, excluding standard exceptions.
13068 The reason we exclude standard exceptions is that they need
13069 to be handled separately: Standard exceptions are defined inside
13070 a runtime unit which is normally not compiled with debugging info,
13071 and thus usually do not show up in our symbol search. However,
13072 if the unit was in fact built with debugging info, we need to
13073 exclude them because they would duplicate the entry we found
13074 during the special loop that specifically searches for those
13075 standard exceptions.
13077 If PREG is not NULL, then this regexp_t object is used to
13078 perform the symbol name matching. Otherwise, no name-based
13079 filtering is performed.
13081 EXCEPTIONS is a vector of exceptions to which matching exceptions
13085 ada_add_global_exceptions (compiled_regex
*preg
,
13086 std::vector
<ada_exc_info
> *exceptions
)
13088 /* In Ada, the symbol "search name" is a linkage name, whereas the
13089 regular expression used to do the matching refers to the natural
13090 name. So match against the decoded name. */
13091 expand_symtabs_matching (NULL
,
13092 lookup_name_info::match_any (),
13093 [&] (const char *search_name
)
13095 std::string decoded
= ada_decode (search_name
);
13096 return name_matches_regex (decoded
.c_str (), preg
);
13101 for (objfile
*objfile
: current_program_space
->objfiles ())
13103 for (compunit_symtab
*s
: objfile
->compunits ())
13105 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13108 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13110 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13111 struct block_iterator iter
;
13112 struct symbol
*sym
;
13114 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13115 if (ada_is_non_standard_exception_sym (sym
)
13116 && name_matches_regex (sym
->natural_name (), preg
))
13118 struct ada_exc_info info
13119 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13121 exceptions
->push_back (info
);
13128 /* Implements ada_exceptions_list with the regular expression passed
13129 as a regex_t, rather than a string.
13131 If not NULL, PREG is used to filter out exceptions whose names
13132 do not match. Otherwise, all exceptions are listed. */
13134 static std::vector
<ada_exc_info
>
13135 ada_exceptions_list_1 (compiled_regex
*preg
)
13137 std::vector
<ada_exc_info
> result
;
13140 /* First, list the known standard exceptions. These exceptions
13141 need to be handled separately, as they are usually defined in
13142 runtime units that have been compiled without debugging info. */
13144 ada_add_standard_exceptions (preg
, &result
);
13146 /* Next, find all exceptions whose scope is local and accessible
13147 from the currently selected frame. */
13149 if (has_stack_frames ())
13151 prev_len
= result
.size ();
13152 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13154 if (result
.size () > prev_len
)
13155 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13158 /* Add all exceptions whose scope is global. */
13160 prev_len
= result
.size ();
13161 ada_add_global_exceptions (preg
, &result
);
13162 if (result
.size () > prev_len
)
13163 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13168 /* Return a vector of ada_exc_info.
13170 If REGEXP is NULL, all exceptions are included in the result.
13171 Otherwise, it should contain a valid regular expression,
13172 and only the exceptions whose names match that regular expression
13173 are included in the result.
13175 The exceptions are sorted in the following order:
13176 - Standard exceptions (defined by the Ada language), in
13177 alphabetical order;
13178 - Exceptions only visible from the current frame, in
13179 alphabetical order;
13180 - Exceptions whose scope is global, in alphabetical order. */
13182 std::vector
<ada_exc_info
>
13183 ada_exceptions_list (const char *regexp
)
13185 if (regexp
== NULL
)
13186 return ada_exceptions_list_1 (NULL
);
13188 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13189 return ada_exceptions_list_1 (®
);
13192 /* Implement the "info exceptions" command. */
13195 info_exceptions_command (const char *regexp
, int from_tty
)
13197 struct gdbarch
*gdbarch
= get_current_arch ();
13199 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13201 if (regexp
!= NULL
)
13203 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13205 printf_filtered (_("All defined Ada exceptions:\n"));
13207 for (const ada_exc_info
&info
: exceptions
)
13208 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13212 /* Information about operators given special treatment in functions
13214 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13216 #define ADA_OPERATORS \
13217 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13218 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13219 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13220 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13221 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13222 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13223 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13224 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13225 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13226 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13227 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13228 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13229 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13230 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13231 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13232 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13233 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13234 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13235 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13238 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13241 switch (exp
->elts
[pc
- 1].opcode
)
13244 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13247 #define OP_DEFN(op, len, args, binop) \
13248 case op: *oplenp = len; *argsp = args; break;
13254 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13259 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13264 /* Implementation of the exp_descriptor method operator_check. */
13267 ada_operator_check (struct expression
*exp
, int pos
,
13268 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13271 const union exp_element
*const elts
= exp
->elts
;
13272 struct type
*type
= NULL
;
13274 switch (elts
[pos
].opcode
)
13276 case UNOP_IN_RANGE
:
13278 type
= elts
[pos
+ 1].type
;
13282 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13285 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13287 if (type
&& TYPE_OBJFILE (type
)
13288 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13294 /* As for operator_length, but assumes PC is pointing at the first
13295 element of the operator, and gives meaningful results only for the
13296 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13299 ada_forward_operator_length (struct expression
*exp
, int pc
,
13300 int *oplenp
, int *argsp
)
13302 switch (exp
->elts
[pc
].opcode
)
13305 *oplenp
= *argsp
= 0;
13308 #define OP_DEFN(op, len, args, binop) \
13309 case op: *oplenp = len; *argsp = args; break;
13315 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13320 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13326 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13328 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13336 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13338 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13343 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13347 /* Ada attributes ('Foo). */
13350 case OP_ATR_LENGTH
:
13354 case OP_ATR_MODULUS
:
13361 case UNOP_IN_RANGE
:
13363 /* XXX: gdb_sprint_host_address, type_sprint */
13364 fprintf_filtered (stream
, _("Type @"));
13365 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13366 fprintf_filtered (stream
, " (");
13367 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13368 fprintf_filtered (stream
, ")");
13370 case BINOP_IN_BOUNDS
:
13371 fprintf_filtered (stream
, " (%d)",
13372 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13374 case TERNOP_IN_RANGE
:
13379 case OP_DISCRETE_RANGE
:
13380 case OP_POSITIONAL
:
13387 char *name
= &exp
->elts
[elt
+ 2].string
;
13388 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13390 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13395 return dump_subexp_body_standard (exp
, stream
, elt
);
13399 for (i
= 0; i
< nargs
; i
+= 1)
13400 elt
= dump_subexp (exp
, stream
, elt
);
13405 /* The Ada extension of print_subexp (q.v.). */
13408 ada_print_subexp (struct expression
*exp
, int *pos
,
13409 struct ui_file
*stream
, enum precedence prec
)
13411 int oplen
, nargs
, i
;
13413 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13415 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13422 print_subexp_standard (exp
, pos
, stream
, prec
);
13426 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13429 case BINOP_IN_BOUNDS
:
13430 /* XXX: sprint_subexp */
13431 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13432 fputs_filtered (" in ", stream
);
13433 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13434 fputs_filtered ("'range", stream
);
13435 if (exp
->elts
[pc
+ 1].longconst
> 1)
13436 fprintf_filtered (stream
, "(%ld)",
13437 (long) exp
->elts
[pc
+ 1].longconst
);
13440 case TERNOP_IN_RANGE
:
13441 if (prec
>= PREC_EQUAL
)
13442 fputs_filtered ("(", stream
);
13443 /* XXX: sprint_subexp */
13444 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13445 fputs_filtered (" in ", stream
);
13446 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13447 fputs_filtered (" .. ", stream
);
13448 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13449 if (prec
>= PREC_EQUAL
)
13450 fputs_filtered (")", stream
);
13455 case OP_ATR_LENGTH
:
13459 case OP_ATR_MODULUS
:
13464 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13466 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13467 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13468 &type_print_raw_options
);
13472 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13473 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13478 for (tem
= 1; tem
< nargs
; tem
+= 1)
13480 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13481 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13483 fputs_filtered (")", stream
);
13488 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13489 fputs_filtered ("'(", stream
);
13490 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13491 fputs_filtered (")", stream
);
13494 case UNOP_IN_RANGE
:
13495 /* XXX: sprint_subexp */
13496 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13497 fputs_filtered (" in ", stream
);
13498 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13499 &type_print_raw_options
);
13502 case OP_DISCRETE_RANGE
:
13503 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13504 fputs_filtered ("..", stream
);
13505 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13509 fputs_filtered ("others => ", stream
);
13510 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13514 for (i
= 0; i
< nargs
-1; i
+= 1)
13517 fputs_filtered ("|", stream
);
13518 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13520 fputs_filtered (" => ", stream
);
13521 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13524 case OP_POSITIONAL
:
13525 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13529 fputs_filtered ("(", stream
);
13530 for (i
= 0; i
< nargs
; i
+= 1)
13533 fputs_filtered (", ", stream
);
13534 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13536 fputs_filtered (")", stream
);
13541 /* Table mapping opcodes into strings for printing operators
13542 and precedences of the operators. */
13544 static const struct op_print ada_op_print_tab
[] = {
13545 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13546 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13547 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13548 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13549 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13550 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13551 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13552 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13553 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13554 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13555 {">", BINOP_GTR
, PREC_ORDER
, 0},
13556 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13557 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13558 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13559 {"+", BINOP_ADD
, PREC_ADD
, 0},
13560 {"-", BINOP_SUB
, PREC_ADD
, 0},
13561 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13562 {"*", BINOP_MUL
, PREC_MUL
, 0},
13563 {"/", BINOP_DIV
, PREC_MUL
, 0},
13564 {"rem", BINOP_REM
, PREC_MUL
, 0},
13565 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13566 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13567 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13568 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13569 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13570 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13571 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13572 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13573 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13574 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13575 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13576 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13579 /* Language vector */
13581 static const struct exp_descriptor ada_exp_descriptor
= {
13583 ada_operator_length
,
13584 ada_operator_check
,
13585 ada_dump_subexp_body
,
13586 ada_evaluate_subexp
13589 /* symbol_name_matcher_ftype adapter for wild_match. */
13592 do_wild_match (const char *symbol_search_name
,
13593 const lookup_name_info
&lookup_name
,
13594 completion_match_result
*comp_match_res
)
13596 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13599 /* symbol_name_matcher_ftype adapter for full_match. */
13602 do_full_match (const char *symbol_search_name
,
13603 const lookup_name_info
&lookup_name
,
13604 completion_match_result
*comp_match_res
)
13606 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13609 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13612 do_exact_match (const char *symbol_search_name
,
13613 const lookup_name_info
&lookup_name
,
13614 completion_match_result
*comp_match_res
)
13616 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13619 /* Build the Ada lookup name for LOOKUP_NAME. */
13621 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13623 gdb::string_view user_name
= lookup_name
.name ();
13625 if (user_name
[0] == '<')
13627 if (user_name
.back () == '>')
13629 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13632 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13633 m_encoded_p
= true;
13634 m_verbatim_p
= true;
13635 m_wild_match_p
= false;
13636 m_standard_p
= false;
13640 m_verbatim_p
= false;
13642 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13646 const char *folded
= ada_fold_name (user_name
);
13647 m_encoded_name
= ada_encode_1 (folded
, false);
13648 if (m_encoded_name
.empty ())
13649 m_encoded_name
= gdb::to_string (user_name
);
13652 m_encoded_name
= gdb::to_string (user_name
);
13654 /* Handle the 'package Standard' special case. See description
13655 of m_standard_p. */
13656 if (startswith (m_encoded_name
.c_str (), "standard__"))
13658 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13659 m_standard_p
= true;
13662 m_standard_p
= false;
13664 /* If the name contains a ".", then the user is entering a fully
13665 qualified entity name, and the match must not be done in wild
13666 mode. Similarly, if the user wants to complete what looks
13667 like an encoded name, the match must not be done in wild
13668 mode. Also, in the standard__ special case always do
13669 non-wild matching. */
13671 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13674 && user_name
.find ('.') == std::string::npos
);
13678 /* symbol_name_matcher_ftype method for Ada. This only handles
13679 completion mode. */
13682 ada_symbol_name_matches (const char *symbol_search_name
,
13683 const lookup_name_info
&lookup_name
,
13684 completion_match_result
*comp_match_res
)
13686 return lookup_name
.ada ().matches (symbol_search_name
,
13687 lookup_name
.match_type (),
13691 /* A name matcher that matches the symbol name exactly, with
13695 literal_symbol_name_matcher (const char *symbol_search_name
,
13696 const lookup_name_info
&lookup_name
,
13697 completion_match_result
*comp_match_res
)
13699 gdb::string_view name_view
= lookup_name
.name ();
13701 if (lookup_name
.completion_mode ()
13702 ? (strncmp (symbol_search_name
, name_view
.data (),
13703 name_view
.size ()) == 0)
13704 : symbol_search_name
== name_view
)
13706 if (comp_match_res
!= NULL
)
13707 comp_match_res
->set_match (symbol_search_name
);
13714 /* Implement the "get_symbol_name_matcher" language_defn method for
13717 static symbol_name_matcher_ftype
*
13718 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13720 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13721 return literal_symbol_name_matcher
;
13723 if (lookup_name
.completion_mode ())
13724 return ada_symbol_name_matches
;
13727 if (lookup_name
.ada ().wild_match_p ())
13728 return do_wild_match
;
13729 else if (lookup_name
.ada ().verbatim_p ())
13730 return do_exact_match
;
13732 return do_full_match
;
13736 /* Class representing the Ada language. */
13738 class ada_language
: public language_defn
13742 : language_defn (language_ada
)
13745 /* See language.h. */
13747 const char *name () const override
13750 /* See language.h. */
13752 const char *natural_name () const override
13755 /* See language.h. */
13757 const std::vector
<const char *> &filename_extensions () const override
13759 static const std::vector
<const char *> extensions
13760 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13764 /* Print an array element index using the Ada syntax. */
13766 void print_array_index (struct type
*index_type
,
13768 struct ui_file
*stream
,
13769 const value_print_options
*options
) const override
13771 struct value
*index_value
= val_atr (index_type
, index
);
13773 value_print (index_value
, stream
, options
);
13774 fprintf_filtered (stream
, " => ");
13777 /* Implement the "read_var_value" language_defn method for Ada. */
13779 struct value
*read_var_value (struct symbol
*var
,
13780 const struct block
*var_block
,
13781 struct frame_info
*frame
) const override
13783 /* The only case where default_read_var_value is not sufficient
13784 is when VAR is a renaming... */
13785 if (frame
!= nullptr)
13787 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13788 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13789 return ada_read_renaming_var_value (var
, frame_block
);
13792 /* This is a typical case where we expect the default_read_var_value
13793 function to work. */
13794 return language_defn::read_var_value (var
, var_block
, frame
);
13797 /* See language.h. */
13798 void language_arch_info (struct gdbarch
*gdbarch
,
13799 struct language_arch_info
*lai
) const override
13801 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13803 /* Helper function to allow shorter lines below. */
13804 auto add
= [&] (struct type
*t
)
13806 lai
->add_primitive_type (t
);
13809 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13811 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13812 0, "long_integer"));
13813 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13814 0, "short_integer"));
13815 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13817 lai
->set_string_char_type (char_type
);
13819 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13820 "float", gdbarch_float_format (gdbarch
)));
13821 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13822 "long_float", gdbarch_double_format (gdbarch
)));
13823 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13824 0, "long_long_integer"));
13825 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13827 gdbarch_long_double_format (gdbarch
)));
13828 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13830 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13832 add (builtin
->builtin_void
);
13834 struct type
*system_addr_ptr
13835 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13837 system_addr_ptr
->set_name ("system__address");
13838 add (system_addr_ptr
);
13840 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13841 type. This is a signed integral type whose size is the same as
13842 the size of addresses. */
13843 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13844 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13845 "storage_offset"));
13847 lai
->set_bool_type (builtin
->builtin_bool
);
13850 /* See language.h. */
13852 bool iterate_over_symbols
13853 (const struct block
*block
, const lookup_name_info
&name
,
13854 domain_enum domain
,
13855 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13857 std::vector
<struct block_symbol
> results
;
13859 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13860 for (block_symbol
&sym
: results
)
13862 if (!callback (&sym
))
13869 /* See language.h. */
13870 bool sniff_from_mangled_name (const char *mangled
,
13871 char **out
) const override
13873 std::string demangled
= ada_decode (mangled
);
13877 if (demangled
!= mangled
&& demangled
[0] != '<')
13879 /* Set the gsymbol language to Ada, but still return 0.
13880 Two reasons for that:
13882 1. For Ada, we prefer computing the symbol's decoded name
13883 on the fly rather than pre-compute it, in order to save
13884 memory (Ada projects are typically very large).
13886 2. There are some areas in the definition of the GNAT
13887 encoding where, with a bit of bad luck, we might be able
13888 to decode a non-Ada symbol, generating an incorrect
13889 demangled name (Eg: names ending with "TB" for instance
13890 are identified as task bodies and so stripped from
13891 the decoded name returned).
13893 Returning true, here, but not setting *DEMANGLED, helps us get
13894 a little bit of the best of both worlds. Because we're last,
13895 we should not affect any of the other languages that were
13896 able to demangle the symbol before us; we get to correctly
13897 tag Ada symbols as such; and even if we incorrectly tagged a
13898 non-Ada symbol, which should be rare, any routing through the
13899 Ada language should be transparent (Ada tries to behave much
13900 like C/C++ with non-Ada symbols). */
13907 /* See language.h. */
13909 char *demangle_symbol (const char *mangled
, int options
) const override
13911 return ada_la_decode (mangled
, options
);
13914 /* See language.h. */
13916 void print_type (struct type
*type
, const char *varstring
,
13917 struct ui_file
*stream
, int show
, int level
,
13918 const struct type_print_options
*flags
) const override
13920 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13923 /* See language.h. */
13925 const char *word_break_characters (void) const override
13927 return ada_completer_word_break_characters
;
13930 /* See language.h. */
13932 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13933 complete_symbol_mode mode
,
13934 symbol_name_match_type name_match_type
,
13935 const char *text
, const char *word
,
13936 enum type_code code
) const override
13938 struct symbol
*sym
;
13939 const struct block
*b
, *surrounding_static_block
= 0;
13940 struct block_iterator iter
;
13942 gdb_assert (code
== TYPE_CODE_UNDEF
);
13944 lookup_name_info
lookup_name (text
, name_match_type
, true);
13946 /* First, look at the partial symtab symbols. */
13947 expand_symtabs_matching (NULL
,
13953 /* At this point scan through the misc symbol vectors and add each
13954 symbol you find to the list. Eventually we want to ignore
13955 anything that isn't a text symbol (everything else will be
13956 handled by the psymtab code above). */
13958 for (objfile
*objfile
: current_program_space
->objfiles ())
13960 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13964 if (completion_skip_symbol (mode
, msymbol
))
13967 language symbol_language
= msymbol
->language ();
13969 /* Ada minimal symbols won't have their language set to Ada. If
13970 we let completion_list_add_name compare using the
13971 default/C-like matcher, then when completing e.g., symbols in a
13972 package named "pck", we'd match internal Ada symbols like
13973 "pckS", which are invalid in an Ada expression, unless you wrap
13974 them in '<' '>' to request a verbatim match.
13976 Unfortunately, some Ada encoded names successfully demangle as
13977 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13978 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13979 with the wrong language set. Paper over that issue here. */
13980 if (symbol_language
== language_auto
13981 || symbol_language
== language_cplus
)
13982 symbol_language
= language_ada
;
13984 completion_list_add_name (tracker
,
13986 msymbol
->linkage_name (),
13987 lookup_name
, text
, word
);
13991 /* Search upwards from currently selected frame (so that we can
13992 complete on local vars. */
13994 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13996 if (!BLOCK_SUPERBLOCK (b
))
13997 surrounding_static_block
= b
; /* For elmin of dups */
13999 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14001 if (completion_skip_symbol (mode
, sym
))
14004 completion_list_add_name (tracker
,
14006 sym
->linkage_name (),
14007 lookup_name
, text
, word
);
14011 /* Go through the symtabs and check the externs and statics for
14012 symbols which match. */
14014 for (objfile
*objfile
: current_program_space
->objfiles ())
14016 for (compunit_symtab
*s
: objfile
->compunits ())
14019 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14020 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14022 if (completion_skip_symbol (mode
, sym
))
14025 completion_list_add_name (tracker
,
14027 sym
->linkage_name (),
14028 lookup_name
, text
, word
);
14033 for (objfile
*objfile
: current_program_space
->objfiles ())
14035 for (compunit_symtab
*s
: objfile
->compunits ())
14038 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14039 /* Don't do this block twice. */
14040 if (b
== surrounding_static_block
)
14042 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14044 if (completion_skip_symbol (mode
, sym
))
14047 completion_list_add_name (tracker
,
14049 sym
->linkage_name (),
14050 lookup_name
, text
, word
);
14056 /* See language.h. */
14058 gdb::unique_xmalloc_ptr
<char> watch_location_expression
14059 (struct type
*type
, CORE_ADDR addr
) const override
14061 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
14062 std::string name
= type_to_string (type
);
14063 return gdb::unique_xmalloc_ptr
<char>
14064 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
14067 /* See language.h. */
14069 void value_print (struct value
*val
, struct ui_file
*stream
,
14070 const struct value_print_options
*options
) const override
14072 return ada_value_print (val
, stream
, options
);
14075 /* See language.h. */
14077 void value_print_inner
14078 (struct value
*val
, struct ui_file
*stream
, int recurse
,
14079 const struct value_print_options
*options
) const override
14081 return ada_value_print_inner (val
, stream
, recurse
, options
);
14084 /* See language.h. */
14086 struct block_symbol lookup_symbol_nonlocal
14087 (const char *name
, const struct block
*block
,
14088 const domain_enum domain
) const override
14090 struct block_symbol sym
;
14092 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
14093 if (sym
.symbol
!= NULL
)
14096 /* If we haven't found a match at this point, try the primitive
14097 types. In other languages, this search is performed before
14098 searching for global symbols in order to short-circuit that
14099 global-symbol search if it happens that the name corresponds
14100 to a primitive type. But we cannot do the same in Ada, because
14101 it is perfectly legitimate for a program to declare a type which
14102 has the same name as a standard type. If looking up a type in
14103 that situation, we have traditionally ignored the primitive type
14104 in favor of user-defined types. This is why, unlike most other
14105 languages, we search the primitive types this late and only after
14106 having searched the global symbols without success. */
14108 if (domain
== VAR_DOMAIN
)
14110 struct gdbarch
*gdbarch
;
14113 gdbarch
= target_gdbarch ();
14115 gdbarch
= block_gdbarch (block
);
14117 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
14118 if (sym
.symbol
!= NULL
)
14125 /* See language.h. */
14127 int parser (struct parser_state
*ps
) const override
14129 warnings_issued
= 0;
14130 return ada_parse (ps
);
14135 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
14136 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
14137 namespace) and converts operators that are user-defined into
14138 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
14139 a preferred result type [at the moment, only type void has any
14140 effect---causing procedures to be preferred over functions in calls].
14141 A null CONTEXT_TYPE indicates that a non-void return type is
14142 preferred. May change (expand) *EXP. */
14144 void post_parser (expression_up
*expp
, int void_context_p
, int completing
,
14145 innermost_block_tracker
*tracker
) const override
14147 struct type
*context_type
= NULL
;
14150 if (void_context_p
)
14151 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14153 resolve_subexp (expp
, &pc
, 1, context_type
, completing
, tracker
);
14156 /* See language.h. */
14158 void emitchar (int ch
, struct type
*chtype
,
14159 struct ui_file
*stream
, int quoter
) const override
14161 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14164 /* See language.h. */
14166 void printchar (int ch
, struct type
*chtype
,
14167 struct ui_file
*stream
) const override
14169 ada_printchar (ch
, chtype
, stream
);
14172 /* See language.h. */
14174 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14175 const gdb_byte
*string
, unsigned int length
,
14176 const char *encoding
, int force_ellipses
,
14177 const struct value_print_options
*options
) const override
14179 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14180 force_ellipses
, options
);
14183 /* See language.h. */
14185 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14186 struct ui_file
*stream
) const override
14188 ada_print_typedef (type
, new_symbol
, stream
);
14191 /* See language.h. */
14193 bool is_string_type_p (struct type
*type
) const override
14195 return ada_is_string_type (type
);
14198 /* See language.h. */
14200 const char *struct_too_deep_ellipsis () const override
14201 { return "(...)"; }
14203 /* See language.h. */
14205 bool c_style_arrays_p () const override
14208 /* See language.h. */
14210 bool store_sym_names_in_linkage_form_p () const override
14213 /* See language.h. */
14215 const struct lang_varobj_ops
*varobj_ops () const override
14216 { return &ada_varobj_ops
; }
14218 /* See language.h. */
14220 const struct exp_descriptor
*expression_ops () const override
14221 { return &ada_exp_descriptor
; }
14223 /* See language.h. */
14225 const struct op_print
*opcode_print_table () const override
14226 { return ada_op_print_tab
; }
14229 /* See language.h. */
14231 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14232 (const lookup_name_info
&lookup_name
) const override
14234 return ada_get_symbol_name_matcher (lookup_name
);
14238 /* Single instance of the Ada language class. */
14240 static ada_language ada_language_defn
;
14242 /* Command-list for the "set/show ada" prefix command. */
14243 static struct cmd_list_element
*set_ada_list
;
14244 static struct cmd_list_element
*show_ada_list
;
14247 initialize_ada_catchpoint_ops (void)
14249 struct breakpoint_ops
*ops
;
14251 initialize_breakpoint_ops ();
14253 ops
= &catch_exception_breakpoint_ops
;
14254 *ops
= bkpt_breakpoint_ops
;
14255 ops
->allocate_location
= allocate_location_exception
;
14256 ops
->re_set
= re_set_exception
;
14257 ops
->check_status
= check_status_exception
;
14258 ops
->print_it
= print_it_exception
;
14259 ops
->print_one
= print_one_exception
;
14260 ops
->print_mention
= print_mention_exception
;
14261 ops
->print_recreate
= print_recreate_exception
;
14263 ops
= &catch_exception_unhandled_breakpoint_ops
;
14264 *ops
= bkpt_breakpoint_ops
;
14265 ops
->allocate_location
= allocate_location_exception
;
14266 ops
->re_set
= re_set_exception
;
14267 ops
->check_status
= check_status_exception
;
14268 ops
->print_it
= print_it_exception
;
14269 ops
->print_one
= print_one_exception
;
14270 ops
->print_mention
= print_mention_exception
;
14271 ops
->print_recreate
= print_recreate_exception
;
14273 ops
= &catch_assert_breakpoint_ops
;
14274 *ops
= bkpt_breakpoint_ops
;
14275 ops
->allocate_location
= allocate_location_exception
;
14276 ops
->re_set
= re_set_exception
;
14277 ops
->check_status
= check_status_exception
;
14278 ops
->print_it
= print_it_exception
;
14279 ops
->print_one
= print_one_exception
;
14280 ops
->print_mention
= print_mention_exception
;
14281 ops
->print_recreate
= print_recreate_exception
;
14283 ops
= &catch_handlers_breakpoint_ops
;
14284 *ops
= bkpt_breakpoint_ops
;
14285 ops
->allocate_location
= allocate_location_exception
;
14286 ops
->re_set
= re_set_exception
;
14287 ops
->check_status
= check_status_exception
;
14288 ops
->print_it
= print_it_exception
;
14289 ops
->print_one
= print_one_exception
;
14290 ops
->print_mention
= print_mention_exception
;
14291 ops
->print_recreate
= print_recreate_exception
;
14294 /* This module's 'new_objfile' observer. */
14297 ada_new_objfile_observer (struct objfile
*objfile
)
14299 ada_clear_symbol_cache ();
14302 /* This module's 'free_objfile' observer. */
14305 ada_free_objfile_observer (struct objfile
*objfile
)
14307 ada_clear_symbol_cache ();
14310 void _initialize_ada_language ();
14312 _initialize_ada_language ()
14314 initialize_ada_catchpoint_ops ();
14316 add_basic_prefix_cmd ("ada", no_class
,
14317 _("Prefix command for changing Ada-specific settings."),
14318 &set_ada_list
, "set ada ", 0, &setlist
);
14320 add_show_prefix_cmd ("ada", no_class
,
14321 _("Generic command for showing Ada-specific settings."),
14322 &show_ada_list
, "show ada ", 0, &showlist
);
14324 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14325 &trust_pad_over_xvs
, _("\
14326 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14327 Show whether an optimization trusting PAD types over XVS types is activated."),
14329 This is related to the encoding used by the GNAT compiler. The debugger\n\
14330 should normally trust the contents of PAD types, but certain older versions\n\
14331 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14332 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14333 work around this bug. It is always safe to turn this option \"off\", but\n\
14334 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14335 this option to \"off\" unless necessary."),
14336 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14338 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14339 &print_signatures
, _("\
14340 Enable or disable the output of formal and return types for functions in the \
14341 overloads selection menu."), _("\
14342 Show whether the output of formal and return types for functions in the \
14343 overloads selection menu is activated."),
14344 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14346 add_catch_command ("exception", _("\
14347 Catch Ada exceptions, when raised.\n\
14348 Usage: catch exception [ARG] [if CONDITION]\n\
14349 Without any argument, stop when any Ada exception is raised.\n\
14350 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14351 being raised does not have a handler (and will therefore lead to the task's\n\
14353 Otherwise, the catchpoint only stops when the name of the exception being\n\
14354 raised is the same as ARG.\n\
14355 CONDITION is a boolean expression that is evaluated to see whether the\n\
14356 exception should cause a stop."),
14357 catch_ada_exception_command
,
14358 catch_ada_completer
,
14362 add_catch_command ("handlers", _("\
14363 Catch Ada exceptions, when handled.\n\
14364 Usage: catch handlers [ARG] [if CONDITION]\n\
14365 Without any argument, stop when any Ada exception is handled.\n\
14366 With an argument, catch only exceptions with the given name.\n\
14367 CONDITION is a boolean expression that is evaluated to see whether the\n\
14368 exception should cause a stop."),
14369 catch_ada_handlers_command
,
14370 catch_ada_completer
,
14373 add_catch_command ("assert", _("\
14374 Catch failed Ada assertions, when raised.\n\
14375 Usage: catch assert [if CONDITION]\n\
14376 CONDITION is a boolean expression that is evaluated to see whether the\n\
14377 exception should cause a stop."),
14378 catch_assert_command
,
14383 varsize_limit
= 65536;
14384 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14385 &varsize_limit
, _("\
14386 Set the maximum number of bytes allowed in a variable-size object."), _("\
14387 Show the maximum number of bytes allowed in a variable-size object."), _("\
14388 Attempts to access an object whose size is not a compile-time constant\n\
14389 and exceeds this limit will cause an error."),
14390 NULL
, NULL
, &setlist
, &showlist
);
14392 add_info ("exceptions", info_exceptions_command
,
14394 List all Ada exception names.\n\
14395 Usage: info exceptions [REGEXP]\n\
14396 If a regular expression is passed as an argument, only those matching\n\
14397 the regular expression are listed."));
14399 add_basic_prefix_cmd ("ada", class_maintenance
,
14400 _("Set Ada maintenance-related variables."),
14401 &maint_set_ada_cmdlist
, "maintenance set ada ",
14402 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14404 add_show_prefix_cmd ("ada", class_maintenance
,
14405 _("Show Ada maintenance-related variables."),
14406 &maint_show_ada_cmdlist
, "maintenance show ada ",
14407 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14409 add_setshow_boolean_cmd
14410 ("ignore-descriptive-types", class_maintenance
,
14411 &ada_ignore_descriptive_types_p
,
14412 _("Set whether descriptive types generated by GNAT should be ignored."),
14413 _("Show whether descriptive types generated by GNAT should be ignored."),
14415 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14416 DWARF attribute."),
14417 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14419 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14420 NULL
, xcalloc
, xfree
);
14422 /* The ada-lang observers. */
14423 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14424 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14425 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);