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 *, std::vector
<LONGEST
> &,
226 static void aggregate_assign_positional (struct value
*, struct value
*,
228 int *, std::vector
<LONGEST
> &,
232 static void aggregate_assign_others (struct value
*, struct value
*,
234 int *, std::vector
<LONGEST
> &,
238 static void add_component_interval (LONGEST
, LONGEST
, std::vector
<LONGEST
> &);
241 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
244 static void ada_forward_operator_length (struct expression
*, int, int *,
247 static struct type
*ada_find_any_type (const char *name
);
249 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
250 (const lookup_name_info
&lookup_name
);
254 /* The result of a symbol lookup to be stored in our symbol cache. */
258 /* The name used to perform the lookup. */
260 /* The namespace used during the lookup. */
262 /* The symbol returned by the lookup, or NULL if no matching symbol
265 /* The block where the symbol was found, or NULL if no matching
267 const struct block
*block
;
268 /* A pointer to the next entry with the same hash. */
269 struct cache_entry
*next
;
272 /* The Ada symbol cache, used to store the result of Ada-mode symbol
273 lookups in the course of executing the user's commands.
275 The cache is implemented using a simple, fixed-sized hash.
276 The size is fixed on the grounds that there are not likely to be
277 all that many symbols looked up during any given session, regardless
278 of the size of the symbol table. If we decide to go to a resizable
279 table, let's just use the stuff from libiberty instead. */
281 #define HASH_SIZE 1009
283 struct ada_symbol_cache
285 /* An obstack used to store the entries in our cache. */
286 struct obstack cache_space
;
288 /* The root of the hash table used to implement our symbol cache. */
289 struct cache_entry
*root
[HASH_SIZE
];
292 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
294 /* Maximum-sized dynamic type. */
295 static unsigned int varsize_limit
;
297 static const char ada_completer_word_break_characters
[] =
299 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
301 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
304 /* The name of the symbol to use to get the name of the main subprogram. */
305 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
306 = "__gnat_ada_main_program_name";
308 /* Limit on the number of warnings to raise per expression evaluation. */
309 static int warning_limit
= 2;
311 /* Number of warning messages issued; reset to 0 by cleanups after
312 expression evaluation. */
313 static int warnings_issued
= 0;
315 static const char * const known_runtime_file_name_patterns
[] = {
316 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
319 static const char * const known_auxiliary_function_name_patterns
[] = {
320 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
323 /* Maintenance-related settings for this module. */
325 static struct cmd_list_element
*maint_set_ada_cmdlist
;
326 static struct cmd_list_element
*maint_show_ada_cmdlist
;
328 /* The "maintenance ada set/show ignore-descriptive-type" value. */
330 static bool ada_ignore_descriptive_types_p
= false;
332 /* Inferior-specific data. */
334 /* Per-inferior data for this module. */
336 struct ada_inferior_data
338 /* The ada__tags__type_specific_data type, which is used when decoding
339 tagged types. With older versions of GNAT, this type was directly
340 accessible through a component ("tsd") in the object tag. But this
341 is no longer the case, so we cache it for each inferior. */
342 struct type
*tsd_type
= nullptr;
344 /* The exception_support_info data. This data is used to determine
345 how to implement support for Ada exception catchpoints in a given
347 const struct exception_support_info
*exception_info
= nullptr;
350 /* Our key to this module's inferior data. */
351 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
353 /* Return our inferior data for the given inferior (INF).
355 This function always returns a valid pointer to an allocated
356 ada_inferior_data structure. If INF's inferior data has not
357 been previously set, this functions creates a new one with all
358 fields set to zero, sets INF's inferior to it, and then returns
359 a pointer to that newly allocated ada_inferior_data. */
361 static struct ada_inferior_data
*
362 get_ada_inferior_data (struct inferior
*inf
)
364 struct ada_inferior_data
*data
;
366 data
= ada_inferior_data
.get (inf
);
368 data
= ada_inferior_data
.emplace (inf
);
373 /* Perform all necessary cleanups regarding our module's inferior data
374 that is required after the inferior INF just exited. */
377 ada_inferior_exit (struct inferior
*inf
)
379 ada_inferior_data
.clear (inf
);
383 /* program-space-specific data. */
385 /* This module's per-program-space data. */
386 struct ada_pspace_data
390 if (sym_cache
!= NULL
)
391 ada_free_symbol_cache (sym_cache
);
394 /* The Ada symbol cache. */
395 struct ada_symbol_cache
*sym_cache
= nullptr;
398 /* Key to our per-program-space data. */
399 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
401 /* Return this module's data for the given program space (PSPACE).
402 If not is found, add a zero'ed one now.
404 This function always returns a valid object. */
406 static struct ada_pspace_data
*
407 get_ada_pspace_data (struct program_space
*pspace
)
409 struct ada_pspace_data
*data
;
411 data
= ada_pspace_data_handle
.get (pspace
);
413 data
= ada_pspace_data_handle
.emplace (pspace
);
420 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
421 all typedef layers have been peeled. Otherwise, return TYPE.
423 Normally, we really expect a typedef type to only have 1 typedef layer.
424 In other words, we really expect the target type of a typedef type to be
425 a non-typedef type. This is particularly true for Ada units, because
426 the language does not have a typedef vs not-typedef distinction.
427 In that respect, the Ada compiler has been trying to eliminate as many
428 typedef definitions in the debugging information, since they generally
429 do not bring any extra information (we still use typedef under certain
430 circumstances related mostly to the GNAT encoding).
432 Unfortunately, we have seen situations where the debugging information
433 generated by the compiler leads to such multiple typedef layers. For
434 instance, consider the following example with stabs:
436 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
437 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
439 This is an error in the debugging information which causes type
440 pck__float_array___XUP to be defined twice, and the second time,
441 it is defined as a typedef of a typedef.
443 This is on the fringe of legality as far as debugging information is
444 concerned, and certainly unexpected. But it is easy to handle these
445 situations correctly, so we can afford to be lenient in this case. */
448 ada_typedef_target_type (struct type
*type
)
450 while (type
->code () == TYPE_CODE_TYPEDEF
)
451 type
= TYPE_TARGET_TYPE (type
);
455 /* Given DECODED_NAME a string holding a symbol name in its
456 decoded form (ie using the Ada dotted notation), returns
457 its unqualified name. */
460 ada_unqualified_name (const char *decoded_name
)
464 /* If the decoded name starts with '<', it means that the encoded
465 name does not follow standard naming conventions, and thus that
466 it is not your typical Ada symbol name. Trying to unqualify it
467 is therefore pointless and possibly erroneous. */
468 if (decoded_name
[0] == '<')
471 result
= strrchr (decoded_name
, '.');
473 result
++; /* Skip the dot... */
475 result
= decoded_name
;
480 /* Return a string starting with '<', followed by STR, and '>'. */
483 add_angle_brackets (const char *str
)
485 return string_printf ("<%s>", str
);
488 /* Assuming V points to an array of S objects, make sure that it contains at
489 least M objects, updating V and S as necessary. */
491 #define GROW_VECT(v, s, m) \
492 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
494 /* Assuming VECT points to an array of *SIZE objects of size
495 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
496 updating *SIZE as necessary and returning the (new) array. */
499 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
501 if (*size
< min_size
)
504 if (*size
< min_size
)
506 vect
= xrealloc (vect
, *size
* element_size
);
511 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
512 suffix of FIELD_NAME beginning "___". */
515 field_name_match (const char *field_name
, const char *target
)
517 int len
= strlen (target
);
520 (strncmp (field_name
, target
, len
) == 0
521 && (field_name
[len
] == '\0'
522 || (startswith (field_name
+ len
, "___")
523 && strcmp (field_name
+ strlen (field_name
) - 6,
528 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
529 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
530 and return its index. This function also handles fields whose name
531 have ___ suffixes because the compiler sometimes alters their name
532 by adding such a suffix to represent fields with certain constraints.
533 If the field could not be found, return a negative number if
534 MAYBE_MISSING is set. Otherwise raise an error. */
537 ada_get_field_index (const struct type
*type
, const char *field_name
,
541 struct type
*struct_type
= check_typedef ((struct type
*) type
);
543 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
544 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
548 error (_("Unable to find field %s in struct %s. Aborting"),
549 field_name
, struct_type
->name ());
554 /* The length of the prefix of NAME prior to any "___" suffix. */
557 ada_name_prefix_len (const char *name
)
563 const char *p
= strstr (name
, "___");
566 return strlen (name
);
572 /* Return non-zero if SUFFIX is a suffix of STR.
573 Return zero if STR is null. */
576 is_suffix (const char *str
, const char *suffix
)
583 len2
= strlen (suffix
);
584 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
587 /* The contents of value VAL, treated as a value of type TYPE. The
588 result is an lval in memory if VAL is. */
590 static struct value
*
591 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
593 type
= ada_check_typedef (type
);
594 if (value_type (val
) == type
)
598 struct value
*result
;
600 /* Make sure that the object size is not unreasonable before
601 trying to allocate some memory for it. */
602 ada_ensure_varsize_limit (type
);
605 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
606 result
= allocate_value_lazy (type
);
609 result
= allocate_value (type
);
610 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
612 set_value_component_location (result
, val
);
613 set_value_bitsize (result
, value_bitsize (val
));
614 set_value_bitpos (result
, value_bitpos (val
));
615 if (VALUE_LVAL (result
) == lval_memory
)
616 set_value_address (result
, value_address (val
));
621 static const gdb_byte
*
622 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
627 return valaddr
+ offset
;
631 cond_offset_target (CORE_ADDR address
, long offset
)
636 return address
+ offset
;
639 /* Issue a warning (as for the definition of warning in utils.c, but
640 with exactly one argument rather than ...), unless the limit on the
641 number of warnings has passed during the evaluation of the current
644 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
645 provided by "complaint". */
646 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
649 lim_warning (const char *format
, ...)
653 va_start (args
, format
);
654 warnings_issued
+= 1;
655 if (warnings_issued
<= warning_limit
)
656 vwarning (format
, args
);
661 /* Issue an error if the size of an object of type T is unreasonable,
662 i.e. if it would be a bad idea to allocate a value of this type in
666 ada_ensure_varsize_limit (const struct type
*type
)
668 if (TYPE_LENGTH (type
) > varsize_limit
)
669 error (_("object size is larger than varsize-limit"));
672 /* Maximum value of a SIZE-byte signed integer type. */
674 max_of_size (int size
)
676 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
678 return top_bit
| (top_bit
- 1);
681 /* Minimum value of a SIZE-byte signed integer type. */
683 min_of_size (int size
)
685 return -max_of_size (size
) - 1;
688 /* Maximum value of a SIZE-byte unsigned integer type. */
690 umax_of_size (int size
)
692 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
694 return top_bit
| (top_bit
- 1);
697 /* Maximum value of integral type T, as a signed quantity. */
699 max_of_type (struct type
*t
)
701 if (t
->is_unsigned ())
702 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
704 return max_of_size (TYPE_LENGTH (t
));
707 /* Minimum value of integral type T, as a signed quantity. */
709 min_of_type (struct type
*t
)
711 if (t
->is_unsigned ())
714 return min_of_size (TYPE_LENGTH (t
));
717 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
719 ada_discrete_type_high_bound (struct type
*type
)
721 type
= resolve_dynamic_type (type
, {}, 0);
722 switch (type
->code ())
724 case TYPE_CODE_RANGE
:
726 const dynamic_prop
&high
= type
->bounds ()->high
;
728 if (high
.kind () == PROP_CONST
)
729 return high
.const_val ();
732 gdb_assert (high
.kind () == PROP_UNDEFINED
);
734 /* This happens when trying to evaluate a type's dynamic bound
735 without a live target. There is nothing relevant for us to
736 return here, so return 0. */
741 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
746 return max_of_type (type
);
748 error (_("Unexpected type in ada_discrete_type_high_bound."));
752 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
754 ada_discrete_type_low_bound (struct type
*type
)
756 type
= resolve_dynamic_type (type
, {}, 0);
757 switch (type
->code ())
759 case TYPE_CODE_RANGE
:
761 const dynamic_prop
&low
= type
->bounds ()->low
;
763 if (low
.kind () == PROP_CONST
)
764 return low
.const_val ();
767 gdb_assert (low
.kind () == PROP_UNDEFINED
);
769 /* This happens when trying to evaluate a type's dynamic bound
770 without a live target. There is nothing relevant for us to
771 return here, so return 0. */
776 return TYPE_FIELD_ENUMVAL (type
, 0);
781 return min_of_type (type
);
783 error (_("Unexpected type in ada_discrete_type_low_bound."));
787 /* The identity on non-range types. For range types, the underlying
788 non-range scalar type. */
791 get_base_type (struct type
*type
)
793 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
795 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
797 type
= TYPE_TARGET_TYPE (type
);
802 /* Return a decoded version of the given VALUE. This means returning
803 a value whose type is obtained by applying all the GNAT-specific
804 encodings, making the resulting type a static but standard description
805 of the initial type. */
808 ada_get_decoded_value (struct value
*value
)
810 struct type
*type
= ada_check_typedef (value_type (value
));
812 if (ada_is_array_descriptor_type (type
)
813 || (ada_is_constrained_packed_array_type (type
)
814 && type
->code () != TYPE_CODE_PTR
))
816 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
817 value
= ada_coerce_to_simple_array_ptr (value
);
819 value
= ada_coerce_to_simple_array (value
);
822 value
= ada_to_fixed_value (value
);
827 /* Same as ada_get_decoded_value, but with the given TYPE.
828 Because there is no associated actual value for this type,
829 the resulting type might be a best-effort approximation in
830 the case of dynamic types. */
833 ada_get_decoded_type (struct type
*type
)
835 type
= to_static_fixed_type (type
);
836 if (ada_is_constrained_packed_array_type (type
))
837 type
= ada_coerce_to_simple_array_type (type
);
843 /* Language Selection */
845 /* If the main program is in Ada, return language_ada, otherwise return LANG
846 (the main program is in Ada iif the adainit symbol is found). */
849 ada_update_initial_language (enum language lang
)
851 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
857 /* If the main procedure is written in Ada, then return its name.
858 The result is good until the next call. Return NULL if the main
859 procedure doesn't appear to be in Ada. */
864 struct bound_minimal_symbol msym
;
865 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
867 /* For Ada, the name of the main procedure is stored in a specific
868 string constant, generated by the binder. Look for that symbol,
869 extract its address, and then read that string. If we didn't find
870 that string, then most probably the main procedure is not written
872 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
874 if (msym
.minsym
!= NULL
)
876 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
877 if (main_program_name_addr
== 0)
878 error (_("Invalid address for Ada main program name."));
880 main_program_name
= target_read_string (main_program_name_addr
, 1024);
881 return main_program_name
.get ();
884 /* The main procedure doesn't seem to be in Ada. */
890 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
893 const struct ada_opname_map ada_opname_table
[] = {
894 {"Oadd", "\"+\"", BINOP_ADD
},
895 {"Osubtract", "\"-\"", BINOP_SUB
},
896 {"Omultiply", "\"*\"", BINOP_MUL
},
897 {"Odivide", "\"/\"", BINOP_DIV
},
898 {"Omod", "\"mod\"", BINOP_MOD
},
899 {"Orem", "\"rem\"", BINOP_REM
},
900 {"Oexpon", "\"**\"", BINOP_EXP
},
901 {"Olt", "\"<\"", BINOP_LESS
},
902 {"Ole", "\"<=\"", BINOP_LEQ
},
903 {"Ogt", "\">\"", BINOP_GTR
},
904 {"Oge", "\">=\"", BINOP_GEQ
},
905 {"Oeq", "\"=\"", BINOP_EQUAL
},
906 {"One", "\"/=\"", BINOP_NOTEQUAL
},
907 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
908 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
909 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
910 {"Oconcat", "\"&\"", BINOP_CONCAT
},
911 {"Oabs", "\"abs\"", UNOP_ABS
},
912 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
913 {"Oadd", "\"+\"", UNOP_PLUS
},
914 {"Osubtract", "\"-\"", UNOP_NEG
},
918 /* The "encoded" form of DECODED, according to GNAT conventions. If
919 THROW_ERRORS, throw an error if invalid operator name is found.
920 Otherwise, return the empty string in that case. */
923 ada_encode_1 (const char *decoded
, bool throw_errors
)
928 std::string encoding_buffer
;
929 for (const char *p
= decoded
; *p
!= '\0'; p
+= 1)
932 encoding_buffer
.append ("__");
935 const struct ada_opname_map
*mapping
;
937 for (mapping
= ada_opname_table
;
938 mapping
->encoded
!= NULL
939 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
941 if (mapping
->encoded
== NULL
)
944 error (_("invalid Ada operator name: %s"), p
);
948 encoding_buffer
.append (mapping
->encoded
);
952 encoding_buffer
.push_back (*p
);
955 return encoding_buffer
;
958 /* The "encoded" form of DECODED, according to GNAT conventions. */
961 ada_encode (const char *decoded
)
963 return ada_encode_1 (decoded
, true);
966 /* Return NAME folded to lower case, or, if surrounded by single
967 quotes, unfolded, but with the quotes stripped away. Result good
971 ada_fold_name (gdb::string_view name
)
973 static char *fold_buffer
= NULL
;
974 static size_t fold_buffer_size
= 0;
976 int len
= name
.size ();
977 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
981 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
982 fold_buffer
[len
- 2] = '\000';
988 for (i
= 0; i
< len
; i
+= 1)
989 fold_buffer
[i
] = tolower (name
[i
]);
990 fold_buffer
[i
] = '\0';
996 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
999 is_lower_alphanum (const char c
)
1001 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1004 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1005 This function saves in LEN the length of that same symbol name but
1006 without either of these suffixes:
1012 These are suffixes introduced by the compiler for entities such as
1013 nested subprogram for instance, in order to avoid name clashes.
1014 They do not serve any purpose for the debugger. */
1017 ada_remove_trailing_digits (const char *encoded
, int *len
)
1019 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1023 while (i
> 0 && isdigit (encoded
[i
]))
1025 if (i
>= 0 && encoded
[i
] == '.')
1027 else if (i
>= 0 && encoded
[i
] == '$')
1029 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1031 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1036 /* Remove the suffix introduced by the compiler for protected object
1040 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1042 /* Remove trailing N. */
1044 /* Protected entry subprograms are broken into two
1045 separate subprograms: The first one is unprotected, and has
1046 a 'N' suffix; the second is the protected version, and has
1047 the 'P' suffix. The second calls the first one after handling
1048 the protection. Since the P subprograms are internally generated,
1049 we leave these names undecoded, giving the user a clue that this
1050 entity is internal. */
1053 && encoded
[*len
- 1] == 'N'
1054 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1058 /* If ENCODED follows the GNAT entity encoding conventions, then return
1059 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1060 replaced by ENCODED. */
1063 ada_decode (const char *encoded
)
1069 std::string decoded
;
1071 /* With function descriptors on PPC64, the value of a symbol named
1072 ".FN", if it exists, is the entry point of the function "FN". */
1073 if (encoded
[0] == '.')
1076 /* The name of the Ada main procedure starts with "_ada_".
1077 This prefix is not part of the decoded name, so skip this part
1078 if we see this prefix. */
1079 if (startswith (encoded
, "_ada_"))
1082 /* If the name starts with '_', then it is not a properly encoded
1083 name, so do not attempt to decode it. Similarly, if the name
1084 starts with '<', the name should not be decoded. */
1085 if (encoded
[0] == '_' || encoded
[0] == '<')
1088 len0
= strlen (encoded
);
1090 ada_remove_trailing_digits (encoded
, &len0
);
1091 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1093 /* Remove the ___X.* suffix if present. Do not forget to verify that
1094 the suffix is located before the current "end" of ENCODED. We want
1095 to avoid re-matching parts of ENCODED that have previously been
1096 marked as discarded (by decrementing LEN0). */
1097 p
= strstr (encoded
, "___");
1098 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1106 /* Remove any trailing TKB suffix. It tells us that this symbol
1107 is for the body of a task, but that information does not actually
1108 appear in the decoded name. */
1110 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1113 /* Remove any trailing TB suffix. The TB suffix is slightly different
1114 from the TKB suffix because it is used for non-anonymous task
1117 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1120 /* Remove trailing "B" suffixes. */
1121 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1123 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1126 /* Make decoded big enough for possible expansion by operator name. */
1128 decoded
.resize (2 * len0
+ 1, 'X');
1130 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1132 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1135 while ((i
>= 0 && isdigit (encoded
[i
]))
1136 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1138 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1140 else if (encoded
[i
] == '$')
1144 /* The first few characters that are not alphabetic are not part
1145 of any encoding we use, so we can copy them over verbatim. */
1147 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1148 decoded
[j
] = encoded
[i
];
1153 /* Is this a symbol function? */
1154 if (at_start_name
&& encoded
[i
] == 'O')
1158 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1160 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1161 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1163 && !isalnum (encoded
[i
+ op_len
]))
1165 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1168 j
+= strlen (ada_opname_table
[k
].decoded
);
1172 if (ada_opname_table
[k
].encoded
!= NULL
)
1177 /* Replace "TK__" with "__", which will eventually be translated
1178 into "." (just below). */
1180 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1183 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1184 be translated into "." (just below). These are internal names
1185 generated for anonymous blocks inside which our symbol is nested. */
1187 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1188 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1189 && isdigit (encoded
[i
+4]))
1193 while (k
< len0
&& isdigit (encoded
[k
]))
1194 k
++; /* Skip any extra digit. */
1196 /* Double-check that the "__B_{DIGITS}+" sequence we found
1197 is indeed followed by "__". */
1198 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1202 /* Remove _E{DIGITS}+[sb] */
1204 /* Just as for protected object subprograms, there are 2 categories
1205 of subprograms created by the compiler for each entry. The first
1206 one implements the actual entry code, and has a suffix following
1207 the convention above; the second one implements the barrier and
1208 uses the same convention as above, except that the 'E' is replaced
1211 Just as above, we do not decode the name of barrier functions
1212 to give the user a clue that the code he is debugging has been
1213 internally generated. */
1215 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1216 && isdigit (encoded
[i
+2]))
1220 while (k
< len0
&& isdigit (encoded
[k
]))
1224 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1227 /* Just as an extra precaution, make sure that if this
1228 suffix is followed by anything else, it is a '_'.
1229 Otherwise, we matched this sequence by accident. */
1231 || (k
< len0
&& encoded
[k
] == '_'))
1236 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1237 the GNAT front-end in protected object subprograms. */
1240 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1242 /* Backtrack a bit up until we reach either the begining of
1243 the encoded name, or "__". Make sure that we only find
1244 digits or lowercase characters. */
1245 const char *ptr
= encoded
+ i
- 1;
1247 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1250 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1254 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1256 /* This is a X[bn]* sequence not separated from the previous
1257 part of the name with a non-alpha-numeric character (in other
1258 words, immediately following an alpha-numeric character), then
1259 verify that it is placed at the end of the encoded name. If
1260 not, then the encoding is not valid and we should abort the
1261 decoding. Otherwise, just skip it, it is used in body-nested
1265 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1269 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1271 /* Replace '__' by '.'. */
1279 /* It's a character part of the decoded name, so just copy it
1281 decoded
[j
] = encoded
[i
];
1288 /* Decoded names should never contain any uppercase character.
1289 Double-check this, and abort the decoding if we find one. */
1291 for (i
= 0; i
< decoded
.length(); ++i
)
1292 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1298 if (encoded
[0] == '<')
1301 decoded
= '<' + std::string(encoded
) + '>';
1306 /* Table for keeping permanent unique copies of decoded names. Once
1307 allocated, names in this table are never released. While this is a
1308 storage leak, it should not be significant unless there are massive
1309 changes in the set of decoded names in successive versions of a
1310 symbol table loaded during a single session. */
1311 static struct htab
*decoded_names_store
;
1313 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1314 in the language-specific part of GSYMBOL, if it has not been
1315 previously computed. Tries to save the decoded name in the same
1316 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1317 in any case, the decoded symbol has a lifetime at least that of
1319 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1320 const, but nevertheless modified to a semantically equivalent form
1321 when a decoded name is cached in it. */
1324 ada_decode_symbol (const struct general_symbol_info
*arg
)
1326 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1327 const char **resultp
=
1328 &gsymbol
->language_specific
.demangled_name
;
1330 if (!gsymbol
->ada_mangled
)
1332 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1333 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1335 gsymbol
->ada_mangled
= 1;
1337 if (obstack
!= NULL
)
1338 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1341 /* Sometimes, we can't find a corresponding objfile, in
1342 which case, we put the result on the heap. Since we only
1343 decode when needed, we hope this usually does not cause a
1344 significant memory leak (FIXME). */
1346 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1347 decoded
.c_str (), INSERT
);
1350 *slot
= xstrdup (decoded
.c_str ());
1359 ada_la_decode (const char *encoded
, int options
)
1361 return xstrdup (ada_decode (encoded
).c_str ());
1368 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1369 generated by the GNAT compiler to describe the index type used
1370 for each dimension of an array, check whether it follows the latest
1371 known encoding. If not, fix it up to conform to the latest encoding.
1372 Otherwise, do nothing. This function also does nothing if
1373 INDEX_DESC_TYPE is NULL.
1375 The GNAT encoding used to describe the array index type evolved a bit.
1376 Initially, the information would be provided through the name of each
1377 field of the structure type only, while the type of these fields was
1378 described as unspecified and irrelevant. The debugger was then expected
1379 to perform a global type lookup using the name of that field in order
1380 to get access to the full index type description. Because these global
1381 lookups can be very expensive, the encoding was later enhanced to make
1382 the global lookup unnecessary by defining the field type as being
1383 the full index type description.
1385 The purpose of this routine is to allow us to support older versions
1386 of the compiler by detecting the use of the older encoding, and by
1387 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1388 we essentially replace each field's meaningless type by the associated
1392 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1396 if (index_desc_type
== NULL
)
1398 gdb_assert (index_desc_type
->num_fields () > 0);
1400 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1401 to check one field only, no need to check them all). If not, return
1404 If our INDEX_DESC_TYPE was generated using the older encoding,
1405 the field type should be a meaningless integer type whose name
1406 is not equal to the field name. */
1407 if (index_desc_type
->field (0).type ()->name () != NULL
1408 && strcmp (index_desc_type
->field (0).type ()->name (),
1409 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1412 /* Fixup each field of INDEX_DESC_TYPE. */
1413 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1415 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1416 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1419 index_desc_type
->field (i
).set_type (raw_type
);
1423 /* The desc_* routines return primitive portions of array descriptors
1426 /* The descriptor or array type, if any, indicated by TYPE; removes
1427 level of indirection, if needed. */
1429 static struct type
*
1430 desc_base_type (struct type
*type
)
1434 type
= ada_check_typedef (type
);
1435 if (type
->code () == TYPE_CODE_TYPEDEF
)
1436 type
= ada_typedef_target_type (type
);
1439 && (type
->code () == TYPE_CODE_PTR
1440 || type
->code () == TYPE_CODE_REF
))
1441 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1446 /* True iff TYPE indicates a "thin" array pointer type. */
1449 is_thin_pntr (struct type
*type
)
1452 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1453 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1456 /* The descriptor type for thin pointer type TYPE. */
1458 static struct type
*
1459 thin_descriptor_type (struct type
*type
)
1461 struct type
*base_type
= desc_base_type (type
);
1463 if (base_type
== NULL
)
1465 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1469 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1471 if (alt_type
== NULL
)
1478 /* A pointer to the array data for thin-pointer value VAL. */
1480 static struct value
*
1481 thin_data_pntr (struct value
*val
)
1483 struct type
*type
= ada_check_typedef (value_type (val
));
1484 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1486 data_type
= lookup_pointer_type (data_type
);
1488 if (type
->code () == TYPE_CODE_PTR
)
1489 return value_cast (data_type
, value_copy (val
));
1491 return value_from_longest (data_type
, value_address (val
));
1494 /* True iff TYPE indicates a "thick" array pointer type. */
1497 is_thick_pntr (struct type
*type
)
1499 type
= desc_base_type (type
);
1500 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1501 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1504 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1505 pointer to one, the type of its bounds data; otherwise, NULL. */
1507 static struct type
*
1508 desc_bounds_type (struct type
*type
)
1512 type
= desc_base_type (type
);
1516 else if (is_thin_pntr (type
))
1518 type
= thin_descriptor_type (type
);
1521 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1523 return ada_check_typedef (r
);
1525 else if (type
->code () == TYPE_CODE_STRUCT
)
1527 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1529 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1534 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1535 one, a pointer to its bounds data. Otherwise NULL. */
1537 static struct value
*
1538 desc_bounds (struct value
*arr
)
1540 struct type
*type
= ada_check_typedef (value_type (arr
));
1542 if (is_thin_pntr (type
))
1544 struct type
*bounds_type
=
1545 desc_bounds_type (thin_descriptor_type (type
));
1548 if (bounds_type
== NULL
)
1549 error (_("Bad GNAT array descriptor"));
1551 /* NOTE: The following calculation is not really kosher, but
1552 since desc_type is an XVE-encoded type (and shouldn't be),
1553 the correct calculation is a real pain. FIXME (and fix GCC). */
1554 if (type
->code () == TYPE_CODE_PTR
)
1555 addr
= value_as_long (arr
);
1557 addr
= value_address (arr
);
1560 value_from_longest (lookup_pointer_type (bounds_type
),
1561 addr
- TYPE_LENGTH (bounds_type
));
1564 else if (is_thick_pntr (type
))
1566 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1567 _("Bad GNAT array descriptor"));
1568 struct type
*p_bounds_type
= value_type (p_bounds
);
1571 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1573 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1575 if (target_type
->is_stub ())
1576 p_bounds
= value_cast (lookup_pointer_type
1577 (ada_check_typedef (target_type
)),
1581 error (_("Bad GNAT array descriptor"));
1589 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1590 position of the field containing the address of the bounds data. */
1593 fat_pntr_bounds_bitpos (struct type
*type
)
1595 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1598 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1599 size of the field containing the address of the bounds data. */
1602 fat_pntr_bounds_bitsize (struct type
*type
)
1604 type
= desc_base_type (type
);
1606 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1607 return TYPE_FIELD_BITSIZE (type
, 1);
1609 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1612 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1613 pointer to one, the type of its array data (a array-with-no-bounds type);
1614 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1617 static struct type
*
1618 desc_data_target_type (struct type
*type
)
1620 type
= desc_base_type (type
);
1622 /* NOTE: The following is bogus; see comment in desc_bounds. */
1623 if (is_thin_pntr (type
))
1624 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1625 else if (is_thick_pntr (type
))
1627 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1630 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1631 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1637 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1640 static struct value
*
1641 desc_data (struct value
*arr
)
1643 struct type
*type
= value_type (arr
);
1645 if (is_thin_pntr (type
))
1646 return thin_data_pntr (arr
);
1647 else if (is_thick_pntr (type
))
1648 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1649 _("Bad GNAT array descriptor"));
1655 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1656 position of the field containing the address of the data. */
1659 fat_pntr_data_bitpos (struct type
*type
)
1661 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1664 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1665 size of the field containing the address of the data. */
1668 fat_pntr_data_bitsize (struct type
*type
)
1670 type
= desc_base_type (type
);
1672 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1673 return TYPE_FIELD_BITSIZE (type
, 0);
1675 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1678 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1679 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1680 bound, if WHICH is 1. The first bound is I=1. */
1682 static struct value
*
1683 desc_one_bound (struct value
*bounds
, int i
, int which
)
1685 char bound_name
[20];
1686 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1687 which
? 'U' : 'L', i
- 1);
1688 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1689 _("Bad GNAT array descriptor bounds"));
1692 /* If BOUNDS is an array-bounds structure type, return the bit position
1693 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1694 bound, if WHICH is 1. The first bound is I=1. */
1697 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1699 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1702 /* If BOUNDS is an array-bounds structure type, return the bit field size
1703 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1704 bound, if WHICH is 1. The first bound is I=1. */
1707 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1709 type
= desc_base_type (type
);
1711 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1712 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1714 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1717 /* If TYPE is the type of an array-bounds structure, the type of its
1718 Ith bound (numbering from 1). Otherwise, NULL. */
1720 static struct type
*
1721 desc_index_type (struct type
*type
, int i
)
1723 type
= desc_base_type (type
);
1725 if (type
->code () == TYPE_CODE_STRUCT
)
1727 char bound_name
[20];
1728 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1729 return lookup_struct_elt_type (type
, bound_name
, 1);
1735 /* The number of index positions in the array-bounds type TYPE.
1736 Return 0 if TYPE is NULL. */
1739 desc_arity (struct type
*type
)
1741 type
= desc_base_type (type
);
1744 return type
->num_fields () / 2;
1748 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1749 an array descriptor type (representing an unconstrained array
1753 ada_is_direct_array_type (struct type
*type
)
1757 type
= ada_check_typedef (type
);
1758 return (type
->code () == TYPE_CODE_ARRAY
1759 || ada_is_array_descriptor_type (type
));
1762 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1766 ada_is_array_type (struct type
*type
)
1769 && (type
->code () == TYPE_CODE_PTR
1770 || type
->code () == TYPE_CODE_REF
))
1771 type
= TYPE_TARGET_TYPE (type
);
1772 return ada_is_direct_array_type (type
);
1775 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1778 ada_is_simple_array_type (struct type
*type
)
1782 type
= ada_check_typedef (type
);
1783 return (type
->code () == TYPE_CODE_ARRAY
1784 || (type
->code () == TYPE_CODE_PTR
1785 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1786 == TYPE_CODE_ARRAY
)));
1789 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1792 ada_is_array_descriptor_type (struct type
*type
)
1794 struct type
*data_type
= desc_data_target_type (type
);
1798 type
= ada_check_typedef (type
);
1799 return (data_type
!= NULL
1800 && data_type
->code () == TYPE_CODE_ARRAY
1801 && desc_arity (desc_bounds_type (type
)) > 0);
1804 /* Non-zero iff type is a partially mal-formed GNAT array
1805 descriptor. FIXME: This is to compensate for some problems with
1806 debugging output from GNAT. Re-examine periodically to see if it
1810 ada_is_bogus_array_descriptor (struct type
*type
)
1814 && type
->code () == TYPE_CODE_STRUCT
1815 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1816 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1817 && !ada_is_array_descriptor_type (type
);
1821 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1822 (fat pointer) returns the type of the array data described---specifically,
1823 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1824 in from the descriptor; otherwise, they are left unspecified. If
1825 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1826 returns NULL. The result is simply the type of ARR if ARR is not
1829 static struct type
*
1830 ada_type_of_array (struct value
*arr
, int bounds
)
1832 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1833 return decode_constrained_packed_array_type (value_type (arr
));
1835 if (!ada_is_array_descriptor_type (value_type (arr
)))
1836 return value_type (arr
);
1840 struct type
*array_type
=
1841 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1843 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1844 TYPE_FIELD_BITSIZE (array_type
, 0) =
1845 decode_packed_array_bitsize (value_type (arr
));
1851 struct type
*elt_type
;
1853 struct value
*descriptor
;
1855 elt_type
= ada_array_element_type (value_type (arr
), -1);
1856 arity
= ada_array_arity (value_type (arr
));
1858 if (elt_type
== NULL
|| arity
== 0)
1859 return ada_check_typedef (value_type (arr
));
1861 descriptor
= desc_bounds (arr
);
1862 if (value_as_long (descriptor
) == 0)
1866 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1867 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1868 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1869 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1872 create_static_range_type (range_type
, value_type (low
),
1873 longest_to_int (value_as_long (low
)),
1874 longest_to_int (value_as_long (high
)));
1875 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1877 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1879 /* We need to store the element packed bitsize, as well as
1880 recompute the array size, because it was previously
1881 computed based on the unpacked element size. */
1882 LONGEST lo
= value_as_long (low
);
1883 LONGEST hi
= value_as_long (high
);
1885 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1886 decode_packed_array_bitsize (value_type (arr
));
1887 /* If the array has no element, then the size is already
1888 zero, and does not need to be recomputed. */
1892 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1894 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1899 return lookup_pointer_type (elt_type
);
1903 /* If ARR does not represent an array, returns ARR unchanged.
1904 Otherwise, returns either a standard GDB array with bounds set
1905 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1906 GDB array. Returns NULL if ARR is a null fat pointer. */
1909 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1911 if (ada_is_array_descriptor_type (value_type (arr
)))
1913 struct type
*arrType
= ada_type_of_array (arr
, 1);
1915 if (arrType
== NULL
)
1917 return value_cast (arrType
, value_copy (desc_data (arr
)));
1919 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1920 return decode_constrained_packed_array (arr
);
1925 /* If ARR does not represent an array, returns ARR unchanged.
1926 Otherwise, returns a standard GDB array describing ARR (which may
1927 be ARR itself if it already is in the proper form). */
1930 ada_coerce_to_simple_array (struct value
*arr
)
1932 if (ada_is_array_descriptor_type (value_type (arr
)))
1934 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1937 error (_("Bounds unavailable for null array pointer."));
1938 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1939 return value_ind (arrVal
);
1941 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1942 return decode_constrained_packed_array (arr
);
1947 /* If TYPE represents a GNAT array type, return it translated to an
1948 ordinary GDB array type (possibly with BITSIZE fields indicating
1949 packing). For other types, is the identity. */
1952 ada_coerce_to_simple_array_type (struct type
*type
)
1954 if (ada_is_constrained_packed_array_type (type
))
1955 return decode_constrained_packed_array_type (type
);
1957 if (ada_is_array_descriptor_type (type
))
1958 return ada_check_typedef (desc_data_target_type (type
));
1963 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1966 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
1970 type
= desc_base_type (type
);
1971 type
= ada_check_typedef (type
);
1973 ada_type_name (type
) != NULL
1974 && strstr (ada_type_name (type
), "___XP") != NULL
;
1977 /* Non-zero iff TYPE represents a standard GNAT constrained
1978 packed-array type. */
1981 ada_is_constrained_packed_array_type (struct type
*type
)
1983 return ada_is_gnat_encoded_packed_array_type (type
)
1984 && !ada_is_array_descriptor_type (type
);
1987 /* Non-zero iff TYPE represents an array descriptor for a
1988 unconstrained packed-array type. */
1991 ada_is_unconstrained_packed_array_type (struct type
*type
)
1993 if (!ada_is_array_descriptor_type (type
))
1996 if (ada_is_gnat_encoded_packed_array_type (type
))
1999 /* If we saw GNAT encodings, then the above code is sufficient.
2000 However, with minimal encodings, we will just have a thick
2002 if (is_thick_pntr (type
))
2004 type
= desc_base_type (type
);
2005 /* The structure's first field is a pointer to an array, so this
2006 fetches the array type. */
2007 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2008 /* Now we can see if the array elements are packed. */
2009 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
2015 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2016 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2019 ada_is_any_packed_array_type (struct type
*type
)
2021 return (ada_is_constrained_packed_array_type (type
)
2022 || (type
->code () == TYPE_CODE_ARRAY
2023 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
2026 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2027 return the size of its elements in bits. */
2030 decode_packed_array_bitsize (struct type
*type
)
2032 const char *raw_name
;
2036 /* Access to arrays implemented as fat pointers are encoded as a typedef
2037 of the fat pointer type. We need the name of the fat pointer type
2038 to do the decoding, so strip the typedef layer. */
2039 if (type
->code () == TYPE_CODE_TYPEDEF
)
2040 type
= ada_typedef_target_type (type
);
2042 raw_name
= ada_type_name (ada_check_typedef (type
));
2044 raw_name
= ada_type_name (desc_base_type (type
));
2049 tail
= strstr (raw_name
, "___XP");
2050 if (tail
== nullptr)
2052 gdb_assert (is_thick_pntr (type
));
2053 /* The structure's first field is a pointer to an array, so this
2054 fetches the array type. */
2055 type
= TYPE_TARGET_TYPE (type
->field (0).type ());
2056 /* Now we can see if the array elements are packed. */
2057 return TYPE_FIELD_BITSIZE (type
, 0);
2060 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2063 (_("could not understand bit size information on packed array"));
2070 /* Given that TYPE is a standard GDB array type with all bounds filled
2071 in, and that the element size of its ultimate scalar constituents
2072 (that is, either its elements, or, if it is an array of arrays, its
2073 elements' elements, etc.) is *ELT_BITS, return an identical type,
2074 but with the bit sizes of its elements (and those of any
2075 constituent arrays) recorded in the BITSIZE components of its
2076 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2079 Note that, for arrays whose index type has an XA encoding where
2080 a bound references a record discriminant, getting that discriminant,
2081 and therefore the actual value of that bound, is not possible
2082 because none of the given parameters gives us access to the record.
2083 This function assumes that it is OK in the context where it is being
2084 used to return an array whose bounds are still dynamic and where
2085 the length is arbitrary. */
2087 static struct type
*
2088 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2090 struct type
*new_elt_type
;
2091 struct type
*new_type
;
2092 struct type
*index_type_desc
;
2093 struct type
*index_type
;
2094 LONGEST low_bound
, high_bound
;
2096 type
= ada_check_typedef (type
);
2097 if (type
->code () != TYPE_CODE_ARRAY
)
2100 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2101 if (index_type_desc
)
2102 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2105 index_type
= type
->index_type ();
2107 new_type
= alloc_type_copy (type
);
2109 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2111 create_array_type (new_type
, new_elt_type
, index_type
);
2112 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2113 new_type
->set_name (ada_type_name (type
));
2115 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2116 && is_dynamic_type (check_typedef (index_type
)))
2117 || !get_discrete_bounds (index_type
, &low_bound
, &high_bound
))
2118 low_bound
= high_bound
= 0;
2119 if (high_bound
< low_bound
)
2120 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2123 *elt_bits
*= (high_bound
- low_bound
+ 1);
2124 TYPE_LENGTH (new_type
) =
2125 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2128 new_type
->set_is_fixed_instance (true);
2132 /* The array type encoded by TYPE, where
2133 ada_is_constrained_packed_array_type (TYPE). */
2135 static struct type
*
2136 decode_constrained_packed_array_type (struct type
*type
)
2138 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2141 struct type
*shadow_type
;
2145 raw_name
= ada_type_name (desc_base_type (type
));
2150 name
= (char *) alloca (strlen (raw_name
) + 1);
2151 tail
= strstr (raw_name
, "___XP");
2152 type
= desc_base_type (type
);
2154 memcpy (name
, raw_name
, tail
- raw_name
);
2155 name
[tail
- raw_name
] = '\000';
2157 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2159 if (shadow_type
== NULL
)
2161 lim_warning (_("could not find bounds information on packed array"));
2164 shadow_type
= check_typedef (shadow_type
);
2166 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2168 lim_warning (_("could not understand bounds "
2169 "information on packed array"));
2173 bits
= decode_packed_array_bitsize (type
);
2174 return constrained_packed_array_type (shadow_type
, &bits
);
2177 /* Helper function for decode_constrained_packed_array. Set the field
2178 bitsize on a series of packed arrays. Returns the number of
2179 elements in TYPE. */
2182 recursively_update_array_bitsize (struct type
*type
)
2184 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2187 if (!get_discrete_bounds (type
->index_type (), &low
, &high
)
2190 LONGEST our_len
= high
- low
+ 1;
2192 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
2193 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2195 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2196 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2197 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2199 TYPE_LENGTH (type
) = ((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2206 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2207 array, returns a simple array that denotes that array. Its type is a
2208 standard GDB array type except that the BITSIZEs of the array
2209 target types are set to the number of bits in each element, and the
2210 type length is set appropriately. */
2212 static struct value
*
2213 decode_constrained_packed_array (struct value
*arr
)
2217 /* If our value is a pointer, then dereference it. Likewise if
2218 the value is a reference. Make sure that this operation does not
2219 cause the target type to be fixed, as this would indirectly cause
2220 this array to be decoded. The rest of the routine assumes that
2221 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2222 and "value_ind" routines to perform the dereferencing, as opposed
2223 to using "ada_coerce_ref" or "ada_value_ind". */
2224 arr
= coerce_ref (arr
);
2225 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2226 arr
= value_ind (arr
);
2228 type
= decode_constrained_packed_array_type (value_type (arr
));
2231 error (_("can't unpack array"));
2235 /* Decoding the packed array type could not correctly set the field
2236 bitsizes for any dimension except the innermost, because the
2237 bounds may be variable and were not passed to that function. So,
2238 we further resolve the array bounds here and then update the
2240 const gdb_byte
*valaddr
= value_contents_for_printing (arr
);
2241 CORE_ADDR address
= value_address (arr
);
2242 gdb::array_view
<const gdb_byte
> view
2243 = gdb::make_array_view (valaddr
, TYPE_LENGTH (type
));
2244 type
= resolve_dynamic_type (type
, view
, address
);
2245 recursively_update_array_bitsize (type
);
2247 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2248 && ada_is_modular_type (value_type (arr
)))
2250 /* This is a (right-justified) modular type representing a packed
2251 array with no wrapper. In order to interpret the value through
2252 the (left-justified) packed array type we just built, we must
2253 first left-justify it. */
2254 int bit_size
, bit_pos
;
2257 mod
= ada_modulus (value_type (arr
)) - 1;
2264 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2265 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2266 bit_pos
/ HOST_CHAR_BIT
,
2267 bit_pos
% HOST_CHAR_BIT
,
2272 return coerce_unspec_val_to_type (arr
, type
);
2276 /* The value of the element of packed array ARR at the ARITY indices
2277 given in IND. ARR must be a simple array. */
2279 static struct value
*
2280 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2283 int bits
, elt_off
, bit_off
;
2284 long elt_total_bit_offset
;
2285 struct type
*elt_type
;
2289 elt_total_bit_offset
= 0;
2290 elt_type
= ada_check_typedef (value_type (arr
));
2291 for (i
= 0; i
< arity
; i
+= 1)
2293 if (elt_type
->code () != TYPE_CODE_ARRAY
2294 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2296 (_("attempt to do packed indexing of "
2297 "something other than a packed array"));
2300 struct type
*range_type
= elt_type
->index_type ();
2301 LONGEST lowerbound
, upperbound
;
2304 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2306 lim_warning (_("don't know bounds of array"));
2307 lowerbound
= upperbound
= 0;
2310 idx
= pos_atr (ind
[i
]);
2311 if (idx
< lowerbound
|| idx
> upperbound
)
2312 lim_warning (_("packed array index %ld out of bounds"),
2314 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2315 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2316 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2319 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2320 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2322 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2327 /* Non-zero iff TYPE includes negative integer values. */
2330 has_negatives (struct type
*type
)
2332 switch (type
->code ())
2337 return !type
->is_unsigned ();
2338 case TYPE_CODE_RANGE
:
2339 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2343 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2344 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2345 the unpacked buffer.
2347 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2348 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2350 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2353 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2355 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2358 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2359 gdb_byte
*unpacked
, int unpacked_len
,
2360 int is_big_endian
, int is_signed_type
,
2363 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2364 int src_idx
; /* Index into the source area */
2365 int src_bytes_left
; /* Number of source bytes left to process. */
2366 int srcBitsLeft
; /* Number of source bits left to move */
2367 int unusedLS
; /* Number of bits in next significant
2368 byte of source that are unused */
2370 int unpacked_idx
; /* Index into the unpacked buffer */
2371 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2373 unsigned long accum
; /* Staging area for bits being transferred */
2374 int accumSize
; /* Number of meaningful bits in accum */
2377 /* Transmit bytes from least to most significant; delta is the direction
2378 the indices move. */
2379 int delta
= is_big_endian
? -1 : 1;
2381 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2383 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2384 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2385 bit_size
, unpacked_len
);
2387 srcBitsLeft
= bit_size
;
2388 src_bytes_left
= src_len
;
2389 unpacked_bytes_left
= unpacked_len
;
2394 src_idx
= src_len
- 1;
2396 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2400 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2406 unpacked_idx
= unpacked_len
- 1;
2410 /* Non-scalar values must be aligned at a byte boundary... */
2412 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2413 /* ... And are placed at the beginning (most-significant) bytes
2415 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2416 unpacked_bytes_left
= unpacked_idx
+ 1;
2421 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2423 src_idx
= unpacked_idx
= 0;
2424 unusedLS
= bit_offset
;
2427 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2432 while (src_bytes_left
> 0)
2434 /* Mask for removing bits of the next source byte that are not
2435 part of the value. */
2436 unsigned int unusedMSMask
=
2437 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2439 /* Sign-extend bits for this byte. */
2440 unsigned int signMask
= sign
& ~unusedMSMask
;
2443 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2444 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2445 if (accumSize
>= HOST_CHAR_BIT
)
2447 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2448 accumSize
-= HOST_CHAR_BIT
;
2449 accum
>>= HOST_CHAR_BIT
;
2450 unpacked_bytes_left
-= 1;
2451 unpacked_idx
+= delta
;
2453 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2455 src_bytes_left
-= 1;
2458 while (unpacked_bytes_left
> 0)
2460 accum
|= sign
<< accumSize
;
2461 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2462 accumSize
-= HOST_CHAR_BIT
;
2465 accum
>>= HOST_CHAR_BIT
;
2466 unpacked_bytes_left
-= 1;
2467 unpacked_idx
+= delta
;
2471 /* Create a new value of type TYPE from the contents of OBJ starting
2472 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2473 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2474 assigning through the result will set the field fetched from.
2475 VALADDR is ignored unless OBJ is NULL, in which case,
2476 VALADDR+OFFSET must address the start of storage containing the
2477 packed value. The value returned in this case is never an lval.
2478 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2481 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2482 long offset
, int bit_offset
, int bit_size
,
2486 const gdb_byte
*src
; /* First byte containing data to unpack */
2488 const int is_scalar
= is_scalar_type (type
);
2489 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2490 gdb::byte_vector staging
;
2492 type
= ada_check_typedef (type
);
2495 src
= valaddr
+ offset
;
2497 src
= value_contents (obj
) + offset
;
2499 if (is_dynamic_type (type
))
2501 /* The length of TYPE might by dynamic, so we need to resolve
2502 TYPE in order to know its actual size, which we then use
2503 to create the contents buffer of the value we return.
2504 The difficulty is that the data containing our object is
2505 packed, and therefore maybe not at a byte boundary. So, what
2506 we do, is unpack the data into a byte-aligned buffer, and then
2507 use that buffer as our object's value for resolving the type. */
2508 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2509 staging
.resize (staging_len
);
2511 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2512 staging
.data (), staging
.size (),
2513 is_big_endian
, has_negatives (type
),
2515 type
= resolve_dynamic_type (type
, staging
, 0);
2516 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2518 /* This happens when the length of the object is dynamic,
2519 and is actually smaller than the space reserved for it.
2520 For instance, in an array of variant records, the bit_size
2521 we're given is the array stride, which is constant and
2522 normally equal to the maximum size of its element.
2523 But, in reality, each element only actually spans a portion
2525 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2531 v
= allocate_value (type
);
2532 src
= valaddr
+ offset
;
2534 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2536 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2539 v
= value_at (type
, value_address (obj
) + offset
);
2540 buf
= (gdb_byte
*) alloca (src_len
);
2541 read_memory (value_address (v
), buf
, src_len
);
2546 v
= allocate_value (type
);
2547 src
= value_contents (obj
) + offset
;
2552 long new_offset
= offset
;
2554 set_value_component_location (v
, obj
);
2555 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2556 set_value_bitsize (v
, bit_size
);
2557 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2560 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2562 set_value_offset (v
, new_offset
);
2564 /* Also set the parent value. This is needed when trying to
2565 assign a new value (in inferior memory). */
2566 set_value_parent (v
, obj
);
2569 set_value_bitsize (v
, bit_size
);
2570 unpacked
= value_contents_writeable (v
);
2574 memset (unpacked
, 0, TYPE_LENGTH (type
));
2578 if (staging
.size () == TYPE_LENGTH (type
))
2580 /* Small short-cut: If we've unpacked the data into a buffer
2581 of the same size as TYPE's length, then we can reuse that,
2582 instead of doing the unpacking again. */
2583 memcpy (unpacked
, staging
.data (), staging
.size ());
2586 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2587 unpacked
, TYPE_LENGTH (type
),
2588 is_big_endian
, has_negatives (type
), is_scalar
);
2593 /* Store the contents of FROMVAL into the location of TOVAL.
2594 Return a new value with the location of TOVAL and contents of
2595 FROMVAL. Handles assignment into packed fields that have
2596 floating-point or non-scalar types. */
2598 static struct value
*
2599 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2601 struct type
*type
= value_type (toval
);
2602 int bits
= value_bitsize (toval
);
2604 toval
= ada_coerce_ref (toval
);
2605 fromval
= ada_coerce_ref (fromval
);
2607 if (ada_is_direct_array_type (value_type (toval
)))
2608 toval
= ada_coerce_to_simple_array (toval
);
2609 if (ada_is_direct_array_type (value_type (fromval
)))
2610 fromval
= ada_coerce_to_simple_array (fromval
);
2612 if (!deprecated_value_modifiable (toval
))
2613 error (_("Left operand of assignment is not a modifiable lvalue."));
2615 if (VALUE_LVAL (toval
) == lval_memory
2617 && (type
->code () == TYPE_CODE_FLT
2618 || type
->code () == TYPE_CODE_STRUCT
))
2620 int len
= (value_bitpos (toval
)
2621 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2623 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2625 CORE_ADDR to_addr
= value_address (toval
);
2627 if (type
->code () == TYPE_CODE_FLT
)
2628 fromval
= value_cast (type
, fromval
);
2630 read_memory (to_addr
, buffer
, len
);
2631 from_size
= value_bitsize (fromval
);
2633 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2635 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2636 ULONGEST from_offset
= 0;
2637 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2638 from_offset
= from_size
- bits
;
2639 copy_bitwise (buffer
, value_bitpos (toval
),
2640 value_contents (fromval
), from_offset
,
2641 bits
, is_big_endian
);
2642 write_memory_with_notification (to_addr
, buffer
, len
);
2644 val
= value_copy (toval
);
2645 memcpy (value_contents_raw (val
), value_contents (fromval
),
2646 TYPE_LENGTH (type
));
2647 deprecated_set_value_type (val
, type
);
2652 return value_assign (toval
, fromval
);
2656 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2657 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2658 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2659 COMPONENT, and not the inferior's memory. The current contents
2660 of COMPONENT are ignored.
2662 Although not part of the initial design, this function also works
2663 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2664 had a null address, and COMPONENT had an address which is equal to
2665 its offset inside CONTAINER. */
2668 value_assign_to_component (struct value
*container
, struct value
*component
,
2671 LONGEST offset_in_container
=
2672 (LONGEST
) (value_address (component
) - value_address (container
));
2673 int bit_offset_in_container
=
2674 value_bitpos (component
) - value_bitpos (container
);
2677 val
= value_cast (value_type (component
), val
);
2679 if (value_bitsize (component
) == 0)
2680 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2682 bits
= value_bitsize (component
);
2684 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2688 if (is_scalar_type (check_typedef (value_type (component
))))
2690 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2693 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2694 value_bitpos (container
) + bit_offset_in_container
,
2695 value_contents (val
), src_offset
, bits
, 1);
2698 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2699 value_bitpos (container
) + bit_offset_in_container
,
2700 value_contents (val
), 0, bits
, 0);
2703 /* Determine if TYPE is an access to an unconstrained array. */
2706 ada_is_access_to_unconstrained_array (struct type
*type
)
2708 return (type
->code () == TYPE_CODE_TYPEDEF
2709 && is_thick_pntr (ada_typedef_target_type (type
)));
2712 /* The value of the element of array ARR at the ARITY indices given in IND.
2713 ARR may be either a simple array, GNAT array descriptor, or pointer
2717 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2721 struct type
*elt_type
;
2723 elt
= ada_coerce_to_simple_array (arr
);
2725 elt_type
= ada_check_typedef (value_type (elt
));
2726 if (elt_type
->code () == TYPE_CODE_ARRAY
2727 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2728 return value_subscript_packed (elt
, arity
, ind
);
2730 for (k
= 0; k
< arity
; k
+= 1)
2732 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2734 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2735 error (_("too many subscripts (%d expected)"), k
);
2737 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2739 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2740 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2742 /* The element is a typedef to an unconstrained array,
2743 except that the value_subscript call stripped the
2744 typedef layer. The typedef layer is GNAT's way to
2745 specify that the element is, at the source level, an
2746 access to the unconstrained array, rather than the
2747 unconstrained array. So, we need to restore that
2748 typedef layer, which we can do by forcing the element's
2749 type back to its original type. Otherwise, the returned
2750 value is going to be printed as the array, rather
2751 than as an access. Another symptom of the same issue
2752 would be that an expression trying to dereference the
2753 element would also be improperly rejected. */
2754 deprecated_set_value_type (elt
, saved_elt_type
);
2757 elt_type
= ada_check_typedef (value_type (elt
));
2763 /* Assuming ARR is a pointer to a GDB array, the value of the element
2764 of *ARR at the ARITY indices given in IND.
2765 Does not read the entire array into memory.
2767 Note: Unlike what one would expect, this function is used instead of
2768 ada_value_subscript for basically all non-packed array types. The reason
2769 for this is that a side effect of doing our own pointer arithmetics instead
2770 of relying on value_subscript is that there is no implicit typedef peeling.
2771 This is important for arrays of array accesses, where it allows us to
2772 preserve the fact that the array's element is an array access, where the
2773 access part os encoded in a typedef layer. */
2775 static struct value
*
2776 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2779 struct value
*array_ind
= ada_value_ind (arr
);
2781 = check_typedef (value_enclosing_type (array_ind
));
2783 if (type
->code () == TYPE_CODE_ARRAY
2784 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2785 return value_subscript_packed (array_ind
, arity
, ind
);
2787 for (k
= 0; k
< arity
; k
+= 1)
2791 if (type
->code () != TYPE_CODE_ARRAY
)
2792 error (_("too many subscripts (%d expected)"), k
);
2793 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2795 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2796 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2797 type
= TYPE_TARGET_TYPE (type
);
2800 return value_ind (arr
);
2803 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2804 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2805 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2806 this array is LOW, as per Ada rules. */
2807 static struct value
*
2808 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2811 struct type
*type0
= ada_check_typedef (type
);
2812 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2813 struct type
*index_type
2814 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2815 struct type
*slice_type
= create_array_type_with_stride
2816 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2817 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2818 TYPE_FIELD_BITSIZE (type0
, 0));
2819 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2820 gdb::optional
<LONGEST
> base_low_pos
, low_pos
;
2823 low_pos
= discrete_position (base_index_type
, low
);
2824 base_low_pos
= discrete_position (base_index_type
, base_low
);
2826 if (!low_pos
.has_value () || !base_low_pos
.has_value ())
2828 warning (_("unable to get positions in slice, use bounds instead"));
2830 base_low_pos
= base_low
;
2833 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
2835 stride
= TYPE_LENGTH (TYPE_TARGET_TYPE (type0
));
2837 base
= value_as_address (array_ptr
) + (*low_pos
- *base_low_pos
) * stride
;
2838 return value_at_lazy (slice_type
, base
);
2842 static struct value
*
2843 ada_value_slice (struct value
*array
, int low
, int high
)
2845 struct type
*type
= ada_check_typedef (value_type (array
));
2846 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2847 struct type
*index_type
2848 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2849 struct type
*slice_type
= create_array_type_with_stride
2850 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2851 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2852 TYPE_FIELD_BITSIZE (type
, 0));
2853 gdb::optional
<LONGEST
> low_pos
, high_pos
;
2856 low_pos
= discrete_position (base_index_type
, low
);
2857 high_pos
= discrete_position (base_index_type
, high
);
2859 if (!low_pos
.has_value () || !high_pos
.has_value ())
2861 warning (_("unable to get positions in slice, use bounds instead"));
2866 return value_cast (slice_type
,
2867 value_slice (array
, low
, *high_pos
- *low_pos
+ 1));
2870 /* If type is a record type in the form of a standard GNAT array
2871 descriptor, returns the number of dimensions for type. If arr is a
2872 simple array, returns the number of "array of"s that prefix its
2873 type designation. Otherwise, returns 0. */
2876 ada_array_arity (struct type
*type
)
2883 type
= desc_base_type (type
);
2886 if (type
->code () == TYPE_CODE_STRUCT
)
2887 return desc_arity (desc_bounds_type (type
));
2889 while (type
->code () == TYPE_CODE_ARRAY
)
2892 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2898 /* If TYPE is a record type in the form of a standard GNAT array
2899 descriptor or a simple array type, returns the element type for
2900 TYPE after indexing by NINDICES indices, or by all indices if
2901 NINDICES is -1. Otherwise, returns NULL. */
2904 ada_array_element_type (struct type
*type
, int nindices
)
2906 type
= desc_base_type (type
);
2908 if (type
->code () == TYPE_CODE_STRUCT
)
2911 struct type
*p_array_type
;
2913 p_array_type
= desc_data_target_type (type
);
2915 k
= ada_array_arity (type
);
2919 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2920 if (nindices
>= 0 && k
> nindices
)
2922 while (k
> 0 && p_array_type
!= NULL
)
2924 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2927 return p_array_type
;
2929 else if (type
->code () == TYPE_CODE_ARRAY
)
2931 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2933 type
= TYPE_TARGET_TYPE (type
);
2942 /* The type of nth index in arrays of given type (n numbering from 1).
2943 Does not examine memory. Throws an error if N is invalid or TYPE
2944 is not an array type. NAME is the name of the Ada attribute being
2945 evaluated ('range, 'first, 'last, or 'length); it is used in building
2946 the error message. */
2948 static struct type
*
2949 ada_index_type (struct type
*type
, int n
, const char *name
)
2951 struct type
*result_type
;
2953 type
= desc_base_type (type
);
2955 if (n
< 0 || n
> ada_array_arity (type
))
2956 error (_("invalid dimension number to '%s"), name
);
2958 if (ada_is_simple_array_type (type
))
2962 for (i
= 1; i
< n
; i
+= 1)
2963 type
= TYPE_TARGET_TYPE (type
);
2964 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2965 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2966 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2967 perhaps stabsread.c would make more sense. */
2968 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2973 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2974 if (result_type
== NULL
)
2975 error (_("attempt to take bound of something that is not an array"));
2981 /* Given that arr is an array type, returns the lower bound of the
2982 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2983 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2984 array-descriptor type. It works for other arrays with bounds supplied
2985 by run-time quantities other than discriminants. */
2988 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2990 struct type
*type
, *index_type_desc
, *index_type
;
2993 gdb_assert (which
== 0 || which
== 1);
2995 if (ada_is_constrained_packed_array_type (arr_type
))
2996 arr_type
= decode_constrained_packed_array_type (arr_type
);
2998 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2999 return (LONGEST
) - which
;
3001 if (arr_type
->code () == TYPE_CODE_PTR
)
3002 type
= TYPE_TARGET_TYPE (arr_type
);
3006 if (type
->is_fixed_instance ())
3008 /* The array has already been fixed, so we do not need to
3009 check the parallel ___XA type again. That encoding has
3010 already been applied, so ignore it now. */
3011 index_type_desc
= NULL
;
3015 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3016 ada_fixup_array_indexes_type (index_type_desc
);
3019 if (index_type_desc
!= NULL
)
3020 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
3024 struct type
*elt_type
= check_typedef (type
);
3026 for (i
= 1; i
< n
; i
++)
3027 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3029 index_type
= elt_type
->index_type ();
3033 (LONGEST
) (which
== 0
3034 ? ada_discrete_type_low_bound (index_type
)
3035 : ada_discrete_type_high_bound (index_type
));
3038 /* Given that arr is an array value, returns the lower bound of the
3039 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3040 WHICH is 1. This routine will also work for arrays with bounds
3041 supplied by run-time quantities other than discriminants. */
3044 ada_array_bound (struct value
*arr
, int n
, int which
)
3046 struct type
*arr_type
;
3048 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3049 arr
= value_ind (arr
);
3050 arr_type
= value_enclosing_type (arr
);
3052 if (ada_is_constrained_packed_array_type (arr_type
))
3053 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3054 else if (ada_is_simple_array_type (arr_type
))
3055 return ada_array_bound_from_type (arr_type
, n
, which
);
3057 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3060 /* Given that arr is an array value, returns the length of the
3061 nth index. This routine will also work for arrays with bounds
3062 supplied by run-time quantities other than discriminants.
3063 Does not work for arrays indexed by enumeration types with representation
3064 clauses at the moment. */
3067 ada_array_length (struct value
*arr
, int n
)
3069 struct type
*arr_type
, *index_type
;
3072 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3073 arr
= value_ind (arr
);
3074 arr_type
= value_enclosing_type (arr
);
3076 if (ada_is_constrained_packed_array_type (arr_type
))
3077 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3079 if (ada_is_simple_array_type (arr_type
))
3081 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3082 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3086 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3087 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3090 arr_type
= check_typedef (arr_type
);
3091 index_type
= ada_index_type (arr_type
, n
, "length");
3092 if (index_type
!= NULL
)
3094 struct type
*base_type
;
3095 if (index_type
->code () == TYPE_CODE_RANGE
)
3096 base_type
= TYPE_TARGET_TYPE (index_type
);
3098 base_type
= index_type
;
3100 low
= pos_atr (value_from_longest (base_type
, low
));
3101 high
= pos_atr (value_from_longest (base_type
, high
));
3103 return high
- low
+ 1;
3106 /* An array whose type is that of ARR_TYPE (an array type), with
3107 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3108 less than LOW, then LOW-1 is used. */
3110 static struct value
*
3111 empty_array (struct type
*arr_type
, int low
, int high
)
3113 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3114 struct type
*index_type
3115 = create_static_range_type
3116 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3117 high
< low
? low
- 1 : high
);
3118 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3120 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3124 /* Name resolution */
3126 /* The "decoded" name for the user-definable Ada operator corresponding
3130 ada_decoded_op_name (enum exp_opcode op
)
3134 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3136 if (ada_opname_table
[i
].op
== op
)
3137 return ada_opname_table
[i
].decoded
;
3139 error (_("Could not find operator name for opcode"));
3142 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3143 in a listing of choices during disambiguation (see sort_choices, below).
3144 The idea is that overloadings of a subprogram name from the
3145 same package should sort in their source order. We settle for ordering
3146 such symbols by their trailing number (__N or $N). */
3149 encoded_ordered_before (const char *N0
, const char *N1
)
3153 else if (N0
== NULL
)
3159 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3161 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3163 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3164 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3169 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3172 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3174 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3175 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3177 return (strcmp (N0
, N1
) < 0);
3181 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3185 sort_choices (struct block_symbol syms
[], int nsyms
)
3189 for (i
= 1; i
< nsyms
; i
+= 1)
3191 struct block_symbol sym
= syms
[i
];
3194 for (j
= i
- 1; j
>= 0; j
-= 1)
3196 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3197 sym
.symbol
->linkage_name ()))
3199 syms
[j
+ 1] = syms
[j
];
3205 /* Whether GDB should display formals and return types for functions in the
3206 overloads selection menu. */
3207 static bool print_signatures
= true;
3209 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3210 all but functions, the signature is just the name of the symbol. For
3211 functions, this is the name of the function, the list of types for formals
3212 and the return type (if any). */
3215 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3216 const struct type_print_options
*flags
)
3218 struct type
*type
= SYMBOL_TYPE (sym
);
3220 fprintf_filtered (stream
, "%s", sym
->print_name ());
3221 if (!print_signatures
3223 || type
->code () != TYPE_CODE_FUNC
)
3226 if (type
->num_fields () > 0)
3230 fprintf_filtered (stream
, " (");
3231 for (i
= 0; i
< type
->num_fields (); ++i
)
3234 fprintf_filtered (stream
, "; ");
3235 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3238 fprintf_filtered (stream
, ")");
3240 if (TYPE_TARGET_TYPE (type
) != NULL
3241 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3243 fprintf_filtered (stream
, " return ");
3244 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3248 /* Read and validate a set of numeric choices from the user in the
3249 range 0 .. N_CHOICES-1. Place the results in increasing
3250 order in CHOICES[0 .. N-1], and return N.
3252 The user types choices as a sequence of numbers on one line
3253 separated by blanks, encoding them as follows:
3255 + A choice of 0 means to cancel the selection, throwing an error.
3256 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3257 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3259 The user is not allowed to choose more than MAX_RESULTS values.
3261 ANNOTATION_SUFFIX, if present, is used to annotate the input
3262 prompts (for use with the -f switch). */
3265 get_selections (int *choices
, int n_choices
, int max_results
,
3266 int is_all_choice
, const char *annotation_suffix
)
3271 int first_choice
= is_all_choice
? 2 : 1;
3273 prompt
= getenv ("PS2");
3277 args
= command_line_input (prompt
, annotation_suffix
);
3280 error_no_arg (_("one or more choice numbers"));
3284 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3285 order, as given in args. Choices are validated. */
3291 args
= skip_spaces (args
);
3292 if (*args
== '\0' && n_chosen
== 0)
3293 error_no_arg (_("one or more choice numbers"));
3294 else if (*args
== '\0')
3297 choice
= strtol (args
, &args2
, 10);
3298 if (args
== args2
|| choice
< 0
3299 || choice
> n_choices
+ first_choice
- 1)
3300 error (_("Argument must be choice number"));
3304 error (_("cancelled"));
3306 if (choice
< first_choice
)
3308 n_chosen
= n_choices
;
3309 for (j
= 0; j
< n_choices
; j
+= 1)
3313 choice
-= first_choice
;
3315 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3319 if (j
< 0 || choice
!= choices
[j
])
3323 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3324 choices
[k
+ 1] = choices
[k
];
3325 choices
[j
+ 1] = choice
;
3330 if (n_chosen
> max_results
)
3331 error (_("Select no more than %d of the above"), max_results
);
3336 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3337 by asking the user (if necessary), returning the number selected,
3338 and setting the first elements of SYMS items. Error if no symbols
3341 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3342 to be re-integrated one of these days. */
3345 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3348 int *chosen
= XALLOCAVEC (int , nsyms
);
3350 int first_choice
= (max_results
== 1) ? 1 : 2;
3351 const char *select_mode
= multiple_symbols_select_mode ();
3353 if (max_results
< 1)
3354 error (_("Request to select 0 symbols!"));
3358 if (select_mode
== multiple_symbols_cancel
)
3360 canceled because the command is ambiguous\n\
3361 See set/show multiple-symbol."));
3363 /* If select_mode is "all", then return all possible symbols.
3364 Only do that if more than one symbol can be selected, of course.
3365 Otherwise, display the menu as usual. */
3366 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3369 printf_filtered (_("[0] cancel\n"));
3370 if (max_results
> 1)
3371 printf_filtered (_("[1] all\n"));
3373 sort_choices (syms
, nsyms
);
3375 for (i
= 0; i
< nsyms
; i
+= 1)
3377 if (syms
[i
].symbol
== NULL
)
3380 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3382 struct symtab_and_line sal
=
3383 find_function_start_sal (syms
[i
].symbol
, 1);
3385 printf_filtered ("[%d] ", i
+ first_choice
);
3386 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3387 &type_print_raw_options
);
3388 if (sal
.symtab
== NULL
)
3389 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3390 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3394 styled_string (file_name_style
.style (),
3395 symtab_to_filename_for_display (sal
.symtab
)),
3402 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3403 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3404 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3405 struct symtab
*symtab
= NULL
;
3407 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3408 symtab
= symbol_symtab (syms
[i
].symbol
);
3410 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3412 printf_filtered ("[%d] ", i
+ first_choice
);
3413 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3414 &type_print_raw_options
);
3415 printf_filtered (_(" at %s:%d\n"),
3416 symtab_to_filename_for_display (symtab
),
3417 SYMBOL_LINE (syms
[i
].symbol
));
3419 else if (is_enumeral
3420 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3422 printf_filtered (("[%d] "), i
+ first_choice
);
3423 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3424 gdb_stdout
, -1, 0, &type_print_raw_options
);
3425 printf_filtered (_("'(%s) (enumeral)\n"),
3426 syms
[i
].symbol
->print_name ());
3430 printf_filtered ("[%d] ", i
+ first_choice
);
3431 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3432 &type_print_raw_options
);
3435 printf_filtered (is_enumeral
3436 ? _(" in %s (enumeral)\n")
3438 symtab_to_filename_for_display (symtab
));
3440 printf_filtered (is_enumeral
3441 ? _(" (enumeral)\n")
3447 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3450 for (i
= 0; i
< n_chosen
; i
+= 1)
3451 syms
[i
] = syms
[chosen
[i
]];
3456 /* Resolve the operator of the subexpression beginning at
3457 position *POS of *EXPP. "Resolving" consists of replacing
3458 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3459 with their resolutions, replacing built-in operators with
3460 function calls to user-defined operators, where appropriate, and,
3461 when DEPROCEDURE_P is non-zero, converting function-valued variables
3462 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3463 are as in ada_resolve, above. */
3465 static struct value
*
3466 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3467 struct type
*context_type
, int parse_completion
,
3468 innermost_block_tracker
*tracker
)
3472 struct expression
*exp
; /* Convenience: == *expp. */
3473 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3474 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3475 int nargs
; /* Number of operands. */
3482 /* Pass one: resolve operands, saving their types and updating *pos,
3487 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3488 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3493 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3495 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3500 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3505 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3506 parse_completion
, tracker
);
3509 case OP_ATR_MODULUS
:
3519 case TERNOP_IN_RANGE
:
3520 case BINOP_IN_BOUNDS
:
3526 case OP_DISCRETE_RANGE
:
3528 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3537 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3539 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3541 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3559 case BINOP_LOGICAL_AND
:
3560 case BINOP_LOGICAL_OR
:
3561 case BINOP_BITWISE_AND
:
3562 case BINOP_BITWISE_IOR
:
3563 case BINOP_BITWISE_XOR
:
3566 case BINOP_NOTEQUAL
:
3573 case BINOP_SUBSCRIPT
:
3581 case UNOP_LOGICAL_NOT
:
3591 case OP_VAR_MSYM_VALUE
:
3598 case OP_INTERNALVAR
:
3608 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3611 case STRUCTOP_STRUCT
:
3612 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3625 error (_("Unexpected operator during name resolution"));
3628 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3629 for (i
= 0; i
< nargs
; i
+= 1)
3630 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3635 /* Pass two: perform any resolution on principal operator. */
3642 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3644 std::vector
<struct block_symbol
> candidates
;
3648 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3649 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3652 if (n_candidates
> 1)
3654 /* Types tend to get re-introduced locally, so if there
3655 are any local symbols that are not types, first filter
3658 for (j
= 0; j
< n_candidates
; j
+= 1)
3659 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3664 case LOC_REGPARM_ADDR
:
3672 if (j
< n_candidates
)
3675 while (j
< n_candidates
)
3677 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3679 candidates
[j
] = candidates
[n_candidates
- 1];
3688 if (n_candidates
== 0)
3689 error (_("No definition found for %s"),
3690 exp
->elts
[pc
+ 2].symbol
->print_name ());
3691 else if (n_candidates
== 1)
3693 else if (deprocedure_p
3694 && !is_nonfunction (candidates
.data (), n_candidates
))
3696 i
= ada_resolve_function
3697 (candidates
.data (), n_candidates
, NULL
, 0,
3698 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3699 context_type
, parse_completion
);
3701 error (_("Could not find a match for %s"),
3702 exp
->elts
[pc
+ 2].symbol
->print_name ());
3706 printf_filtered (_("Multiple matches for %s\n"),
3707 exp
->elts
[pc
+ 2].symbol
->print_name ());
3708 user_select_syms (candidates
.data (), n_candidates
, 1);
3712 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3713 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3714 tracker
->update (candidates
[i
]);
3718 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3721 replace_operator_with_call (expp
, pc
, 0, 4,
3722 exp
->elts
[pc
+ 2].symbol
,
3723 exp
->elts
[pc
+ 1].block
);
3730 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3731 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3733 std::vector
<struct block_symbol
> candidates
;
3737 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3738 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3741 if (n_candidates
== 1)
3745 i
= ada_resolve_function
3746 (candidates
.data (), n_candidates
,
3748 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3749 context_type
, parse_completion
);
3751 error (_("Could not find a match for %s"),
3752 exp
->elts
[pc
+ 5].symbol
->print_name ());
3755 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3756 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3757 tracker
->update (candidates
[i
]);
3768 case BINOP_BITWISE_AND
:
3769 case BINOP_BITWISE_IOR
:
3770 case BINOP_BITWISE_XOR
:
3772 case BINOP_NOTEQUAL
:
3780 case UNOP_LOGICAL_NOT
:
3782 if (possible_user_operator_p (op
, argvec
))
3784 std::vector
<struct block_symbol
> candidates
;
3788 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3792 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3793 nargs
, ada_decoded_op_name (op
), NULL
,
3798 replace_operator_with_call (expp
, pc
, nargs
, 1,
3799 candidates
[i
].symbol
,
3800 candidates
[i
].block
);
3811 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3812 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3813 exp
->elts
[pc
+ 1].objfile
,
3814 exp
->elts
[pc
+ 2].msymbol
);
3816 return evaluate_subexp_type (exp
, pos
);
3819 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3820 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3822 /* The term "match" here is rather loose. The match is heuristic and
3826 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3828 ftype
= ada_check_typedef (ftype
);
3829 atype
= ada_check_typedef (atype
);
3831 if (ftype
->code () == TYPE_CODE_REF
)
3832 ftype
= TYPE_TARGET_TYPE (ftype
);
3833 if (atype
->code () == TYPE_CODE_REF
)
3834 atype
= TYPE_TARGET_TYPE (atype
);
3836 switch (ftype
->code ())
3839 return ftype
->code () == atype
->code ();
3841 if (atype
->code () == TYPE_CODE_PTR
)
3842 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3843 TYPE_TARGET_TYPE (atype
), 0);
3846 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3848 case TYPE_CODE_ENUM
:
3849 case TYPE_CODE_RANGE
:
3850 switch (atype
->code ())
3853 case TYPE_CODE_ENUM
:
3854 case TYPE_CODE_RANGE
:
3860 case TYPE_CODE_ARRAY
:
3861 return (atype
->code () == TYPE_CODE_ARRAY
3862 || ada_is_array_descriptor_type (atype
));
3864 case TYPE_CODE_STRUCT
:
3865 if (ada_is_array_descriptor_type (ftype
))
3866 return (atype
->code () == TYPE_CODE_ARRAY
3867 || ada_is_array_descriptor_type (atype
));
3869 return (atype
->code () == TYPE_CODE_STRUCT
3870 && !ada_is_array_descriptor_type (atype
));
3872 case TYPE_CODE_UNION
:
3874 return (atype
->code () == ftype
->code ());
3878 /* Return non-zero if the formals of FUNC "sufficiently match" the
3879 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3880 may also be an enumeral, in which case it is treated as a 0-
3881 argument function. */
3884 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3887 struct type
*func_type
= SYMBOL_TYPE (func
);
3889 if (SYMBOL_CLASS (func
) == LOC_CONST
3890 && func_type
->code () == TYPE_CODE_ENUM
)
3891 return (n_actuals
== 0);
3892 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3895 if (func_type
->num_fields () != n_actuals
)
3898 for (i
= 0; i
< n_actuals
; i
+= 1)
3900 if (actuals
[i
] == NULL
)
3904 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3905 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3907 if (!ada_type_match (ftype
, atype
, 1))
3914 /* False iff function type FUNC_TYPE definitely does not produce a value
3915 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3916 FUNC_TYPE is not a valid function type with a non-null return type
3917 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3920 return_match (struct type
*func_type
, struct type
*context_type
)
3922 struct type
*return_type
;
3924 if (func_type
== NULL
)
3927 if (func_type
->code () == TYPE_CODE_FUNC
)
3928 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3930 return_type
= get_base_type (func_type
);
3931 if (return_type
== NULL
)
3934 context_type
= get_base_type (context_type
);
3936 if (return_type
->code () == TYPE_CODE_ENUM
)
3937 return context_type
== NULL
|| return_type
== context_type
;
3938 else if (context_type
== NULL
)
3939 return return_type
->code () != TYPE_CODE_VOID
;
3941 return return_type
->code () == context_type
->code ();
3945 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3946 function (if any) that matches the types of the NARGS arguments in
3947 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3948 that returns that type, then eliminate matches that don't. If
3949 CONTEXT_TYPE is void and there is at least one match that does not
3950 return void, eliminate all matches that do.
3952 Asks the user if there is more than one match remaining. Returns -1
3953 if there is no such symbol or none is selected. NAME is used
3954 solely for messages. May re-arrange and modify SYMS in
3955 the process; the index returned is for the modified vector. */
3958 ada_resolve_function (struct block_symbol syms
[],
3959 int nsyms
, struct value
**args
, int nargs
,
3960 const char *name
, struct type
*context_type
,
3961 int parse_completion
)
3965 int m
; /* Number of hits */
3968 /* In the first pass of the loop, we only accept functions matching
3969 context_type. If none are found, we add a second pass of the loop
3970 where every function is accepted. */
3971 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3973 for (k
= 0; k
< nsyms
; k
+= 1)
3975 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3977 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3978 && (fallback
|| return_match (type
, context_type
)))
3986 /* If we got multiple matches, ask the user which one to use. Don't do this
3987 interactive thing during completion, though, as the purpose of the
3988 completion is providing a list of all possible matches. Prompting the
3989 user to filter it down would be completely unexpected in this case. */
3992 else if (m
> 1 && !parse_completion
)
3994 printf_filtered (_("Multiple matches for %s\n"), name
);
3995 user_select_syms (syms
, m
, 1);
4001 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4002 on the function identified by SYM and BLOCK, and taking NARGS
4003 arguments. Update *EXPP as needed to hold more space. */
4006 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4007 int oplen
, struct symbol
*sym
,
4008 const struct block
*block
)
4010 /* We want to add 6 more elements (3 for funcall, 4 for function
4011 symbol, -OPLEN for operator being replaced) to the
4013 struct expression
*exp
= expp
->get ();
4014 int save_nelts
= exp
->nelts
;
4015 int extra_elts
= 7 - oplen
;
4016 exp
->nelts
+= extra_elts
;
4019 exp
->resize (exp
->nelts
);
4020 memmove (exp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4021 EXP_ELEM_TO_BYTES (save_nelts
- pc
- oplen
));
4023 exp
->resize (exp
->nelts
);
4025 exp
->elts
[pc
].opcode
= exp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4026 exp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4028 exp
->elts
[pc
+ 3].opcode
= exp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4029 exp
->elts
[pc
+ 4].block
= block
;
4030 exp
->elts
[pc
+ 5].symbol
= sym
;
4033 /* Type-class predicates */
4035 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4039 numeric_type_p (struct type
*type
)
4045 switch (type
->code ())
4050 case TYPE_CODE_RANGE
:
4051 return (type
== TYPE_TARGET_TYPE (type
)
4052 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4059 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4062 integer_type_p (struct type
*type
)
4068 switch (type
->code ())
4072 case TYPE_CODE_RANGE
:
4073 return (type
== TYPE_TARGET_TYPE (type
)
4074 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4081 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4084 scalar_type_p (struct type
*type
)
4090 switch (type
->code ())
4093 case TYPE_CODE_RANGE
:
4094 case TYPE_CODE_ENUM
:
4103 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4106 discrete_type_p (struct type
*type
)
4112 switch (type
->code ())
4115 case TYPE_CODE_RANGE
:
4116 case TYPE_CODE_ENUM
:
4117 case TYPE_CODE_BOOL
:
4125 /* Returns non-zero if OP with operands in the vector ARGS could be
4126 a user-defined function. Errs on the side of pre-defined operators
4127 (i.e., result 0). */
4130 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4132 struct type
*type0
=
4133 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4134 struct type
*type1
=
4135 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4149 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4153 case BINOP_BITWISE_AND
:
4154 case BINOP_BITWISE_IOR
:
4155 case BINOP_BITWISE_XOR
:
4156 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4159 case BINOP_NOTEQUAL
:
4164 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4167 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4170 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4174 case UNOP_LOGICAL_NOT
:
4176 return (!numeric_type_p (type0
));
4185 1. In the following, we assume that a renaming type's name may
4186 have an ___XD suffix. It would be nice if this went away at some
4188 2. We handle both the (old) purely type-based representation of
4189 renamings and the (new) variable-based encoding. At some point,
4190 it is devoutly to be hoped that the former goes away
4191 (FIXME: hilfinger-2007-07-09).
4192 3. Subprogram renamings are not implemented, although the XRS
4193 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4195 /* If SYM encodes a renaming,
4197 <renaming> renames <renamed entity>,
4199 sets *LEN to the length of the renamed entity's name,
4200 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4201 the string describing the subcomponent selected from the renamed
4202 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4203 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4204 are undefined). Otherwise, returns a value indicating the category
4205 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4206 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4207 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4208 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4209 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4210 may be NULL, in which case they are not assigned.
4212 [Currently, however, GCC does not generate subprogram renamings.] */
4214 enum ada_renaming_category
4215 ada_parse_renaming (struct symbol
*sym
,
4216 const char **renamed_entity
, int *len
,
4217 const char **renaming_expr
)
4219 enum ada_renaming_category kind
;
4224 return ADA_NOT_RENAMING
;
4225 switch (SYMBOL_CLASS (sym
))
4228 return ADA_NOT_RENAMING
;
4232 case LOC_OPTIMIZED_OUT
:
4233 info
= strstr (sym
->linkage_name (), "___XR");
4235 return ADA_NOT_RENAMING
;
4239 kind
= ADA_OBJECT_RENAMING
;
4243 kind
= ADA_EXCEPTION_RENAMING
;
4247 kind
= ADA_PACKAGE_RENAMING
;
4251 kind
= ADA_SUBPROGRAM_RENAMING
;
4255 return ADA_NOT_RENAMING
;
4259 if (renamed_entity
!= NULL
)
4260 *renamed_entity
= info
;
4261 suffix
= strstr (info
, "___XE");
4262 if (suffix
== NULL
|| suffix
== info
)
4263 return ADA_NOT_RENAMING
;
4265 *len
= strlen (info
) - strlen (suffix
);
4267 if (renaming_expr
!= NULL
)
4268 *renaming_expr
= suffix
;
4272 /* Compute the value of the given RENAMING_SYM, which is expected to
4273 be a symbol encoding a renaming expression. BLOCK is the block
4274 used to evaluate the renaming. */
4276 static struct value
*
4277 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4278 const struct block
*block
)
4280 const char *sym_name
;
4282 sym_name
= renaming_sym
->linkage_name ();
4283 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4284 return evaluate_expression (expr
.get ());
4288 /* Evaluation: Function Calls */
4290 /* Return an lvalue containing the value VAL. This is the identity on
4291 lvalues, and otherwise has the side-effect of allocating memory
4292 in the inferior where a copy of the value contents is copied. */
4294 static struct value
*
4295 ensure_lval (struct value
*val
)
4297 if (VALUE_LVAL (val
) == not_lval
4298 || VALUE_LVAL (val
) == lval_internalvar
)
4300 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4301 const CORE_ADDR addr
=
4302 value_as_long (value_allocate_space_in_inferior (len
));
4304 VALUE_LVAL (val
) = lval_memory
;
4305 set_value_address (val
, addr
);
4306 write_memory (addr
, value_contents (val
), len
);
4312 /* Given ARG, a value of type (pointer or reference to a)*
4313 structure/union, extract the component named NAME from the ultimate
4314 target structure/union and return it as a value with its
4317 The routine searches for NAME among all members of the structure itself
4318 and (recursively) among all members of any wrapper members
4321 If NO_ERR, then simply return NULL in case of error, rather than
4324 static struct value
*
4325 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4327 struct type
*t
, *t1
;
4332 t1
= t
= ada_check_typedef (value_type (arg
));
4333 if (t
->code () == TYPE_CODE_REF
)
4335 t1
= TYPE_TARGET_TYPE (t
);
4338 t1
= ada_check_typedef (t1
);
4339 if (t1
->code () == TYPE_CODE_PTR
)
4341 arg
= coerce_ref (arg
);
4346 while (t
->code () == TYPE_CODE_PTR
)
4348 t1
= TYPE_TARGET_TYPE (t
);
4351 t1
= ada_check_typedef (t1
);
4352 if (t1
->code () == TYPE_CODE_PTR
)
4354 arg
= value_ind (arg
);
4361 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4365 v
= ada_search_struct_field (name
, arg
, 0, t
);
4368 int bit_offset
, bit_size
, byte_offset
;
4369 struct type
*field_type
;
4372 if (t
->code () == TYPE_CODE_PTR
)
4373 address
= value_address (ada_value_ind (arg
));
4375 address
= value_address (ada_coerce_ref (arg
));
4377 /* Check to see if this is a tagged type. We also need to handle
4378 the case where the type is a reference to a tagged type, but
4379 we have to be careful to exclude pointers to tagged types.
4380 The latter should be shown as usual (as a pointer), whereas
4381 a reference should mostly be transparent to the user. */
4383 if (ada_is_tagged_type (t1
, 0)
4384 || (t1
->code () == TYPE_CODE_REF
4385 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4387 /* We first try to find the searched field in the current type.
4388 If not found then let's look in the fixed type. */
4390 if (!find_struct_field (name
, t1
, 0,
4391 &field_type
, &byte_offset
, &bit_offset
,
4400 /* Convert to fixed type in all cases, so that we have proper
4401 offsets to each field in unconstrained record types. */
4402 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4403 address
, NULL
, check_tag
);
4405 /* Resolve the dynamic type as well. */
4406 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4407 t1
= value_type (arg
);
4409 if (find_struct_field (name
, t1
, 0,
4410 &field_type
, &byte_offset
, &bit_offset
,
4415 if (t
->code () == TYPE_CODE_REF
)
4416 arg
= ada_coerce_ref (arg
);
4418 arg
= ada_value_ind (arg
);
4419 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4420 bit_offset
, bit_size
,
4424 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4428 if (v
!= NULL
|| no_err
)
4431 error (_("There is no member named %s."), name
);
4437 error (_("Attempt to extract a component of "
4438 "a value that is not a record."));
4441 /* Return the value ACTUAL, converted to be an appropriate value for a
4442 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4443 allocating any necessary descriptors (fat pointers), or copies of
4444 values not residing in memory, updating it as needed. */
4447 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4449 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4450 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4451 struct type
*formal_target
=
4452 formal_type
->code () == TYPE_CODE_PTR
4453 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4454 struct type
*actual_target
=
4455 actual_type
->code () == TYPE_CODE_PTR
4456 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4458 if (ada_is_array_descriptor_type (formal_target
)
4459 && actual_target
->code () == TYPE_CODE_ARRAY
)
4460 return make_array_descriptor (formal_type
, actual
);
4461 else if (formal_type
->code () == TYPE_CODE_PTR
4462 || formal_type
->code () == TYPE_CODE_REF
)
4464 struct value
*result
;
4466 if (formal_target
->code () == TYPE_CODE_ARRAY
4467 && ada_is_array_descriptor_type (actual_target
))
4468 result
= desc_data (actual
);
4469 else if (formal_type
->code () != TYPE_CODE_PTR
)
4471 if (VALUE_LVAL (actual
) != lval_memory
)
4475 actual_type
= ada_check_typedef (value_type (actual
));
4476 val
= allocate_value (actual_type
);
4477 memcpy ((char *) value_contents_raw (val
),
4478 (char *) value_contents (actual
),
4479 TYPE_LENGTH (actual_type
));
4480 actual
= ensure_lval (val
);
4482 result
= value_addr (actual
);
4486 return value_cast_pointers (formal_type
, result
, 0);
4488 else if (actual_type
->code () == TYPE_CODE_PTR
)
4489 return ada_value_ind (actual
);
4490 else if (ada_is_aligner_type (formal_type
))
4492 /* We need to turn this parameter into an aligner type
4494 struct value
*aligner
= allocate_value (formal_type
);
4495 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4497 value_assign_to_component (aligner
, component
, actual
);
4504 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4505 type TYPE. This is usually an inefficient no-op except on some targets
4506 (such as AVR) where the representation of a pointer and an address
4510 value_pointer (struct value
*value
, struct type
*type
)
4512 struct gdbarch
*gdbarch
= get_type_arch (type
);
4513 unsigned len
= TYPE_LENGTH (type
);
4514 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4517 addr
= value_address (value
);
4518 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4519 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4524 /* Push a descriptor of type TYPE for array value ARR on the stack at
4525 *SP, updating *SP to reflect the new descriptor. Return either
4526 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4527 to-descriptor type rather than a descriptor type), a struct value *
4528 representing a pointer to this descriptor. */
4530 static struct value
*
4531 make_array_descriptor (struct type
*type
, struct value
*arr
)
4533 struct type
*bounds_type
= desc_bounds_type (type
);
4534 struct type
*desc_type
= desc_base_type (type
);
4535 struct value
*descriptor
= allocate_value (desc_type
);
4536 struct value
*bounds
= allocate_value (bounds_type
);
4539 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4542 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4543 ada_array_bound (arr
, i
, 0),
4544 desc_bound_bitpos (bounds_type
, i
, 0),
4545 desc_bound_bitsize (bounds_type
, i
, 0));
4546 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4547 ada_array_bound (arr
, i
, 1),
4548 desc_bound_bitpos (bounds_type
, i
, 1),
4549 desc_bound_bitsize (bounds_type
, i
, 1));
4552 bounds
= ensure_lval (bounds
);
4554 modify_field (value_type (descriptor
),
4555 value_contents_writeable (descriptor
),
4556 value_pointer (ensure_lval (arr
),
4557 desc_type
->field (0).type ()),
4558 fat_pntr_data_bitpos (desc_type
),
4559 fat_pntr_data_bitsize (desc_type
));
4561 modify_field (value_type (descriptor
),
4562 value_contents_writeable (descriptor
),
4563 value_pointer (bounds
,
4564 desc_type
->field (1).type ()),
4565 fat_pntr_bounds_bitpos (desc_type
),
4566 fat_pntr_bounds_bitsize (desc_type
));
4568 descriptor
= ensure_lval (descriptor
);
4570 if (type
->code () == TYPE_CODE_PTR
)
4571 return value_addr (descriptor
);
4576 /* Symbol Cache Module */
4578 /* Performance measurements made as of 2010-01-15 indicate that
4579 this cache does bring some noticeable improvements. Depending
4580 on the type of entity being printed, the cache can make it as much
4581 as an order of magnitude faster than without it.
4583 The descriptive type DWARF extension has significantly reduced
4584 the need for this cache, at least when DWARF is being used. However,
4585 even in this case, some expensive name-based symbol searches are still
4586 sometimes necessary - to find an XVZ variable, mostly. */
4588 /* Initialize the contents of SYM_CACHE. */
4591 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4593 obstack_init (&sym_cache
->cache_space
);
4594 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4597 /* Free the memory used by SYM_CACHE. */
4600 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4602 obstack_free (&sym_cache
->cache_space
, NULL
);
4606 /* Return the symbol cache associated to the given program space PSPACE.
4607 If not allocated for this PSPACE yet, allocate and initialize one. */
4609 static struct ada_symbol_cache
*
4610 ada_get_symbol_cache (struct program_space
*pspace
)
4612 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4614 if (pspace_data
->sym_cache
== NULL
)
4616 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4617 ada_init_symbol_cache (pspace_data
->sym_cache
);
4620 return pspace_data
->sym_cache
;
4623 /* Clear all entries from the symbol cache. */
4626 ada_clear_symbol_cache (void)
4628 struct ada_symbol_cache
*sym_cache
4629 = ada_get_symbol_cache (current_program_space
);
4631 obstack_free (&sym_cache
->cache_space
, NULL
);
4632 ada_init_symbol_cache (sym_cache
);
4635 /* Search our cache for an entry matching NAME and DOMAIN.
4636 Return it if found, or NULL otherwise. */
4638 static struct cache_entry
**
4639 find_entry (const char *name
, domain_enum domain
)
4641 struct ada_symbol_cache
*sym_cache
4642 = ada_get_symbol_cache (current_program_space
);
4643 int h
= msymbol_hash (name
) % HASH_SIZE
;
4644 struct cache_entry
**e
;
4646 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4648 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4654 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4655 Return 1 if found, 0 otherwise.
4657 If an entry was found and SYM is not NULL, set *SYM to the entry's
4658 SYM. Same principle for BLOCK if not NULL. */
4661 lookup_cached_symbol (const char *name
, domain_enum domain
,
4662 struct symbol
**sym
, const struct block
**block
)
4664 struct cache_entry
**e
= find_entry (name
, domain
);
4671 *block
= (*e
)->block
;
4675 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4676 in domain DOMAIN, save this result in our symbol cache. */
4679 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4680 const struct block
*block
)
4682 struct ada_symbol_cache
*sym_cache
4683 = ada_get_symbol_cache (current_program_space
);
4685 struct cache_entry
*e
;
4687 /* Symbols for builtin types don't have a block.
4688 For now don't cache such symbols. */
4689 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4692 /* If the symbol is a local symbol, then do not cache it, as a search
4693 for that symbol depends on the context. To determine whether
4694 the symbol is local or not, we check the block where we found it
4695 against the global and static blocks of its associated symtab. */
4697 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4698 GLOBAL_BLOCK
) != block
4699 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4700 STATIC_BLOCK
) != block
)
4703 h
= msymbol_hash (name
) % HASH_SIZE
;
4704 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4705 e
->next
= sym_cache
->root
[h
];
4706 sym_cache
->root
[h
] = e
;
4707 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4715 /* Return the symbol name match type that should be used used when
4716 searching for all symbols matching LOOKUP_NAME.
4718 LOOKUP_NAME is expected to be a symbol name after transformation
4721 static symbol_name_match_type
4722 name_match_type_from_name (const char *lookup_name
)
4724 return (strstr (lookup_name
, "__") == NULL
4725 ? symbol_name_match_type::WILD
4726 : symbol_name_match_type::FULL
);
4729 /* Return the result of a standard (literal, C-like) lookup of NAME in
4730 given DOMAIN, visible from lexical block BLOCK. */
4732 static struct symbol
*
4733 standard_lookup (const char *name
, const struct block
*block
,
4736 /* Initialize it just to avoid a GCC false warning. */
4737 struct block_symbol sym
= {};
4739 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4741 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4742 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4747 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4748 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4749 since they contend in overloading in the same way. */
4751 is_nonfunction (struct block_symbol syms
[], int n
)
4755 for (i
= 0; i
< n
; i
+= 1)
4756 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4757 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4758 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4764 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4765 struct types. Otherwise, they may not. */
4768 equiv_types (struct type
*type0
, struct type
*type1
)
4772 if (type0
== NULL
|| type1
== NULL
4773 || type0
->code () != type1
->code ())
4775 if ((type0
->code () == TYPE_CODE_STRUCT
4776 || type0
->code () == TYPE_CODE_ENUM
)
4777 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4778 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4784 /* True iff SYM0 represents the same entity as SYM1, or one that is
4785 no more defined than that of SYM1. */
4788 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4792 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4793 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4796 switch (SYMBOL_CLASS (sym0
))
4802 struct type
*type0
= SYMBOL_TYPE (sym0
);
4803 struct type
*type1
= SYMBOL_TYPE (sym1
);
4804 const char *name0
= sym0
->linkage_name ();
4805 const char *name1
= sym1
->linkage_name ();
4806 int len0
= strlen (name0
);
4809 type0
->code () == type1
->code ()
4810 && (equiv_types (type0
, type1
)
4811 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4812 && startswith (name1
+ len0
, "___XV")));
4815 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4816 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4820 const char *name0
= sym0
->linkage_name ();
4821 const char *name1
= sym1
->linkage_name ();
4822 return (strcmp (name0
, name1
) == 0
4823 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4831 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4832 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4835 add_defn_to_vec (struct obstack
*obstackp
,
4837 const struct block
*block
)
4840 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4842 /* Do not try to complete stub types, as the debugger is probably
4843 already scanning all symbols matching a certain name at the
4844 time when this function is called. Trying to replace the stub
4845 type by its associated full type will cause us to restart a scan
4846 which may lead to an infinite recursion. Instead, the client
4847 collecting the matching symbols will end up collecting several
4848 matches, with at least one of them complete. It can then filter
4849 out the stub ones if needed. */
4851 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4853 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4855 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4857 prevDefns
[i
].symbol
= sym
;
4858 prevDefns
[i
].block
= block
;
4864 struct block_symbol info
;
4868 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4872 /* Number of block_symbol structures currently collected in current vector in
4876 num_defns_collected (struct obstack
*obstackp
)
4878 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4881 /* Vector of block_symbol structures currently collected in current vector in
4882 OBSTACKP. If FINISH, close off the vector and return its final address. */
4884 static struct block_symbol
*
4885 defns_collected (struct obstack
*obstackp
, int finish
)
4888 return (struct block_symbol
*) obstack_finish (obstackp
);
4890 return (struct block_symbol
*) obstack_base (obstackp
);
4893 /* Return a bound minimal symbol matching NAME according to Ada
4894 decoding rules. Returns an invalid symbol if there is no such
4895 minimal symbol. Names prefixed with "standard__" are handled
4896 specially: "standard__" is first stripped off, and only static and
4897 global symbols are searched. */
4899 struct bound_minimal_symbol
4900 ada_lookup_simple_minsym (const char *name
)
4902 struct bound_minimal_symbol result
;
4904 memset (&result
, 0, sizeof (result
));
4906 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4907 lookup_name_info
lookup_name (name
, match_type
);
4909 symbol_name_matcher_ftype
*match_name
4910 = ada_get_symbol_name_matcher (lookup_name
);
4912 for (objfile
*objfile
: current_program_space
->objfiles ())
4914 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4916 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4917 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4919 result
.minsym
= msymbol
;
4920 result
.objfile
= objfile
;
4929 /* For all subprograms that statically enclose the subprogram of the
4930 selected frame, add symbols matching identifier NAME in DOMAIN
4931 and their blocks to the list of data in OBSTACKP, as for
4932 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4933 with a wildcard prefix. */
4936 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4937 const lookup_name_info
&lookup_name
,
4942 /* True if TYPE is definitely an artificial type supplied to a symbol
4943 for which no debugging information was given in the symbol file. */
4946 is_nondebugging_type (struct type
*type
)
4948 const char *name
= ada_type_name (type
);
4950 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4953 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4954 that are deemed "identical" for practical purposes.
4956 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4957 types and that their number of enumerals is identical (in other
4958 words, type1->num_fields () == type2->num_fields ()). */
4961 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4965 /* The heuristic we use here is fairly conservative. We consider
4966 that 2 enumerate types are identical if they have the same
4967 number of enumerals and that all enumerals have the same
4968 underlying value and name. */
4970 /* All enums in the type should have an identical underlying value. */
4971 for (i
= 0; i
< type1
->num_fields (); i
++)
4972 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4975 /* All enumerals should also have the same name (modulo any numerical
4977 for (i
= 0; i
< type1
->num_fields (); i
++)
4979 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4980 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4981 int len_1
= strlen (name_1
);
4982 int len_2
= strlen (name_2
);
4984 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4985 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4987 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4988 TYPE_FIELD_NAME (type2
, i
),
4996 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4997 that are deemed "identical" for practical purposes. Sometimes,
4998 enumerals are not strictly identical, but their types are so similar
4999 that they can be considered identical.
5001 For instance, consider the following code:
5003 type Color is (Black, Red, Green, Blue, White);
5004 type RGB_Color is new Color range Red .. Blue;
5006 Type RGB_Color is a subrange of an implicit type which is a copy
5007 of type Color. If we call that implicit type RGB_ColorB ("B" is
5008 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5009 As a result, when an expression references any of the enumeral
5010 by name (Eg. "print green"), the expression is technically
5011 ambiguous and the user should be asked to disambiguate. But
5012 doing so would only hinder the user, since it wouldn't matter
5013 what choice he makes, the outcome would always be the same.
5014 So, for practical purposes, we consider them as the same. */
5017 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5021 /* Before performing a thorough comparison check of each type,
5022 we perform a series of inexpensive checks. We expect that these
5023 checks will quickly fail in the vast majority of cases, and thus
5024 help prevent the unnecessary use of a more expensive comparison.
5025 Said comparison also expects us to make some of these checks
5026 (see ada_identical_enum_types_p). */
5028 /* Quick check: All symbols should have an enum type. */
5029 for (i
= 0; i
< syms
.size (); i
++)
5030 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
5033 /* Quick check: They should all have the same value. */
5034 for (i
= 1; i
< syms
.size (); i
++)
5035 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5038 /* Quick check: They should all have the same number of enumerals. */
5039 for (i
= 1; i
< syms
.size (); i
++)
5040 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
5041 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
5044 /* All the sanity checks passed, so we might have a set of
5045 identical enumeration types. Perform a more complete
5046 comparison of the type of each symbol. */
5047 for (i
= 1; i
< syms
.size (); i
++)
5048 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5049 SYMBOL_TYPE (syms
[0].symbol
)))
5055 /* Remove any non-debugging symbols in SYMS that definitely
5056 duplicate other symbols in the list (The only case I know of where
5057 this happens is when object files containing stabs-in-ecoff are
5058 linked with files containing ordinary ecoff debugging symbols (or no
5059 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5060 Returns the number of items in the modified list. */
5063 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5067 /* We should never be called with less than 2 symbols, as there
5068 cannot be any extra symbol in that case. But it's easy to
5069 handle, since we have nothing to do in that case. */
5070 if (syms
->size () < 2)
5071 return syms
->size ();
5074 while (i
< syms
->size ())
5078 /* If two symbols have the same name and one of them is a stub type,
5079 the get rid of the stub. */
5081 if (SYMBOL_TYPE ((*syms
)[i
].symbol
)->is_stub ()
5082 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5084 for (j
= 0; j
< syms
->size (); j
++)
5087 && !SYMBOL_TYPE ((*syms
)[j
].symbol
)->is_stub ()
5088 && (*syms
)[j
].symbol
->linkage_name () != NULL
5089 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5090 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5095 /* Two symbols with the same name, same class and same address
5096 should be identical. */
5098 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5099 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5100 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5102 for (j
= 0; j
< syms
->size (); j
+= 1)
5105 && (*syms
)[j
].symbol
->linkage_name () != NULL
5106 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5107 (*syms
)[j
].symbol
->linkage_name ()) == 0
5108 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5109 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5110 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5111 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5117 syms
->erase (syms
->begin () + i
);
5122 /* If all the remaining symbols are identical enumerals, then
5123 just keep the first one and discard the rest.
5125 Unlike what we did previously, we do not discard any entry
5126 unless they are ALL identical. This is because the symbol
5127 comparison is not a strict comparison, but rather a practical
5128 comparison. If all symbols are considered identical, then
5129 we can just go ahead and use the first one and discard the rest.
5130 But if we cannot reduce the list to a single element, we have
5131 to ask the user to disambiguate anyways. And if we have to
5132 present a multiple-choice menu, it's less confusing if the list
5133 isn't missing some choices that were identical and yet distinct. */
5134 if (symbols_are_identical_enums (*syms
))
5137 return syms
->size ();
5140 /* Given a type that corresponds to a renaming entity, use the type name
5141 to extract the scope (package name or function name, fully qualified,
5142 and following the GNAT encoding convention) where this renaming has been
5146 xget_renaming_scope (struct type
*renaming_type
)
5148 /* The renaming types adhere to the following convention:
5149 <scope>__<rename>___<XR extension>.
5150 So, to extract the scope, we search for the "___XR" extension,
5151 and then backtrack until we find the first "__". */
5153 const char *name
= renaming_type
->name ();
5154 const char *suffix
= strstr (name
, "___XR");
5157 /* Now, backtrack a bit until we find the first "__". Start looking
5158 at suffix - 3, as the <rename> part is at least one character long. */
5160 for (last
= suffix
- 3; last
> name
; last
--)
5161 if (last
[0] == '_' && last
[1] == '_')
5164 /* Make a copy of scope and return it. */
5165 return std::string (name
, last
);
5168 /* Return nonzero if NAME corresponds to a package name. */
5171 is_package_name (const char *name
)
5173 /* Here, We take advantage of the fact that no symbols are generated
5174 for packages, while symbols are generated for each function.
5175 So the condition for NAME represent a package becomes equivalent
5176 to NAME not existing in our list of symbols. There is only one
5177 small complication with library-level functions (see below). */
5179 /* If it is a function that has not been defined at library level,
5180 then we should be able to look it up in the symbols. */
5181 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5184 /* Library-level function names start with "_ada_". See if function
5185 "_ada_" followed by NAME can be found. */
5187 /* Do a quick check that NAME does not contain "__", since library-level
5188 functions names cannot contain "__" in them. */
5189 if (strstr (name
, "__") != NULL
)
5192 std::string fun_name
= string_printf ("_ada_%s", name
);
5194 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5197 /* Return nonzero if SYM corresponds to a renaming entity that is
5198 not visible from FUNCTION_NAME. */
5201 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5203 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5206 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5208 /* If the rename has been defined in a package, then it is visible. */
5209 if (is_package_name (scope
.c_str ()))
5212 /* Check that the rename is in the current function scope by checking
5213 that its name starts with SCOPE. */
5215 /* If the function name starts with "_ada_", it means that it is
5216 a library-level function. Strip this prefix before doing the
5217 comparison, as the encoding for the renaming does not contain
5219 if (startswith (function_name
, "_ada_"))
5222 return !startswith (function_name
, scope
.c_str ());
5225 /* Remove entries from SYMS that corresponds to a renaming entity that
5226 is not visible from the function associated with CURRENT_BLOCK or
5227 that is superfluous due to the presence of more specific renaming
5228 information. Places surviving symbols in the initial entries of
5229 SYMS and returns the number of surviving symbols.
5232 First, in cases where an object renaming is implemented as a
5233 reference variable, GNAT may produce both the actual reference
5234 variable and the renaming encoding. In this case, we discard the
5237 Second, GNAT emits a type following a specified encoding for each renaming
5238 entity. Unfortunately, STABS currently does not support the definition
5239 of types that are local to a given lexical block, so all renamings types
5240 are emitted at library level. As a consequence, if an application
5241 contains two renaming entities using the same name, and a user tries to
5242 print the value of one of these entities, the result of the ada symbol
5243 lookup will also contain the wrong renaming type.
5245 This function partially covers for this limitation by attempting to
5246 remove from the SYMS list renaming symbols that should be visible
5247 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5248 method with the current information available. The implementation
5249 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5251 - When the user tries to print a rename in a function while there
5252 is another rename entity defined in a package: Normally, the
5253 rename in the function has precedence over the rename in the
5254 package, so the latter should be removed from the list. This is
5255 currently not the case.
5257 - This function will incorrectly remove valid renames if
5258 the CURRENT_BLOCK corresponds to a function which symbol name
5259 has been changed by an "Export" pragma. As a consequence,
5260 the user will be unable to print such rename entities. */
5263 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5264 const struct block
*current_block
)
5266 struct symbol
*current_function
;
5267 const char *current_function_name
;
5269 int is_new_style_renaming
;
5271 /* If there is both a renaming foo___XR... encoded as a variable and
5272 a simple variable foo in the same block, discard the latter.
5273 First, zero out such symbols, then compress. */
5274 is_new_style_renaming
= 0;
5275 for (i
= 0; i
< syms
->size (); i
+= 1)
5277 struct symbol
*sym
= (*syms
)[i
].symbol
;
5278 const struct block
*block
= (*syms
)[i
].block
;
5282 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5284 name
= sym
->linkage_name ();
5285 suffix
= strstr (name
, "___XR");
5289 int name_len
= suffix
- name
;
5292 is_new_style_renaming
= 1;
5293 for (j
= 0; j
< syms
->size (); j
+= 1)
5294 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5295 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5297 && block
== (*syms
)[j
].block
)
5298 (*syms
)[j
].symbol
= NULL
;
5301 if (is_new_style_renaming
)
5305 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5306 if ((*syms
)[j
].symbol
!= NULL
)
5308 (*syms
)[k
] = (*syms
)[j
];
5314 /* Extract the function name associated to CURRENT_BLOCK.
5315 Abort if unable to do so. */
5317 if (current_block
== NULL
)
5318 return syms
->size ();
5320 current_function
= block_linkage_function (current_block
);
5321 if (current_function
== NULL
)
5322 return syms
->size ();
5324 current_function_name
= current_function
->linkage_name ();
5325 if (current_function_name
== NULL
)
5326 return syms
->size ();
5328 /* Check each of the symbols, and remove it from the list if it is
5329 a type corresponding to a renaming that is out of the scope of
5330 the current block. */
5333 while (i
< syms
->size ())
5335 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5336 == ADA_OBJECT_RENAMING
5337 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5338 current_function_name
))
5339 syms
->erase (syms
->begin () + i
);
5344 return syms
->size ();
5347 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5348 whose name and domain match NAME and DOMAIN respectively.
5349 If no match was found, then extend the search to "enclosing"
5350 routines (in other words, if we're inside a nested function,
5351 search the symbols defined inside the enclosing functions).
5352 If WILD_MATCH_P is nonzero, perform the naming matching in
5353 "wild" mode (see function "wild_match" for more info).
5355 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5358 ada_add_local_symbols (struct obstack
*obstackp
,
5359 const lookup_name_info
&lookup_name
,
5360 const struct block
*block
, domain_enum domain
)
5362 int block_depth
= 0;
5364 while (block
!= NULL
)
5367 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5369 /* If we found a non-function match, assume that's the one. */
5370 if (is_nonfunction (defns_collected (obstackp
, 0),
5371 num_defns_collected (obstackp
)))
5374 block
= BLOCK_SUPERBLOCK (block
);
5377 /* If no luck so far, try to find NAME as a local symbol in some lexically
5378 enclosing subprogram. */
5379 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5380 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5383 /* An object of this type is used as the user_data argument when
5384 calling the map_matching_symbols method. */
5388 struct objfile
*objfile
;
5389 struct obstack
*obstackp
;
5390 struct symbol
*arg_sym
;
5394 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5395 to a list of symbols. DATA is a pointer to a struct match_data *
5396 containing the obstack that collects the symbol list, the file that SYM
5397 must come from, a flag indicating whether a non-argument symbol has
5398 been found in the current block, and the last argument symbol
5399 passed in SYM within the current block (if any). When SYM is null,
5400 marking the end of a block, the argument symbol is added if no
5401 other has been found. */
5404 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5405 struct match_data
*data
)
5407 const struct block
*block
= bsym
->block
;
5408 struct symbol
*sym
= bsym
->symbol
;
5412 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5413 add_defn_to_vec (data
->obstackp
,
5414 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5416 data
->found_sym
= 0;
5417 data
->arg_sym
= NULL
;
5421 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5423 else if (SYMBOL_IS_ARGUMENT (sym
))
5424 data
->arg_sym
= sym
;
5427 data
->found_sym
= 1;
5428 add_defn_to_vec (data
->obstackp
,
5429 fixup_symbol_section (sym
, data
->objfile
),
5436 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5437 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5438 symbols to OBSTACKP. Return whether we found such symbols. */
5441 ada_add_block_renamings (struct obstack
*obstackp
,
5442 const struct block
*block
,
5443 const lookup_name_info
&lookup_name
,
5446 struct using_direct
*renaming
;
5447 int defns_mark
= num_defns_collected (obstackp
);
5449 symbol_name_matcher_ftype
*name_match
5450 = ada_get_symbol_name_matcher (lookup_name
);
5452 for (renaming
= block_using (block
);
5454 renaming
= renaming
->next
)
5458 /* Avoid infinite recursions: skip this renaming if we are actually
5459 already traversing it.
5461 Currently, symbol lookup in Ada don't use the namespace machinery from
5462 C++/Fortran support: skip namespace imports that use them. */
5463 if (renaming
->searched
5464 || (renaming
->import_src
!= NULL
5465 && renaming
->import_src
[0] != '\0')
5466 || (renaming
->import_dest
!= NULL
5467 && renaming
->import_dest
[0] != '\0'))
5469 renaming
->searched
= 1;
5471 /* TODO: here, we perform another name-based symbol lookup, which can
5472 pull its own multiple overloads. In theory, we should be able to do
5473 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5474 not a simple name. But in order to do this, we would need to enhance
5475 the DWARF reader to associate a symbol to this renaming, instead of a
5476 name. So, for now, we do something simpler: re-use the C++/Fortran
5477 namespace machinery. */
5478 r_name
= (renaming
->alias
!= NULL
5480 : renaming
->declaration
);
5481 if (name_match (r_name
, lookup_name
, NULL
))
5483 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5484 lookup_name
.match_type ());
5485 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5488 renaming
->searched
= 0;
5490 return num_defns_collected (obstackp
) != defns_mark
;
5493 /* Implements compare_names, but only applying the comparision using
5494 the given CASING. */
5497 compare_names_with_case (const char *string1
, const char *string2
,
5498 enum case_sensitivity casing
)
5500 while (*string1
!= '\0' && *string2
!= '\0')
5504 if (isspace (*string1
) || isspace (*string2
))
5505 return strcmp_iw_ordered (string1
, string2
);
5507 if (casing
== case_sensitive_off
)
5509 c1
= tolower (*string1
);
5510 c2
= tolower (*string2
);
5527 return strcmp_iw_ordered (string1
, string2
);
5529 if (*string2
== '\0')
5531 if (is_name_suffix (string1
))
5538 if (*string2
== '(')
5539 return strcmp_iw_ordered (string1
, string2
);
5542 if (casing
== case_sensitive_off
)
5543 return tolower (*string1
) - tolower (*string2
);
5545 return *string1
- *string2
;
5550 /* Compare STRING1 to STRING2, with results as for strcmp.
5551 Compatible with strcmp_iw_ordered in that...
5553 strcmp_iw_ordered (STRING1, STRING2) <= 0
5557 compare_names (STRING1, STRING2) <= 0
5559 (they may differ as to what symbols compare equal). */
5562 compare_names (const char *string1
, const char *string2
)
5566 /* Similar to what strcmp_iw_ordered does, we need to perform
5567 a case-insensitive comparison first, and only resort to
5568 a second, case-sensitive, comparison if the first one was
5569 not sufficient to differentiate the two strings. */
5571 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5573 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5578 /* Convenience function to get at the Ada encoded lookup name for
5579 LOOKUP_NAME, as a C string. */
5582 ada_lookup_name (const lookup_name_info
&lookup_name
)
5584 return lookup_name
.ada ().lookup_name ().c_str ();
5587 /* Add to OBSTACKP all non-local symbols whose name and domain match
5588 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5589 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5590 symbols otherwise. */
5593 add_nonlocal_symbols (struct obstack
*obstackp
,
5594 const lookup_name_info
&lookup_name
,
5595 domain_enum domain
, int global
)
5597 struct match_data data
;
5599 memset (&data
, 0, sizeof data
);
5600 data
.obstackp
= obstackp
;
5602 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5604 auto callback
= [&] (struct block_symbol
*bsym
)
5606 return aux_add_nonlocal_symbols (bsym
, &data
);
5609 for (objfile
*objfile
: current_program_space
->objfiles ())
5611 data
.objfile
= objfile
;
5613 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5614 domain
, global
, callback
,
5616 ? NULL
: compare_names
));
5618 for (compunit_symtab
*cu
: objfile
->compunits ())
5620 const struct block
*global_block
5621 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5623 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5629 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5631 const char *name
= ada_lookup_name (lookup_name
);
5632 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5633 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5635 for (objfile
*objfile
: current_program_space
->objfiles ())
5637 data
.objfile
= objfile
;
5638 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5639 domain
, global
, callback
,
5645 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5646 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5647 returning the number of matches. Add these to OBSTACKP.
5649 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5650 symbol match within the nest of blocks whose innermost member is BLOCK,
5651 is the one match returned (no other matches in that or
5652 enclosing blocks is returned). If there are any matches in or
5653 surrounding BLOCK, then these alone are returned.
5655 Names prefixed with "standard__" are handled specially:
5656 "standard__" is first stripped off (by the lookup_name
5657 constructor), and only static and global symbols are searched.
5659 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5660 to lookup global symbols. */
5663 ada_add_all_symbols (struct obstack
*obstackp
,
5664 const struct block
*block
,
5665 const lookup_name_info
&lookup_name
,
5668 int *made_global_lookup_p
)
5672 if (made_global_lookup_p
)
5673 *made_global_lookup_p
= 0;
5675 /* Special case: If the user specifies a symbol name inside package
5676 Standard, do a non-wild matching of the symbol name without
5677 the "standard__" prefix. This was primarily introduced in order
5678 to allow the user to specifically access the standard exceptions
5679 using, for instance, Standard.Constraint_Error when Constraint_Error
5680 is ambiguous (due to the user defining its own Constraint_Error
5681 entity inside its program). */
5682 if (lookup_name
.ada ().standard_p ())
5685 /* Check the non-global symbols. If we have ANY match, then we're done. */
5690 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5693 /* In the !full_search case we're are being called by
5694 iterate_over_symbols, and we don't want to search
5696 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5698 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5702 /* No non-global symbols found. Check our cache to see if we have
5703 already performed this search before. If we have, then return
5706 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5707 domain
, &sym
, &block
))
5710 add_defn_to_vec (obstackp
, sym
, block
);
5714 if (made_global_lookup_p
)
5715 *made_global_lookup_p
= 1;
5717 /* Search symbols from all global blocks. */
5719 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5721 /* Now add symbols from all per-file blocks if we've gotten no hits
5722 (not strictly correct, but perhaps better than an error). */
5724 if (num_defns_collected (obstackp
) == 0)
5725 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5728 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5729 is non-zero, enclosing scope and in global scopes, returning the number of
5731 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5732 found and the blocks and symbol tables (if any) in which they were
5735 When full_search is non-zero, any non-function/non-enumeral
5736 symbol match within the nest of blocks whose innermost member is BLOCK,
5737 is the one match returned (no other matches in that or
5738 enclosing blocks is returned). If there are any matches in or
5739 surrounding BLOCK, then these alone are returned.
5741 Names prefixed with "standard__" are handled specially: "standard__"
5742 is first stripped off, and only static and global symbols are searched. */
5745 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5746 const struct block
*block
,
5748 std::vector
<struct block_symbol
> *results
,
5751 int syms_from_global_search
;
5753 auto_obstack obstack
;
5755 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5756 domain
, full_search
, &syms_from_global_search
);
5758 ndefns
= num_defns_collected (&obstack
);
5760 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5761 for (int i
= 0; i
< ndefns
; ++i
)
5762 results
->push_back (base
[i
]);
5764 ndefns
= remove_extra_symbols (results
);
5766 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5767 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5769 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5770 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5771 (*results
)[0].symbol
, (*results
)[0].block
);
5773 ndefns
= remove_irrelevant_renamings (results
, block
);
5778 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5779 in global scopes, returning the number of matches, and filling *RESULTS
5780 with (SYM,BLOCK) tuples.
5782 See ada_lookup_symbol_list_worker for further details. */
5785 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5787 std::vector
<struct block_symbol
> *results
)
5789 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5790 lookup_name_info
lookup_name (name
, name_match_type
);
5792 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5795 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5796 to 1, but choosing the first symbol found if there are multiple
5799 The result is stored in *INFO, which must be non-NULL.
5800 If no match is found, INFO->SYM is set to NULL. */
5803 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5805 struct block_symbol
*info
)
5807 /* Since we already have an encoded name, wrap it in '<>' to force a
5808 verbatim match. Otherwise, if the name happens to not look like
5809 an encoded name (because it doesn't include a "__"),
5810 ada_lookup_name_info would re-encode/fold it again, and that
5811 would e.g., incorrectly lowercase object renaming names like
5812 "R28b" -> "r28b". */
5813 std::string verbatim
= add_angle_brackets (name
);
5815 gdb_assert (info
!= NULL
);
5816 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5819 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5820 scope and in global scopes, or NULL if none. NAME is folded and
5821 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5822 choosing the first symbol if there are multiple choices. */
5825 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5828 std::vector
<struct block_symbol
> candidates
;
5831 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5833 if (n_candidates
== 0)
5836 block_symbol info
= candidates
[0];
5837 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5842 /* True iff STR is a possible encoded suffix of a normal Ada name
5843 that is to be ignored for matching purposes. Suffixes of parallel
5844 names (e.g., XVE) are not included here. Currently, the possible suffixes
5845 are given by any of the regular expressions:
5847 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5848 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5849 TKB [subprogram suffix for task bodies]
5850 _E[0-9]+[bs]$ [protected object entry suffixes]
5851 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5853 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5854 match is performed. This sequence is used to differentiate homonyms,
5855 is an optional part of a valid name suffix. */
5858 is_name_suffix (const char *str
)
5861 const char *matching
;
5862 const int len
= strlen (str
);
5864 /* Skip optional leading __[0-9]+. */
5866 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5869 while (isdigit (str
[0]))
5875 if (str
[0] == '.' || str
[0] == '$')
5878 while (isdigit (matching
[0]))
5880 if (matching
[0] == '\0')
5886 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5889 while (isdigit (matching
[0]))
5891 if (matching
[0] == '\0')
5895 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5897 if (strcmp (str
, "TKB") == 0)
5901 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5902 with a N at the end. Unfortunately, the compiler uses the same
5903 convention for other internal types it creates. So treating
5904 all entity names that end with an "N" as a name suffix causes
5905 some regressions. For instance, consider the case of an enumerated
5906 type. To support the 'Image attribute, it creates an array whose
5908 Having a single character like this as a suffix carrying some
5909 information is a bit risky. Perhaps we should change the encoding
5910 to be something like "_N" instead. In the meantime, do not do
5911 the following check. */
5912 /* Protected Object Subprograms */
5913 if (len
== 1 && str
[0] == 'N')
5918 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5921 while (isdigit (matching
[0]))
5923 if ((matching
[0] == 'b' || matching
[0] == 's')
5924 && matching
[1] == '\0')
5928 /* ??? We should not modify STR directly, as we are doing below. This
5929 is fine in this case, but may become problematic later if we find
5930 that this alternative did not work, and want to try matching
5931 another one from the begining of STR. Since we modified it, we
5932 won't be able to find the begining of the string anymore! */
5936 while (str
[0] != '_' && str
[0] != '\0')
5938 if (str
[0] != 'n' && str
[0] != 'b')
5944 if (str
[0] == '\000')
5949 if (str
[1] != '_' || str
[2] == '\000')
5953 if (strcmp (str
+ 3, "JM") == 0)
5955 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5956 the LJM suffix in favor of the JM one. But we will
5957 still accept LJM as a valid suffix for a reasonable
5958 amount of time, just to allow ourselves to debug programs
5959 compiled using an older version of GNAT. */
5960 if (strcmp (str
+ 3, "LJM") == 0)
5964 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5965 || str
[4] == 'U' || str
[4] == 'P')
5967 if (str
[4] == 'R' && str
[5] != 'T')
5971 if (!isdigit (str
[2]))
5973 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5974 if (!isdigit (str
[k
]) && str
[k
] != '_')
5978 if (str
[0] == '$' && isdigit (str
[1]))
5980 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5981 if (!isdigit (str
[k
]) && str
[k
] != '_')
5988 /* Return non-zero if the string starting at NAME and ending before
5989 NAME_END contains no capital letters. */
5992 is_valid_name_for_wild_match (const char *name0
)
5994 std::string decoded_name
= ada_decode (name0
);
5997 /* If the decoded name starts with an angle bracket, it means that
5998 NAME0 does not follow the GNAT encoding format. It should then
5999 not be allowed as a possible wild match. */
6000 if (decoded_name
[0] == '<')
6003 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6004 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6010 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
6011 character which could start a simple name. Assumes that *NAMEP points
6012 somewhere inside the string beginning at NAME0. */
6015 advance_wild_match (const char **namep
, const char *name0
, char target0
)
6017 const char *name
= *namep
;
6027 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6030 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6035 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6036 || name
[2] == target0
))
6041 else if (t1
== '_' && name
[2] == 'B' && name
[3] == '_')
6043 /* Names like "pkg__B_N__name", where N is a number, are
6044 block-local. We can handle these by simply skipping
6051 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6061 /* Return true iff NAME encodes a name of the form prefix.PATN.
6062 Ignores any informational suffixes of NAME (i.e., for which
6063 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6067 wild_match (const char *name
, const char *patn
)
6070 const char *name0
= name
;
6074 const char *match
= name
;
6078 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6081 if (*p
== '\0' && is_name_suffix (name
))
6082 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6084 if (name
[-1] == '_')
6087 if (!advance_wild_match (&name
, name0
, *patn
))
6092 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6093 *defn_symbols, updating the list of symbols in OBSTACKP (if
6094 necessary). OBJFILE is the section containing BLOCK. */
6097 ada_add_block_symbols (struct obstack
*obstackp
,
6098 const struct block
*block
,
6099 const lookup_name_info
&lookup_name
,
6100 domain_enum domain
, struct objfile
*objfile
)
6102 struct block_iterator iter
;
6103 /* A matching argument symbol, if any. */
6104 struct symbol
*arg_sym
;
6105 /* Set true when we find a matching non-argument symbol. */
6111 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6113 sym
= block_iter_match_next (lookup_name
, &iter
))
6115 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6117 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6119 if (SYMBOL_IS_ARGUMENT (sym
))
6124 add_defn_to_vec (obstackp
,
6125 fixup_symbol_section (sym
, objfile
),
6132 /* Handle renamings. */
6134 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6137 if (!found_sym
&& arg_sym
!= NULL
)
6139 add_defn_to_vec (obstackp
,
6140 fixup_symbol_section (arg_sym
, objfile
),
6144 if (!lookup_name
.ada ().wild_match_p ())
6148 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6149 const char *name
= ada_lookup_name
.c_str ();
6150 size_t name_len
= ada_lookup_name
.size ();
6152 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6154 if (symbol_matches_domain (sym
->language (),
6155 SYMBOL_DOMAIN (sym
), domain
))
6159 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6162 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6164 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6169 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6171 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6173 if (SYMBOL_IS_ARGUMENT (sym
))
6178 add_defn_to_vec (obstackp
,
6179 fixup_symbol_section (sym
, objfile
),
6187 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6188 They aren't parameters, right? */
6189 if (!found_sym
&& arg_sym
!= NULL
)
6191 add_defn_to_vec (obstackp
,
6192 fixup_symbol_section (arg_sym
, objfile
),
6199 /* Symbol Completion */
6204 ada_lookup_name_info::matches
6205 (const char *sym_name
,
6206 symbol_name_match_type match_type
,
6207 completion_match_result
*comp_match_res
) const
6210 const char *text
= m_encoded_name
.c_str ();
6211 size_t text_len
= m_encoded_name
.size ();
6213 /* First, test against the fully qualified name of the symbol. */
6215 if (strncmp (sym_name
, text
, text_len
) == 0)
6218 std::string decoded_name
= ada_decode (sym_name
);
6219 if (match
&& !m_encoded_p
)
6221 /* One needed check before declaring a positive match is to verify
6222 that iff we are doing a verbatim match, the decoded version
6223 of the symbol name starts with '<'. Otherwise, this symbol name
6224 is not a suitable completion. */
6226 bool has_angle_bracket
= (decoded_name
[0] == '<');
6227 match
= (has_angle_bracket
== m_verbatim_p
);
6230 if (match
&& !m_verbatim_p
)
6232 /* When doing non-verbatim match, another check that needs to
6233 be done is to verify that the potentially matching symbol name
6234 does not include capital letters, because the ada-mode would
6235 not be able to understand these symbol names without the
6236 angle bracket notation. */
6239 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6244 /* Second: Try wild matching... */
6246 if (!match
&& m_wild_match_p
)
6248 /* Since we are doing wild matching, this means that TEXT
6249 may represent an unqualified symbol name. We therefore must
6250 also compare TEXT against the unqualified name of the symbol. */
6251 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6253 if (strncmp (sym_name
, text
, text_len
) == 0)
6257 /* Finally: If we found a match, prepare the result to return. */
6262 if (comp_match_res
!= NULL
)
6264 std::string
&match_str
= comp_match_res
->match
.storage ();
6267 match_str
= ada_decode (sym_name
);
6271 match_str
= add_angle_brackets (sym_name
);
6273 match_str
= sym_name
;
6277 comp_match_res
->set_match (match_str
.c_str ());
6285 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6286 for tagged types. */
6289 ada_is_dispatch_table_ptr_type (struct type
*type
)
6293 if (type
->code () != TYPE_CODE_PTR
)
6296 name
= TYPE_TARGET_TYPE (type
)->name ();
6300 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6303 /* Return non-zero if TYPE is an interface tag. */
6306 ada_is_interface_tag (struct type
*type
)
6308 const char *name
= type
->name ();
6313 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6316 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6317 to be invisible to users. */
6320 ada_is_ignored_field (struct type
*type
, int field_num
)
6322 if (field_num
< 0 || field_num
> type
->num_fields ())
6325 /* Check the name of that field. */
6327 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6329 /* Anonymous field names should not be printed.
6330 brobecker/2007-02-20: I don't think this can actually happen
6331 but we don't want to print the value of anonymous fields anyway. */
6335 /* Normally, fields whose name start with an underscore ("_")
6336 are fields that have been internally generated by the compiler,
6337 and thus should not be printed. The "_parent" field is special,
6338 however: This is a field internally generated by the compiler
6339 for tagged types, and it contains the components inherited from
6340 the parent type. This field should not be printed as is, but
6341 should not be ignored either. */
6342 if (name
[0] == '_' && !startswith (name
, "_parent"))
6346 /* If this is the dispatch table of a tagged type or an interface tag,
6348 if (ada_is_tagged_type (type
, 1)
6349 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6350 || ada_is_interface_tag (type
->field (field_num
).type ())))
6353 /* Not a special field, so it should not be ignored. */
6357 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6358 pointer or reference type whose ultimate target has a tag field. */
6361 ada_is_tagged_type (struct type
*type
, int refok
)
6363 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6366 /* True iff TYPE represents the type of X'Tag */
6369 ada_is_tag_type (struct type
*type
)
6371 type
= ada_check_typedef (type
);
6373 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6377 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6379 return (name
!= NULL
6380 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6384 /* The type of the tag on VAL. */
6386 static struct type
*
6387 ada_tag_type (struct value
*val
)
6389 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6392 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6393 retired at Ada 05). */
6396 is_ada95_tag (struct value
*tag
)
6398 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6401 /* The value of the tag on VAL. */
6403 static struct value
*
6404 ada_value_tag (struct value
*val
)
6406 return ada_value_struct_elt (val
, "_tag", 0);
6409 /* The value of the tag on the object of type TYPE whose contents are
6410 saved at VALADDR, if it is non-null, or is at memory address
6413 static struct value
*
6414 value_tag_from_contents_and_address (struct type
*type
,
6415 const gdb_byte
*valaddr
,
6418 int tag_byte_offset
;
6419 struct type
*tag_type
;
6421 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6424 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6426 : valaddr
+ tag_byte_offset
);
6427 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6429 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6434 static struct type
*
6435 type_from_tag (struct value
*tag
)
6437 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6439 if (type_name
!= NULL
)
6440 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6444 /* Given a value OBJ of a tagged type, return a value of this
6445 type at the base address of the object. The base address, as
6446 defined in Ada.Tags, it is the address of the primary tag of
6447 the object, and therefore where the field values of its full
6448 view can be fetched. */
6451 ada_tag_value_at_base_address (struct value
*obj
)
6454 LONGEST offset_to_top
= 0;
6455 struct type
*ptr_type
, *obj_type
;
6457 CORE_ADDR base_address
;
6459 obj_type
= value_type (obj
);
6461 /* It is the responsability of the caller to deref pointers. */
6463 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6466 tag
= ada_value_tag (obj
);
6470 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6472 if (is_ada95_tag (tag
))
6475 ptr_type
= language_lookup_primitive_type
6476 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6477 ptr_type
= lookup_pointer_type (ptr_type
);
6478 val
= value_cast (ptr_type
, tag
);
6482 /* It is perfectly possible that an exception be raised while
6483 trying to determine the base address, just like for the tag;
6484 see ada_tag_name for more details. We do not print the error
6485 message for the same reason. */
6489 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6492 catch (const gdb_exception_error
&e
)
6497 /* If offset is null, nothing to do. */
6499 if (offset_to_top
== 0)
6502 /* -1 is a special case in Ada.Tags; however, what should be done
6503 is not quite clear from the documentation. So do nothing for
6506 if (offset_to_top
== -1)
6509 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6510 from the base address. This was however incompatible with
6511 C++ dispatch table: C++ uses a *negative* value to *add*
6512 to the base address. Ada's convention has therefore been
6513 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6514 use the same convention. Here, we support both cases by
6515 checking the sign of OFFSET_TO_TOP. */
6517 if (offset_to_top
> 0)
6518 offset_to_top
= -offset_to_top
;
6520 base_address
= value_address (obj
) + offset_to_top
;
6521 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6523 /* Make sure that we have a proper tag at the new address.
6524 Otherwise, offset_to_top is bogus (which can happen when
6525 the object is not initialized yet). */
6530 obj_type
= type_from_tag (tag
);
6535 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6538 /* Return the "ada__tags__type_specific_data" type. */
6540 static struct type
*
6541 ada_get_tsd_type (struct inferior
*inf
)
6543 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6545 if (data
->tsd_type
== 0)
6546 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6547 return data
->tsd_type
;
6550 /* Return the TSD (type-specific data) associated to the given TAG.
6551 TAG is assumed to be the tag of a tagged-type entity.
6553 May return NULL if we are unable to get the TSD. */
6555 static struct value
*
6556 ada_get_tsd_from_tag (struct value
*tag
)
6561 /* First option: The TSD is simply stored as a field of our TAG.
6562 Only older versions of GNAT would use this format, but we have
6563 to test it first, because there are no visible markers for
6564 the current approach except the absence of that field. */
6566 val
= ada_value_struct_elt (tag
, "tsd", 1);
6570 /* Try the second representation for the dispatch table (in which
6571 there is no explicit 'tsd' field in the referent of the tag pointer,
6572 and instead the tsd pointer is stored just before the dispatch
6575 type
= ada_get_tsd_type (current_inferior());
6578 type
= lookup_pointer_type (lookup_pointer_type (type
));
6579 val
= value_cast (type
, tag
);
6582 return value_ind (value_ptradd (val
, -1));
6585 /* Given the TSD of a tag (type-specific data), return a string
6586 containing the name of the associated type.
6588 May return NULL if we are unable to determine the tag name. */
6590 static gdb::unique_xmalloc_ptr
<char>
6591 ada_tag_name_from_tsd (struct value
*tsd
)
6596 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6599 gdb::unique_xmalloc_ptr
<char> buffer
6600 = target_read_string (value_as_address (val
), INT_MAX
);
6601 if (buffer
== nullptr)
6604 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6613 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6616 Return NULL if the TAG is not an Ada tag, or if we were unable to
6617 determine the name of that tag. */
6619 gdb::unique_xmalloc_ptr
<char>
6620 ada_tag_name (struct value
*tag
)
6622 gdb::unique_xmalloc_ptr
<char> name
;
6624 if (!ada_is_tag_type (value_type (tag
)))
6627 /* It is perfectly possible that an exception be raised while trying
6628 to determine the TAG's name, even under normal circumstances:
6629 The associated variable may be uninitialized or corrupted, for
6630 instance. We do not let any exception propagate past this point.
6631 instead we return NULL.
6633 We also do not print the error message either (which often is very
6634 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6635 the caller print a more meaningful message if necessary. */
6638 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6641 name
= ada_tag_name_from_tsd (tsd
);
6643 catch (const gdb_exception_error
&e
)
6650 /* The parent type of TYPE, or NULL if none. */
6653 ada_parent_type (struct type
*type
)
6657 type
= ada_check_typedef (type
);
6659 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6662 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6663 if (ada_is_parent_field (type
, i
))
6665 struct type
*parent_type
= type
->field (i
).type ();
6667 /* If the _parent field is a pointer, then dereference it. */
6668 if (parent_type
->code () == TYPE_CODE_PTR
)
6669 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6670 /* If there is a parallel XVS type, get the actual base type. */
6671 parent_type
= ada_get_base_type (parent_type
);
6673 return ada_check_typedef (parent_type
);
6679 /* True iff field number FIELD_NUM of structure type TYPE contains the
6680 parent-type (inherited) fields of a derived type. Assumes TYPE is
6681 a structure type with at least FIELD_NUM+1 fields. */
6684 ada_is_parent_field (struct type
*type
, int field_num
)
6686 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6688 return (name
!= NULL
6689 && (startswith (name
, "PARENT")
6690 || startswith (name
, "_parent")));
6693 /* True iff field number FIELD_NUM of structure type TYPE is a
6694 transparent wrapper field (which should be silently traversed when doing
6695 field selection and flattened when printing). Assumes TYPE is a
6696 structure type with at least FIELD_NUM+1 fields. Such fields are always
6700 ada_is_wrapper_field (struct type
*type
, int field_num
)
6702 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6704 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6706 /* This happens in functions with "out" or "in out" parameters
6707 which are passed by copy. For such functions, GNAT describes
6708 the function's return type as being a struct where the return
6709 value is in a field called RETVAL, and where the other "out"
6710 or "in out" parameters are fields of that struct. This is not
6715 return (name
!= NULL
6716 && (startswith (name
, "PARENT")
6717 || strcmp (name
, "REP") == 0
6718 || startswith (name
, "_parent")
6719 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6722 /* True iff field number FIELD_NUM of structure or union type TYPE
6723 is a variant wrapper. Assumes TYPE is a structure type with at least
6724 FIELD_NUM+1 fields. */
6727 ada_is_variant_part (struct type
*type
, int field_num
)
6729 /* Only Ada types are eligible. */
6730 if (!ADA_TYPE_P (type
))
6733 struct type
*field_type
= type
->field (field_num
).type ();
6735 return (field_type
->code () == TYPE_CODE_UNION
6736 || (is_dynamic_field (type
, field_num
)
6737 && (TYPE_TARGET_TYPE (field_type
)->code ()
6738 == TYPE_CODE_UNION
)));
6741 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6742 whose discriminants are contained in the record type OUTER_TYPE,
6743 returns the type of the controlling discriminant for the variant.
6744 May return NULL if the type could not be found. */
6747 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6749 const char *name
= ada_variant_discrim_name (var_type
);
6751 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6754 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6755 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6756 represents a 'when others' clause; otherwise 0. */
6759 ada_is_others_clause (struct type
*type
, int field_num
)
6761 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6763 return (name
!= NULL
&& name
[0] == 'O');
6766 /* Assuming that TYPE0 is the type of the variant part of a record,
6767 returns the name of the discriminant controlling the variant.
6768 The value is valid until the next call to ada_variant_discrim_name. */
6771 ada_variant_discrim_name (struct type
*type0
)
6773 static char *result
= NULL
;
6774 static size_t result_len
= 0;
6777 const char *discrim_end
;
6778 const char *discrim_start
;
6780 if (type0
->code () == TYPE_CODE_PTR
)
6781 type
= TYPE_TARGET_TYPE (type0
);
6785 name
= ada_type_name (type
);
6787 if (name
== NULL
|| name
[0] == '\000')
6790 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6793 if (startswith (discrim_end
, "___XVN"))
6796 if (discrim_end
== name
)
6799 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6802 if (discrim_start
== name
+ 1)
6804 if ((discrim_start
> name
+ 3
6805 && startswith (discrim_start
- 3, "___"))
6806 || discrim_start
[-1] == '.')
6810 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6811 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6812 result
[discrim_end
- discrim_start
] = '\0';
6816 /* Scan STR for a subtype-encoded number, beginning at position K.
6817 Put the position of the character just past the number scanned in
6818 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6819 Return 1 if there was a valid number at the given position, and 0
6820 otherwise. A "subtype-encoded" number consists of the absolute value
6821 in decimal, followed by the letter 'm' to indicate a negative number.
6822 Assumes 0m does not occur. */
6825 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6829 if (!isdigit (str
[k
]))
6832 /* Do it the hard way so as not to make any assumption about
6833 the relationship of unsigned long (%lu scan format code) and
6836 while (isdigit (str
[k
]))
6838 RU
= RU
* 10 + (str
[k
] - '0');
6845 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6851 /* NOTE on the above: Technically, C does not say what the results of
6852 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6853 number representable as a LONGEST (although either would probably work
6854 in most implementations). When RU>0, the locution in the then branch
6855 above is always equivalent to the negative of RU. */
6862 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6863 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6864 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6867 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6869 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6883 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6893 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6894 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6896 if (val
>= L
&& val
<= U
)
6908 /* FIXME: Lots of redundancy below. Try to consolidate. */
6910 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6911 ARG_TYPE, extract and return the value of one of its (non-static)
6912 fields. FIELDNO says which field. Differs from value_primitive_field
6913 only in that it can handle packed values of arbitrary type. */
6916 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6917 struct type
*arg_type
)
6921 arg_type
= ada_check_typedef (arg_type
);
6922 type
= arg_type
->field (fieldno
).type ();
6924 /* Handle packed fields. It might be that the field is not packed
6925 relative to its containing structure, but the structure itself is
6926 packed; in this case we must take the bit-field path. */
6927 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6929 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6930 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6932 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6933 offset
+ bit_pos
/ 8,
6934 bit_pos
% 8, bit_size
, type
);
6937 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6940 /* Find field with name NAME in object of type TYPE. If found,
6941 set the following for each argument that is non-null:
6942 - *FIELD_TYPE_P to the field's type;
6943 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6944 an object of that type;
6945 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6946 - *BIT_SIZE_P to its size in bits if the field is packed, and
6948 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6949 fields up to but not including the desired field, or by the total
6950 number of fields if not found. A NULL value of NAME never
6951 matches; the function just counts visible fields in this case.
6953 Notice that we need to handle when a tagged record hierarchy
6954 has some components with the same name, like in this scenario:
6956 type Top_T is tagged record
6962 type Middle_T is new Top.Top_T with record
6963 N : Character := 'a';
6967 type Bottom_T is new Middle.Middle_T with record
6969 C : Character := '5';
6971 A : Character := 'J';
6974 Let's say we now have a variable declared and initialized as follow:
6976 TC : Top_A := new Bottom_T;
6978 And then we use this variable to call this function
6980 procedure Assign (Obj: in out Top_T; TV : Integer);
6984 Assign (Top_T (B), 12);
6986 Now, we're in the debugger, and we're inside that procedure
6987 then and we want to print the value of obj.c:
6989 Usually, the tagged record or one of the parent type owns the
6990 component to print and there's no issue but in this particular
6991 case, what does it mean to ask for Obj.C? Since the actual
6992 type for object is type Bottom_T, it could mean two things: type
6993 component C from the Middle_T view, but also component C from
6994 Bottom_T. So in that "undefined" case, when the component is
6995 not found in the non-resolved type (which includes all the
6996 components of the parent type), then resolve it and see if we
6997 get better luck once expanded.
6999 In the case of homonyms in the derived tagged type, we don't
7000 guaranty anything, and pick the one that's easiest for us
7003 Returns 1 if found, 0 otherwise. */
7006 find_struct_field (const char *name
, struct type
*type
, int offset
,
7007 struct type
**field_type_p
,
7008 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7012 int parent_offset
= -1;
7014 type
= ada_check_typedef (type
);
7016 if (field_type_p
!= NULL
)
7017 *field_type_p
= NULL
;
7018 if (byte_offset_p
!= NULL
)
7020 if (bit_offset_p
!= NULL
)
7022 if (bit_size_p
!= NULL
)
7025 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7027 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7028 int fld_offset
= offset
+ bit_pos
/ 8;
7029 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7031 if (t_field_name
== NULL
)
7034 else if (ada_is_parent_field (type
, i
))
7036 /* This is a field pointing us to the parent type of a tagged
7037 type. As hinted in this function's documentation, we give
7038 preference to fields in the current record first, so what
7039 we do here is just record the index of this field before
7040 we skip it. If it turns out we couldn't find our field
7041 in the current record, then we'll get back to it and search
7042 inside it whether the field might exist in the parent. */
7048 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7050 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7052 if (field_type_p
!= NULL
)
7053 *field_type_p
= type
->field (i
).type ();
7054 if (byte_offset_p
!= NULL
)
7055 *byte_offset_p
= fld_offset
;
7056 if (bit_offset_p
!= NULL
)
7057 *bit_offset_p
= bit_pos
% 8;
7058 if (bit_size_p
!= NULL
)
7059 *bit_size_p
= bit_size
;
7062 else if (ada_is_wrapper_field (type
, i
))
7064 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7065 field_type_p
, byte_offset_p
, bit_offset_p
,
7066 bit_size_p
, index_p
))
7069 else if (ada_is_variant_part (type
, i
))
7071 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7074 struct type
*field_type
7075 = ada_check_typedef (type
->field (i
).type ());
7077 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7079 if (find_struct_field (name
, field_type
->field (j
).type (),
7081 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7082 field_type_p
, byte_offset_p
,
7083 bit_offset_p
, bit_size_p
, index_p
))
7087 else if (index_p
!= NULL
)
7091 /* Field not found so far. If this is a tagged type which
7092 has a parent, try finding that field in the parent now. */
7094 if (parent_offset
!= -1)
7096 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7097 int fld_offset
= offset
+ bit_pos
/ 8;
7099 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7100 fld_offset
, field_type_p
, byte_offset_p
,
7101 bit_offset_p
, bit_size_p
, index_p
))
7108 /* Number of user-visible fields in record type TYPE. */
7111 num_visible_fields (struct type
*type
)
7116 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7120 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7121 and search in it assuming it has (class) type TYPE.
7122 If found, return value, else return NULL.
7124 Searches recursively through wrapper fields (e.g., '_parent').
7126 In the case of homonyms in the tagged types, please refer to the
7127 long explanation in find_struct_field's function documentation. */
7129 static struct value
*
7130 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7134 int parent_offset
= -1;
7136 type
= ada_check_typedef (type
);
7137 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7139 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7141 if (t_field_name
== NULL
)
7144 else if (ada_is_parent_field (type
, i
))
7146 /* This is a field pointing us to the parent type of a tagged
7147 type. As hinted in this function's documentation, we give
7148 preference to fields in the current record first, so what
7149 we do here is just record the index of this field before
7150 we skip it. If it turns out we couldn't find our field
7151 in the current record, then we'll get back to it and search
7152 inside it whether the field might exist in the parent. */
7158 else if (field_name_match (t_field_name
, name
))
7159 return ada_value_primitive_field (arg
, offset
, i
, type
);
7161 else if (ada_is_wrapper_field (type
, i
))
7163 struct value
*v
= /* Do not let indent join lines here. */
7164 ada_search_struct_field (name
, arg
,
7165 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7166 type
->field (i
).type ());
7172 else if (ada_is_variant_part (type
, i
))
7174 /* PNH: Do we ever get here? See find_struct_field. */
7176 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7177 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7179 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7181 struct value
*v
= ada_search_struct_field
/* Force line
7184 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7185 field_type
->field (j
).type ());
7193 /* Field not found so far. If this is a tagged type which
7194 has a parent, try finding that field in the parent now. */
7196 if (parent_offset
!= -1)
7198 struct value
*v
= ada_search_struct_field (
7199 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7200 type
->field (parent_offset
).type ());
7209 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7210 int, struct type
*);
7213 /* Return field #INDEX in ARG, where the index is that returned by
7214 * find_struct_field through its INDEX_P argument. Adjust the address
7215 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7216 * If found, return value, else return NULL. */
7218 static struct value
*
7219 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7222 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7226 /* Auxiliary function for ada_index_struct_field. Like
7227 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7230 static struct value
*
7231 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7235 type
= ada_check_typedef (type
);
7237 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7239 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7241 else if (ada_is_wrapper_field (type
, i
))
7243 struct value
*v
= /* Do not let indent join lines here. */
7244 ada_index_struct_field_1 (index_p
, arg
,
7245 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7246 type
->field (i
).type ());
7252 else if (ada_is_variant_part (type
, i
))
7254 /* PNH: Do we ever get here? See ada_search_struct_field,
7255 find_struct_field. */
7256 error (_("Cannot assign this kind of variant record"));
7258 else if (*index_p
== 0)
7259 return ada_value_primitive_field (arg
, offset
, i
, type
);
7266 /* Return a string representation of type TYPE. */
7269 type_as_string (struct type
*type
)
7271 string_file tmp_stream
;
7273 type_print (type
, "", &tmp_stream
, -1);
7275 return std::move (tmp_stream
.string ());
7278 /* Given a type TYPE, look up the type of the component of type named NAME.
7279 If DISPP is non-null, add its byte displacement from the beginning of a
7280 structure (pointed to by a value) of type TYPE to *DISPP (does not
7281 work for packed fields).
7283 Matches any field whose name has NAME as a prefix, possibly
7286 TYPE can be either a struct or union. If REFOK, TYPE may also
7287 be a (pointer or reference)+ to a struct or union, and the
7288 ultimate target type will be searched.
7290 Looks recursively into variant clauses and parent types.
7292 In the case of homonyms in the tagged types, please refer to the
7293 long explanation in find_struct_field's function documentation.
7295 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7296 TYPE is not a type of the right kind. */
7298 static struct type
*
7299 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7303 int parent_offset
= -1;
7308 if (refok
&& type
!= NULL
)
7311 type
= ada_check_typedef (type
);
7312 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7314 type
= TYPE_TARGET_TYPE (type
);
7318 || (type
->code () != TYPE_CODE_STRUCT
7319 && type
->code () != TYPE_CODE_UNION
))
7324 error (_("Type %s is not a structure or union type"),
7325 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7328 type
= to_static_fixed_type (type
);
7330 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7332 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7335 if (t_field_name
== NULL
)
7338 else if (ada_is_parent_field (type
, i
))
7340 /* This is a field pointing us to the parent type of a tagged
7341 type. As hinted in this function's documentation, we give
7342 preference to fields in the current record first, so what
7343 we do here is just record the index of this field before
7344 we skip it. If it turns out we couldn't find our field
7345 in the current record, then we'll get back to it and search
7346 inside it whether the field might exist in the parent. */
7352 else if (field_name_match (t_field_name
, name
))
7353 return type
->field (i
).type ();
7355 else if (ada_is_wrapper_field (type
, i
))
7357 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7363 else if (ada_is_variant_part (type
, i
))
7366 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7368 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7370 /* FIXME pnh 2008/01/26: We check for a field that is
7371 NOT wrapped in a struct, since the compiler sometimes
7372 generates these for unchecked variant types. Revisit
7373 if the compiler changes this practice. */
7374 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7376 if (v_field_name
!= NULL
7377 && field_name_match (v_field_name
, name
))
7378 t
= field_type
->field (j
).type ();
7380 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7390 /* Field not found so far. If this is a tagged type which
7391 has a parent, try finding that field in the parent now. */
7393 if (parent_offset
!= -1)
7397 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7406 const char *name_str
= name
!= NULL
? name
: _("<null>");
7408 error (_("Type %s has no component named %s"),
7409 type_as_string (type
).c_str (), name_str
);
7415 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7416 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7417 represents an unchecked union (that is, the variant part of a
7418 record that is named in an Unchecked_Union pragma). */
7421 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7423 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7425 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7429 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7430 within OUTER, determine which variant clause (field number in VAR_TYPE,
7431 numbering from 0) is applicable. Returns -1 if none are. */
7434 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7438 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7439 struct value
*discrim
;
7440 LONGEST discrim_val
;
7442 /* Using plain value_from_contents_and_address here causes problems
7443 because we will end up trying to resolve a type that is currently
7444 being constructed. */
7445 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7446 if (discrim
== NULL
)
7448 discrim_val
= value_as_long (discrim
);
7451 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7453 if (ada_is_others_clause (var_type
, i
))
7455 else if (ada_in_variant (discrim_val
, var_type
, i
))
7459 return others_clause
;
7464 /* Dynamic-Sized Records */
7466 /* Strategy: The type ostensibly attached to a value with dynamic size
7467 (i.e., a size that is not statically recorded in the debugging
7468 data) does not accurately reflect the size or layout of the value.
7469 Our strategy is to convert these values to values with accurate,
7470 conventional types that are constructed on the fly. */
7472 /* There is a subtle and tricky problem here. In general, we cannot
7473 determine the size of dynamic records without its data. However,
7474 the 'struct value' data structure, which GDB uses to represent
7475 quantities in the inferior process (the target), requires the size
7476 of the type at the time of its allocation in order to reserve space
7477 for GDB's internal copy of the data. That's why the
7478 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7479 rather than struct value*s.
7481 However, GDB's internal history variables ($1, $2, etc.) are
7482 struct value*s containing internal copies of the data that are not, in
7483 general, the same as the data at their corresponding addresses in
7484 the target. Fortunately, the types we give to these values are all
7485 conventional, fixed-size types (as per the strategy described
7486 above), so that we don't usually have to perform the
7487 'to_fixed_xxx_type' conversions to look at their values.
7488 Unfortunately, there is one exception: if one of the internal
7489 history variables is an array whose elements are unconstrained
7490 records, then we will need to create distinct fixed types for each
7491 element selected. */
7493 /* The upshot of all of this is that many routines take a (type, host
7494 address, target address) triple as arguments to represent a value.
7495 The host address, if non-null, is supposed to contain an internal
7496 copy of the relevant data; otherwise, the program is to consult the
7497 target at the target address. */
7499 /* Assuming that VAL0 represents a pointer value, the result of
7500 dereferencing it. Differs from value_ind in its treatment of
7501 dynamic-sized types. */
7504 ada_value_ind (struct value
*val0
)
7506 struct value
*val
= value_ind (val0
);
7508 if (ada_is_tagged_type (value_type (val
), 0))
7509 val
= ada_tag_value_at_base_address (val
);
7511 return ada_to_fixed_value (val
);
7514 /* The value resulting from dereferencing any "reference to"
7515 qualifiers on VAL0. */
7517 static struct value
*
7518 ada_coerce_ref (struct value
*val0
)
7520 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7522 struct value
*val
= val0
;
7524 val
= coerce_ref (val
);
7526 if (ada_is_tagged_type (value_type (val
), 0))
7527 val
= ada_tag_value_at_base_address (val
);
7529 return ada_to_fixed_value (val
);
7535 /* Return the bit alignment required for field #F of template type TYPE. */
7538 field_alignment (struct type
*type
, int f
)
7540 const char *name
= TYPE_FIELD_NAME (type
, f
);
7544 /* The field name should never be null, unless the debugging information
7545 is somehow malformed. In this case, we assume the field does not
7546 require any alignment. */
7550 len
= strlen (name
);
7552 if (!isdigit (name
[len
- 1]))
7555 if (isdigit (name
[len
- 2]))
7556 align_offset
= len
- 2;
7558 align_offset
= len
- 1;
7560 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7561 return TARGET_CHAR_BIT
;
7563 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7566 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7568 static struct symbol
*
7569 ada_find_any_type_symbol (const char *name
)
7573 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7574 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7577 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7581 /* Find a type named NAME. Ignores ambiguity. This routine will look
7582 solely for types defined by debug info, it will not search the GDB
7585 static struct type
*
7586 ada_find_any_type (const char *name
)
7588 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7591 return SYMBOL_TYPE (sym
);
7596 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7597 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7598 symbol, in which case it is returned. Otherwise, this looks for
7599 symbols whose name is that of NAME_SYM suffixed with "___XR".
7600 Return symbol if found, and NULL otherwise. */
7603 ada_is_renaming_symbol (struct symbol
*name_sym
)
7605 const char *name
= name_sym
->linkage_name ();
7606 return strstr (name
, "___XR") != NULL
;
7609 /* Because of GNAT encoding conventions, several GDB symbols may match a
7610 given type name. If the type denoted by TYPE0 is to be preferred to
7611 that of TYPE1 for purposes of type printing, return non-zero;
7612 otherwise return 0. */
7615 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7619 else if (type0
== NULL
)
7621 else if (type1
->code () == TYPE_CODE_VOID
)
7623 else if (type0
->code () == TYPE_CODE_VOID
)
7625 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7627 else if (ada_is_constrained_packed_array_type (type0
))
7629 else if (ada_is_array_descriptor_type (type0
)
7630 && !ada_is_array_descriptor_type (type1
))
7634 const char *type0_name
= type0
->name ();
7635 const char *type1_name
= type1
->name ();
7637 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7638 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7644 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7648 ada_type_name (struct type
*type
)
7652 return type
->name ();
7655 /* Search the list of "descriptive" types associated to TYPE for a type
7656 whose name is NAME. */
7658 static struct type
*
7659 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7661 struct type
*result
, *tmp
;
7663 if (ada_ignore_descriptive_types_p
)
7666 /* If there no descriptive-type info, then there is no parallel type
7668 if (!HAVE_GNAT_AUX_INFO (type
))
7671 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7672 while (result
!= NULL
)
7674 const char *result_name
= ada_type_name (result
);
7676 if (result_name
== NULL
)
7678 warning (_("unexpected null name on descriptive type"));
7682 /* If the names match, stop. */
7683 if (strcmp (result_name
, name
) == 0)
7686 /* Otherwise, look at the next item on the list, if any. */
7687 if (HAVE_GNAT_AUX_INFO (result
))
7688 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7692 /* If not found either, try after having resolved the typedef. */
7697 result
= check_typedef (result
);
7698 if (HAVE_GNAT_AUX_INFO (result
))
7699 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7705 /* If we didn't find a match, see whether this is a packed array. With
7706 older compilers, the descriptive type information is either absent or
7707 irrelevant when it comes to packed arrays so the above lookup fails.
7708 Fall back to using a parallel lookup by name in this case. */
7709 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7710 return ada_find_any_type (name
);
7715 /* Find a parallel type to TYPE with the specified NAME, using the
7716 descriptive type taken from the debugging information, if available,
7717 and otherwise using the (slower) name-based method. */
7719 static struct type
*
7720 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7722 struct type
*result
= NULL
;
7724 if (HAVE_GNAT_AUX_INFO (type
))
7725 result
= find_parallel_type_by_descriptive_type (type
, name
);
7727 result
= ada_find_any_type (name
);
7732 /* Same as above, but specify the name of the parallel type by appending
7733 SUFFIX to the name of TYPE. */
7736 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7739 const char *type_name
= ada_type_name (type
);
7742 if (type_name
== NULL
)
7745 len
= strlen (type_name
);
7747 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7749 strcpy (name
, type_name
);
7750 strcpy (name
+ len
, suffix
);
7752 return ada_find_parallel_type_with_name (type
, name
);
7755 /* If TYPE is a variable-size record type, return the corresponding template
7756 type describing its fields. Otherwise, return NULL. */
7758 static struct type
*
7759 dynamic_template_type (struct type
*type
)
7761 type
= ada_check_typedef (type
);
7763 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7764 || ada_type_name (type
) == NULL
)
7768 int len
= strlen (ada_type_name (type
));
7770 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7773 return ada_find_parallel_type (type
, "___XVE");
7777 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7778 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7781 is_dynamic_field (struct type
*templ_type
, int field_num
)
7783 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7786 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7787 && strstr (name
, "___XVL") != NULL
;
7790 /* The index of the variant field of TYPE, or -1 if TYPE does not
7791 represent a variant record type. */
7794 variant_field_index (struct type
*type
)
7798 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7801 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7803 if (ada_is_variant_part (type
, f
))
7809 /* A record type with no fields. */
7811 static struct type
*
7812 empty_record (struct type
*templ
)
7814 struct type
*type
= alloc_type_copy (templ
);
7816 type
->set_code (TYPE_CODE_STRUCT
);
7817 INIT_NONE_SPECIFIC (type
);
7818 type
->set_name ("<empty>");
7819 TYPE_LENGTH (type
) = 0;
7823 /* An ordinary record type (with fixed-length fields) that describes
7824 the value of type TYPE at VALADDR or ADDRESS (see comments at
7825 the beginning of this section) VAL according to GNAT conventions.
7826 DVAL0 should describe the (portion of a) record that contains any
7827 necessary discriminants. It should be NULL if value_type (VAL) is
7828 an outer-level type (i.e., as opposed to a branch of a variant.) A
7829 variant field (unless unchecked) is replaced by a particular branch
7832 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7833 length are not statically known are discarded. As a consequence,
7834 VALADDR, ADDRESS and DVAL0 are ignored.
7836 NOTE: Limitations: For now, we assume that dynamic fields and
7837 variants occupy whole numbers of bytes. However, they need not be
7841 ada_template_to_fixed_record_type_1 (struct type
*type
,
7842 const gdb_byte
*valaddr
,
7843 CORE_ADDR address
, struct value
*dval0
,
7844 int keep_dynamic_fields
)
7846 struct value
*mark
= value_mark ();
7849 int nfields
, bit_len
;
7855 /* Compute the number of fields in this record type that are going
7856 to be processed: unless keep_dynamic_fields, this includes only
7857 fields whose position and length are static will be processed. */
7858 if (keep_dynamic_fields
)
7859 nfields
= type
->num_fields ();
7863 while (nfields
< type
->num_fields ()
7864 && !ada_is_variant_part (type
, nfields
)
7865 && !is_dynamic_field (type
, nfields
))
7869 rtype
= alloc_type_copy (type
);
7870 rtype
->set_code (TYPE_CODE_STRUCT
);
7871 INIT_NONE_SPECIFIC (rtype
);
7872 rtype
->set_num_fields (nfields
);
7874 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7875 rtype
->set_name (ada_type_name (type
));
7876 rtype
->set_is_fixed_instance (true);
7882 for (f
= 0; f
< nfields
; f
+= 1)
7884 off
= align_up (off
, field_alignment (type
, f
))
7885 + TYPE_FIELD_BITPOS (type
, f
);
7886 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7887 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7889 if (ada_is_variant_part (type
, f
))
7894 else if (is_dynamic_field (type
, f
))
7896 const gdb_byte
*field_valaddr
= valaddr
;
7897 CORE_ADDR field_address
= address
;
7898 struct type
*field_type
=
7899 TYPE_TARGET_TYPE (type
->field (f
).type ());
7903 /* rtype's length is computed based on the run-time
7904 value of discriminants. If the discriminants are not
7905 initialized, the type size may be completely bogus and
7906 GDB may fail to allocate a value for it. So check the
7907 size first before creating the value. */
7908 ada_ensure_varsize_limit (rtype
);
7909 /* Using plain value_from_contents_and_address here
7910 causes problems because we will end up trying to
7911 resolve a type that is currently being
7913 dval
= value_from_contents_and_address_unresolved (rtype
,
7916 rtype
= value_type (dval
);
7921 /* If the type referenced by this field is an aligner type, we need
7922 to unwrap that aligner type, because its size might not be set.
7923 Keeping the aligner type would cause us to compute the wrong
7924 size for this field, impacting the offset of the all the fields
7925 that follow this one. */
7926 if (ada_is_aligner_type (field_type
))
7928 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7930 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7931 field_address
= cond_offset_target (field_address
, field_offset
);
7932 field_type
= ada_aligned_type (field_type
);
7935 field_valaddr
= cond_offset_host (field_valaddr
,
7936 off
/ TARGET_CHAR_BIT
);
7937 field_address
= cond_offset_target (field_address
,
7938 off
/ TARGET_CHAR_BIT
);
7940 /* Get the fixed type of the field. Note that, in this case,
7941 we do not want to get the real type out of the tag: if
7942 the current field is the parent part of a tagged record,
7943 we will get the tag of the object. Clearly wrong: the real
7944 type of the parent is not the real type of the child. We
7945 would end up in an infinite loop. */
7946 field_type
= ada_get_base_type (field_type
);
7947 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7948 field_address
, dval
, 0);
7949 /* If the field size is already larger than the maximum
7950 object size, then the record itself will necessarily
7951 be larger than the maximum object size. We need to make
7952 this check now, because the size might be so ridiculously
7953 large (due to an uninitialized variable in the inferior)
7954 that it would cause an overflow when adding it to the
7956 ada_ensure_varsize_limit (field_type
);
7958 rtype
->field (f
).set_type (field_type
);
7959 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7960 /* The multiplication can potentially overflow. But because
7961 the field length has been size-checked just above, and
7962 assuming that the maximum size is a reasonable value,
7963 an overflow should not happen in practice. So rather than
7964 adding overflow recovery code to this already complex code,
7965 we just assume that it's not going to happen. */
7967 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7971 /* Note: If this field's type is a typedef, it is important
7972 to preserve the typedef layer.
7974 Otherwise, we might be transforming a typedef to a fat
7975 pointer (encoding a pointer to an unconstrained array),
7976 into a basic fat pointer (encoding an unconstrained
7977 array). As both types are implemented using the same
7978 structure, the typedef is the only clue which allows us
7979 to distinguish between the two options. Stripping it
7980 would prevent us from printing this field appropriately. */
7981 rtype
->field (f
).set_type (type
->field (f
).type ());
7982 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7983 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7985 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7988 struct type
*field_type
= type
->field (f
).type ();
7990 /* We need to be careful of typedefs when computing
7991 the length of our field. If this is a typedef,
7992 get the length of the target type, not the length
7994 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7995 field_type
= ada_typedef_target_type (field_type
);
7998 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8001 if (off
+ fld_bit_len
> bit_len
)
8002 bit_len
= off
+ fld_bit_len
;
8004 TYPE_LENGTH (rtype
) =
8005 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8008 /* We handle the variant part, if any, at the end because of certain
8009 odd cases in which it is re-ordered so as NOT to be the last field of
8010 the record. This can happen in the presence of representation
8012 if (variant_field
>= 0)
8014 struct type
*branch_type
;
8016 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8020 /* Using plain value_from_contents_and_address here causes
8021 problems because we will end up trying to resolve a type
8022 that is currently being constructed. */
8023 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8025 rtype
= value_type (dval
);
8031 to_fixed_variant_branch_type
8032 (type
->field (variant_field
).type (),
8033 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8034 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8035 if (branch_type
== NULL
)
8037 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8038 rtype
->field (f
- 1) = rtype
->field (f
);
8039 rtype
->set_num_fields (rtype
->num_fields () - 1);
8043 rtype
->field (variant_field
).set_type (branch_type
);
8044 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8046 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8048 if (off
+ fld_bit_len
> bit_len
)
8049 bit_len
= off
+ fld_bit_len
;
8050 TYPE_LENGTH (rtype
) =
8051 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8055 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8056 should contain the alignment of that record, which should be a strictly
8057 positive value. If null or negative, then something is wrong, most
8058 probably in the debug info. In that case, we don't round up the size
8059 of the resulting type. If this record is not part of another structure,
8060 the current RTYPE length might be good enough for our purposes. */
8061 if (TYPE_LENGTH (type
) <= 0)
8064 warning (_("Invalid type size for `%s' detected: %s."),
8065 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8067 warning (_("Invalid type size for <unnamed> detected: %s."),
8068 pulongest (TYPE_LENGTH (type
)));
8072 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8073 TYPE_LENGTH (type
));
8076 value_free_to_mark (mark
);
8077 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8078 error (_("record type with dynamic size is larger than varsize-limit"));
8082 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8085 static struct type
*
8086 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8087 CORE_ADDR address
, struct value
*dval0
)
8089 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8093 /* An ordinary record type in which ___XVL-convention fields and
8094 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8095 static approximations, containing all possible fields. Uses
8096 no runtime values. Useless for use in values, but that's OK,
8097 since the results are used only for type determinations. Works on both
8098 structs and unions. Representation note: to save space, we memorize
8099 the result of this function in the TYPE_TARGET_TYPE of the
8102 static struct type
*
8103 template_to_static_fixed_type (struct type
*type0
)
8109 /* No need no do anything if the input type is already fixed. */
8110 if (type0
->is_fixed_instance ())
8113 /* Likewise if we already have computed the static approximation. */
8114 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8115 return TYPE_TARGET_TYPE (type0
);
8117 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8119 nfields
= type0
->num_fields ();
8121 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8122 recompute all over next time. */
8123 TYPE_TARGET_TYPE (type0
) = type
;
8125 for (f
= 0; f
< nfields
; f
+= 1)
8127 struct type
*field_type
= type0
->field (f
).type ();
8128 struct type
*new_type
;
8130 if (is_dynamic_field (type0
, f
))
8132 field_type
= ada_check_typedef (field_type
);
8133 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8136 new_type
= static_unwrap_type (field_type
);
8138 if (new_type
!= field_type
)
8140 /* Clone TYPE0 only the first time we get a new field type. */
8143 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8144 type
->set_code (type0
->code ());
8145 INIT_NONE_SPECIFIC (type
);
8146 type
->set_num_fields (nfields
);
8150 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8151 memcpy (fields
, type0
->fields (),
8152 sizeof (struct field
) * nfields
);
8153 type
->set_fields (fields
);
8155 type
->set_name (ada_type_name (type0
));
8156 type
->set_is_fixed_instance (true);
8157 TYPE_LENGTH (type
) = 0;
8159 type
->field (f
).set_type (new_type
);
8160 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8167 /* Given an object of type TYPE whose contents are at VALADDR and
8168 whose address in memory is ADDRESS, returns a revision of TYPE,
8169 which should be a non-dynamic-sized record, in which the variant
8170 part, if any, is replaced with the appropriate branch. Looks
8171 for discriminant values in DVAL0, which can be NULL if the record
8172 contains the necessary discriminant values. */
8174 static struct type
*
8175 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8176 CORE_ADDR address
, struct value
*dval0
)
8178 struct value
*mark
= value_mark ();
8181 struct type
*branch_type
;
8182 int nfields
= type
->num_fields ();
8183 int variant_field
= variant_field_index (type
);
8185 if (variant_field
== -1)
8190 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8191 type
= value_type (dval
);
8196 rtype
= alloc_type_copy (type
);
8197 rtype
->set_code (TYPE_CODE_STRUCT
);
8198 INIT_NONE_SPECIFIC (rtype
);
8199 rtype
->set_num_fields (nfields
);
8202 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8203 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8204 rtype
->set_fields (fields
);
8206 rtype
->set_name (ada_type_name (type
));
8207 rtype
->set_is_fixed_instance (true);
8208 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8210 branch_type
= to_fixed_variant_branch_type
8211 (type
->field (variant_field
).type (),
8212 cond_offset_host (valaddr
,
8213 TYPE_FIELD_BITPOS (type
, variant_field
)
8215 cond_offset_target (address
,
8216 TYPE_FIELD_BITPOS (type
, variant_field
)
8217 / TARGET_CHAR_BIT
), dval
);
8218 if (branch_type
== NULL
)
8222 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8223 rtype
->field (f
- 1) = rtype
->field (f
);
8224 rtype
->set_num_fields (rtype
->num_fields () - 1);
8228 rtype
->field (variant_field
).set_type (branch_type
);
8229 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8230 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8231 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8233 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8235 value_free_to_mark (mark
);
8239 /* An ordinary record type (with fixed-length fields) that describes
8240 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8241 beginning of this section]. Any necessary discriminants' values
8242 should be in DVAL, a record value; it may be NULL if the object
8243 at ADDR itself contains any necessary discriminant values.
8244 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8245 values from the record are needed. Except in the case that DVAL,
8246 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8247 unchecked) is replaced by a particular branch of the variant.
8249 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8250 is questionable and may be removed. It can arise during the
8251 processing of an unconstrained-array-of-record type where all the
8252 variant branches have exactly the same size. This is because in
8253 such cases, the compiler does not bother to use the XVS convention
8254 when encoding the record. I am currently dubious of this
8255 shortcut and suspect the compiler should be altered. FIXME. */
8257 static struct type
*
8258 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8259 CORE_ADDR address
, struct value
*dval
)
8261 struct type
*templ_type
;
8263 if (type0
->is_fixed_instance ())
8266 templ_type
= dynamic_template_type (type0
);
8268 if (templ_type
!= NULL
)
8269 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8270 else if (variant_field_index (type0
) >= 0)
8272 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8274 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8279 type0
->set_is_fixed_instance (true);
8285 /* An ordinary record type (with fixed-length fields) that describes
8286 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8287 union type. Any necessary discriminants' values should be in DVAL,
8288 a record value. That is, this routine selects the appropriate
8289 branch of the union at ADDR according to the discriminant value
8290 indicated in the union's type name. Returns VAR_TYPE0 itself if
8291 it represents a variant subject to a pragma Unchecked_Union. */
8293 static struct type
*
8294 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8295 CORE_ADDR address
, struct value
*dval
)
8298 struct type
*templ_type
;
8299 struct type
*var_type
;
8301 if (var_type0
->code () == TYPE_CODE_PTR
)
8302 var_type
= TYPE_TARGET_TYPE (var_type0
);
8304 var_type
= var_type0
;
8306 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8308 if (templ_type
!= NULL
)
8309 var_type
= templ_type
;
8311 if (is_unchecked_variant (var_type
, value_type (dval
)))
8313 which
= ada_which_variant_applies (var_type
, dval
);
8316 return empty_record (var_type
);
8317 else if (is_dynamic_field (var_type
, which
))
8318 return to_fixed_record_type
8319 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8320 valaddr
, address
, dval
);
8321 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8323 to_fixed_record_type
8324 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8326 return var_type
->field (which
).type ();
8329 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8330 ENCODING_TYPE, a type following the GNAT conventions for discrete
8331 type encodings, only carries redundant information. */
8334 ada_is_redundant_range_encoding (struct type
*range_type
,
8335 struct type
*encoding_type
)
8337 const char *bounds_str
;
8341 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8343 if (get_base_type (range_type
)->code ()
8344 != get_base_type (encoding_type
)->code ())
8346 /* The compiler probably used a simple base type to describe
8347 the range type instead of the range's actual base type,
8348 expecting us to get the real base type from the encoding
8349 anyway. In this situation, the encoding cannot be ignored
8354 if (is_dynamic_type (range_type
))
8357 if (encoding_type
->name () == NULL
)
8360 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8361 if (bounds_str
== NULL
)
8364 n
= 8; /* Skip "___XDLU_". */
8365 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8367 if (range_type
->bounds ()->low
.const_val () != lo
)
8370 n
+= 2; /* Skip the "__" separator between the two bounds. */
8371 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8373 if (range_type
->bounds ()->high
.const_val () != hi
)
8379 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8380 a type following the GNAT encoding for describing array type
8381 indices, only carries redundant information. */
8384 ada_is_redundant_index_type_desc (struct type
*array_type
,
8385 struct type
*desc_type
)
8387 struct type
*this_layer
= check_typedef (array_type
);
8390 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8392 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8393 desc_type
->field (i
).type ()))
8395 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8401 /* Assuming that TYPE0 is an array type describing the type of a value
8402 at ADDR, and that DVAL describes a record containing any
8403 discriminants used in TYPE0, returns a type for the value that
8404 contains no dynamic components (that is, no components whose sizes
8405 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8406 true, gives an error message if the resulting type's size is over
8409 static struct type
*
8410 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8413 struct type
*index_type_desc
;
8414 struct type
*result
;
8415 int constrained_packed_array_p
;
8416 static const char *xa_suffix
= "___XA";
8418 type0
= ada_check_typedef (type0
);
8419 if (type0
->is_fixed_instance ())
8422 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8423 if (constrained_packed_array_p
)
8425 type0
= decode_constrained_packed_array_type (type0
);
8426 if (type0
== nullptr)
8427 error (_("could not decode constrained packed array type"));
8430 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8432 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8433 encoding suffixed with 'P' may still be generated. If so,
8434 it should be used to find the XA type. */
8436 if (index_type_desc
== NULL
)
8438 const char *type_name
= ada_type_name (type0
);
8440 if (type_name
!= NULL
)
8442 const int len
= strlen (type_name
);
8443 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8445 if (type_name
[len
- 1] == 'P')
8447 strcpy (name
, type_name
);
8448 strcpy (name
+ len
- 1, xa_suffix
);
8449 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8454 ada_fixup_array_indexes_type (index_type_desc
);
8455 if (index_type_desc
!= NULL
8456 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8458 /* Ignore this ___XA parallel type, as it does not bring any
8459 useful information. This allows us to avoid creating fixed
8460 versions of the array's index types, which would be identical
8461 to the original ones. This, in turn, can also help avoid
8462 the creation of fixed versions of the array itself. */
8463 index_type_desc
= NULL
;
8466 if (index_type_desc
== NULL
)
8468 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8470 /* NOTE: elt_type---the fixed version of elt_type0---should never
8471 depend on the contents of the array in properly constructed
8473 /* Create a fixed version of the array element type.
8474 We're not providing the address of an element here,
8475 and thus the actual object value cannot be inspected to do
8476 the conversion. This should not be a problem, since arrays of
8477 unconstrained objects are not allowed. In particular, all
8478 the elements of an array of a tagged type should all be of
8479 the same type specified in the debugging info. No need to
8480 consult the object tag. */
8481 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8483 /* Make sure we always create a new array type when dealing with
8484 packed array types, since we're going to fix-up the array
8485 type length and element bitsize a little further down. */
8486 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8489 result
= create_array_type (alloc_type_copy (type0
),
8490 elt_type
, type0
->index_type ());
8495 struct type
*elt_type0
;
8498 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8499 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8501 /* NOTE: result---the fixed version of elt_type0---should never
8502 depend on the contents of the array in properly constructed
8504 /* Create a fixed version of the array element type.
8505 We're not providing the address of an element here,
8506 and thus the actual object value cannot be inspected to do
8507 the conversion. This should not be a problem, since arrays of
8508 unconstrained objects are not allowed. In particular, all
8509 the elements of an array of a tagged type should all be of
8510 the same type specified in the debugging info. No need to
8511 consult the object tag. */
8513 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8516 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8518 struct type
*range_type
=
8519 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8521 result
= create_array_type (alloc_type_copy (elt_type0
),
8522 result
, range_type
);
8523 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8525 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8526 error (_("array type with dynamic size is larger than varsize-limit"));
8529 /* We want to preserve the type name. This can be useful when
8530 trying to get the type name of a value that has already been
8531 printed (for instance, if the user did "print VAR; whatis $". */
8532 result
->set_name (type0
->name ());
8534 if (constrained_packed_array_p
)
8536 /* So far, the resulting type has been created as if the original
8537 type was a regular (non-packed) array type. As a result, the
8538 bitsize of the array elements needs to be set again, and the array
8539 length needs to be recomputed based on that bitsize. */
8540 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8541 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8543 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8544 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8545 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8546 TYPE_LENGTH (result
)++;
8549 result
->set_is_fixed_instance (true);
8554 /* A standard type (containing no dynamically sized components)
8555 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8556 DVAL describes a record containing any discriminants used in TYPE0,
8557 and may be NULL if there are none, or if the object of type TYPE at
8558 ADDRESS or in VALADDR contains these discriminants.
8560 If CHECK_TAG is not null, in the case of tagged types, this function
8561 attempts to locate the object's tag and use it to compute the actual
8562 type. However, when ADDRESS is null, we cannot use it to determine the
8563 location of the tag, and therefore compute the tagged type's actual type.
8564 So we return the tagged type without consulting the tag. */
8566 static struct type
*
8567 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8568 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8570 type
= ada_check_typedef (type
);
8572 /* Only un-fixed types need to be handled here. */
8573 if (!HAVE_GNAT_AUX_INFO (type
))
8576 switch (type
->code ())
8580 case TYPE_CODE_STRUCT
:
8582 struct type
*static_type
= to_static_fixed_type (type
);
8583 struct type
*fixed_record_type
=
8584 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8586 /* If STATIC_TYPE is a tagged type and we know the object's address,
8587 then we can determine its tag, and compute the object's actual
8588 type from there. Note that we have to use the fixed record
8589 type (the parent part of the record may have dynamic fields
8590 and the way the location of _tag is expressed may depend on
8593 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8596 value_tag_from_contents_and_address
8600 struct type
*real_type
= type_from_tag (tag
);
8602 value_from_contents_and_address (fixed_record_type
,
8605 fixed_record_type
= value_type (obj
);
8606 if (real_type
!= NULL
)
8607 return to_fixed_record_type
8609 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8612 /* Check to see if there is a parallel ___XVZ variable.
8613 If there is, then it provides the actual size of our type. */
8614 else if (ada_type_name (fixed_record_type
) != NULL
)
8616 const char *name
= ada_type_name (fixed_record_type
);
8618 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8619 bool xvz_found
= false;
8622 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8625 xvz_found
= get_int_var_value (xvz_name
, size
);
8627 catch (const gdb_exception_error
&except
)
8629 /* We found the variable, but somehow failed to read
8630 its value. Rethrow the same error, but with a little
8631 bit more information, to help the user understand
8632 what went wrong (Eg: the variable might have been
8634 throw_error (except
.error
,
8635 _("unable to read value of %s (%s)"),
8636 xvz_name
, except
.what ());
8639 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8641 fixed_record_type
= copy_type (fixed_record_type
);
8642 TYPE_LENGTH (fixed_record_type
) = size
;
8644 /* The FIXED_RECORD_TYPE may have be a stub. We have
8645 observed this when the debugging info is STABS, and
8646 apparently it is something that is hard to fix.
8648 In practice, we don't need the actual type definition
8649 at all, because the presence of the XVZ variable allows us
8650 to assume that there must be a XVS type as well, which we
8651 should be able to use later, when we need the actual type
8654 In the meantime, pretend that the "fixed" type we are
8655 returning is NOT a stub, because this can cause trouble
8656 when using this type to create new types targeting it.
8657 Indeed, the associated creation routines often check
8658 whether the target type is a stub and will try to replace
8659 it, thus using a type with the wrong size. This, in turn,
8660 might cause the new type to have the wrong size too.
8661 Consider the case of an array, for instance, where the size
8662 of the array is computed from the number of elements in
8663 our array multiplied by the size of its element. */
8664 fixed_record_type
->set_is_stub (false);
8667 return fixed_record_type
;
8669 case TYPE_CODE_ARRAY
:
8670 return to_fixed_array_type (type
, dval
, 1);
8671 case TYPE_CODE_UNION
:
8675 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8679 /* The same as ada_to_fixed_type_1, except that it preserves the type
8680 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8682 The typedef layer needs be preserved in order to differentiate between
8683 arrays and array pointers when both types are implemented using the same
8684 fat pointer. In the array pointer case, the pointer is encoded as
8685 a typedef of the pointer type. For instance, considering:
8687 type String_Access is access String;
8688 S1 : String_Access := null;
8690 To the debugger, S1 is defined as a typedef of type String. But
8691 to the user, it is a pointer. So if the user tries to print S1,
8692 we should not dereference the array, but print the array address
8695 If we didn't preserve the typedef layer, we would lose the fact that
8696 the type is to be presented as a pointer (needs de-reference before
8697 being printed). And we would also use the source-level type name. */
8700 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8701 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8704 struct type
*fixed_type
=
8705 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8707 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8708 then preserve the typedef layer.
8710 Implementation note: We can only check the main-type portion of
8711 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8712 from TYPE now returns a type that has the same instance flags
8713 as TYPE. For instance, if TYPE is a "typedef const", and its
8714 target type is a "struct", then the typedef elimination will return
8715 a "const" version of the target type. See check_typedef for more
8716 details about how the typedef layer elimination is done.
8718 brobecker/2010-11-19: It seems to me that the only case where it is
8719 useful to preserve the typedef layer is when dealing with fat pointers.
8720 Perhaps, we could add a check for that and preserve the typedef layer
8721 only in that situation. But this seems unnecessary so far, probably
8722 because we call check_typedef/ada_check_typedef pretty much everywhere.
8724 if (type
->code () == TYPE_CODE_TYPEDEF
8725 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8726 == TYPE_MAIN_TYPE (fixed_type
)))
8732 /* A standard (static-sized) type corresponding as well as possible to
8733 TYPE0, but based on no runtime data. */
8735 static struct type
*
8736 to_static_fixed_type (struct type
*type0
)
8743 if (type0
->is_fixed_instance ())
8746 type0
= ada_check_typedef (type0
);
8748 switch (type0
->code ())
8752 case TYPE_CODE_STRUCT
:
8753 type
= dynamic_template_type (type0
);
8755 return template_to_static_fixed_type (type
);
8757 return template_to_static_fixed_type (type0
);
8758 case TYPE_CODE_UNION
:
8759 type
= ada_find_parallel_type (type0
, "___XVU");
8761 return template_to_static_fixed_type (type
);
8763 return template_to_static_fixed_type (type0
);
8767 /* A static approximation of TYPE with all type wrappers removed. */
8769 static struct type
*
8770 static_unwrap_type (struct type
*type
)
8772 if (ada_is_aligner_type (type
))
8774 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8775 if (ada_type_name (type1
) == NULL
)
8776 type1
->set_name (ada_type_name (type
));
8778 return static_unwrap_type (type1
);
8782 struct type
*raw_real_type
= ada_get_base_type (type
);
8784 if (raw_real_type
== type
)
8787 return to_static_fixed_type (raw_real_type
);
8791 /* In some cases, incomplete and private types require
8792 cross-references that are not resolved as records (for example,
8794 type FooP is access Foo;
8796 type Foo is array ...;
8797 ). In these cases, since there is no mechanism for producing
8798 cross-references to such types, we instead substitute for FooP a
8799 stub enumeration type that is nowhere resolved, and whose tag is
8800 the name of the actual type. Call these types "non-record stubs". */
8802 /* A type equivalent to TYPE that is not a non-record stub, if one
8803 exists, otherwise TYPE. */
8806 ada_check_typedef (struct type
*type
)
8811 /* If our type is an access to an unconstrained array, which is encoded
8812 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8813 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8814 what allows us to distinguish between fat pointers that represent
8815 array types, and fat pointers that represent array access types
8816 (in both cases, the compiler implements them as fat pointers). */
8817 if (ada_is_access_to_unconstrained_array (type
))
8820 type
= check_typedef (type
);
8821 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8822 || !type
->is_stub ()
8823 || type
->name () == NULL
)
8827 const char *name
= type
->name ();
8828 struct type
*type1
= ada_find_any_type (name
);
8833 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8834 stubs pointing to arrays, as we don't create symbols for array
8835 types, only for the typedef-to-array types). If that's the case,
8836 strip the typedef layer. */
8837 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8838 type1
= ada_check_typedef (type1
);
8844 /* A value representing the data at VALADDR/ADDRESS as described by
8845 type TYPE0, but with a standard (static-sized) type that correctly
8846 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8847 type, then return VAL0 [this feature is simply to avoid redundant
8848 creation of struct values]. */
8850 static struct value
*
8851 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8854 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8856 if (type
== type0
&& val0
!= NULL
)
8859 if (VALUE_LVAL (val0
) != lval_memory
)
8861 /* Our value does not live in memory; it could be a convenience
8862 variable, for instance. Create a not_lval value using val0's
8864 return value_from_contents (type
, value_contents (val0
));
8867 return value_from_contents_and_address (type
, 0, address
);
8870 /* A value representing VAL, but with a standard (static-sized) type
8871 that correctly describes it. Does not necessarily create a new
8875 ada_to_fixed_value (struct value
*val
)
8877 val
= unwrap_value (val
);
8878 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8885 /* Table mapping attribute numbers to names.
8886 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8888 static const char * const attribute_names
[] = {
8906 ada_attribute_name (enum exp_opcode n
)
8908 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8909 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8911 return attribute_names
[0];
8914 /* Evaluate the 'POS attribute applied to ARG. */
8917 pos_atr (struct value
*arg
)
8919 struct value
*val
= coerce_ref (arg
);
8920 struct type
*type
= value_type (val
);
8922 if (!discrete_type_p (type
))
8923 error (_("'POS only defined on discrete types"));
8925 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8926 if (!result
.has_value ())
8927 error (_("enumeration value is invalid: can't find 'POS"));
8932 static struct value
*
8933 value_pos_atr (struct type
*type
, struct value
*arg
)
8935 return value_from_longest (type
, pos_atr (arg
));
8938 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8940 static struct value
*
8941 val_atr (struct type
*type
, LONGEST val
)
8943 gdb_assert (discrete_type_p (type
));
8944 if (type
->code () == TYPE_CODE_RANGE
)
8945 type
= TYPE_TARGET_TYPE (type
);
8946 if (type
->code () == TYPE_CODE_ENUM
)
8948 if (val
< 0 || val
>= type
->num_fields ())
8949 error (_("argument to 'VAL out of range"));
8950 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8952 return value_from_longest (type
, val
);
8955 static struct value
*
8956 value_val_atr (struct type
*type
, struct value
*arg
)
8958 if (!discrete_type_p (type
))
8959 error (_("'VAL only defined on discrete types"));
8960 if (!integer_type_p (value_type (arg
)))
8961 error (_("'VAL requires integral argument"));
8963 return val_atr (type
, value_as_long (arg
));
8969 /* True if TYPE appears to be an Ada character type.
8970 [At the moment, this is true only for Character and Wide_Character;
8971 It is a heuristic test that could stand improvement]. */
8974 ada_is_character_type (struct type
*type
)
8978 /* If the type code says it's a character, then assume it really is,
8979 and don't check any further. */
8980 if (type
->code () == TYPE_CODE_CHAR
)
8983 /* Otherwise, assume it's a character type iff it is a discrete type
8984 with a known character type name. */
8985 name
= ada_type_name (type
);
8986 return (name
!= NULL
8987 && (type
->code () == TYPE_CODE_INT
8988 || type
->code () == TYPE_CODE_RANGE
)
8989 && (strcmp (name
, "character") == 0
8990 || strcmp (name
, "wide_character") == 0
8991 || strcmp (name
, "wide_wide_character") == 0
8992 || strcmp (name
, "unsigned char") == 0));
8995 /* True if TYPE appears to be an Ada string type. */
8998 ada_is_string_type (struct type
*type
)
9000 type
= ada_check_typedef (type
);
9002 && type
->code () != TYPE_CODE_PTR
9003 && (ada_is_simple_array_type (type
)
9004 || ada_is_array_descriptor_type (type
))
9005 && ada_array_arity (type
) == 1)
9007 struct type
*elttype
= ada_array_element_type (type
, 1);
9009 return ada_is_character_type (elttype
);
9015 /* The compiler sometimes provides a parallel XVS type for a given
9016 PAD type. Normally, it is safe to follow the PAD type directly,
9017 but older versions of the compiler have a bug that causes the offset
9018 of its "F" field to be wrong. Following that field in that case
9019 would lead to incorrect results, but this can be worked around
9020 by ignoring the PAD type and using the associated XVS type instead.
9022 Set to True if the debugger should trust the contents of PAD types.
9023 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9024 static bool trust_pad_over_xvs
= true;
9026 /* True if TYPE is a struct type introduced by the compiler to force the
9027 alignment of a value. Such types have a single field with a
9028 distinctive name. */
9031 ada_is_aligner_type (struct type
*type
)
9033 type
= ada_check_typedef (type
);
9035 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9038 return (type
->code () == TYPE_CODE_STRUCT
9039 && type
->num_fields () == 1
9040 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9043 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9044 the parallel type. */
9047 ada_get_base_type (struct type
*raw_type
)
9049 struct type
*real_type_namer
;
9050 struct type
*raw_real_type
;
9052 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9055 if (ada_is_aligner_type (raw_type
))
9056 /* The encoding specifies that we should always use the aligner type.
9057 So, even if this aligner type has an associated XVS type, we should
9060 According to the compiler gurus, an XVS type parallel to an aligner
9061 type may exist because of a stabs limitation. In stabs, aligner
9062 types are empty because the field has a variable-sized type, and
9063 thus cannot actually be used as an aligner type. As a result,
9064 we need the associated parallel XVS type to decode the type.
9065 Since the policy in the compiler is to not change the internal
9066 representation based on the debugging info format, we sometimes
9067 end up having a redundant XVS type parallel to the aligner type. */
9070 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9071 if (real_type_namer
== NULL
9072 || real_type_namer
->code () != TYPE_CODE_STRUCT
9073 || real_type_namer
->num_fields () != 1)
9076 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9078 /* This is an older encoding form where the base type needs to be
9079 looked up by name. We prefer the newer encoding because it is
9081 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9082 if (raw_real_type
== NULL
)
9085 return raw_real_type
;
9088 /* The field in our XVS type is a reference to the base type. */
9089 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9092 /* The type of value designated by TYPE, with all aligners removed. */
9095 ada_aligned_type (struct type
*type
)
9097 if (ada_is_aligner_type (type
))
9098 return ada_aligned_type (type
->field (0).type ());
9100 return ada_get_base_type (type
);
9104 /* The address of the aligned value in an object at address VALADDR
9105 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9108 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9110 if (ada_is_aligner_type (type
))
9111 return ada_aligned_value_addr (type
->field (0).type (),
9113 TYPE_FIELD_BITPOS (type
,
9114 0) / TARGET_CHAR_BIT
);
9121 /* The printed representation of an enumeration literal with encoded
9122 name NAME. The value is good to the next call of ada_enum_name. */
9124 ada_enum_name (const char *name
)
9126 static char *result
;
9127 static size_t result_len
= 0;
9130 /* First, unqualify the enumeration name:
9131 1. Search for the last '.' character. If we find one, then skip
9132 all the preceding characters, the unqualified name starts
9133 right after that dot.
9134 2. Otherwise, we may be debugging on a target where the compiler
9135 translates dots into "__". Search forward for double underscores,
9136 but stop searching when we hit an overloading suffix, which is
9137 of the form "__" followed by digits. */
9139 tmp
= strrchr (name
, '.');
9144 while ((tmp
= strstr (name
, "__")) != NULL
)
9146 if (isdigit (tmp
[2]))
9157 if (name
[1] == 'U' || name
[1] == 'W')
9159 if (sscanf (name
+ 2, "%x", &v
) != 1)
9162 else if (((name
[1] >= '0' && name
[1] <= '9')
9163 || (name
[1] >= 'a' && name
[1] <= 'z'))
9166 GROW_VECT (result
, result_len
, 4);
9167 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9173 GROW_VECT (result
, result_len
, 16);
9174 if (isascii (v
) && isprint (v
))
9175 xsnprintf (result
, result_len
, "'%c'", v
);
9176 else if (name
[1] == 'U')
9177 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9179 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9185 tmp
= strstr (name
, "__");
9187 tmp
= strstr (name
, "$");
9190 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9191 strncpy (result
, name
, tmp
- name
);
9192 result
[tmp
- name
] = '\0';
9200 /* Evaluate the subexpression of EXP starting at *POS as for
9201 evaluate_type, updating *POS to point just past the evaluated
9204 static struct value
*
9205 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9207 return evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9210 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9213 static struct value
*
9214 unwrap_value (struct value
*val
)
9216 struct type
*type
= ada_check_typedef (value_type (val
));
9218 if (ada_is_aligner_type (type
))
9220 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9221 struct type
*val_type
= ada_check_typedef (value_type (v
));
9223 if (ada_type_name (val_type
) == NULL
)
9224 val_type
->set_name (ada_type_name (type
));
9226 return unwrap_value (v
);
9230 struct type
*raw_real_type
=
9231 ada_check_typedef (ada_get_base_type (type
));
9233 /* If there is no parallel XVS or XVE type, then the value is
9234 already unwrapped. Return it without further modification. */
9235 if ((type
== raw_real_type
)
9236 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9240 coerce_unspec_val_to_type
9241 (val
, ada_to_fixed_type (raw_real_type
, 0,
9242 value_address (val
),
9247 static struct value
*
9248 cast_from_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9251 = gnat_encoded_fixed_point_scaling_factor (value_type (arg
));
9252 arg
= value_cast (value_type (scale
), arg
);
9254 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9255 return value_cast (type
, arg
);
9258 static struct value
*
9259 cast_to_gnat_encoded_fixed_point_type (struct type
*type
, struct value
*arg
)
9261 if (type
== value_type (arg
))
9264 struct value
*scale
= gnat_encoded_fixed_point_scaling_factor (type
);
9265 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9266 arg
= cast_from_gnat_encoded_fixed_point_type (value_type (scale
), arg
);
9268 arg
= value_cast (value_type (scale
), arg
);
9270 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9271 return value_cast (type
, arg
);
9274 /* Given two array types T1 and T2, return nonzero iff both arrays
9275 contain the same number of elements. */
9278 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9280 LONGEST lo1
, hi1
, lo2
, hi2
;
9282 /* Get the array bounds in order to verify that the size of
9283 the two arrays match. */
9284 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9285 || !get_array_bounds (t2
, &lo2
, &hi2
))
9286 error (_("unable to determine array bounds"));
9288 /* To make things easier for size comparison, normalize a bit
9289 the case of empty arrays by making sure that the difference
9290 between upper bound and lower bound is always -1. */
9296 return (hi1
- lo1
== hi2
- lo2
);
9299 /* Assuming that VAL is an array of integrals, and TYPE represents
9300 an array with the same number of elements, but with wider integral
9301 elements, return an array "casted" to TYPE. In practice, this
9302 means that the returned array is built by casting each element
9303 of the original array into TYPE's (wider) element type. */
9305 static struct value
*
9306 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9308 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9313 /* Verify that both val and type are arrays of scalars, and
9314 that the size of val's elements is smaller than the size
9315 of type's element. */
9316 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9317 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9318 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9319 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9320 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9321 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9323 if (!get_array_bounds (type
, &lo
, &hi
))
9324 error (_("unable to determine array bounds"));
9326 res
= allocate_value (type
);
9328 /* Promote each array element. */
9329 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9331 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9333 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9334 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9340 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9341 return the converted value. */
9343 static struct value
*
9344 coerce_for_assign (struct type
*type
, struct value
*val
)
9346 struct type
*type2
= value_type (val
);
9351 type2
= ada_check_typedef (type2
);
9352 type
= ada_check_typedef (type
);
9354 if (type2
->code () == TYPE_CODE_PTR
9355 && type
->code () == TYPE_CODE_ARRAY
)
9357 val
= ada_value_ind (val
);
9358 type2
= value_type (val
);
9361 if (type2
->code () == TYPE_CODE_ARRAY
9362 && type
->code () == TYPE_CODE_ARRAY
)
9364 if (!ada_same_array_size_p (type
, type2
))
9365 error (_("cannot assign arrays of different length"));
9367 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9368 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9369 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9370 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9372 /* Allow implicit promotion of the array elements to
9374 return ada_promote_array_of_integrals (type
, val
);
9377 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9378 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9379 error (_("Incompatible types in assignment"));
9380 deprecated_set_value_type (val
, type
);
9385 static struct value
*
9386 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9389 struct type
*type1
, *type2
;
9392 arg1
= coerce_ref (arg1
);
9393 arg2
= coerce_ref (arg2
);
9394 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9395 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9397 if (type1
->code () != TYPE_CODE_INT
9398 || type2
->code () != TYPE_CODE_INT
)
9399 return value_binop (arg1
, arg2
, op
);
9408 return value_binop (arg1
, arg2
, op
);
9411 v2
= value_as_long (arg2
);
9413 error (_("second operand of %s must not be zero."), op_string (op
));
9415 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9416 return value_binop (arg1
, arg2
, op
);
9418 v1
= value_as_long (arg1
);
9423 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9424 v
+= v
> 0 ? -1 : 1;
9432 /* Should not reach this point. */
9436 val
= allocate_value (type1
);
9437 store_unsigned_integer (value_contents_raw (val
),
9438 TYPE_LENGTH (value_type (val
)),
9439 type_byte_order (type1
), v
);
9444 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9446 if (ada_is_direct_array_type (value_type (arg1
))
9447 || ada_is_direct_array_type (value_type (arg2
)))
9449 struct type
*arg1_type
, *arg2_type
;
9451 /* Automatically dereference any array reference before
9452 we attempt to perform the comparison. */
9453 arg1
= ada_coerce_ref (arg1
);
9454 arg2
= ada_coerce_ref (arg2
);
9456 arg1
= ada_coerce_to_simple_array (arg1
);
9457 arg2
= ada_coerce_to_simple_array (arg2
);
9459 arg1_type
= ada_check_typedef (value_type (arg1
));
9460 arg2_type
= ada_check_typedef (value_type (arg2
));
9462 if (arg1_type
->code () != TYPE_CODE_ARRAY
9463 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9464 error (_("Attempt to compare array with non-array"));
9465 /* FIXME: The following works only for types whose
9466 representations use all bits (no padding or undefined bits)
9467 and do not have user-defined equality. */
9468 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9469 && memcmp (value_contents (arg1
), value_contents (arg2
),
9470 TYPE_LENGTH (arg1_type
)) == 0);
9472 return value_equal (arg1
, arg2
);
9475 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9476 component of LHS (a simple array or a record), updating *POS past
9477 the expression, assuming that LHS is contained in CONTAINER. Does
9478 not modify the inferior's memory, nor does it modify LHS (unless
9479 LHS == CONTAINER). */
9482 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9483 struct expression
*exp
, int *pos
)
9485 struct value
*mark
= value_mark ();
9487 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9489 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9491 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9492 struct value
*index_val
= value_from_longest (index_type
, index
);
9494 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9498 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9499 elt
= ada_to_fixed_value (elt
);
9502 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9503 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9505 value_assign_to_component (container
, elt
,
9506 ada_evaluate_subexp (NULL
, exp
, pos
,
9509 value_free_to_mark (mark
);
9512 /* Assuming that LHS represents an lvalue having a record or array
9513 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9514 of that aggregate's value to LHS, advancing *POS past the
9515 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9516 lvalue containing LHS (possibly LHS itself). Does not modify
9517 the inferior's memory, nor does it modify the contents of
9518 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9520 static struct value
*
9521 assign_aggregate (struct value
*container
,
9522 struct value
*lhs
, struct expression
*exp
,
9523 int *pos
, enum noside noside
)
9525 struct type
*lhs_type
;
9526 int n
= exp
->elts
[*pos
+1].longconst
;
9527 LONGEST low_index
, high_index
;
9531 if (noside
!= EVAL_NORMAL
)
9533 for (i
= 0; i
< n
; i
+= 1)
9534 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9538 container
= ada_coerce_ref (container
);
9539 if (ada_is_direct_array_type (value_type (container
)))
9540 container
= ada_coerce_to_simple_array (container
);
9541 lhs
= ada_coerce_ref (lhs
);
9542 if (!deprecated_value_modifiable (lhs
))
9543 error (_("Left operand of assignment is not a modifiable lvalue."));
9545 lhs_type
= check_typedef (value_type (lhs
));
9546 if (ada_is_direct_array_type (lhs_type
))
9548 lhs
= ada_coerce_to_simple_array (lhs
);
9549 lhs_type
= check_typedef (value_type (lhs
));
9550 low_index
= lhs_type
->bounds ()->low
.const_val ();
9551 high_index
= lhs_type
->bounds ()->high
.const_val ();
9553 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9556 high_index
= num_visible_fields (lhs_type
) - 1;
9559 error (_("Left-hand side must be array or record."));
9561 std::vector
<LONGEST
> indices (4);
9562 indices
[0] = indices
[1] = low_index
- 1;
9563 indices
[2] = indices
[3] = high_index
+ 1;
9565 for (i
= 0; i
< n
; i
+= 1)
9567 switch (exp
->elts
[*pos
].opcode
)
9570 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9571 low_index
, high_index
);
9574 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9575 low_index
, high_index
);
9579 error (_("Misplaced 'others' clause"));
9580 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9581 low_index
, high_index
);
9584 error (_("Internal error: bad aggregate clause"));
9591 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9592 construct at *POS, updating *POS past the construct, given that
9593 the positions are relative to lower bound LOW, where HIGH is the
9594 upper bound. Record the position in INDICES. CONTAINER is as for
9595 assign_aggregate. */
9597 aggregate_assign_positional (struct value
*container
,
9598 struct value
*lhs
, struct expression
*exp
,
9599 int *pos
, std::vector
<LONGEST
> &indices
,
9600 LONGEST low
, LONGEST high
)
9602 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9604 if (ind
- 1 == high
)
9605 warning (_("Extra components in aggregate ignored."));
9608 add_component_interval (ind
, ind
, indices
);
9610 assign_component (container
, lhs
, ind
, exp
, pos
);
9613 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9616 /* Assign into the components of LHS indexed by the OP_CHOICES
9617 construct at *POS, updating *POS past the construct, given that
9618 the allowable indices are LOW..HIGH. Record the indices assigned
9619 to in INDICES. CONTAINER is as for assign_aggregate. */
9621 aggregate_assign_from_choices (struct value
*container
,
9622 struct value
*lhs
, struct expression
*exp
,
9623 int *pos
, std::vector
<LONGEST
> &indices
,
9624 LONGEST low
, LONGEST high
)
9627 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9628 int choice_pos
, expr_pc
;
9629 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9631 choice_pos
= *pos
+= 3;
9633 for (j
= 0; j
< n_choices
; j
+= 1)
9634 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9636 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9638 for (j
= 0; j
< n_choices
; j
+= 1)
9640 LONGEST lower
, upper
;
9641 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9643 if (op
== OP_DISCRETE_RANGE
)
9646 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9648 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9653 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9665 name
= &exp
->elts
[choice_pos
+ 2].string
;
9668 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9671 error (_("Invalid record component association."));
9673 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9675 if (! find_struct_field (name
, value_type (lhs
), 0,
9676 NULL
, NULL
, NULL
, NULL
, &ind
))
9677 error (_("Unknown component name: %s."), name
);
9678 lower
= upper
= ind
;
9681 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9682 error (_("Index in component association out of bounds."));
9684 add_component_interval (lower
, upper
, indices
);
9685 while (lower
<= upper
)
9690 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9696 /* Assign the value of the expression in the OP_OTHERS construct in
9697 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9698 have not been previously assigned. The index intervals already assigned
9699 are in INDICES. Updates *POS to after the OP_OTHERS clause.
9700 CONTAINER is as for assign_aggregate. */
9702 aggregate_assign_others (struct value
*container
,
9703 struct value
*lhs
, struct expression
*exp
,
9704 int *pos
, std::vector
<LONGEST
> &indices
,
9705 LONGEST low
, LONGEST high
)
9708 int expr_pc
= *pos
+ 1;
9710 int num_indices
= indices
.size ();
9711 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9715 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9720 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9723 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9726 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9727 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9730 add_component_interval (LONGEST low
, LONGEST high
,
9731 std::vector
<LONGEST
> &indices
)
9735 int size
= indices
.size ();
9736 for (i
= 0; i
< size
; i
+= 2) {
9737 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9741 for (kh
= i
+ 2; kh
< size
; kh
+= 2)
9742 if (high
< indices
[kh
])
9744 if (low
< indices
[i
])
9746 indices
[i
+ 1] = indices
[kh
- 1];
9747 if (high
> indices
[i
+ 1])
9748 indices
[i
+ 1] = high
;
9749 memcpy (indices
.data () + i
+ 2, indices
.data () + kh
, size
- kh
);
9750 indices
.resize (kh
- i
- 2);
9753 else if (high
< indices
[i
])
9757 indices
.resize (indices
.size () + 2);
9758 for (j
= size
- 1; j
>= i
+ 2; j
-= 1)
9759 indices
[j
] = indices
[j
- 2];
9761 indices
[i
+ 1] = high
;
9764 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9767 static struct value
*
9768 ada_value_cast (struct type
*type
, struct value
*arg2
)
9770 if (type
== ada_check_typedef (value_type (arg2
)))
9773 if (ada_is_gnat_encoded_fixed_point_type (type
))
9774 return cast_to_gnat_encoded_fixed_point_type (type
, arg2
);
9776 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9777 return cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
9779 return value_cast (type
, arg2
);
9782 /* Evaluating Ada expressions, and printing their result.
9783 ------------------------------------------------------
9788 We usually evaluate an Ada expression in order to print its value.
9789 We also evaluate an expression in order to print its type, which
9790 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9791 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9792 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9793 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9796 Evaluating expressions is a little more complicated for Ada entities
9797 than it is for entities in languages such as C. The main reason for
9798 this is that Ada provides types whose definition might be dynamic.
9799 One example of such types is variant records. Or another example
9800 would be an array whose bounds can only be known at run time.
9802 The following description is a general guide as to what should be
9803 done (and what should NOT be done) in order to evaluate an expression
9804 involving such types, and when. This does not cover how the semantic
9805 information is encoded by GNAT as this is covered separatly. For the
9806 document used as the reference for the GNAT encoding, see exp_dbug.ads
9807 in the GNAT sources.
9809 Ideally, we should embed each part of this description next to its
9810 associated code. Unfortunately, the amount of code is so vast right
9811 now that it's hard to see whether the code handling a particular
9812 situation might be duplicated or not. One day, when the code is
9813 cleaned up, this guide might become redundant with the comments
9814 inserted in the code, and we might want to remove it.
9816 2. ``Fixing'' an Entity, the Simple Case:
9817 -----------------------------------------
9819 When evaluating Ada expressions, the tricky issue is that they may
9820 reference entities whose type contents and size are not statically
9821 known. Consider for instance a variant record:
9823 type Rec (Empty : Boolean := True) is record
9826 when False => Value : Integer;
9829 Yes : Rec := (Empty => False, Value => 1);
9830 No : Rec := (empty => True);
9832 The size and contents of that record depends on the value of the
9833 descriminant (Rec.Empty). At this point, neither the debugging
9834 information nor the associated type structure in GDB are able to
9835 express such dynamic types. So what the debugger does is to create
9836 "fixed" versions of the type that applies to the specific object.
9837 We also informally refer to this operation as "fixing" an object,
9838 which means creating its associated fixed type.
9840 Example: when printing the value of variable "Yes" above, its fixed
9841 type would look like this:
9848 On the other hand, if we printed the value of "No", its fixed type
9855 Things become a little more complicated when trying to fix an entity
9856 with a dynamic type that directly contains another dynamic type,
9857 such as an array of variant records, for instance. There are
9858 two possible cases: Arrays, and records.
9860 3. ``Fixing'' Arrays:
9861 ---------------------
9863 The type structure in GDB describes an array in terms of its bounds,
9864 and the type of its elements. By design, all elements in the array
9865 have the same type and we cannot represent an array of variant elements
9866 using the current type structure in GDB. When fixing an array,
9867 we cannot fix the array element, as we would potentially need one
9868 fixed type per element of the array. As a result, the best we can do
9869 when fixing an array is to produce an array whose bounds and size
9870 are correct (allowing us to read it from memory), but without having
9871 touched its element type. Fixing each element will be done later,
9872 when (if) necessary.
9874 Arrays are a little simpler to handle than records, because the same
9875 amount of memory is allocated for each element of the array, even if
9876 the amount of space actually used by each element differs from element
9877 to element. Consider for instance the following array of type Rec:
9879 type Rec_Array is array (1 .. 2) of Rec;
9881 The actual amount of memory occupied by each element might be different
9882 from element to element, depending on the value of their discriminant.
9883 But the amount of space reserved for each element in the array remains
9884 fixed regardless. So we simply need to compute that size using
9885 the debugging information available, from which we can then determine
9886 the array size (we multiply the number of elements of the array by
9887 the size of each element).
9889 The simplest case is when we have an array of a constrained element
9890 type. For instance, consider the following type declarations:
9892 type Bounded_String (Max_Size : Integer) is
9894 Buffer : String (1 .. Max_Size);
9896 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9898 In this case, the compiler describes the array as an array of
9899 variable-size elements (identified by its XVS suffix) for which
9900 the size can be read in the parallel XVZ variable.
9902 In the case of an array of an unconstrained element type, the compiler
9903 wraps the array element inside a private PAD type. This type should not
9904 be shown to the user, and must be "unwrap"'ed before printing. Note
9905 that we also use the adjective "aligner" in our code to designate
9906 these wrapper types.
9908 In some cases, the size allocated for each element is statically
9909 known. In that case, the PAD type already has the correct size,
9910 and the array element should remain unfixed.
9912 But there are cases when this size is not statically known.
9913 For instance, assuming that "Five" is an integer variable:
9915 type Dynamic is array (1 .. Five) of Integer;
9916 type Wrapper (Has_Length : Boolean := False) is record
9919 when True => Length : Integer;
9923 type Wrapper_Array is array (1 .. 2) of Wrapper;
9925 Hello : Wrapper_Array := (others => (Has_Length => True,
9926 Data => (others => 17),
9930 The debugging info would describe variable Hello as being an
9931 array of a PAD type. The size of that PAD type is not statically
9932 known, but can be determined using a parallel XVZ variable.
9933 In that case, a copy of the PAD type with the correct size should
9934 be used for the fixed array.
9936 3. ``Fixing'' record type objects:
9937 ----------------------------------
9939 Things are slightly different from arrays in the case of dynamic
9940 record types. In this case, in order to compute the associated
9941 fixed type, we need to determine the size and offset of each of
9942 its components. This, in turn, requires us to compute the fixed
9943 type of each of these components.
9945 Consider for instance the example:
9947 type Bounded_String (Max_Size : Natural) is record
9948 Str : String (1 .. Max_Size);
9951 My_String : Bounded_String (Max_Size => 10);
9953 In that case, the position of field "Length" depends on the size
9954 of field Str, which itself depends on the value of the Max_Size
9955 discriminant. In order to fix the type of variable My_String,
9956 we need to fix the type of field Str. Therefore, fixing a variant
9957 record requires us to fix each of its components.
9959 However, if a component does not have a dynamic size, the component
9960 should not be fixed. In particular, fields that use a PAD type
9961 should not fixed. Here is an example where this might happen
9962 (assuming type Rec above):
9964 type Container (Big : Boolean) is record
9968 when True => Another : Integer;
9972 My_Container : Container := (Big => False,
9973 First => (Empty => True),
9976 In that example, the compiler creates a PAD type for component First,
9977 whose size is constant, and then positions the component After just
9978 right after it. The offset of component After is therefore constant
9981 The debugger computes the position of each field based on an algorithm
9982 that uses, among other things, the actual position and size of the field
9983 preceding it. Let's now imagine that the user is trying to print
9984 the value of My_Container. If the type fixing was recursive, we would
9985 end up computing the offset of field After based on the size of the
9986 fixed version of field First. And since in our example First has
9987 only one actual field, the size of the fixed type is actually smaller
9988 than the amount of space allocated to that field, and thus we would
9989 compute the wrong offset of field After.
9991 To make things more complicated, we need to watch out for dynamic
9992 components of variant records (identified by the ___XVL suffix in
9993 the component name). Even if the target type is a PAD type, the size
9994 of that type might not be statically known. So the PAD type needs
9995 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9996 we might end up with the wrong size for our component. This can be
9997 observed with the following type declarations:
9999 type Octal is new Integer range 0 .. 7;
10000 type Octal_Array is array (Positive range <>) of Octal;
10001 pragma Pack (Octal_Array);
10003 type Octal_Buffer (Size : Positive) is record
10004 Buffer : Octal_Array (1 .. Size);
10008 In that case, Buffer is a PAD type whose size is unset and needs
10009 to be computed by fixing the unwrapped type.
10011 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10012 ----------------------------------------------------------
10014 Lastly, when should the sub-elements of an entity that remained unfixed
10015 thus far, be actually fixed?
10017 The answer is: Only when referencing that element. For instance
10018 when selecting one component of a record, this specific component
10019 should be fixed at that point in time. Or when printing the value
10020 of a record, each component should be fixed before its value gets
10021 printed. Similarly for arrays, the element of the array should be
10022 fixed when printing each element of the array, or when extracting
10023 one element out of that array. On the other hand, fixing should
10024 not be performed on the elements when taking a slice of an array!
10026 Note that one of the side effects of miscomputing the offset and
10027 size of each field is that we end up also miscomputing the size
10028 of the containing type. This can have adverse results when computing
10029 the value of an entity. GDB fetches the value of an entity based
10030 on the size of its type, and thus a wrong size causes GDB to fetch
10031 the wrong amount of memory. In the case where the computed size is
10032 too small, GDB fetches too little data to print the value of our
10033 entity. Results in this case are unpredictable, as we usually read
10034 past the buffer containing the data =:-o. */
10036 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10037 for that subexpression cast to TO_TYPE. Advance *POS over the
10041 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10042 enum noside noside
, struct type
*to_type
)
10046 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10047 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10052 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10054 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10055 return value_zero (to_type
, not_lval
);
10057 val
= evaluate_var_msym_value (noside
,
10058 exp
->elts
[pc
+ 1].objfile
,
10059 exp
->elts
[pc
+ 2].msymbol
);
10062 val
= evaluate_var_value (noside
,
10063 exp
->elts
[pc
+ 1].block
,
10064 exp
->elts
[pc
+ 2].symbol
);
10066 if (noside
== EVAL_SKIP
)
10067 return eval_skip_value (exp
);
10069 val
= ada_value_cast (to_type
, val
);
10071 /* Follow the Ada language semantics that do not allow taking
10072 an address of the result of a cast (view conversion in Ada). */
10073 if (VALUE_LVAL (val
) == lval_memory
)
10075 if (value_lazy (val
))
10076 value_fetch_lazy (val
);
10077 VALUE_LVAL (val
) = not_lval
;
10082 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10083 if (noside
== EVAL_SKIP
)
10084 return eval_skip_value (exp
);
10085 return ada_value_cast (to_type
, val
);
10088 /* Implement the evaluate_exp routine in the exp_descriptor structure
10089 for the Ada language. */
10091 static struct value
*
10092 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10093 int *pos
, enum noside noside
)
10095 enum exp_opcode op
;
10099 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10102 struct value
**argvec
;
10106 op
= exp
->elts
[pc
].opcode
;
10112 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10114 if (noside
== EVAL_NORMAL
)
10115 arg1
= unwrap_value (arg1
);
10117 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10118 then we need to perform the conversion manually, because
10119 evaluate_subexp_standard doesn't do it. This conversion is
10120 necessary in Ada because the different kinds of float/fixed
10121 types in Ada have different representations.
10123 Similarly, we need to perform the conversion from OP_LONG
10125 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10126 arg1
= ada_value_cast (expect_type
, arg1
);
10132 struct value
*result
;
10135 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10136 /* The result type will have code OP_STRING, bashed there from
10137 OP_ARRAY. Bash it back. */
10138 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10139 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10145 type
= exp
->elts
[pc
+ 1].type
;
10146 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10150 type
= exp
->elts
[pc
+ 1].type
;
10151 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10154 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10155 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10157 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10158 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10160 return ada_value_assign (arg1
, arg1
);
10162 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10163 except if the lhs of our assignment is a convenience variable.
10164 In the case of assigning to a convenience variable, the lhs
10165 should be exactly the result of the evaluation of the rhs. */
10166 type
= value_type (arg1
);
10167 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10169 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10170 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10172 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10176 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10177 arg2
= cast_to_gnat_encoded_fixed_point_type (value_type (arg1
), arg2
);
10178 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10180 (_("Fixed-point values must be assigned to fixed-point variables"));
10182 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10183 return ada_value_assign (arg1
, arg2
);
10186 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10187 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10188 if (noside
== EVAL_SKIP
)
10190 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10191 return (value_from_longest
10192 (value_type (arg1
),
10193 value_as_long (arg1
) + value_as_long (arg2
)));
10194 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10195 return (value_from_longest
10196 (value_type (arg2
),
10197 value_as_long (arg1
) + value_as_long (arg2
)));
10198 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10199 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10200 && value_type (arg1
) != value_type (arg2
))
10201 error (_("Operands of fixed-point addition must have the same type"));
10202 /* Do the addition, and cast the result to the type of the first
10203 argument. We cannot cast the result to a reference type, so if
10204 ARG1 is a reference type, find its underlying type. */
10205 type
= value_type (arg1
);
10206 while (type
->code () == TYPE_CODE_REF
)
10207 type
= TYPE_TARGET_TYPE (type
);
10208 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10209 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10212 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10213 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10214 if (noside
== EVAL_SKIP
)
10216 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10217 return (value_from_longest
10218 (value_type (arg1
),
10219 value_as_long (arg1
) - value_as_long (arg2
)));
10220 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10221 return (value_from_longest
10222 (value_type (arg2
),
10223 value_as_long (arg1
) - value_as_long (arg2
)));
10224 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10225 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10226 && value_type (arg1
) != value_type (arg2
))
10227 error (_("Operands of fixed-point subtraction "
10228 "must have the same type"));
10229 /* Do the substraction, and cast the result to the type of the first
10230 argument. We cannot cast the result to a reference type, so if
10231 ARG1 is a reference type, find its underlying type. */
10232 type
= value_type (arg1
);
10233 while (type
->code () == TYPE_CODE_REF
)
10234 type
= TYPE_TARGET_TYPE (type
);
10235 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10236 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10242 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10243 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10244 if (noside
== EVAL_SKIP
)
10246 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10248 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10249 return value_zero (value_type (arg1
), not_lval
);
10253 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10254 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10255 arg1
= cast_from_gnat_encoded_fixed_point_type (type
, arg1
);
10256 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10257 arg2
= cast_from_gnat_encoded_fixed_point_type (type
, arg2
);
10258 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10259 return ada_value_binop (arg1
, arg2
, op
);
10263 case BINOP_NOTEQUAL
:
10264 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10265 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10266 if (noside
== EVAL_SKIP
)
10268 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10272 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10273 tem
= ada_value_equal (arg1
, arg2
);
10275 if (op
== BINOP_NOTEQUAL
)
10277 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10278 return value_from_longest (type
, (LONGEST
) tem
);
10281 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10282 if (noside
== EVAL_SKIP
)
10284 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10285 return value_cast (value_type (arg1
), value_neg (arg1
));
10288 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10289 return value_neg (arg1
);
10292 case BINOP_LOGICAL_AND
:
10293 case BINOP_LOGICAL_OR
:
10294 case UNOP_LOGICAL_NOT
:
10299 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10300 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10301 return value_cast (type
, val
);
10304 case BINOP_BITWISE_AND
:
10305 case BINOP_BITWISE_IOR
:
10306 case BINOP_BITWISE_XOR
:
10310 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10312 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10314 return value_cast (value_type (arg1
), val
);
10320 if (noside
== EVAL_SKIP
)
10326 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10327 /* Only encountered when an unresolved symbol occurs in a
10328 context other than a function call, in which case, it is
10330 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10331 exp
->elts
[pc
+ 2].symbol
->print_name ());
10333 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10335 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10336 /* Check to see if this is a tagged type. We also need to handle
10337 the case where the type is a reference to a tagged type, but
10338 we have to be careful to exclude pointers to tagged types.
10339 The latter should be shown as usual (as a pointer), whereas
10340 a reference should mostly be transparent to the user. */
10341 if (ada_is_tagged_type (type
, 0)
10342 || (type
->code () == TYPE_CODE_REF
10343 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10345 /* Tagged types are a little special in the fact that the real
10346 type is dynamic and can only be determined by inspecting the
10347 object's tag. This means that we need to get the object's
10348 value first (EVAL_NORMAL) and then extract the actual object
10351 Note that we cannot skip the final step where we extract
10352 the object type from its tag, because the EVAL_NORMAL phase
10353 results in dynamic components being resolved into fixed ones.
10354 This can cause problems when trying to print the type
10355 description of tagged types whose parent has a dynamic size:
10356 We use the type name of the "_parent" component in order
10357 to print the name of the ancestor type in the type description.
10358 If that component had a dynamic size, the resolution into
10359 a fixed type would result in the loss of that type name,
10360 thus preventing us from printing the name of the ancestor
10361 type in the type description. */
10362 arg1
= evaluate_subexp (nullptr, exp
, pos
, EVAL_NORMAL
);
10364 if (type
->code () != TYPE_CODE_REF
)
10366 struct type
*actual_type
;
10368 actual_type
= type_from_tag (ada_value_tag (arg1
));
10369 if (actual_type
== NULL
)
10370 /* If, for some reason, we were unable to determine
10371 the actual type from the tag, then use the static
10372 approximation that we just computed as a fallback.
10373 This can happen if the debugging information is
10374 incomplete, for instance. */
10375 actual_type
= type
;
10376 return value_zero (actual_type
, not_lval
);
10380 /* In the case of a ref, ada_coerce_ref takes care
10381 of determining the actual type. But the evaluation
10382 should return a ref as it should be valid to ask
10383 for its address; so rebuild a ref after coerce. */
10384 arg1
= ada_coerce_ref (arg1
);
10385 return value_ref (arg1
, TYPE_CODE_REF
);
10389 /* Records and unions for which GNAT encodings have been
10390 generated need to be statically fixed as well.
10391 Otherwise, non-static fixing produces a type where
10392 all dynamic properties are removed, which prevents "ptype"
10393 from being able to completely describe the type.
10394 For instance, a case statement in a variant record would be
10395 replaced by the relevant components based on the actual
10396 value of the discriminants. */
10397 if ((type
->code () == TYPE_CODE_STRUCT
10398 && dynamic_template_type (type
) != NULL
)
10399 || (type
->code () == TYPE_CODE_UNION
10400 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10403 return value_zero (to_static_fixed_type (type
), not_lval
);
10407 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10408 return ada_to_fixed_value (arg1
);
10413 /* Allocate arg vector, including space for the function to be
10414 called in argvec[0] and a terminating NULL. */
10415 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10416 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10418 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10419 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10420 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10421 exp
->elts
[pc
+ 5].symbol
->print_name ());
10424 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10425 argvec
[tem
] = evaluate_subexp (nullptr, exp
, pos
, noside
);
10428 if (noside
== EVAL_SKIP
)
10432 if (ada_is_constrained_packed_array_type
10433 (desc_base_type (value_type (argvec
[0]))))
10434 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10435 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10436 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10437 /* This is a packed array that has already been fixed, and
10438 therefore already coerced to a simple array. Nothing further
10441 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10443 /* Make sure we dereference references so that all the code below
10444 feels like it's really handling the referenced value. Wrapping
10445 types (for alignment) may be there, so make sure we strip them as
10447 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10449 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10450 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10451 argvec
[0] = value_addr (argvec
[0]);
10453 type
= ada_check_typedef (value_type (argvec
[0]));
10455 /* Ada allows us to implicitly dereference arrays when subscripting
10456 them. So, if this is an array typedef (encoding use for array
10457 access types encoded as fat pointers), strip it now. */
10458 if (type
->code () == TYPE_CODE_TYPEDEF
)
10459 type
= ada_typedef_target_type (type
);
10461 if (type
->code () == TYPE_CODE_PTR
)
10463 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10465 case TYPE_CODE_FUNC
:
10466 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10468 case TYPE_CODE_ARRAY
:
10470 case TYPE_CODE_STRUCT
:
10471 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10472 argvec
[0] = ada_value_ind (argvec
[0]);
10473 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10476 error (_("cannot subscript or call something of type `%s'"),
10477 ada_type_name (value_type (argvec
[0])));
10482 switch (type
->code ())
10484 case TYPE_CODE_FUNC
:
10485 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10487 if (TYPE_TARGET_TYPE (type
) == NULL
)
10488 error_call_unknown_return_type (NULL
);
10489 return allocate_value (TYPE_TARGET_TYPE (type
));
10491 return call_function_by_hand (argvec
[0], NULL
,
10492 gdb::make_array_view (argvec
+ 1,
10494 case TYPE_CODE_INTERNAL_FUNCTION
:
10495 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10496 /* We don't know anything about what the internal
10497 function might return, but we have to return
10499 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10502 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10503 argvec
[0], nargs
, argvec
+ 1);
10505 case TYPE_CODE_STRUCT
:
10509 arity
= ada_array_arity (type
);
10510 type
= ada_array_element_type (type
, nargs
);
10512 error (_("cannot subscript or call a record"));
10513 if (arity
!= nargs
)
10514 error (_("wrong number of subscripts; expecting %d"), arity
);
10515 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10516 return value_zero (ada_aligned_type (type
), lval_memory
);
10518 unwrap_value (ada_value_subscript
10519 (argvec
[0], nargs
, argvec
+ 1));
10521 case TYPE_CODE_ARRAY
:
10522 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10524 type
= ada_array_element_type (type
, nargs
);
10526 error (_("element type of array unknown"));
10528 return value_zero (ada_aligned_type (type
), lval_memory
);
10531 unwrap_value (ada_value_subscript
10532 (ada_coerce_to_simple_array (argvec
[0]),
10533 nargs
, argvec
+ 1));
10534 case TYPE_CODE_PTR
: /* Pointer to array */
10535 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10537 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10538 type
= ada_array_element_type (type
, nargs
);
10540 error (_("element type of array unknown"));
10542 return value_zero (ada_aligned_type (type
), lval_memory
);
10545 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10546 nargs
, argvec
+ 1));
10549 error (_("Attempt to index or call something other than an "
10550 "array or function"));
10555 struct value
*array
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10556 struct value
*low_bound_val
10557 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10558 struct value
*high_bound_val
10559 = evaluate_subexp (nullptr, exp
, pos
, noside
);
10561 LONGEST high_bound
;
10563 low_bound_val
= coerce_ref (low_bound_val
);
10564 high_bound_val
= coerce_ref (high_bound_val
);
10565 low_bound
= value_as_long (low_bound_val
);
10566 high_bound
= value_as_long (high_bound_val
);
10568 if (noside
== EVAL_SKIP
)
10571 /* If this is a reference to an aligner type, then remove all
10573 if (value_type (array
)->code () == TYPE_CODE_REF
10574 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10575 TYPE_TARGET_TYPE (value_type (array
)) =
10576 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10578 if (ada_is_any_packed_array_type (value_type (array
)))
10579 error (_("cannot slice a packed array"));
10581 /* If this is a reference to an array or an array lvalue,
10582 convert to a pointer. */
10583 if (value_type (array
)->code () == TYPE_CODE_REF
10584 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10585 && VALUE_LVAL (array
) == lval_memory
))
10586 array
= value_addr (array
);
10588 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10589 && ada_is_array_descriptor_type (ada_check_typedef
10590 (value_type (array
))))
10591 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10594 array
= ada_coerce_to_simple_array_ptr (array
);
10596 /* If we have more than one level of pointer indirection,
10597 dereference the value until we get only one level. */
10598 while (value_type (array
)->code () == TYPE_CODE_PTR
10599 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10601 array
= value_ind (array
);
10603 /* Make sure we really do have an array type before going further,
10604 to avoid a SEGV when trying to get the index type or the target
10605 type later down the road if the debug info generated by
10606 the compiler is incorrect or incomplete. */
10607 if (!ada_is_simple_array_type (value_type (array
)))
10608 error (_("cannot take slice of non-array"));
10610 if (ada_check_typedef (value_type (array
))->code ()
10613 struct type
*type0
= ada_check_typedef (value_type (array
));
10615 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10616 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10619 struct type
*arr_type0
=
10620 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10622 return ada_value_slice_from_ptr (array
, arr_type0
,
10623 longest_to_int (low_bound
),
10624 longest_to_int (high_bound
));
10627 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10629 else if (high_bound
< low_bound
)
10630 return empty_array (value_type (array
), low_bound
, high_bound
);
10632 return ada_value_slice (array
, longest_to_int (low_bound
),
10633 longest_to_int (high_bound
));
10636 case UNOP_IN_RANGE
:
10638 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10639 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10641 if (noside
== EVAL_SKIP
)
10644 switch (type
->code ())
10647 lim_warning (_("Membership test incompletely implemented; "
10648 "always returns true"));
10649 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10650 return value_from_longest (type
, (LONGEST
) 1);
10652 case TYPE_CODE_RANGE
:
10653 arg2
= value_from_longest (type
,
10654 type
->bounds ()->low
.const_val ());
10655 arg3
= value_from_longest (type
,
10656 type
->bounds ()->high
.const_val ());
10657 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10658 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10659 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10661 value_from_longest (type
,
10662 (value_less (arg1
, arg3
)
10663 || value_equal (arg1
, arg3
))
10664 && (value_less (arg2
, arg1
)
10665 || value_equal (arg2
, arg1
)));
10668 case BINOP_IN_BOUNDS
:
10670 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10671 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10673 if (noside
== EVAL_SKIP
)
10676 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10678 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10679 return value_zero (type
, not_lval
);
10682 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10684 type
= ada_index_type (value_type (arg2
), tem
, "range");
10686 type
= value_type (arg1
);
10688 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10689 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10691 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10692 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10693 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10695 value_from_longest (type
,
10696 (value_less (arg1
, arg3
)
10697 || value_equal (arg1
, arg3
))
10698 && (value_less (arg2
, arg1
)
10699 || value_equal (arg2
, arg1
)));
10701 case TERNOP_IN_RANGE
:
10702 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10703 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10704 arg3
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10706 if (noside
== EVAL_SKIP
)
10709 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10710 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10711 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10713 value_from_longest (type
,
10714 (value_less (arg1
, arg3
)
10715 || value_equal (arg1
, arg3
))
10716 && (value_less (arg2
, arg1
)
10717 || value_equal (arg2
, arg1
)));
10721 case OP_ATR_LENGTH
:
10723 struct type
*type_arg
;
10725 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10727 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10729 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10733 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10737 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10738 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10739 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10742 if (noside
== EVAL_SKIP
)
10744 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10746 if (type_arg
== NULL
)
10747 type_arg
= value_type (arg1
);
10749 if (ada_is_constrained_packed_array_type (type_arg
))
10750 type_arg
= decode_constrained_packed_array_type (type_arg
);
10752 if (!discrete_type_p (type_arg
))
10756 default: /* Should never happen. */
10757 error (_("unexpected attribute encountered"));
10760 type_arg
= ada_index_type (type_arg
, tem
,
10761 ada_attribute_name (op
));
10763 case OP_ATR_LENGTH
:
10764 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10769 return value_zero (type_arg
, not_lval
);
10771 else if (type_arg
== NULL
)
10773 arg1
= ada_coerce_ref (arg1
);
10775 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10776 arg1
= ada_coerce_to_simple_array (arg1
);
10778 if (op
== OP_ATR_LENGTH
)
10779 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10782 type
= ada_index_type (value_type (arg1
), tem
,
10783 ada_attribute_name (op
));
10785 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10790 default: /* Should never happen. */
10791 error (_("unexpected attribute encountered"));
10793 return value_from_longest
10794 (type
, ada_array_bound (arg1
, tem
, 0));
10796 return value_from_longest
10797 (type
, ada_array_bound (arg1
, tem
, 1));
10798 case OP_ATR_LENGTH
:
10799 return value_from_longest
10800 (type
, ada_array_length (arg1
, tem
));
10803 else if (discrete_type_p (type_arg
))
10805 struct type
*range_type
;
10806 const char *name
= ada_type_name (type_arg
);
10809 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10810 range_type
= to_fixed_range_type (type_arg
, NULL
);
10811 if (range_type
== NULL
)
10812 range_type
= type_arg
;
10816 error (_("unexpected attribute encountered"));
10818 return value_from_longest
10819 (range_type
, ada_discrete_type_low_bound (range_type
));
10821 return value_from_longest
10822 (range_type
, ada_discrete_type_high_bound (range_type
));
10823 case OP_ATR_LENGTH
:
10824 error (_("the 'length attribute applies only to array types"));
10827 else if (type_arg
->code () == TYPE_CODE_FLT
)
10828 error (_("unimplemented type attribute"));
10833 if (ada_is_constrained_packed_array_type (type_arg
))
10834 type_arg
= decode_constrained_packed_array_type (type_arg
);
10836 if (op
== OP_ATR_LENGTH
)
10837 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10840 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10842 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10848 error (_("unexpected attribute encountered"));
10850 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10851 return value_from_longest (type
, low
);
10853 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10854 return value_from_longest (type
, high
);
10855 case OP_ATR_LENGTH
:
10856 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10857 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10858 return value_from_longest (type
, high
- low
+ 1);
10864 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10865 if (noside
== EVAL_SKIP
)
10868 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10869 return value_zero (ada_tag_type (arg1
), not_lval
);
10871 return ada_value_tag (arg1
);
10875 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10876 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10877 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10878 if (noside
== EVAL_SKIP
)
10880 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10881 return value_zero (value_type (arg1
), not_lval
);
10884 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10885 return value_binop (arg1
, arg2
,
10886 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10889 case OP_ATR_MODULUS
:
10891 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10893 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10894 if (noside
== EVAL_SKIP
)
10897 if (!ada_is_modular_type (type_arg
))
10898 error (_("'modulus must be applied to modular type"));
10900 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10901 ada_modulus (type_arg
));
10906 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10907 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10908 if (noside
== EVAL_SKIP
)
10910 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10911 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10912 return value_zero (type
, not_lval
);
10914 return value_pos_atr (type
, arg1
);
10917 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10918 type
= value_type (arg1
);
10920 /* If the argument is a reference, then dereference its type, since
10921 the user is really asking for the size of the actual object,
10922 not the size of the pointer. */
10923 if (type
->code () == TYPE_CODE_REF
)
10924 type
= TYPE_TARGET_TYPE (type
);
10926 if (noside
== EVAL_SKIP
)
10928 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10929 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10931 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10932 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10935 evaluate_subexp (nullptr, exp
, pos
, EVAL_SKIP
);
10936 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10937 type
= exp
->elts
[pc
+ 2].type
;
10938 if (noside
== EVAL_SKIP
)
10940 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10941 return value_zero (type
, not_lval
);
10943 return value_val_atr (type
, arg1
);
10946 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10947 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10948 if (noside
== EVAL_SKIP
)
10950 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10951 return value_zero (value_type (arg1
), not_lval
);
10954 /* For integer exponentiation operations,
10955 only promote the first argument. */
10956 if (is_integral_type (value_type (arg2
)))
10957 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10959 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10961 return value_binop (arg1
, arg2
, op
);
10965 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10966 if (noside
== EVAL_SKIP
)
10972 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10973 if (noside
== EVAL_SKIP
)
10975 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10976 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10977 return value_neg (arg1
);
10982 preeval_pos
= *pos
;
10983 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
10984 if (noside
== EVAL_SKIP
)
10986 type
= ada_check_typedef (value_type (arg1
));
10987 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10989 if (ada_is_array_descriptor_type (type
))
10990 /* GDB allows dereferencing GNAT array descriptors. */
10992 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10994 if (arrType
== NULL
)
10995 error (_("Attempt to dereference null array pointer."));
10996 return value_at_lazy (arrType
, 0);
10998 else if (type
->code () == TYPE_CODE_PTR
10999 || type
->code () == TYPE_CODE_REF
11000 /* In C you can dereference an array to get the 1st elt. */
11001 || type
->code () == TYPE_CODE_ARRAY
)
11003 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11004 only be determined by inspecting the object's tag.
11005 This means that we need to evaluate completely the
11006 expression in order to get its type. */
11008 if ((type
->code () == TYPE_CODE_REF
11009 || type
->code () == TYPE_CODE_PTR
)
11010 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11013 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11014 type
= value_type (ada_value_ind (arg1
));
11018 type
= to_static_fixed_type
11020 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11022 ada_ensure_varsize_limit (type
);
11023 return value_zero (type
, lval_memory
);
11025 else if (type
->code () == TYPE_CODE_INT
)
11027 /* GDB allows dereferencing an int. */
11028 if (expect_type
== NULL
)
11029 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11034 to_static_fixed_type (ada_aligned_type (expect_type
));
11035 return value_zero (expect_type
, lval_memory
);
11039 error (_("Attempt to take contents of a non-pointer value."));
11041 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11042 type
= ada_check_typedef (value_type (arg1
));
11044 if (type
->code () == TYPE_CODE_INT
)
11045 /* GDB allows dereferencing an int. If we were given
11046 the expect_type, then use that as the target type.
11047 Otherwise, assume that the target type is an int. */
11049 if (expect_type
!= NULL
)
11050 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11053 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11054 (CORE_ADDR
) value_as_address (arg1
));
11057 if (ada_is_array_descriptor_type (type
))
11058 /* GDB allows dereferencing GNAT array descriptors. */
11059 return ada_coerce_to_simple_array (arg1
);
11061 return ada_value_ind (arg1
);
11063 case STRUCTOP_STRUCT
:
11064 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11065 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11066 preeval_pos
= *pos
;
11067 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
11068 if (noside
== EVAL_SKIP
)
11070 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11072 struct type
*type1
= value_type (arg1
);
11074 if (ada_is_tagged_type (type1
, 1))
11076 type
= ada_lookup_struct_elt_type (type1
,
11077 &exp
->elts
[pc
+ 2].string
,
11080 /* If the field is not found, check if it exists in the
11081 extension of this object's type. This means that we
11082 need to evaluate completely the expression. */
11087 = evaluate_subexp (nullptr, exp
, &preeval_pos
, EVAL_NORMAL
);
11088 arg1
= ada_value_struct_elt (arg1
,
11089 &exp
->elts
[pc
+ 2].string
,
11091 arg1
= unwrap_value (arg1
);
11092 type
= value_type (ada_to_fixed_value (arg1
));
11097 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11100 return value_zero (ada_aligned_type (type
), lval_memory
);
11104 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11105 arg1
= unwrap_value (arg1
);
11106 return ada_to_fixed_value (arg1
);
11110 /* The value is not supposed to be used. This is here to make it
11111 easier to accommodate expressions that contain types. */
11113 if (noside
== EVAL_SKIP
)
11115 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11116 return allocate_value (exp
->elts
[pc
+ 1].type
);
11118 error (_("Attempt to use a type name as an expression"));
11123 case OP_DISCRETE_RANGE
:
11124 case OP_POSITIONAL
:
11126 if (noside
== EVAL_NORMAL
)
11130 error (_("Undefined name, ambiguous name, or renaming used in "
11131 "component association: %s."), &exp
->elts
[pc
+2].string
);
11133 error (_("Aggregates only allowed on the right of an assignment"));
11135 internal_error (__FILE__
, __LINE__
,
11136 _("aggregate apparently mangled"));
11139 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11141 for (tem
= 0; tem
< nargs
; tem
+= 1)
11142 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11147 return eval_skip_value (exp
);
11153 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11154 type name that encodes the 'small and 'delta information.
11155 Otherwise, return NULL. */
11157 static const char *
11158 gnat_encoded_fixed_point_type_info (struct type
*type
)
11160 const char *name
= ada_type_name (type
);
11161 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11163 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11165 const char *tail
= strstr (name
, "___XF_");
11172 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11173 return gnat_encoded_fixed_point_type_info (TYPE_TARGET_TYPE (type
));
11178 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11181 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11183 return gnat_encoded_fixed_point_type_info (type
) != NULL
;
11186 /* Return non-zero iff TYPE represents a System.Address type. */
11189 ada_is_system_address_type (struct type
*type
)
11191 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11194 /* Assuming that TYPE is the representation of an Ada fixed-point
11195 type, return the target floating-point type to be used to represent
11196 of this type during internal computation. */
11198 static struct type
*
11199 ada_scaling_type (struct type
*type
)
11201 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11204 /* Assuming that TYPE is the representation of an Ada fixed-point
11205 type, return its delta, or NULL if the type is malformed and the
11206 delta cannot be determined. */
11209 gnat_encoded_fixed_point_delta (struct type
*type
)
11211 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11212 struct type
*scale_type
= ada_scaling_type (type
);
11214 long long num
, den
;
11216 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11219 return value_binop (value_from_longest (scale_type
, num
),
11220 value_from_longest (scale_type
, den
), BINOP_DIV
);
11223 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11224 the scaling factor ('SMALL value) associated with the type. */
11227 gnat_encoded_fixed_point_scaling_factor (struct type
*type
)
11229 const char *encoding
= gnat_encoded_fixed_point_type_info (type
);
11230 struct type
*scale_type
= ada_scaling_type (type
);
11232 long long num0
, den0
, num1
, den1
;
11235 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11236 &num0
, &den0
, &num1
, &den1
);
11239 return value_from_longest (scale_type
, 1);
11241 return value_binop (value_from_longest (scale_type
, num1
),
11242 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11244 return value_binop (value_from_longest (scale_type
, num0
),
11245 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11252 /* Scan STR beginning at position K for a discriminant name, and
11253 return the value of that discriminant field of DVAL in *PX. If
11254 PNEW_K is not null, put the position of the character beyond the
11255 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11256 not alter *PX and *PNEW_K if unsuccessful. */
11259 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11262 static char *bound_buffer
= NULL
;
11263 static size_t bound_buffer_len
= 0;
11264 const char *pstart
, *pend
, *bound
;
11265 struct value
*bound_val
;
11267 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11271 pend
= strstr (pstart
, "__");
11275 k
+= strlen (bound
);
11279 int len
= pend
- pstart
;
11281 /* Strip __ and beyond. */
11282 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11283 strncpy (bound_buffer
, pstart
, len
);
11284 bound_buffer
[len
] = '\0';
11286 bound
= bound_buffer
;
11290 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11291 if (bound_val
== NULL
)
11294 *px
= value_as_long (bound_val
);
11295 if (pnew_k
!= NULL
)
11300 /* Value of variable named NAME. Only exact matches are considered.
11301 If no such variable found, then if ERR_MSG is null, returns 0, and
11302 otherwise causes an error with message ERR_MSG. */
11304 static struct value
*
11305 get_var_value (const char *name
, const char *err_msg
)
11307 std::string quoted_name
= add_angle_brackets (name
);
11309 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11311 std::vector
<struct block_symbol
> syms
;
11312 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11313 get_selected_block (0),
11314 VAR_DOMAIN
, &syms
, 1);
11318 if (err_msg
== NULL
)
11321 error (("%s"), err_msg
);
11324 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11327 /* Value of integer variable named NAME in the current environment.
11328 If no such variable is found, returns false. Otherwise, sets VALUE
11329 to the variable's value and returns true. */
11332 get_int_var_value (const char *name
, LONGEST
&value
)
11334 struct value
*var_val
= get_var_value (name
, 0);
11339 value
= value_as_long (var_val
);
11344 /* Return a range type whose base type is that of the range type named
11345 NAME in the current environment, and whose bounds are calculated
11346 from NAME according to the GNAT range encoding conventions.
11347 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11348 corresponding range type from debug information; fall back to using it
11349 if symbol lookup fails. If a new type must be created, allocate it
11350 like ORIG_TYPE was. The bounds information, in general, is encoded
11351 in NAME, the base type given in the named range type. */
11353 static struct type
*
11354 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11357 struct type
*base_type
;
11358 const char *subtype_info
;
11360 gdb_assert (raw_type
!= NULL
);
11361 gdb_assert (raw_type
->name () != NULL
);
11363 if (raw_type
->code () == TYPE_CODE_RANGE
)
11364 base_type
= TYPE_TARGET_TYPE (raw_type
);
11366 base_type
= raw_type
;
11368 name
= raw_type
->name ();
11369 subtype_info
= strstr (name
, "___XD");
11370 if (subtype_info
== NULL
)
11372 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11373 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11375 if (L
< INT_MIN
|| U
> INT_MAX
)
11378 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11383 static char *name_buf
= NULL
;
11384 static size_t name_len
= 0;
11385 int prefix_len
= subtype_info
- name
;
11388 const char *bounds_str
;
11391 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11392 strncpy (name_buf
, name
, prefix_len
);
11393 name_buf
[prefix_len
] = '\0';
11396 bounds_str
= strchr (subtype_info
, '_');
11399 if (*subtype_info
== 'L')
11401 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11402 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11404 if (bounds_str
[n
] == '_')
11406 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11412 strcpy (name_buf
+ prefix_len
, "___L");
11413 if (!get_int_var_value (name_buf
, L
))
11415 lim_warning (_("Unknown lower bound, using 1."));
11420 if (*subtype_info
== 'U')
11422 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11423 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11428 strcpy (name_buf
+ prefix_len
, "___U");
11429 if (!get_int_var_value (name_buf
, U
))
11431 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11436 type
= create_static_range_type (alloc_type_copy (raw_type
),
11438 /* create_static_range_type alters the resulting type's length
11439 to match the size of the base_type, which is not what we want.
11440 Set it back to the original range type's length. */
11441 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11442 type
->set_name (name
);
11447 /* True iff NAME is the name of a range type. */
11450 ada_is_range_type_name (const char *name
)
11452 return (name
!= NULL
&& strstr (name
, "___XD"));
11456 /* Modular types */
11458 /* True iff TYPE is an Ada modular type. */
11461 ada_is_modular_type (struct type
*type
)
11463 struct type
*subranged_type
= get_base_type (type
);
11465 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11466 && subranged_type
->code () == TYPE_CODE_INT
11467 && subranged_type
->is_unsigned ());
11470 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11473 ada_modulus (struct type
*type
)
11475 const dynamic_prop
&high
= type
->bounds ()->high
;
11477 if (high
.kind () == PROP_CONST
)
11478 return (ULONGEST
) high
.const_val () + 1;
11480 /* If TYPE is unresolved, the high bound might be a location list. Return
11481 0, for lack of a better value to return. */
11486 /* Ada exception catchpoint support:
11487 ---------------------------------
11489 We support 3 kinds of exception catchpoints:
11490 . catchpoints on Ada exceptions
11491 . catchpoints on unhandled Ada exceptions
11492 . catchpoints on failed assertions
11494 Exceptions raised during failed assertions, or unhandled exceptions
11495 could perfectly be caught with the general catchpoint on Ada exceptions.
11496 However, we can easily differentiate these two special cases, and having
11497 the option to distinguish these two cases from the rest can be useful
11498 to zero-in on certain situations.
11500 Exception catchpoints are a specialized form of breakpoint,
11501 since they rely on inserting breakpoints inside known routines
11502 of the GNAT runtime. The implementation therefore uses a standard
11503 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11506 Support in the runtime for exception catchpoints have been changed
11507 a few times already, and these changes affect the implementation
11508 of these catchpoints. In order to be able to support several
11509 variants of the runtime, we use a sniffer that will determine
11510 the runtime variant used by the program being debugged. */
11512 /* Ada's standard exceptions.
11514 The Ada 83 standard also defined Numeric_Error. But there so many
11515 situations where it was unclear from the Ada 83 Reference Manual
11516 (RM) whether Constraint_Error or Numeric_Error should be raised,
11517 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11518 Interpretation saying that anytime the RM says that Numeric_Error
11519 should be raised, the implementation may raise Constraint_Error.
11520 Ada 95 went one step further and pretty much removed Numeric_Error
11521 from the list of standard exceptions (it made it a renaming of
11522 Constraint_Error, to help preserve compatibility when compiling
11523 an Ada83 compiler). As such, we do not include Numeric_Error from
11524 this list of standard exceptions. */
11526 static const char * const standard_exc
[] = {
11527 "constraint_error",
11533 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11535 /* A structure that describes how to support exception catchpoints
11536 for a given executable. */
11538 struct exception_support_info
11540 /* The name of the symbol to break on in order to insert
11541 a catchpoint on exceptions. */
11542 const char *catch_exception_sym
;
11544 /* The name of the symbol to break on in order to insert
11545 a catchpoint on unhandled exceptions. */
11546 const char *catch_exception_unhandled_sym
;
11548 /* The name of the symbol to break on in order to insert
11549 a catchpoint on failed assertions. */
11550 const char *catch_assert_sym
;
11552 /* The name of the symbol to break on in order to insert
11553 a catchpoint on exception handling. */
11554 const char *catch_handlers_sym
;
11556 /* Assuming that the inferior just triggered an unhandled exception
11557 catchpoint, this function is responsible for returning the address
11558 in inferior memory where the name of that exception is stored.
11559 Return zero if the address could not be computed. */
11560 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11563 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11564 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11566 /* The following exception support info structure describes how to
11567 implement exception catchpoints with the latest version of the
11568 Ada runtime (as of 2019-08-??). */
11570 static const struct exception_support_info default_exception_support_info
=
11572 "__gnat_debug_raise_exception", /* catch_exception_sym */
11573 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11574 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11575 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11576 ada_unhandled_exception_name_addr
11579 /* The following exception support info structure describes how to
11580 implement exception catchpoints with an earlier version of the
11581 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11583 static const struct exception_support_info exception_support_info_v0
=
11585 "__gnat_debug_raise_exception", /* catch_exception_sym */
11586 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11587 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11588 "__gnat_begin_handler", /* catch_handlers_sym */
11589 ada_unhandled_exception_name_addr
11592 /* The following exception support info structure describes how to
11593 implement exception catchpoints with a slightly older version
11594 of the Ada runtime. */
11596 static const struct exception_support_info exception_support_info_fallback
=
11598 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11599 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11600 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11601 "__gnat_begin_handler", /* catch_handlers_sym */
11602 ada_unhandled_exception_name_addr_from_raise
11605 /* Return nonzero if we can detect the exception support routines
11606 described in EINFO.
11608 This function errors out if an abnormal situation is detected
11609 (for instance, if we find the exception support routines, but
11610 that support is found to be incomplete). */
11613 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11615 struct symbol
*sym
;
11617 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11618 that should be compiled with debugging information. As a result, we
11619 expect to find that symbol in the symtabs. */
11621 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11624 /* Perhaps we did not find our symbol because the Ada runtime was
11625 compiled without debugging info, or simply stripped of it.
11626 It happens on some GNU/Linux distributions for instance, where
11627 users have to install a separate debug package in order to get
11628 the runtime's debugging info. In that situation, let the user
11629 know why we cannot insert an Ada exception catchpoint.
11631 Note: Just for the purpose of inserting our Ada exception
11632 catchpoint, we could rely purely on the associated minimal symbol.
11633 But we would be operating in degraded mode anyway, since we are
11634 still lacking the debugging info needed later on to extract
11635 the name of the exception being raised (this name is printed in
11636 the catchpoint message, and is also used when trying to catch
11637 a specific exception). We do not handle this case for now. */
11638 struct bound_minimal_symbol msym
11639 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11641 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11642 error (_("Your Ada runtime appears to be missing some debugging "
11643 "information.\nCannot insert Ada exception catchpoint "
11644 "in this configuration."));
11649 /* Make sure that the symbol we found corresponds to a function. */
11651 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11653 error (_("Symbol \"%s\" is not a function (class = %d)"),
11654 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11658 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11661 struct bound_minimal_symbol msym
11662 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11664 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11665 error (_("Your Ada runtime appears to be missing some debugging "
11666 "information.\nCannot insert Ada exception catchpoint "
11667 "in this configuration."));
11672 /* Make sure that the symbol we found corresponds to a function. */
11674 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11676 error (_("Symbol \"%s\" is not a function (class = %d)"),
11677 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11684 /* Inspect the Ada runtime and determine which exception info structure
11685 should be used to provide support for exception catchpoints.
11687 This function will always set the per-inferior exception_info,
11688 or raise an error. */
11691 ada_exception_support_info_sniffer (void)
11693 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11695 /* If the exception info is already known, then no need to recompute it. */
11696 if (data
->exception_info
!= NULL
)
11699 /* Check the latest (default) exception support info. */
11700 if (ada_has_this_exception_support (&default_exception_support_info
))
11702 data
->exception_info
= &default_exception_support_info
;
11706 /* Try the v0 exception suport info. */
11707 if (ada_has_this_exception_support (&exception_support_info_v0
))
11709 data
->exception_info
= &exception_support_info_v0
;
11713 /* Try our fallback exception suport info. */
11714 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11716 data
->exception_info
= &exception_support_info_fallback
;
11720 /* Sometimes, it is normal for us to not be able to find the routine
11721 we are looking for. This happens when the program is linked with
11722 the shared version of the GNAT runtime, and the program has not been
11723 started yet. Inform the user of these two possible causes if
11726 if (ada_update_initial_language (language_unknown
) != language_ada
)
11727 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11729 /* If the symbol does not exist, then check that the program is
11730 already started, to make sure that shared libraries have been
11731 loaded. If it is not started, this may mean that the symbol is
11732 in a shared library. */
11734 if (inferior_ptid
.pid () == 0)
11735 error (_("Unable to insert catchpoint. Try to start the program first."));
11737 /* At this point, we know that we are debugging an Ada program and
11738 that the inferior has been started, but we still are not able to
11739 find the run-time symbols. That can mean that we are in
11740 configurable run time mode, or that a-except as been optimized
11741 out by the linker... In any case, at this point it is not worth
11742 supporting this feature. */
11744 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11747 /* True iff FRAME is very likely to be that of a function that is
11748 part of the runtime system. This is all very heuristic, but is
11749 intended to be used as advice as to what frames are uninteresting
11753 is_known_support_routine (struct frame_info
*frame
)
11755 enum language func_lang
;
11757 const char *fullname
;
11759 /* If this code does not have any debugging information (no symtab),
11760 This cannot be any user code. */
11762 symtab_and_line sal
= find_frame_sal (frame
);
11763 if (sal
.symtab
== NULL
)
11766 /* If there is a symtab, but the associated source file cannot be
11767 located, then assume this is not user code: Selecting a frame
11768 for which we cannot display the code would not be very helpful
11769 for the user. This should also take care of case such as VxWorks
11770 where the kernel has some debugging info provided for a few units. */
11772 fullname
= symtab_to_fullname (sal
.symtab
);
11773 if (access (fullname
, R_OK
) != 0)
11776 /* Check the unit filename against the Ada runtime file naming.
11777 We also check the name of the objfile against the name of some
11778 known system libraries that sometimes come with debugging info
11781 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11783 re_comp (known_runtime_file_name_patterns
[i
]);
11784 if (re_exec (lbasename (sal
.symtab
->filename
)))
11786 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11787 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11791 /* Check whether the function is a GNAT-generated entity. */
11793 gdb::unique_xmalloc_ptr
<char> func_name
11794 = find_frame_funname (frame
, &func_lang
, NULL
);
11795 if (func_name
== NULL
)
11798 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11800 re_comp (known_auxiliary_function_name_patterns
[i
]);
11801 if (re_exec (func_name
.get ()))
11808 /* Find the first frame that contains debugging information and that is not
11809 part of the Ada run-time, starting from FI and moving upward. */
11812 ada_find_printable_frame (struct frame_info
*fi
)
11814 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11816 if (!is_known_support_routine (fi
))
11825 /* Assuming that the inferior just triggered an unhandled exception
11826 catchpoint, return the address in inferior memory where the name
11827 of the exception is stored.
11829 Return zero if the address could not be computed. */
11832 ada_unhandled_exception_name_addr (void)
11834 return parse_and_eval_address ("e.full_name");
11837 /* Same as ada_unhandled_exception_name_addr, except that this function
11838 should be used when the inferior uses an older version of the runtime,
11839 where the exception name needs to be extracted from a specific frame
11840 several frames up in the callstack. */
11843 ada_unhandled_exception_name_addr_from_raise (void)
11846 struct frame_info
*fi
;
11847 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11849 /* To determine the name of this exception, we need to select
11850 the frame corresponding to RAISE_SYM_NAME. This frame is
11851 at least 3 levels up, so we simply skip the first 3 frames
11852 without checking the name of their associated function. */
11853 fi
= get_current_frame ();
11854 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11856 fi
= get_prev_frame (fi
);
11860 enum language func_lang
;
11862 gdb::unique_xmalloc_ptr
<char> func_name
11863 = find_frame_funname (fi
, &func_lang
, NULL
);
11864 if (func_name
!= NULL
)
11866 if (strcmp (func_name
.get (),
11867 data
->exception_info
->catch_exception_sym
) == 0)
11868 break; /* We found the frame we were looking for... */
11870 fi
= get_prev_frame (fi
);
11877 return parse_and_eval_address ("id.full_name");
11880 /* Assuming the inferior just triggered an Ada exception catchpoint
11881 (of any type), return the address in inferior memory where the name
11882 of the exception is stored, if applicable.
11884 Assumes the selected frame is the current frame.
11886 Return zero if the address could not be computed, or if not relevant. */
11889 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11890 struct breakpoint
*b
)
11892 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11896 case ada_catch_exception
:
11897 return (parse_and_eval_address ("e.full_name"));
11900 case ada_catch_exception_unhandled
:
11901 return data
->exception_info
->unhandled_exception_name_addr ();
11904 case ada_catch_handlers
:
11905 return 0; /* The runtimes does not provide access to the exception
11909 case ada_catch_assert
:
11910 return 0; /* Exception name is not relevant in this case. */
11914 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11918 return 0; /* Should never be reached. */
11921 /* Assuming the inferior is stopped at an exception catchpoint,
11922 return the message which was associated to the exception, if
11923 available. Return NULL if the message could not be retrieved.
11925 Note: The exception message can be associated to an exception
11926 either through the use of the Raise_Exception function, or
11927 more simply (Ada 2005 and later), via:
11929 raise Exception_Name with "exception message";
11933 static gdb::unique_xmalloc_ptr
<char>
11934 ada_exception_message_1 (void)
11936 struct value
*e_msg_val
;
11939 /* For runtimes that support this feature, the exception message
11940 is passed as an unbounded string argument called "message". */
11941 e_msg_val
= parse_and_eval ("message");
11942 if (e_msg_val
== NULL
)
11943 return NULL
; /* Exception message not supported. */
11945 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11946 gdb_assert (e_msg_val
!= NULL
);
11947 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11949 /* If the message string is empty, then treat it as if there was
11950 no exception message. */
11951 if (e_msg_len
<= 0)
11954 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
11955 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
11957 e_msg
.get ()[e_msg_len
] = '\0';
11962 /* Same as ada_exception_message_1, except that all exceptions are
11963 contained here (returning NULL instead). */
11965 static gdb::unique_xmalloc_ptr
<char>
11966 ada_exception_message (void)
11968 gdb::unique_xmalloc_ptr
<char> e_msg
;
11972 e_msg
= ada_exception_message_1 ();
11974 catch (const gdb_exception_error
&e
)
11976 e_msg
.reset (nullptr);
11982 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11983 any error that ada_exception_name_addr_1 might cause to be thrown.
11984 When an error is intercepted, a warning with the error message is printed,
11985 and zero is returned. */
11988 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11989 struct breakpoint
*b
)
11991 CORE_ADDR result
= 0;
11995 result
= ada_exception_name_addr_1 (ex
, b
);
11998 catch (const gdb_exception_error
&e
)
12000 warning (_("failed to get exception name: %s"), e
.what ());
12007 static std::string ada_exception_catchpoint_cond_string
12008 (const char *excep_string
,
12009 enum ada_exception_catchpoint_kind ex
);
12011 /* Ada catchpoints.
12013 In the case of catchpoints on Ada exceptions, the catchpoint will
12014 stop the target on every exception the program throws. When a user
12015 specifies the name of a specific exception, we translate this
12016 request into a condition expression (in text form), and then parse
12017 it into an expression stored in each of the catchpoint's locations.
12018 We then use this condition to check whether the exception that was
12019 raised is the one the user is interested in. If not, then the
12020 target is resumed again. We store the name of the requested
12021 exception, in order to be able to re-set the condition expression
12022 when symbols change. */
12024 /* An instance of this type is used to represent an Ada catchpoint
12025 breakpoint location. */
12027 class ada_catchpoint_location
: public bp_location
12030 ada_catchpoint_location (breakpoint
*owner
)
12031 : bp_location (owner
, bp_loc_software_breakpoint
)
12034 /* The condition that checks whether the exception that was raised
12035 is the specific exception the user specified on catchpoint
12037 expression_up excep_cond_expr
;
12040 /* An instance of this type is used to represent an Ada catchpoint. */
12042 struct ada_catchpoint
: public breakpoint
12044 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12049 /* The name of the specific exception the user specified. */
12050 std::string excep_string
;
12052 /* What kind of catchpoint this is. */
12053 enum ada_exception_catchpoint_kind m_kind
;
12056 /* Parse the exception condition string in the context of each of the
12057 catchpoint's locations, and store them for later evaluation. */
12060 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12061 enum ada_exception_catchpoint_kind ex
)
12063 struct bp_location
*bl
;
12065 /* Nothing to do if there's no specific exception to catch. */
12066 if (c
->excep_string
.empty ())
12069 /* Same if there are no locations... */
12070 if (c
->loc
== NULL
)
12073 /* Compute the condition expression in text form, from the specific
12074 expection we want to catch. */
12075 std::string cond_string
12076 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12078 /* Iterate over all the catchpoint's locations, and parse an
12079 expression for each. */
12080 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12082 struct ada_catchpoint_location
*ada_loc
12083 = (struct ada_catchpoint_location
*) bl
;
12086 if (!bl
->shlib_disabled
)
12090 s
= cond_string
.c_str ();
12093 exp
= parse_exp_1 (&s
, bl
->address
,
12094 block_for_pc (bl
->address
),
12097 catch (const gdb_exception_error
&e
)
12099 warning (_("failed to reevaluate internal exception condition "
12100 "for catchpoint %d: %s"),
12101 c
->number
, e
.what ());
12105 ada_loc
->excep_cond_expr
= std::move (exp
);
12109 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12110 structure for all exception catchpoint kinds. */
12112 static struct bp_location
*
12113 allocate_location_exception (struct breakpoint
*self
)
12115 return new ada_catchpoint_location (self
);
12118 /* Implement the RE_SET method in the breakpoint_ops structure for all
12119 exception catchpoint kinds. */
12122 re_set_exception (struct breakpoint
*b
)
12124 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12126 /* Call the base class's method. This updates the catchpoint's
12128 bkpt_breakpoint_ops
.re_set (b
);
12130 /* Reparse the exception conditional expressions. One for each
12132 create_excep_cond_exprs (c
, c
->m_kind
);
12135 /* Returns true if we should stop for this breakpoint hit. If the
12136 user specified a specific exception, we only want to cause a stop
12137 if the program thrown that exception. */
12140 should_stop_exception (const struct bp_location
*bl
)
12142 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12143 const struct ada_catchpoint_location
*ada_loc
12144 = (const struct ada_catchpoint_location
*) bl
;
12147 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12148 if (c
->m_kind
== ada_catch_assert
)
12149 clear_internalvar (var
);
12156 if (c
->m_kind
== ada_catch_handlers
)
12157 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12158 ".all.occurrence.id");
12162 struct value
*exc
= parse_and_eval (expr
);
12163 set_internalvar (var
, exc
);
12165 catch (const gdb_exception_error
&ex
)
12167 clear_internalvar (var
);
12171 /* With no specific exception, should always stop. */
12172 if (c
->excep_string
.empty ())
12175 if (ada_loc
->excep_cond_expr
== NULL
)
12177 /* We will have a NULL expression if back when we were creating
12178 the expressions, this location's had failed to parse. */
12185 struct value
*mark
;
12187 mark
= value_mark ();
12188 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12189 value_free_to_mark (mark
);
12191 catch (const gdb_exception
&ex
)
12193 exception_fprintf (gdb_stderr
, ex
,
12194 _("Error in testing exception condition:\n"));
12200 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12201 for all exception catchpoint kinds. */
12204 check_status_exception (bpstat bs
)
12206 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12209 /* Implement the PRINT_IT method in the breakpoint_ops structure
12210 for all exception catchpoint kinds. */
12212 static enum print_stop_action
12213 print_it_exception (bpstat bs
)
12215 struct ui_out
*uiout
= current_uiout
;
12216 struct breakpoint
*b
= bs
->breakpoint_at
;
12218 annotate_catchpoint (b
->number
);
12220 if (uiout
->is_mi_like_p ())
12222 uiout
->field_string ("reason",
12223 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12224 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12227 uiout
->text (b
->disposition
== disp_del
12228 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12229 uiout
->field_signed ("bkptno", b
->number
);
12230 uiout
->text (", ");
12232 /* ada_exception_name_addr relies on the selected frame being the
12233 current frame. Need to do this here because this function may be
12234 called more than once when printing a stop, and below, we'll
12235 select the first frame past the Ada run-time (see
12236 ada_find_printable_frame). */
12237 select_frame (get_current_frame ());
12239 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12242 case ada_catch_exception
:
12243 case ada_catch_exception_unhandled
:
12244 case ada_catch_handlers
:
12246 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12247 char exception_name
[256];
12251 read_memory (addr
, (gdb_byte
*) exception_name
,
12252 sizeof (exception_name
) - 1);
12253 exception_name
[sizeof (exception_name
) - 1] = '\0';
12257 /* For some reason, we were unable to read the exception
12258 name. This could happen if the Runtime was compiled
12259 without debugging info, for instance. In that case,
12260 just replace the exception name by the generic string
12261 "exception" - it will read as "an exception" in the
12262 notification we are about to print. */
12263 memcpy (exception_name
, "exception", sizeof ("exception"));
12265 /* In the case of unhandled exception breakpoints, we print
12266 the exception name as "unhandled EXCEPTION_NAME", to make
12267 it clearer to the user which kind of catchpoint just got
12268 hit. We used ui_out_text to make sure that this extra
12269 info does not pollute the exception name in the MI case. */
12270 if (c
->m_kind
== ada_catch_exception_unhandled
)
12271 uiout
->text ("unhandled ");
12272 uiout
->field_string ("exception-name", exception_name
);
12275 case ada_catch_assert
:
12276 /* In this case, the name of the exception is not really
12277 important. Just print "failed assertion" to make it clearer
12278 that his program just hit an assertion-failure catchpoint.
12279 We used ui_out_text because this info does not belong in
12281 uiout
->text ("failed assertion");
12285 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12286 if (exception_message
!= NULL
)
12288 uiout
->text (" (");
12289 uiout
->field_string ("exception-message", exception_message
.get ());
12293 uiout
->text (" at ");
12294 ada_find_printable_frame (get_current_frame ());
12296 return PRINT_SRC_AND_LOC
;
12299 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12300 for all exception catchpoint kinds. */
12303 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12305 struct ui_out
*uiout
= current_uiout
;
12306 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12307 struct value_print_options opts
;
12309 get_user_print_options (&opts
);
12311 if (opts
.addressprint
)
12312 uiout
->field_skip ("addr");
12314 annotate_field (5);
12317 case ada_catch_exception
:
12318 if (!c
->excep_string
.empty ())
12320 std::string msg
= string_printf (_("`%s' Ada exception"),
12321 c
->excep_string
.c_str ());
12323 uiout
->field_string ("what", msg
);
12326 uiout
->field_string ("what", "all Ada exceptions");
12330 case ada_catch_exception_unhandled
:
12331 uiout
->field_string ("what", "unhandled Ada exceptions");
12334 case ada_catch_handlers
:
12335 if (!c
->excep_string
.empty ())
12337 uiout
->field_fmt ("what",
12338 _("`%s' Ada exception handlers"),
12339 c
->excep_string
.c_str ());
12342 uiout
->field_string ("what", "all Ada exceptions handlers");
12345 case ada_catch_assert
:
12346 uiout
->field_string ("what", "failed Ada assertions");
12350 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12355 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12356 for all exception catchpoint kinds. */
12359 print_mention_exception (struct breakpoint
*b
)
12361 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12362 struct ui_out
*uiout
= current_uiout
;
12364 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12365 : _("Catchpoint "));
12366 uiout
->field_signed ("bkptno", b
->number
);
12367 uiout
->text (": ");
12371 case ada_catch_exception
:
12372 if (!c
->excep_string
.empty ())
12374 std::string info
= string_printf (_("`%s' Ada exception"),
12375 c
->excep_string
.c_str ());
12376 uiout
->text (info
.c_str ());
12379 uiout
->text (_("all Ada exceptions"));
12382 case ada_catch_exception_unhandled
:
12383 uiout
->text (_("unhandled Ada exceptions"));
12386 case ada_catch_handlers
:
12387 if (!c
->excep_string
.empty ())
12390 = string_printf (_("`%s' Ada exception handlers"),
12391 c
->excep_string
.c_str ());
12392 uiout
->text (info
.c_str ());
12395 uiout
->text (_("all Ada exceptions handlers"));
12398 case ada_catch_assert
:
12399 uiout
->text (_("failed Ada assertions"));
12403 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12408 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12409 for all exception catchpoint kinds. */
12412 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12414 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12418 case ada_catch_exception
:
12419 fprintf_filtered (fp
, "catch exception");
12420 if (!c
->excep_string
.empty ())
12421 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12424 case ada_catch_exception_unhandled
:
12425 fprintf_filtered (fp
, "catch exception unhandled");
12428 case ada_catch_handlers
:
12429 fprintf_filtered (fp
, "catch handlers");
12432 case ada_catch_assert
:
12433 fprintf_filtered (fp
, "catch assert");
12437 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12439 print_recreate_thread (b
, fp
);
12442 /* Virtual tables for various breakpoint types. */
12443 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12444 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12445 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12446 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12448 /* See ada-lang.h. */
12451 is_ada_exception_catchpoint (breakpoint
*bp
)
12453 return (bp
->ops
== &catch_exception_breakpoint_ops
12454 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12455 || bp
->ops
== &catch_assert_breakpoint_ops
12456 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12459 /* Split the arguments specified in a "catch exception" command.
12460 Set EX to the appropriate catchpoint type.
12461 Set EXCEP_STRING to the name of the specific exception if
12462 specified by the user.
12463 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12464 "catch handlers" command. False otherwise.
12465 If a condition is found at the end of the arguments, the condition
12466 expression is stored in COND_STRING (memory must be deallocated
12467 after use). Otherwise COND_STRING is set to NULL. */
12470 catch_ada_exception_command_split (const char *args
,
12471 bool is_catch_handlers_cmd
,
12472 enum ada_exception_catchpoint_kind
*ex
,
12473 std::string
*excep_string
,
12474 std::string
*cond_string
)
12476 std::string exception_name
;
12478 exception_name
= extract_arg (&args
);
12479 if (exception_name
== "if")
12481 /* This is not an exception name; this is the start of a condition
12482 expression for a catchpoint on all exceptions. So, "un-get"
12483 this token, and set exception_name to NULL. */
12484 exception_name
.clear ();
12488 /* Check to see if we have a condition. */
12490 args
= skip_spaces (args
);
12491 if (startswith (args
, "if")
12492 && (isspace (args
[2]) || args
[2] == '\0'))
12495 args
= skip_spaces (args
);
12497 if (args
[0] == '\0')
12498 error (_("Condition missing after `if' keyword"));
12499 *cond_string
= args
;
12501 args
+= strlen (args
);
12504 /* Check that we do not have any more arguments. Anything else
12507 if (args
[0] != '\0')
12508 error (_("Junk at end of expression"));
12510 if (is_catch_handlers_cmd
)
12512 /* Catch handling of exceptions. */
12513 *ex
= ada_catch_handlers
;
12514 *excep_string
= exception_name
;
12516 else if (exception_name
.empty ())
12518 /* Catch all exceptions. */
12519 *ex
= ada_catch_exception
;
12520 excep_string
->clear ();
12522 else if (exception_name
== "unhandled")
12524 /* Catch unhandled exceptions. */
12525 *ex
= ada_catch_exception_unhandled
;
12526 excep_string
->clear ();
12530 /* Catch a specific exception. */
12531 *ex
= ada_catch_exception
;
12532 *excep_string
= exception_name
;
12536 /* Return the name of the symbol on which we should break in order to
12537 implement a catchpoint of the EX kind. */
12539 static const char *
12540 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12542 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12544 gdb_assert (data
->exception_info
!= NULL
);
12548 case ada_catch_exception
:
12549 return (data
->exception_info
->catch_exception_sym
);
12551 case ada_catch_exception_unhandled
:
12552 return (data
->exception_info
->catch_exception_unhandled_sym
);
12554 case ada_catch_assert
:
12555 return (data
->exception_info
->catch_assert_sym
);
12557 case ada_catch_handlers
:
12558 return (data
->exception_info
->catch_handlers_sym
);
12561 internal_error (__FILE__
, __LINE__
,
12562 _("unexpected catchpoint kind (%d)"), ex
);
12566 /* Return the breakpoint ops "virtual table" used for catchpoints
12569 static const struct breakpoint_ops
*
12570 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12574 case ada_catch_exception
:
12575 return (&catch_exception_breakpoint_ops
);
12577 case ada_catch_exception_unhandled
:
12578 return (&catch_exception_unhandled_breakpoint_ops
);
12580 case ada_catch_assert
:
12581 return (&catch_assert_breakpoint_ops
);
12583 case ada_catch_handlers
:
12584 return (&catch_handlers_breakpoint_ops
);
12587 internal_error (__FILE__
, __LINE__
,
12588 _("unexpected catchpoint kind (%d)"), ex
);
12592 /* Return the condition that will be used to match the current exception
12593 being raised with the exception that the user wants to catch. This
12594 assumes that this condition is used when the inferior just triggered
12595 an exception catchpoint.
12596 EX: the type of catchpoints used for catching Ada exceptions. */
12599 ada_exception_catchpoint_cond_string (const char *excep_string
,
12600 enum ada_exception_catchpoint_kind ex
)
12603 bool is_standard_exc
= false;
12604 std::string result
;
12606 if (ex
== ada_catch_handlers
)
12608 /* For exception handlers catchpoints, the condition string does
12609 not use the same parameter as for the other exceptions. */
12610 result
= ("long_integer (GNAT_GCC_exception_Access"
12611 "(gcc_exception).all.occurrence.id)");
12614 result
= "long_integer (e)";
12616 /* The standard exceptions are a special case. They are defined in
12617 runtime units that have been compiled without debugging info; if
12618 EXCEP_STRING is the not-fully-qualified name of a standard
12619 exception (e.g. "constraint_error") then, during the evaluation
12620 of the condition expression, the symbol lookup on this name would
12621 *not* return this standard exception. The catchpoint condition
12622 may then be set only on user-defined exceptions which have the
12623 same not-fully-qualified name (e.g. my_package.constraint_error).
12625 To avoid this unexcepted behavior, these standard exceptions are
12626 systematically prefixed by "standard". This means that "catch
12627 exception constraint_error" is rewritten into "catch exception
12628 standard.constraint_error".
12630 If an exception named constraint_error is defined in another package of
12631 the inferior program, then the only way to specify this exception as a
12632 breakpoint condition is to use its fully-qualified named:
12633 e.g. my_package.constraint_error. */
12635 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12637 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12639 is_standard_exc
= true;
12646 if (is_standard_exc
)
12647 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12649 string_appendf (result
, "long_integer (&%s)", excep_string
);
12654 /* Return the symtab_and_line that should be used to insert an exception
12655 catchpoint of the TYPE kind.
12657 ADDR_STRING returns the name of the function where the real
12658 breakpoint that implements the catchpoints is set, depending on the
12659 type of catchpoint we need to create. */
12661 static struct symtab_and_line
12662 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12663 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12665 const char *sym_name
;
12666 struct symbol
*sym
;
12668 /* First, find out which exception support info to use. */
12669 ada_exception_support_info_sniffer ();
12671 /* Then lookup the function on which we will break in order to catch
12672 the Ada exceptions requested by the user. */
12673 sym_name
= ada_exception_sym_name (ex
);
12674 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12677 error (_("Catchpoint symbol not found: %s"), sym_name
);
12679 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12680 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12682 /* Set ADDR_STRING. */
12683 *addr_string
= sym_name
;
12686 *ops
= ada_exception_breakpoint_ops (ex
);
12688 return find_function_start_sal (sym
, 1);
12691 /* Create an Ada exception catchpoint.
12693 EX_KIND is the kind of exception catchpoint to be created.
12695 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12696 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12697 of the exception to which this catchpoint applies.
12699 COND_STRING, if not empty, is the catchpoint condition.
12701 TEMPFLAG, if nonzero, means that the underlying breakpoint
12702 should be temporary.
12704 FROM_TTY is the usual argument passed to all commands implementations. */
12707 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12708 enum ada_exception_catchpoint_kind ex_kind
,
12709 const std::string
&excep_string
,
12710 const std::string
&cond_string
,
12715 std::string addr_string
;
12716 const struct breakpoint_ops
*ops
= NULL
;
12717 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12719 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12720 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12721 ops
, tempflag
, disabled
, from_tty
);
12722 c
->excep_string
= excep_string
;
12723 create_excep_cond_exprs (c
.get (), ex_kind
);
12724 if (!cond_string
.empty ())
12725 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12726 install_breakpoint (0, std::move (c
), 1);
12729 /* Implement the "catch exception" command. */
12732 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12733 struct cmd_list_element
*command
)
12735 const char *arg
= arg_entry
;
12736 struct gdbarch
*gdbarch
= get_current_arch ();
12738 enum ada_exception_catchpoint_kind ex_kind
;
12739 std::string excep_string
;
12740 std::string cond_string
;
12742 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12746 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12748 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12749 excep_string
, cond_string
,
12750 tempflag
, 1 /* enabled */,
12754 /* Implement the "catch handlers" command. */
12757 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12758 struct cmd_list_element
*command
)
12760 const char *arg
= arg_entry
;
12761 struct gdbarch
*gdbarch
= get_current_arch ();
12763 enum ada_exception_catchpoint_kind ex_kind
;
12764 std::string excep_string
;
12765 std::string cond_string
;
12767 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12771 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12773 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12774 excep_string
, cond_string
,
12775 tempflag
, 1 /* enabled */,
12779 /* Completion function for the Ada "catch" commands. */
12782 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12783 const char *text
, const char *word
)
12785 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12787 for (const ada_exc_info
&info
: exceptions
)
12789 if (startswith (info
.name
, word
))
12790 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12794 /* Split the arguments specified in a "catch assert" command.
12796 ARGS contains the command's arguments (or the empty string if
12797 no arguments were passed).
12799 If ARGS contains a condition, set COND_STRING to that condition
12800 (the memory needs to be deallocated after use). */
12803 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12805 args
= skip_spaces (args
);
12807 /* Check whether a condition was provided. */
12808 if (startswith (args
, "if")
12809 && (isspace (args
[2]) || args
[2] == '\0'))
12812 args
= skip_spaces (args
);
12813 if (args
[0] == '\0')
12814 error (_("condition missing after `if' keyword"));
12815 cond_string
.assign (args
);
12818 /* Otherwise, there should be no other argument at the end of
12820 else if (args
[0] != '\0')
12821 error (_("Junk at end of arguments."));
12824 /* Implement the "catch assert" command. */
12827 catch_assert_command (const char *arg_entry
, int from_tty
,
12828 struct cmd_list_element
*command
)
12830 const char *arg
= arg_entry
;
12831 struct gdbarch
*gdbarch
= get_current_arch ();
12833 std::string cond_string
;
12835 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12839 catch_ada_assert_command_split (arg
, cond_string
);
12840 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12842 tempflag
, 1 /* enabled */,
12846 /* Return non-zero if the symbol SYM is an Ada exception object. */
12849 ada_is_exception_sym (struct symbol
*sym
)
12851 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12853 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12854 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12855 && SYMBOL_CLASS (sym
) != LOC_CONST
12856 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12857 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12860 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12861 Ada exception object. This matches all exceptions except the ones
12862 defined by the Ada language. */
12865 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12869 if (!ada_is_exception_sym (sym
))
12872 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12873 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12874 return 0; /* A standard exception. */
12876 /* Numeric_Error is also a standard exception, so exclude it.
12877 See the STANDARD_EXC description for more details as to why
12878 this exception is not listed in that array. */
12879 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12885 /* A helper function for std::sort, comparing two struct ada_exc_info
12888 The comparison is determined first by exception name, and then
12889 by exception address. */
12892 ada_exc_info::operator< (const ada_exc_info
&other
) const
12896 result
= strcmp (name
, other
.name
);
12899 if (result
== 0 && addr
< other
.addr
)
12905 ada_exc_info::operator== (const ada_exc_info
&other
) const
12907 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12910 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12911 routine, but keeping the first SKIP elements untouched.
12913 All duplicates are also removed. */
12916 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12919 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12920 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12921 exceptions
->end ());
12924 /* Add all exceptions defined by the Ada standard whose name match
12925 a regular expression.
12927 If PREG is not NULL, then this regexp_t object is used to
12928 perform the symbol name matching. Otherwise, no name-based
12929 filtering is performed.
12931 EXCEPTIONS is a vector of exceptions to which matching exceptions
12935 ada_add_standard_exceptions (compiled_regex
*preg
,
12936 std::vector
<ada_exc_info
> *exceptions
)
12940 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12943 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12945 struct bound_minimal_symbol msymbol
12946 = ada_lookup_simple_minsym (standard_exc
[i
]);
12948 if (msymbol
.minsym
!= NULL
)
12950 struct ada_exc_info info
12951 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12953 exceptions
->push_back (info
);
12959 /* Add all Ada exceptions defined locally and accessible from the given
12962 If PREG is not NULL, then this regexp_t object is used to
12963 perform the symbol name matching. Otherwise, no name-based
12964 filtering is performed.
12966 EXCEPTIONS is a vector of exceptions to which matching exceptions
12970 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12971 struct frame_info
*frame
,
12972 std::vector
<ada_exc_info
> *exceptions
)
12974 const struct block
*block
= get_frame_block (frame
, 0);
12978 struct block_iterator iter
;
12979 struct symbol
*sym
;
12981 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12983 switch (SYMBOL_CLASS (sym
))
12990 if (ada_is_exception_sym (sym
))
12992 struct ada_exc_info info
= {sym
->print_name (),
12993 SYMBOL_VALUE_ADDRESS (sym
)};
12995 exceptions
->push_back (info
);
12999 if (BLOCK_FUNCTION (block
) != NULL
)
13001 block
= BLOCK_SUPERBLOCK (block
);
13005 /* Return true if NAME matches PREG or if PREG is NULL. */
13008 name_matches_regex (const char *name
, compiled_regex
*preg
)
13010 return (preg
== NULL
13011 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13014 /* Add all exceptions defined globally whose name name match
13015 a regular expression, excluding standard exceptions.
13017 The reason we exclude standard exceptions is that they need
13018 to be handled separately: Standard exceptions are defined inside
13019 a runtime unit which is normally not compiled with debugging info,
13020 and thus usually do not show up in our symbol search. However,
13021 if the unit was in fact built with debugging info, we need to
13022 exclude them because they would duplicate the entry we found
13023 during the special loop that specifically searches for those
13024 standard exceptions.
13026 If PREG is not NULL, then this regexp_t object is used to
13027 perform the symbol name matching. Otherwise, no name-based
13028 filtering is performed.
13030 EXCEPTIONS is a vector of exceptions to which matching exceptions
13034 ada_add_global_exceptions (compiled_regex
*preg
,
13035 std::vector
<ada_exc_info
> *exceptions
)
13037 /* In Ada, the symbol "search name" is a linkage name, whereas the
13038 regular expression used to do the matching refers to the natural
13039 name. So match against the decoded name. */
13040 expand_symtabs_matching (NULL
,
13041 lookup_name_info::match_any (),
13042 [&] (const char *search_name
)
13044 std::string decoded
= ada_decode (search_name
);
13045 return name_matches_regex (decoded
.c_str (), preg
);
13050 for (objfile
*objfile
: current_program_space
->objfiles ())
13052 for (compunit_symtab
*s
: objfile
->compunits ())
13054 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13057 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13059 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13060 struct block_iterator iter
;
13061 struct symbol
*sym
;
13063 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13064 if (ada_is_non_standard_exception_sym (sym
)
13065 && name_matches_regex (sym
->natural_name (), preg
))
13067 struct ada_exc_info info
13068 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13070 exceptions
->push_back (info
);
13077 /* Implements ada_exceptions_list with the regular expression passed
13078 as a regex_t, rather than a string.
13080 If not NULL, PREG is used to filter out exceptions whose names
13081 do not match. Otherwise, all exceptions are listed. */
13083 static std::vector
<ada_exc_info
>
13084 ada_exceptions_list_1 (compiled_regex
*preg
)
13086 std::vector
<ada_exc_info
> result
;
13089 /* First, list the known standard exceptions. These exceptions
13090 need to be handled separately, as they are usually defined in
13091 runtime units that have been compiled without debugging info. */
13093 ada_add_standard_exceptions (preg
, &result
);
13095 /* Next, find all exceptions whose scope is local and accessible
13096 from the currently selected frame. */
13098 if (has_stack_frames ())
13100 prev_len
= result
.size ();
13101 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13103 if (result
.size () > prev_len
)
13104 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13107 /* Add all exceptions whose scope is global. */
13109 prev_len
= result
.size ();
13110 ada_add_global_exceptions (preg
, &result
);
13111 if (result
.size () > prev_len
)
13112 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13117 /* Return a vector of ada_exc_info.
13119 If REGEXP is NULL, all exceptions are included in the result.
13120 Otherwise, it should contain a valid regular expression,
13121 and only the exceptions whose names match that regular expression
13122 are included in the result.
13124 The exceptions are sorted in the following order:
13125 - Standard exceptions (defined by the Ada language), in
13126 alphabetical order;
13127 - Exceptions only visible from the current frame, in
13128 alphabetical order;
13129 - Exceptions whose scope is global, in alphabetical order. */
13131 std::vector
<ada_exc_info
>
13132 ada_exceptions_list (const char *regexp
)
13134 if (regexp
== NULL
)
13135 return ada_exceptions_list_1 (NULL
);
13137 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13138 return ada_exceptions_list_1 (®
);
13141 /* Implement the "info exceptions" command. */
13144 info_exceptions_command (const char *regexp
, int from_tty
)
13146 struct gdbarch
*gdbarch
= get_current_arch ();
13148 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13150 if (regexp
!= NULL
)
13152 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13154 printf_filtered (_("All defined Ada exceptions:\n"));
13156 for (const ada_exc_info
&info
: exceptions
)
13157 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13161 /* Information about operators given special treatment in functions
13163 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13165 #define ADA_OPERATORS \
13166 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13167 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13168 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13169 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13170 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13171 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13172 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13173 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13174 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13175 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13176 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13177 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13178 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13179 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13180 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13181 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13182 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13183 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13184 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13187 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13190 switch (exp
->elts
[pc
- 1].opcode
)
13193 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13196 #define OP_DEFN(op, len, args, binop) \
13197 case op: *oplenp = len; *argsp = args; break;
13203 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13208 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13213 /* Implementation of the exp_descriptor method operator_check. */
13216 ada_operator_check (struct expression
*exp
, int pos
,
13217 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13220 const union exp_element
*const elts
= exp
->elts
;
13221 struct type
*type
= NULL
;
13223 switch (elts
[pos
].opcode
)
13225 case UNOP_IN_RANGE
:
13227 type
= elts
[pos
+ 1].type
;
13231 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13234 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13236 if (type
&& TYPE_OBJFILE (type
)
13237 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13243 /* As for operator_length, but assumes PC is pointing at the first
13244 element of the operator, and gives meaningful results only for the
13245 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13248 ada_forward_operator_length (struct expression
*exp
, int pc
,
13249 int *oplenp
, int *argsp
)
13251 switch (exp
->elts
[pc
].opcode
)
13254 *oplenp
= *argsp
= 0;
13257 #define OP_DEFN(op, len, args, binop) \
13258 case op: *oplenp = len; *argsp = args; break;
13264 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13269 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13275 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13277 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13285 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13287 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13292 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13296 /* Ada attributes ('Foo). */
13299 case OP_ATR_LENGTH
:
13303 case OP_ATR_MODULUS
:
13310 case UNOP_IN_RANGE
:
13312 /* XXX: gdb_sprint_host_address, type_sprint */
13313 fprintf_filtered (stream
, _("Type @"));
13314 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13315 fprintf_filtered (stream
, " (");
13316 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13317 fprintf_filtered (stream
, ")");
13319 case BINOP_IN_BOUNDS
:
13320 fprintf_filtered (stream
, " (%d)",
13321 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13323 case TERNOP_IN_RANGE
:
13328 case OP_DISCRETE_RANGE
:
13329 case OP_POSITIONAL
:
13336 char *name
= &exp
->elts
[elt
+ 2].string
;
13337 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13339 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13344 return dump_subexp_body_standard (exp
, stream
, elt
);
13348 for (i
= 0; i
< nargs
; i
+= 1)
13349 elt
= dump_subexp (exp
, stream
, elt
);
13354 /* The Ada extension of print_subexp (q.v.). */
13357 ada_print_subexp (struct expression
*exp
, int *pos
,
13358 struct ui_file
*stream
, enum precedence prec
)
13360 int oplen
, nargs
, i
;
13362 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13364 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13371 print_subexp_standard (exp
, pos
, stream
, prec
);
13375 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13378 case BINOP_IN_BOUNDS
:
13379 /* XXX: sprint_subexp */
13380 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13381 fputs_filtered (" in ", stream
);
13382 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13383 fputs_filtered ("'range", stream
);
13384 if (exp
->elts
[pc
+ 1].longconst
> 1)
13385 fprintf_filtered (stream
, "(%ld)",
13386 (long) exp
->elts
[pc
+ 1].longconst
);
13389 case TERNOP_IN_RANGE
:
13390 if (prec
>= PREC_EQUAL
)
13391 fputs_filtered ("(", stream
);
13392 /* XXX: sprint_subexp */
13393 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13394 fputs_filtered (" in ", stream
);
13395 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13396 fputs_filtered (" .. ", stream
);
13397 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13398 if (prec
>= PREC_EQUAL
)
13399 fputs_filtered (")", stream
);
13404 case OP_ATR_LENGTH
:
13408 case OP_ATR_MODULUS
:
13413 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13415 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13416 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13417 &type_print_raw_options
);
13421 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13422 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13427 for (tem
= 1; tem
< nargs
; tem
+= 1)
13429 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13430 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13432 fputs_filtered (")", stream
);
13437 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13438 fputs_filtered ("'(", stream
);
13439 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13440 fputs_filtered (")", stream
);
13443 case UNOP_IN_RANGE
:
13444 /* XXX: sprint_subexp */
13445 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13446 fputs_filtered (" in ", stream
);
13447 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13448 &type_print_raw_options
);
13451 case OP_DISCRETE_RANGE
:
13452 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13453 fputs_filtered ("..", stream
);
13454 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13458 fputs_filtered ("others => ", stream
);
13459 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13463 for (i
= 0; i
< nargs
-1; i
+= 1)
13466 fputs_filtered ("|", stream
);
13467 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13469 fputs_filtered (" => ", stream
);
13470 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13473 case OP_POSITIONAL
:
13474 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13478 fputs_filtered ("(", stream
);
13479 for (i
= 0; i
< nargs
; i
+= 1)
13482 fputs_filtered (", ", stream
);
13483 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13485 fputs_filtered (")", stream
);
13490 /* Table mapping opcodes into strings for printing operators
13491 and precedences of the operators. */
13493 static const struct op_print ada_op_print_tab
[] = {
13494 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13495 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13496 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13497 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13498 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13499 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13500 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13501 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13502 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13503 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13504 {">", BINOP_GTR
, PREC_ORDER
, 0},
13505 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13506 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13507 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13508 {"+", BINOP_ADD
, PREC_ADD
, 0},
13509 {"-", BINOP_SUB
, PREC_ADD
, 0},
13510 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13511 {"*", BINOP_MUL
, PREC_MUL
, 0},
13512 {"/", BINOP_DIV
, PREC_MUL
, 0},
13513 {"rem", BINOP_REM
, PREC_MUL
, 0},
13514 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13515 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13516 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13517 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13518 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13519 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13520 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13521 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13522 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13523 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13524 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13525 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13528 /* Language vector */
13530 static const struct exp_descriptor ada_exp_descriptor
= {
13532 ada_operator_length
,
13533 ada_operator_check
,
13534 ada_dump_subexp_body
,
13535 ada_evaluate_subexp
13538 /* symbol_name_matcher_ftype adapter for wild_match. */
13541 do_wild_match (const char *symbol_search_name
,
13542 const lookup_name_info
&lookup_name
,
13543 completion_match_result
*comp_match_res
)
13545 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13548 /* symbol_name_matcher_ftype adapter for full_match. */
13551 do_full_match (const char *symbol_search_name
,
13552 const lookup_name_info
&lookup_name
,
13553 completion_match_result
*comp_match_res
)
13555 if (startswith (symbol_search_name
, "_ada_"))
13556 symbol_search_name
+= 5;
13558 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13559 int uscore_count
= 0;
13560 while (*lname
!= '\0')
13562 if (*symbol_search_name
!= *lname
)
13564 if (*symbol_search_name
== 'B' && uscore_count
== 2
13565 && symbol_search_name
[1] == '_')
13567 symbol_search_name
+= 2;
13568 while (isdigit (*symbol_search_name
))
13569 ++symbol_search_name
;
13570 if (symbol_search_name
[0] == '_'
13571 && symbol_search_name
[1] == '_')
13573 symbol_search_name
+= 2;
13580 if (*symbol_search_name
== '_')
13585 ++symbol_search_name
;
13589 return is_name_suffix (symbol_search_name
);
13592 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13595 do_exact_match (const char *symbol_search_name
,
13596 const lookup_name_info
&lookup_name
,
13597 completion_match_result
*comp_match_res
)
13599 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13602 /* Build the Ada lookup name for LOOKUP_NAME. */
13604 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13606 gdb::string_view user_name
= lookup_name
.name ();
13608 if (user_name
[0] == '<')
13610 if (user_name
.back () == '>')
13612 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13615 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13616 m_encoded_p
= true;
13617 m_verbatim_p
= true;
13618 m_wild_match_p
= false;
13619 m_standard_p
= false;
13623 m_verbatim_p
= false;
13625 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13629 const char *folded
= ada_fold_name (user_name
);
13630 m_encoded_name
= ada_encode_1 (folded
, false);
13631 if (m_encoded_name
.empty ())
13632 m_encoded_name
= gdb::to_string (user_name
);
13635 m_encoded_name
= gdb::to_string (user_name
);
13637 /* Handle the 'package Standard' special case. See description
13638 of m_standard_p. */
13639 if (startswith (m_encoded_name
.c_str (), "standard__"))
13641 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13642 m_standard_p
= true;
13645 m_standard_p
= false;
13647 /* If the name contains a ".", then the user is entering a fully
13648 qualified entity name, and the match must not be done in wild
13649 mode. Similarly, if the user wants to complete what looks
13650 like an encoded name, the match must not be done in wild
13651 mode. Also, in the standard__ special case always do
13652 non-wild matching. */
13654 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13657 && user_name
.find ('.') == std::string::npos
);
13661 /* symbol_name_matcher_ftype method for Ada. This only handles
13662 completion mode. */
13665 ada_symbol_name_matches (const char *symbol_search_name
,
13666 const lookup_name_info
&lookup_name
,
13667 completion_match_result
*comp_match_res
)
13669 return lookup_name
.ada ().matches (symbol_search_name
,
13670 lookup_name
.match_type (),
13674 /* A name matcher that matches the symbol name exactly, with
13678 literal_symbol_name_matcher (const char *symbol_search_name
,
13679 const lookup_name_info
&lookup_name
,
13680 completion_match_result
*comp_match_res
)
13682 gdb::string_view name_view
= lookup_name
.name ();
13684 if (lookup_name
.completion_mode ()
13685 ? (strncmp (symbol_search_name
, name_view
.data (),
13686 name_view
.size ()) == 0)
13687 : symbol_search_name
== name_view
)
13689 if (comp_match_res
!= NULL
)
13690 comp_match_res
->set_match (symbol_search_name
);
13697 /* Implement the "get_symbol_name_matcher" language_defn method for
13700 static symbol_name_matcher_ftype
*
13701 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13703 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13704 return literal_symbol_name_matcher
;
13706 if (lookup_name
.completion_mode ())
13707 return ada_symbol_name_matches
;
13710 if (lookup_name
.ada ().wild_match_p ())
13711 return do_wild_match
;
13712 else if (lookup_name
.ada ().verbatim_p ())
13713 return do_exact_match
;
13715 return do_full_match
;
13719 /* Class representing the Ada language. */
13721 class ada_language
: public language_defn
13725 : language_defn (language_ada
)
13728 /* See language.h. */
13730 const char *name () const override
13733 /* See language.h. */
13735 const char *natural_name () const override
13738 /* See language.h. */
13740 const std::vector
<const char *> &filename_extensions () const override
13742 static const std::vector
<const char *> extensions
13743 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13747 /* Print an array element index using the Ada syntax. */
13749 void print_array_index (struct type
*index_type
,
13751 struct ui_file
*stream
,
13752 const value_print_options
*options
) const override
13754 struct value
*index_value
= val_atr (index_type
, index
);
13756 value_print (index_value
, stream
, options
);
13757 fprintf_filtered (stream
, " => ");
13760 /* Implement the "read_var_value" language_defn method for Ada. */
13762 struct value
*read_var_value (struct symbol
*var
,
13763 const struct block
*var_block
,
13764 struct frame_info
*frame
) const override
13766 /* The only case where default_read_var_value is not sufficient
13767 is when VAR is a renaming... */
13768 if (frame
!= nullptr)
13770 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13771 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13772 return ada_read_renaming_var_value (var
, frame_block
);
13775 /* This is a typical case where we expect the default_read_var_value
13776 function to work. */
13777 return language_defn::read_var_value (var
, var_block
, frame
);
13780 /* See language.h. */
13781 void language_arch_info (struct gdbarch
*gdbarch
,
13782 struct language_arch_info
*lai
) const override
13784 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13786 /* Helper function to allow shorter lines below. */
13787 auto add
= [&] (struct type
*t
)
13789 lai
->add_primitive_type (t
);
13792 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13794 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13795 0, "long_integer"));
13796 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13797 0, "short_integer"));
13798 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13800 lai
->set_string_char_type (char_type
);
13802 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13803 "float", gdbarch_float_format (gdbarch
)));
13804 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13805 "long_float", gdbarch_double_format (gdbarch
)));
13806 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13807 0, "long_long_integer"));
13808 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13810 gdbarch_long_double_format (gdbarch
)));
13811 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13813 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13815 add (builtin
->builtin_void
);
13817 struct type
*system_addr_ptr
13818 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13820 system_addr_ptr
->set_name ("system__address");
13821 add (system_addr_ptr
);
13823 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13824 type. This is a signed integral type whose size is the same as
13825 the size of addresses. */
13826 unsigned int addr_length
= TYPE_LENGTH (system_addr_ptr
);
13827 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13828 "storage_offset"));
13830 lai
->set_bool_type (builtin
->builtin_bool
);
13833 /* See language.h. */
13835 bool iterate_over_symbols
13836 (const struct block
*block
, const lookup_name_info
&name
,
13837 domain_enum domain
,
13838 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13840 std::vector
<struct block_symbol
> results
;
13842 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13843 for (block_symbol
&sym
: results
)
13845 if (!callback (&sym
))
13852 /* See language.h. */
13853 bool sniff_from_mangled_name (const char *mangled
,
13854 char **out
) const override
13856 std::string demangled
= ada_decode (mangled
);
13860 if (demangled
!= mangled
&& demangled
[0] != '<')
13862 /* Set the gsymbol language to Ada, but still return 0.
13863 Two reasons for that:
13865 1. For Ada, we prefer computing the symbol's decoded name
13866 on the fly rather than pre-compute it, in order to save
13867 memory (Ada projects are typically very large).
13869 2. There are some areas in the definition of the GNAT
13870 encoding where, with a bit of bad luck, we might be able
13871 to decode a non-Ada symbol, generating an incorrect
13872 demangled name (Eg: names ending with "TB" for instance
13873 are identified as task bodies and so stripped from
13874 the decoded name returned).
13876 Returning true, here, but not setting *DEMANGLED, helps us get
13877 a little bit of the best of both worlds. Because we're last,
13878 we should not affect any of the other languages that were
13879 able to demangle the symbol before us; we get to correctly
13880 tag Ada symbols as such; and even if we incorrectly tagged a
13881 non-Ada symbol, which should be rare, any routing through the
13882 Ada language should be transparent (Ada tries to behave much
13883 like C/C++ with non-Ada symbols). */
13890 /* See language.h. */
13892 char *demangle_symbol (const char *mangled
, int options
) const override
13894 return ada_la_decode (mangled
, options
);
13897 /* See language.h. */
13899 void print_type (struct type
*type
, const char *varstring
,
13900 struct ui_file
*stream
, int show
, int level
,
13901 const struct type_print_options
*flags
) const override
13903 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13906 /* See language.h. */
13908 const char *word_break_characters (void) const override
13910 return ada_completer_word_break_characters
;
13913 /* See language.h. */
13915 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13916 complete_symbol_mode mode
,
13917 symbol_name_match_type name_match_type
,
13918 const char *text
, const char *word
,
13919 enum type_code code
) const override
13921 struct symbol
*sym
;
13922 const struct block
*b
, *surrounding_static_block
= 0;
13923 struct block_iterator iter
;
13925 gdb_assert (code
== TYPE_CODE_UNDEF
);
13927 lookup_name_info
lookup_name (text
, name_match_type
, true);
13929 /* First, look at the partial symtab symbols. */
13930 expand_symtabs_matching (NULL
,
13936 /* At this point scan through the misc symbol vectors and add each
13937 symbol you find to the list. Eventually we want to ignore
13938 anything that isn't a text symbol (everything else will be
13939 handled by the psymtab code above). */
13941 for (objfile
*objfile
: current_program_space
->objfiles ())
13943 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13947 if (completion_skip_symbol (mode
, msymbol
))
13950 language symbol_language
= msymbol
->language ();
13952 /* Ada minimal symbols won't have their language set to Ada. If
13953 we let completion_list_add_name compare using the
13954 default/C-like matcher, then when completing e.g., symbols in a
13955 package named "pck", we'd match internal Ada symbols like
13956 "pckS", which are invalid in an Ada expression, unless you wrap
13957 them in '<' '>' to request a verbatim match.
13959 Unfortunately, some Ada encoded names successfully demangle as
13960 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13961 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13962 with the wrong language set. Paper over that issue here. */
13963 if (symbol_language
== language_auto
13964 || symbol_language
== language_cplus
)
13965 symbol_language
= language_ada
;
13967 completion_list_add_name (tracker
,
13969 msymbol
->linkage_name (),
13970 lookup_name
, text
, word
);
13974 /* Search upwards from currently selected frame (so that we can
13975 complete on local vars. */
13977 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
13979 if (!BLOCK_SUPERBLOCK (b
))
13980 surrounding_static_block
= b
; /* For elmin of dups */
13982 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13984 if (completion_skip_symbol (mode
, sym
))
13987 completion_list_add_name (tracker
,
13989 sym
->linkage_name (),
13990 lookup_name
, text
, word
);
13994 /* Go through the symtabs and check the externs and statics for
13995 symbols which match. */
13997 for (objfile
*objfile
: current_program_space
->objfiles ())
13999 for (compunit_symtab
*s
: objfile
->compunits ())
14002 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14003 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14005 if (completion_skip_symbol (mode
, sym
))
14008 completion_list_add_name (tracker
,
14010 sym
->linkage_name (),
14011 lookup_name
, text
, word
);
14016 for (objfile
*objfile
: current_program_space
->objfiles ())
14018 for (compunit_symtab
*s
: objfile
->compunits ())
14021 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14022 /* Don't do this block twice. */
14023 if (b
== surrounding_static_block
)
14025 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14027 if (completion_skip_symbol (mode
, sym
))
14030 completion_list_add_name (tracker
,
14032 sym
->linkage_name (),
14033 lookup_name
, text
, word
);
14039 /* See language.h. */
14041 gdb::unique_xmalloc_ptr
<char> watch_location_expression
14042 (struct type
*type
, CORE_ADDR addr
) const override
14044 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
14045 std::string name
= type_to_string (type
);
14046 return gdb::unique_xmalloc_ptr
<char>
14047 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
14050 /* See language.h. */
14052 void value_print (struct value
*val
, struct ui_file
*stream
,
14053 const struct value_print_options
*options
) const override
14055 return ada_value_print (val
, stream
, options
);
14058 /* See language.h. */
14060 void value_print_inner
14061 (struct value
*val
, struct ui_file
*stream
, int recurse
,
14062 const struct value_print_options
*options
) const override
14064 return ada_value_print_inner (val
, stream
, recurse
, options
);
14067 /* See language.h. */
14069 struct block_symbol lookup_symbol_nonlocal
14070 (const char *name
, const struct block
*block
,
14071 const domain_enum domain
) const override
14073 struct block_symbol sym
;
14075 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
14076 if (sym
.symbol
!= NULL
)
14079 /* If we haven't found a match at this point, try the primitive
14080 types. In other languages, this search is performed before
14081 searching for global symbols in order to short-circuit that
14082 global-symbol search if it happens that the name corresponds
14083 to a primitive type. But we cannot do the same in Ada, because
14084 it is perfectly legitimate for a program to declare a type which
14085 has the same name as a standard type. If looking up a type in
14086 that situation, we have traditionally ignored the primitive type
14087 in favor of user-defined types. This is why, unlike most other
14088 languages, we search the primitive types this late and only after
14089 having searched the global symbols without success. */
14091 if (domain
== VAR_DOMAIN
)
14093 struct gdbarch
*gdbarch
;
14096 gdbarch
= target_gdbarch ();
14098 gdbarch
= block_gdbarch (block
);
14100 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
14101 if (sym
.symbol
!= NULL
)
14108 /* See language.h. */
14110 int parser (struct parser_state
*ps
) const override
14112 warnings_issued
= 0;
14113 return ada_parse (ps
);
14118 Same as evaluate_type (*EXP), but resolves ambiguous symbol references
14119 (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
14120 namespace) and converts operators that are user-defined into
14121 appropriate function calls. If CONTEXT_TYPE is non-null, it provides
14122 a preferred result type [at the moment, only type void has any
14123 effect---causing procedures to be preferred over functions in calls].
14124 A null CONTEXT_TYPE indicates that a non-void return type is
14125 preferred. May change (expand) *EXP. */
14127 void post_parser (expression_up
*expp
, struct parser_state
*ps
)
14130 struct type
*context_type
= NULL
;
14133 if (ps
->void_context_p
)
14134 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
14136 resolve_subexp (expp
, &pc
, 1, context_type
, ps
->parse_completion
,
14137 ps
->block_tracker
);
14140 /* See language.h. */
14142 void emitchar (int ch
, struct type
*chtype
,
14143 struct ui_file
*stream
, int quoter
) const override
14145 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
14148 /* See language.h. */
14150 void printchar (int ch
, struct type
*chtype
,
14151 struct ui_file
*stream
) const override
14153 ada_printchar (ch
, chtype
, stream
);
14156 /* See language.h. */
14158 void printstr (struct ui_file
*stream
, struct type
*elttype
,
14159 const gdb_byte
*string
, unsigned int length
,
14160 const char *encoding
, int force_ellipses
,
14161 const struct value_print_options
*options
) const override
14163 ada_printstr (stream
, elttype
, string
, length
, encoding
,
14164 force_ellipses
, options
);
14167 /* See language.h. */
14169 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
14170 struct ui_file
*stream
) const override
14172 ada_print_typedef (type
, new_symbol
, stream
);
14175 /* See language.h. */
14177 bool is_string_type_p (struct type
*type
) const override
14179 return ada_is_string_type (type
);
14182 /* See language.h. */
14184 const char *struct_too_deep_ellipsis () const override
14185 { return "(...)"; }
14187 /* See language.h. */
14189 bool c_style_arrays_p () const override
14192 /* See language.h. */
14194 bool store_sym_names_in_linkage_form_p () const override
14197 /* See language.h. */
14199 const struct lang_varobj_ops
*varobj_ops () const override
14200 { return &ada_varobj_ops
; }
14202 /* See language.h. */
14204 const struct exp_descriptor
*expression_ops () const override
14205 { return &ada_exp_descriptor
; }
14207 /* See language.h. */
14209 const struct op_print
*opcode_print_table () const override
14210 { return ada_op_print_tab
; }
14213 /* See language.h. */
14215 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14216 (const lookup_name_info
&lookup_name
) const override
14218 return ada_get_symbol_name_matcher (lookup_name
);
14222 /* Single instance of the Ada language class. */
14224 static ada_language ada_language_defn
;
14226 /* Command-list for the "set/show ada" prefix command. */
14227 static struct cmd_list_element
*set_ada_list
;
14228 static struct cmd_list_element
*show_ada_list
;
14231 initialize_ada_catchpoint_ops (void)
14233 struct breakpoint_ops
*ops
;
14235 initialize_breakpoint_ops ();
14237 ops
= &catch_exception_breakpoint_ops
;
14238 *ops
= bkpt_breakpoint_ops
;
14239 ops
->allocate_location
= allocate_location_exception
;
14240 ops
->re_set
= re_set_exception
;
14241 ops
->check_status
= check_status_exception
;
14242 ops
->print_it
= print_it_exception
;
14243 ops
->print_one
= print_one_exception
;
14244 ops
->print_mention
= print_mention_exception
;
14245 ops
->print_recreate
= print_recreate_exception
;
14247 ops
= &catch_exception_unhandled_breakpoint_ops
;
14248 *ops
= bkpt_breakpoint_ops
;
14249 ops
->allocate_location
= allocate_location_exception
;
14250 ops
->re_set
= re_set_exception
;
14251 ops
->check_status
= check_status_exception
;
14252 ops
->print_it
= print_it_exception
;
14253 ops
->print_one
= print_one_exception
;
14254 ops
->print_mention
= print_mention_exception
;
14255 ops
->print_recreate
= print_recreate_exception
;
14257 ops
= &catch_assert_breakpoint_ops
;
14258 *ops
= bkpt_breakpoint_ops
;
14259 ops
->allocate_location
= allocate_location_exception
;
14260 ops
->re_set
= re_set_exception
;
14261 ops
->check_status
= check_status_exception
;
14262 ops
->print_it
= print_it_exception
;
14263 ops
->print_one
= print_one_exception
;
14264 ops
->print_mention
= print_mention_exception
;
14265 ops
->print_recreate
= print_recreate_exception
;
14267 ops
= &catch_handlers_breakpoint_ops
;
14268 *ops
= bkpt_breakpoint_ops
;
14269 ops
->allocate_location
= allocate_location_exception
;
14270 ops
->re_set
= re_set_exception
;
14271 ops
->check_status
= check_status_exception
;
14272 ops
->print_it
= print_it_exception
;
14273 ops
->print_one
= print_one_exception
;
14274 ops
->print_mention
= print_mention_exception
;
14275 ops
->print_recreate
= print_recreate_exception
;
14278 /* This module's 'new_objfile' observer. */
14281 ada_new_objfile_observer (struct objfile
*objfile
)
14283 ada_clear_symbol_cache ();
14286 /* This module's 'free_objfile' observer. */
14289 ada_free_objfile_observer (struct objfile
*objfile
)
14291 ada_clear_symbol_cache ();
14294 void _initialize_ada_language ();
14296 _initialize_ada_language ()
14298 initialize_ada_catchpoint_ops ();
14300 add_basic_prefix_cmd ("ada", no_class
,
14301 _("Prefix command for changing Ada-specific settings."),
14302 &set_ada_list
, "set ada ", 0, &setlist
);
14304 add_show_prefix_cmd ("ada", no_class
,
14305 _("Generic command for showing Ada-specific settings."),
14306 &show_ada_list
, "show ada ", 0, &showlist
);
14308 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14309 &trust_pad_over_xvs
, _("\
14310 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14311 Show whether an optimization trusting PAD types over XVS types is activated."),
14313 This is related to the encoding used by the GNAT compiler. The debugger\n\
14314 should normally trust the contents of PAD types, but certain older versions\n\
14315 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14316 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14317 work around this bug. It is always safe to turn this option \"off\", but\n\
14318 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14319 this option to \"off\" unless necessary."),
14320 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14322 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14323 &print_signatures
, _("\
14324 Enable or disable the output of formal and return types for functions in the \
14325 overloads selection menu."), _("\
14326 Show whether the output of formal and return types for functions in the \
14327 overloads selection menu is activated."),
14328 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14330 add_catch_command ("exception", _("\
14331 Catch Ada exceptions, when raised.\n\
14332 Usage: catch exception [ARG] [if CONDITION]\n\
14333 Without any argument, stop when any Ada exception is raised.\n\
14334 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14335 being raised does not have a handler (and will therefore lead to the task's\n\
14337 Otherwise, the catchpoint only stops when the name of the exception being\n\
14338 raised is the same as ARG.\n\
14339 CONDITION is a boolean expression that is evaluated to see whether the\n\
14340 exception should cause a stop."),
14341 catch_ada_exception_command
,
14342 catch_ada_completer
,
14346 add_catch_command ("handlers", _("\
14347 Catch Ada exceptions, when handled.\n\
14348 Usage: catch handlers [ARG] [if CONDITION]\n\
14349 Without any argument, stop when any Ada exception is handled.\n\
14350 With an argument, catch only exceptions with the given name.\n\
14351 CONDITION is a boolean expression that is evaluated to see whether the\n\
14352 exception should cause a stop."),
14353 catch_ada_handlers_command
,
14354 catch_ada_completer
,
14357 add_catch_command ("assert", _("\
14358 Catch failed Ada assertions, when raised.\n\
14359 Usage: catch assert [if CONDITION]\n\
14360 CONDITION is a boolean expression that is evaluated to see whether the\n\
14361 exception should cause a stop."),
14362 catch_assert_command
,
14367 varsize_limit
= 65536;
14368 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14369 &varsize_limit
, _("\
14370 Set the maximum number of bytes allowed in a variable-size object."), _("\
14371 Show the maximum number of bytes allowed in a variable-size object."), _("\
14372 Attempts to access an object whose size is not a compile-time constant\n\
14373 and exceeds this limit will cause an error."),
14374 NULL
, NULL
, &setlist
, &showlist
);
14376 add_info ("exceptions", info_exceptions_command
,
14378 List all Ada exception names.\n\
14379 Usage: info exceptions [REGEXP]\n\
14380 If a regular expression is passed as an argument, only those matching\n\
14381 the regular expression are listed."));
14383 add_basic_prefix_cmd ("ada", class_maintenance
,
14384 _("Set Ada maintenance-related variables."),
14385 &maint_set_ada_cmdlist
, "maintenance set ada ",
14386 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14388 add_show_prefix_cmd ("ada", class_maintenance
,
14389 _("Show Ada maintenance-related variables."),
14390 &maint_show_ada_cmdlist
, "maintenance show ada ",
14391 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14393 add_setshow_boolean_cmd
14394 ("ignore-descriptive-types", class_maintenance
,
14395 &ada_ignore_descriptive_types_p
,
14396 _("Set whether descriptive types generated by GNAT should be ignored."),
14397 _("Show whether descriptive types generated by GNAT should be ignored."),
14399 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14400 DWARF attribute."),
14401 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14403 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14404 NULL
, xcalloc
, xfree
);
14406 /* The ada-lang observers. */
14407 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14408 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14409 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);