1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2023 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 "gdbsupport/gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdbsupport/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"
52 #include "cli/cli-decode.h"
55 #include "mi/mi-common.h"
56 #include "arch-utils.h"
57 #include "cli/cli-utils.h"
58 #include "gdbsupport/function-view.h"
59 #include "gdbsupport/byte-vector.h"
64 /* Define whether or not the C operator '/' truncates towards zero for
65 differently signed operands (truncation direction is undefined in C).
66 Copied from valarith.c. */
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72 static struct type
*desc_base_type (struct type
*);
74 static struct type
*desc_bounds_type (struct type
*);
76 static struct value
*desc_bounds (struct value
*);
78 static int fat_pntr_bounds_bitpos (struct type
*);
80 static int fat_pntr_bounds_bitsize (struct type
*);
82 static struct type
*desc_data_target_type (struct type
*);
84 static struct value
*desc_data (struct value
*);
86 static int fat_pntr_data_bitpos (struct type
*);
88 static int fat_pntr_data_bitsize (struct type
*);
90 static struct value
*desc_one_bound (struct value
*, int, int);
92 static int desc_bound_bitpos (struct type
*, int, int);
94 static int desc_bound_bitsize (struct type
*, int, int);
96 static struct type
*desc_index_type (struct type
*, int);
98 static int desc_arity (struct type
*);
100 static int ada_args_match (struct symbol
*, struct value
**, int);
102 static struct value
*make_array_descriptor (struct type
*, struct value
*);
104 static void ada_add_block_symbols (std::vector
<struct block_symbol
> &,
105 const struct block
*,
106 const lookup_name_info
&lookup_name
,
107 domain_enum
, struct objfile
*);
109 static void ada_add_all_symbols (std::vector
<struct block_symbol
> &,
110 const struct block
*,
111 const lookup_name_info
&lookup_name
,
112 domain_enum
, int, int *);
114 static int is_nonfunction (const std::vector
<struct block_symbol
> &);
116 static void add_defn_to_vec (std::vector
<struct block_symbol
> &,
118 const struct block
*);
120 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
122 static const char *ada_decoded_op_name (enum exp_opcode
);
124 static int numeric_type_p (struct type
*);
126 static int integer_type_p (struct type
*);
128 static int scalar_type_p (struct type
*);
130 static int discrete_type_p (struct type
*);
132 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
135 static struct type
*ada_find_parallel_type_with_name (struct type
*,
138 static int is_dynamic_field (struct type
*, int);
140 static struct type
*to_fixed_variant_branch_type (struct type
*,
142 CORE_ADDR
, struct value
*);
144 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
146 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
148 static struct type
*to_static_fixed_type (struct type
*);
149 static struct type
*static_unwrap_type (struct type
*type
);
151 static struct value
*unwrap_value (struct value
*);
153 static struct type
*constrained_packed_array_type (struct type
*, long *);
155 static struct type
*decode_constrained_packed_array_type (struct type
*);
157 static long decode_packed_array_bitsize (struct type
*);
159 static struct value
*decode_constrained_packed_array (struct value
*);
161 static int ada_is_unconstrained_packed_array_type (struct type
*);
163 static struct value
*value_subscript_packed (struct value
*, int,
166 static struct value
*coerce_unspec_val_to_type (struct value
*,
169 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
171 static int equiv_types (struct type
*, struct type
*);
173 static int is_name_suffix (const char *);
175 static int advance_wild_match (const char **, const char *, char);
177 static bool wild_match (const char *name
, const char *patn
);
179 static struct value
*ada_coerce_ref (struct value
*);
181 static LONGEST
pos_atr (struct value
*);
183 static struct value
*val_atr (struct type
*, LONGEST
);
185 static struct symbol
*standard_lookup (const char *, const struct block
*,
188 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
191 static int find_struct_field (const char *, struct type
*, int,
192 struct type
**, int *, int *, int *, int *);
194 static int ada_resolve_function (std::vector
<struct block_symbol
> &,
195 struct value
**, int, const char *,
196 struct type
*, bool);
198 static int ada_is_direct_array_type (struct type
*);
200 static struct value
*ada_index_struct_field (int, struct value
*, int,
203 static void add_component_interval (LONGEST
, LONGEST
, std::vector
<LONGEST
> &);
206 static struct type
*ada_find_any_type (const char *name
);
208 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
209 (const lookup_name_info
&lookup_name
);
213 /* The character set used for source files. */
214 static const char *ada_source_charset
;
216 /* The string "UTF-8". This is here so we can check for the UTF-8
217 charset using == rather than strcmp. */
218 static const char ada_utf8
[] = "UTF-8";
220 /* Each entry in the UTF-32 case-folding table is of this form. */
223 /* The start and end, inclusive, of this range of codepoints. */
225 /* The delta to apply to get the upper-case form. 0 if this is
226 already upper-case. */
228 /* The delta to apply to get the lower-case form. 0 if this is
229 already lower-case. */
232 bool operator< (uint32_t val
) const
238 static const utf8_entry ada_case_fold
[] =
240 #include "ada-casefold.h"
245 /* The result of a symbol lookup to be stored in our symbol cache. */
249 /* The name used to perform the lookup. */
251 /* The namespace used during the lookup. */
253 /* The symbol returned by the lookup, or NULL if no matching symbol
256 /* The block where the symbol was found, or NULL if no matching
258 const struct block
*block
;
259 /* A pointer to the next entry with the same hash. */
260 struct cache_entry
*next
;
263 /* The Ada symbol cache, used to store the result of Ada-mode symbol
264 lookups in the course of executing the user's commands.
266 The cache is implemented using a simple, fixed-sized hash.
267 The size is fixed on the grounds that there are not likely to be
268 all that many symbols looked up during any given session, regardless
269 of the size of the symbol table. If we decide to go to a resizable
270 table, let's just use the stuff from libiberty instead. */
272 #define HASH_SIZE 1009
274 struct ada_symbol_cache
276 /* An obstack used to store the entries in our cache. */
277 struct auto_obstack cache_space
;
279 /* The root of the hash table used to implement our symbol cache. */
280 struct cache_entry
*root
[HASH_SIZE
] {};
283 static const char ada_completer_word_break_characters
[] =
285 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
290 /* The name of the symbol to use to get the name of the main subprogram. */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
292 = "__gnat_ada_main_program_name";
294 /* Limit on the number of warnings to raise per expression evaluation. */
295 static int warning_limit
= 2;
297 /* Number of warning messages issued; reset to 0 by cleanups after
298 expression evaluation. */
299 static int warnings_issued
= 0;
301 static const char * const known_runtime_file_name_patterns
[] = {
302 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
305 static const char * const known_auxiliary_function_name_patterns
[] = {
306 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
309 /* Maintenance-related settings for this module. */
311 static struct cmd_list_element
*maint_set_ada_cmdlist
;
312 static struct cmd_list_element
*maint_show_ada_cmdlist
;
314 /* The "maintenance ada set/show ignore-descriptive-type" value. */
316 static bool ada_ignore_descriptive_types_p
= false;
318 /* Inferior-specific data. */
320 /* Per-inferior data for this module. */
322 struct ada_inferior_data
324 /* The ada__tags__type_specific_data type, which is used when decoding
325 tagged types. With older versions of GNAT, this type was directly
326 accessible through a component ("tsd") in the object tag. But this
327 is no longer the case, so we cache it for each inferior. */
328 struct type
*tsd_type
= nullptr;
330 /* The exception_support_info data. This data is used to determine
331 how to implement support for Ada exception catchpoints in a given
333 const struct exception_support_info
*exception_info
= nullptr;
336 /* Our key to this module's inferior data. */
337 static const registry
<inferior
>::key
<ada_inferior_data
> ada_inferior_data
;
339 /* Return our inferior data for the given inferior (INF).
341 This function always returns a valid pointer to an allocated
342 ada_inferior_data structure. If INF's inferior data has not
343 been previously set, this functions creates a new one with all
344 fields set to zero, sets INF's inferior to it, and then returns
345 a pointer to that newly allocated ada_inferior_data. */
347 static struct ada_inferior_data
*
348 get_ada_inferior_data (struct inferior
*inf
)
350 struct ada_inferior_data
*data
;
352 data
= ada_inferior_data
.get (inf
);
354 data
= ada_inferior_data
.emplace (inf
);
359 /* Perform all necessary cleanups regarding our module's inferior data
360 that is required after the inferior INF just exited. */
363 ada_inferior_exit (struct inferior
*inf
)
365 ada_inferior_data
.clear (inf
);
369 /* program-space-specific data. */
371 /* This module's per-program-space data. */
372 struct ada_pspace_data
374 /* The Ada symbol cache. */
375 std::unique_ptr
<ada_symbol_cache
> sym_cache
;
378 /* Key to our per-program-space data. */
379 static const registry
<program_space
>::key
<ada_pspace_data
>
380 ada_pspace_data_handle
;
382 /* Return this module's data for the given program space (PSPACE).
383 If not is found, add a zero'ed one now.
385 This function always returns a valid object. */
387 static struct ada_pspace_data
*
388 get_ada_pspace_data (struct program_space
*pspace
)
390 struct ada_pspace_data
*data
;
392 data
= ada_pspace_data_handle
.get (pspace
);
394 data
= ada_pspace_data_handle
.emplace (pspace
);
401 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
402 all typedef layers have been peeled. Otherwise, return TYPE.
404 Normally, we really expect a typedef type to only have 1 typedef layer.
405 In other words, we really expect the target type of a typedef type to be
406 a non-typedef type. This is particularly true for Ada units, because
407 the language does not have a typedef vs not-typedef distinction.
408 In that respect, the Ada compiler has been trying to eliminate as many
409 typedef definitions in the debugging information, since they generally
410 do not bring any extra information (we still use typedef under certain
411 circumstances related mostly to the GNAT encoding).
413 Unfortunately, we have seen situations where the debugging information
414 generated by the compiler leads to such multiple typedef layers. For
415 instance, consider the following example with stabs:
417 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
418 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
420 This is an error in the debugging information which causes type
421 pck__float_array___XUP to be defined twice, and the second time,
422 it is defined as a typedef of a typedef.
424 This is on the fringe of legality as far as debugging information is
425 concerned, and certainly unexpected. But it is easy to handle these
426 situations correctly, so we can afford to be lenient in this case. */
429 ada_typedef_target_type (struct type
*type
)
431 while (type
->code () == TYPE_CODE_TYPEDEF
)
432 type
= type
->target_type ();
436 /* Given DECODED_NAME a string holding a symbol name in its
437 decoded form (ie using the Ada dotted notation), returns
438 its unqualified name. */
441 ada_unqualified_name (const char *decoded_name
)
445 /* If the decoded name starts with '<', it means that the encoded
446 name does not follow standard naming conventions, and thus that
447 it is not your typical Ada symbol name. Trying to unqualify it
448 is therefore pointless and possibly erroneous. */
449 if (decoded_name
[0] == '<')
452 result
= strrchr (decoded_name
, '.');
454 result
++; /* Skip the dot... */
456 result
= decoded_name
;
461 /* Return a string starting with '<', followed by STR, and '>'. */
464 add_angle_brackets (const char *str
)
466 return string_printf ("<%s>", str
);
469 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
470 suffix of FIELD_NAME beginning "___". */
473 field_name_match (const char *field_name
, const char *target
)
475 int len
= strlen (target
);
478 (strncmp (field_name
, target
, len
) == 0
479 && (field_name
[len
] == '\0'
480 || (startswith (field_name
+ len
, "___")
481 && strcmp (field_name
+ strlen (field_name
) - 6,
486 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
487 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
488 and return its index. This function also handles fields whose name
489 have ___ suffixes because the compiler sometimes alters their name
490 by adding such a suffix to represent fields with certain constraints.
491 If the field could not be found, return a negative number if
492 MAYBE_MISSING is set. Otherwise raise an error. */
495 ada_get_field_index (const struct type
*type
, const char *field_name
,
499 struct type
*struct_type
= check_typedef ((struct type
*) type
);
501 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
502 if (field_name_match (struct_type
->field (fieldno
).name (), field_name
))
506 error (_("Unable to find field %s in struct %s. Aborting"),
507 field_name
, struct_type
->name ());
512 /* The length of the prefix of NAME prior to any "___" suffix. */
515 ada_name_prefix_len (const char *name
)
521 const char *p
= strstr (name
, "___");
524 return strlen (name
);
530 /* Return non-zero if SUFFIX is a suffix of STR.
531 Return zero if STR is null. */
534 is_suffix (const char *str
, const char *suffix
)
541 len2
= strlen (suffix
);
542 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
545 /* The contents of value VAL, treated as a value of type TYPE. The
546 result is an lval in memory if VAL is. */
548 static struct value
*
549 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
551 type
= ada_check_typedef (type
);
552 if (val
->type () == type
)
556 struct value
*result
;
558 if (value_optimized_out (val
))
559 result
= allocate_optimized_out_value (type
);
560 else if (value_lazy (val
)
561 /* Be careful not to make a lazy not_lval value. */
562 || (VALUE_LVAL (val
) != not_lval
563 && type
->length () > val
->type ()->length ()))
564 result
= allocate_value_lazy (type
);
567 result
= allocate_value (type
);
568 value_contents_copy (result
, 0, val
, 0, type
->length ());
570 set_value_component_location (result
, val
);
571 set_value_bitsize (result
, value_bitsize (val
));
572 set_value_bitpos (result
, value_bitpos (val
));
573 if (VALUE_LVAL (result
) == lval_memory
)
574 set_value_address (result
, value_address (val
));
579 static const gdb_byte
*
580 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
585 return valaddr
+ offset
;
589 cond_offset_target (CORE_ADDR address
, long offset
)
594 return address
+ offset
;
597 /* Issue a warning (as for the definition of warning in utils.c, but
598 with exactly one argument rather than ...), unless the limit on the
599 number of warnings has passed during the evaluation of the current
602 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
603 provided by "complaint". */
604 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
607 lim_warning (const char *format
, ...)
611 va_start (args
, format
);
612 warnings_issued
+= 1;
613 if (warnings_issued
<= warning_limit
)
614 vwarning (format
, args
);
619 /* Maximum value of a SIZE-byte signed integer type. */
621 max_of_size (int size
)
623 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
625 return top_bit
| (top_bit
- 1);
628 /* Minimum value of a SIZE-byte signed integer type. */
630 min_of_size (int size
)
632 return -max_of_size (size
) - 1;
635 /* Maximum value of a SIZE-byte unsigned integer type. */
637 umax_of_size (int size
)
639 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
641 return top_bit
| (top_bit
- 1);
644 /* Maximum value of integral type T, as a signed quantity. */
646 max_of_type (struct type
*t
)
648 if (t
->is_unsigned ())
649 return (LONGEST
) umax_of_size (t
->length ());
651 return max_of_size (t
->length ());
654 /* Minimum value of integral type T, as a signed quantity. */
656 min_of_type (struct type
*t
)
658 if (t
->is_unsigned ())
661 return min_of_size (t
->length ());
664 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
666 ada_discrete_type_high_bound (struct type
*type
)
668 type
= resolve_dynamic_type (type
, {}, 0);
669 switch (type
->code ())
671 case TYPE_CODE_RANGE
:
673 const dynamic_prop
&high
= type
->bounds ()->high
;
675 if (high
.kind () == PROP_CONST
)
676 return high
.const_val ();
679 gdb_assert (high
.kind () == PROP_UNDEFINED
);
681 /* This happens when trying to evaluate a type's dynamic bound
682 without a live target. There is nothing relevant for us to
683 return here, so return 0. */
688 return type
->field (type
->num_fields () - 1).loc_enumval ();
693 return max_of_type (type
);
695 error (_("Unexpected type in ada_discrete_type_high_bound."));
699 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
701 ada_discrete_type_low_bound (struct type
*type
)
703 type
= resolve_dynamic_type (type
, {}, 0);
704 switch (type
->code ())
706 case TYPE_CODE_RANGE
:
708 const dynamic_prop
&low
= type
->bounds ()->low
;
710 if (low
.kind () == PROP_CONST
)
711 return low
.const_val ();
714 gdb_assert (low
.kind () == PROP_UNDEFINED
);
716 /* This happens when trying to evaluate a type's dynamic bound
717 without a live target. There is nothing relevant for us to
718 return here, so return 0. */
723 return type
->field (0).loc_enumval ();
728 return min_of_type (type
);
730 error (_("Unexpected type in ada_discrete_type_low_bound."));
734 /* The identity on non-range types. For range types, the underlying
735 non-range scalar type. */
738 get_base_type (struct type
*type
)
740 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
742 if (type
== type
->target_type () || type
->target_type () == NULL
)
744 type
= type
->target_type ();
749 /* Return a decoded version of the given VALUE. This means returning
750 a value whose type is obtained by applying all the GNAT-specific
751 encodings, making the resulting type a static but standard description
752 of the initial type. */
755 ada_get_decoded_value (struct value
*value
)
757 struct type
*type
= ada_check_typedef (value
->type ());
759 if (ada_is_array_descriptor_type (type
)
760 || (ada_is_constrained_packed_array_type (type
)
761 && type
->code () != TYPE_CODE_PTR
))
763 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
764 value
= ada_coerce_to_simple_array_ptr (value
);
766 value
= ada_coerce_to_simple_array (value
);
769 value
= ada_to_fixed_value (value
);
774 /* Same as ada_get_decoded_value, but with the given TYPE.
775 Because there is no associated actual value for this type,
776 the resulting type might be a best-effort approximation in
777 the case of dynamic types. */
780 ada_get_decoded_type (struct type
*type
)
782 type
= to_static_fixed_type (type
);
783 if (ada_is_constrained_packed_array_type (type
))
784 type
= ada_coerce_to_simple_array_type (type
);
790 /* Language Selection */
792 /* If the main program is in Ada, return language_ada, otherwise return LANG
793 (the main program is in Ada iif the adainit symbol is found). */
796 ada_update_initial_language (enum language lang
)
798 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
804 /* If the main procedure is written in Ada, then return its name.
805 The result is good until the next call. Return NULL if the main
806 procedure doesn't appear to be in Ada. */
811 struct bound_minimal_symbol msym
;
812 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
814 /* For Ada, the name of the main procedure is stored in a specific
815 string constant, generated by the binder. Look for that symbol,
816 extract its address, and then read that string. If we didn't find
817 that string, then most probably the main procedure is not written
819 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
821 if (msym
.minsym
!= NULL
)
823 CORE_ADDR main_program_name_addr
= msym
.value_address ();
824 if (main_program_name_addr
== 0)
825 error (_("Invalid address for Ada main program name."));
827 main_program_name
= target_read_string (main_program_name_addr
, 1024);
828 return main_program_name
.get ();
831 /* The main procedure doesn't seem to be in Ada. */
837 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
840 const struct ada_opname_map ada_opname_table
[] = {
841 {"Oadd", "\"+\"", BINOP_ADD
},
842 {"Osubtract", "\"-\"", BINOP_SUB
},
843 {"Omultiply", "\"*\"", BINOP_MUL
},
844 {"Odivide", "\"/\"", BINOP_DIV
},
845 {"Omod", "\"mod\"", BINOP_MOD
},
846 {"Orem", "\"rem\"", BINOP_REM
},
847 {"Oexpon", "\"**\"", BINOP_EXP
},
848 {"Olt", "\"<\"", BINOP_LESS
},
849 {"Ole", "\"<=\"", BINOP_LEQ
},
850 {"Ogt", "\">\"", BINOP_GTR
},
851 {"Oge", "\">=\"", BINOP_GEQ
},
852 {"Oeq", "\"=\"", BINOP_EQUAL
},
853 {"One", "\"/=\"", BINOP_NOTEQUAL
},
854 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
855 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
856 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
857 {"Oconcat", "\"&\"", BINOP_CONCAT
},
858 {"Oabs", "\"abs\"", UNOP_ABS
},
859 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
860 {"Oadd", "\"+\"", UNOP_PLUS
},
861 {"Osubtract", "\"-\"", UNOP_NEG
},
865 /* If STR is a decoded version of a compiler-provided suffix (like the
866 "[cold]" in "symbol[cold]"), return true. Otherwise, return
870 is_compiler_suffix (const char *str
)
872 gdb_assert (*str
== '[');
874 while (*str
!= '\0' && isalpha (*str
))
876 /* We accept a missing "]" in order to support completion. */
877 return *str
== '\0' || (str
[0] == ']' && str
[1] == '\0');
880 /* Append a non-ASCII character to RESULT. */
882 append_hex_encoded (std::string
&result
, uint32_t one_char
)
884 if (one_char
<= 0xff)
887 result
.append (phex (one_char
, 1));
889 else if (one_char
<= 0xffff)
892 result
.append (phex (one_char
, 2));
896 result
.append ("WW");
897 result
.append (phex (one_char
, 4));
901 /* Return a string that is a copy of the data in STORAGE, with
902 non-ASCII characters replaced by the appropriate hex encoding. A
903 template is used because, for UTF-8, we actually want to work with
904 UTF-32 codepoints. */
907 copy_and_hex_encode (struct obstack
*storage
)
909 const T
*chars
= (T
*) obstack_base (storage
);
910 int num_chars
= obstack_object_size (storage
) / sizeof (T
);
912 for (int i
= 0; i
< num_chars
; ++i
)
914 if (chars
[i
] <= 0x7f)
916 /* The host character set has to be a superset of ASCII, as
917 are all the other character sets we can use. */
918 result
.push_back (chars
[i
]);
921 append_hex_encoded (result
, chars
[i
]);
926 /* The "encoded" form of DECODED, according to GNAT conventions. If
927 THROW_ERRORS, throw an error if invalid operator name is found.
928 Otherwise, return the empty string in that case. */
931 ada_encode_1 (const char *decoded
, bool throw_errors
)
936 std::string encoding_buffer
;
937 bool saw_non_ascii
= false;
938 for (const char *p
= decoded
; *p
!= '\0'; p
+= 1)
940 if ((*p
& 0x80) != 0)
941 saw_non_ascii
= true;
944 encoding_buffer
.append ("__");
945 else if (*p
== '[' && is_compiler_suffix (p
))
947 encoding_buffer
= encoding_buffer
+ "." + (p
+ 1);
948 if (encoding_buffer
.back () == ']')
949 encoding_buffer
.pop_back ();
954 const struct ada_opname_map
*mapping
;
956 for (mapping
= ada_opname_table
;
957 mapping
->encoded
!= NULL
958 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
960 if (mapping
->encoded
== NULL
)
963 error (_("invalid Ada operator name: %s"), p
);
967 encoding_buffer
.append (mapping
->encoded
);
971 encoding_buffer
.push_back (*p
);
974 /* If a non-ASCII character is seen, we must convert it to the
975 appropriate hex form. As this is more expensive, we keep track
976 of whether it is even necessary. */
979 auto_obstack storage
;
980 bool is_utf8
= ada_source_charset
== ada_utf8
;
983 convert_between_encodings
985 is_utf8
? HOST_UTF32
: ada_source_charset
,
986 (const gdb_byte
*) encoding_buffer
.c_str (),
987 encoding_buffer
.length (), 1,
988 &storage
, translit_none
);
990 catch (const gdb_exception
&)
992 static bool warned
= false;
994 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
995 might like to know why. */
999 warning (_("charset conversion failure for '%s'.\n"
1000 "You may have the wrong value for 'set ada source-charset'."),
1001 encoding_buffer
.c_str ());
1004 /* We don't try to recover from errors. */
1005 return encoding_buffer
;
1009 return copy_and_hex_encode
<uint32_t> (&storage
);
1010 return copy_and_hex_encode
<gdb_byte
> (&storage
);
1013 return encoding_buffer
;
1016 /* Find the entry for C in the case-folding table. Return nullptr if
1017 the entry does not cover C. */
1018 static const utf8_entry
*
1019 find_case_fold_entry (uint32_t c
)
1021 auto iter
= std::lower_bound (std::begin (ada_case_fold
),
1022 std::end (ada_case_fold
),
1024 if (iter
== std::end (ada_case_fold
)
1031 /* Return NAME folded to lower case, or, if surrounded by single
1032 quotes, unfolded, but with the quotes stripped away. If
1033 THROW_ON_ERROR is true, encoding failures will throw an exception
1034 rather than emitting a warning. Result good to next call. */
1037 ada_fold_name (gdb::string_view name
, bool throw_on_error
= false)
1039 static std::string fold_storage
;
1041 if (!name
.empty () && name
[0] == '\'')
1042 fold_storage
= gdb::to_string (name
.substr (1, name
.size () - 2));
1045 /* Why convert to UTF-32 and implement our own case-folding,
1046 rather than convert to wchar_t and use the platform's
1047 functions? I'm glad you asked.
1049 The main problem is that GNAT implements an unusual rule for
1050 case folding. For ASCII letters, letters in single-byte
1051 encodings (such as ISO-8859-*), and Unicode letters that fit
1052 in a single byte (i.e., code point is <= 0xff), the letter is
1053 folded to lower case. Other Unicode letters are folded to
1056 This rule means that the code must be able to examine the
1057 value of the character. And, some hosts do not use Unicode
1058 for wchar_t, so examining the value of such characters is
1060 auto_obstack storage
;
1063 convert_between_encodings
1064 (host_charset (), HOST_UTF32
,
1065 (const gdb_byte
*) name
.data (),
1067 &storage
, translit_none
);
1069 catch (const gdb_exception
&)
1074 static bool warned
= false;
1076 /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1077 might like to know why. */
1081 warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1082 "This normally should not happen, please file a bug report."),
1083 gdb::to_string (name
).c_str (), host_charset ());
1086 /* We don't try to recover from errors; just return the
1088 fold_storage
= gdb::to_string (name
);
1089 return fold_storage
.c_str ();
1092 bool is_utf8
= ada_source_charset
== ada_utf8
;
1093 uint32_t *chars
= (uint32_t *) obstack_base (&storage
);
1094 int num_chars
= obstack_object_size (&storage
) / sizeof (uint32_t);
1095 for (int i
= 0; i
< num_chars
; ++i
)
1097 const struct utf8_entry
*entry
= find_case_fold_entry (chars
[i
]);
1098 if (entry
!= nullptr)
1100 uint32_t low
= chars
[i
] + entry
->lower_delta
;
1101 if (!is_utf8
|| low
<= 0xff)
1104 chars
[i
] = chars
[i
] + entry
->upper_delta
;
1108 /* Now convert back to ordinary characters. */
1109 auto_obstack reconverted
;
1112 convert_between_encodings (HOST_UTF32
,
1114 (const gdb_byte
*) chars
,
1115 num_chars
* sizeof (uint32_t),
1119 obstack_1grow (&reconverted
, '\0');
1120 fold_storage
= std::string ((const char *) obstack_base (&reconverted
));
1122 catch (const gdb_exception
&)
1127 static bool warned
= false;
1129 /* Converting back from UTF-32 shouldn't normally fail, but
1130 there are some host encodings without upper/lower
1135 warning (_("could not convert the lower-cased variant of '%s'\n"
1136 "from UTF-32 to the host encoding (%s)."),
1137 gdb::to_string (name
).c_str (), host_charset ());
1140 /* We don't try to recover from errors; just return the
1142 fold_storage
= gdb::to_string (name
);
1146 return fold_storage
.c_str ();
1149 /* The "encoded" form of DECODED, according to GNAT conventions. If
1150 FOLD is true (the default), case-fold any ordinary symbol. Symbols
1151 with <...> quoting are not folded in any case. */
1154 ada_encode (const char *decoded
, bool fold
)
1156 if (fold
&& decoded
[0] != '<')
1157 decoded
= ada_fold_name (decoded
);
1158 return ada_encode_1 (decoded
, true);
1161 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1164 is_lower_alphanum (const char c
)
1166 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1169 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1170 This function saves in LEN the length of that same symbol name but
1171 without either of these suffixes:
1177 These are suffixes introduced by the compiler for entities such as
1178 nested subprogram for instance, in order to avoid name clashes.
1179 They do not serve any purpose for the debugger. */
1182 ada_remove_trailing_digits (const char *encoded
, int *len
)
1184 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1188 while (i
> 0 && isdigit (encoded
[i
]))
1190 if (i
>= 0 && encoded
[i
] == '.')
1192 else if (i
>= 0 && encoded
[i
] == '$')
1194 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1196 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1201 /* Remove the suffix introduced by the compiler for protected object
1205 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1207 /* Remove trailing N. */
1209 /* Protected entry subprograms are broken into two
1210 separate subprograms: The first one is unprotected, and has
1211 a 'N' suffix; the second is the protected version, and has
1212 the 'P' suffix. The second calls the first one after handling
1213 the protection. Since the P subprograms are internally generated,
1214 we leave these names undecoded, giving the user a clue that this
1215 entity is internal. */
1218 && encoded
[*len
- 1] == 'N'
1219 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1223 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1224 then update *LEN to remove the suffix and return the offset of the
1225 character just past the ".". Otherwise, return -1. */
1228 remove_compiler_suffix (const char *encoded
, int *len
)
1230 int offset
= *len
- 1;
1231 while (offset
> 0 && isalpha (encoded
[offset
]))
1233 if (offset
> 0 && encoded
[offset
] == '.')
1241 /* Convert an ASCII hex string to a number. Reads exactly N
1242 characters from STR. Returns true on success, false if one of the
1243 digits was not a hex digit. */
1245 convert_hex (const char *str
, int n
, uint32_t *out
)
1247 uint32_t result
= 0;
1249 for (int i
= 0; i
< n
; ++i
)
1251 if (!isxdigit (str
[i
]))
1254 result
|= fromhex (str
[i
]);
1261 /* Convert a wide character from its ASCII hex representation in STR
1262 (consisting of exactly N characters) to the host encoding,
1263 appending the resulting bytes to OUT. If N==2 and the Ada source
1264 charset is not UTF-8, then hex refers to an encoding in the
1265 ADA_SOURCE_CHARSET; otherwise, use UTF-32. Return true on success.
1266 Return false and do not modify OUT on conversion failure. */
1268 convert_from_hex_encoded (std::string
&out
, const char *str
, int n
)
1272 if (!convert_hex (str
, n
, &value
))
1277 /* In the 'U' case, the hex digits encode the character in the
1278 Ada source charset. However, if the source charset is UTF-8,
1279 this really means it is a single-byte UTF-32 character. */
1280 if (n
== 2 && ada_source_charset
!= ada_utf8
)
1282 gdb_byte one_char
= (gdb_byte
) value
;
1284 convert_between_encodings (ada_source_charset
, host_charset (),
1286 sizeof (one_char
), sizeof (one_char
),
1287 &bytes
, translit_none
);
1290 convert_between_encodings (HOST_UTF32
, host_charset (),
1291 (const gdb_byte
*) &value
,
1292 sizeof (value
), sizeof (value
),
1293 &bytes
, translit_none
);
1294 obstack_1grow (&bytes
, '\0');
1295 out
.append ((const char *) obstack_base (&bytes
));
1297 catch (const gdb_exception
&)
1299 /* On failure, the caller will just let the encoded form
1300 through, which seems basically reasonable. */
1307 /* See ada-lang.h. */
1310 ada_decode (const char *encoded
, bool wrap
, bool operators
)
1316 std::string decoded
;
1319 /* With function descriptors on PPC64, the value of a symbol named
1320 ".FN", if it exists, is the entry point of the function "FN". */
1321 if (encoded
[0] == '.')
1324 /* The name of the Ada main procedure starts with "_ada_".
1325 This prefix is not part of the decoded name, so skip this part
1326 if we see this prefix. */
1327 if (startswith (encoded
, "_ada_"))
1329 /* The "___ghost_" prefix is used for ghost entities. Normally
1330 these aren't preserved but when they are, it's useful to see
1332 if (startswith (encoded
, "___ghost_"))
1335 /* If the name starts with '_', then it is not a properly encoded
1336 name, so do not attempt to decode it. Similarly, if the name
1337 starts with '<', the name should not be decoded. */
1338 if (encoded
[0] == '_' || encoded
[0] == '<')
1341 len0
= strlen (encoded
);
1343 suffix
= remove_compiler_suffix (encoded
, &len0
);
1345 ada_remove_trailing_digits (encoded
, &len0
);
1346 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1348 /* Remove the ___X.* suffix if present. Do not forget to verify that
1349 the suffix is located before the current "end" of ENCODED. We want
1350 to avoid re-matching parts of ENCODED that have previously been
1351 marked as discarded (by decrementing LEN0). */
1352 p
= strstr (encoded
, "___");
1353 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1361 /* Remove any trailing TKB suffix. It tells us that this symbol
1362 is for the body of a task, but that information does not actually
1363 appear in the decoded name. */
1365 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1368 /* Remove any trailing TB suffix. The TB suffix is slightly different
1369 from the TKB suffix because it is used for non-anonymous task
1372 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1375 /* Remove trailing "B" suffixes. */
1376 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1378 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1381 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1383 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1386 while ((i
>= 0 && isdigit (encoded
[i
]))
1387 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1389 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1391 else if (encoded
[i
] == '$')
1395 /* The first few characters that are not alphabetic are not part
1396 of any encoding we use, so we can copy them over verbatim. */
1398 for (i
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1)
1399 decoded
.push_back (encoded
[i
]);
1404 /* Is this a symbol function? */
1405 if (operators
&& at_start_name
&& encoded
[i
] == 'O')
1409 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1411 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1412 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1414 && !isalnum (encoded
[i
+ op_len
]))
1416 decoded
.append (ada_opname_table
[k
].decoded
);
1422 if (ada_opname_table
[k
].encoded
!= NULL
)
1427 /* Replace "TK__" with "__", which will eventually be translated
1428 into "." (just below). */
1430 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1433 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1434 be translated into "." (just below). These are internal names
1435 generated for anonymous blocks inside which our symbol is nested. */
1437 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1438 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1439 && isdigit (encoded
[i
+4]))
1443 while (k
< len0
&& isdigit (encoded
[k
]))
1444 k
++; /* Skip any extra digit. */
1446 /* Double-check that the "__B_{DIGITS}+" sequence we found
1447 is indeed followed by "__". */
1448 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1452 /* Remove _E{DIGITS}+[sb] */
1454 /* Just as for protected object subprograms, there are 2 categories
1455 of subprograms created by the compiler for each entry. The first
1456 one implements the actual entry code, and has a suffix following
1457 the convention above; the second one implements the barrier and
1458 uses the same convention as above, except that the 'E' is replaced
1461 Just as above, we do not decode the name of barrier functions
1462 to give the user a clue that the code he is debugging has been
1463 internally generated. */
1465 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1466 && isdigit (encoded
[i
+2]))
1470 while (k
< len0
&& isdigit (encoded
[k
]))
1474 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1477 /* Just as an extra precaution, make sure that if this
1478 suffix is followed by anything else, it is a '_'.
1479 Otherwise, we matched this sequence by accident. */
1481 || (k
< len0
&& encoded
[k
] == '_'))
1486 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1487 the GNAT front-end in protected object subprograms. */
1490 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1492 /* Backtrack a bit up until we reach either the begining of
1493 the encoded name, or "__". Make sure that we only find
1494 digits or lowercase characters. */
1495 const char *ptr
= encoded
+ i
- 1;
1497 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1500 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1504 if (i
< len0
+ 3 && encoded
[i
] == 'U' && isxdigit (encoded
[i
+ 1]))
1506 if (convert_from_hex_encoded (decoded
, &encoded
[i
+ 1], 2))
1512 else if (i
< len0
+ 5 && encoded
[i
] == 'W' && isxdigit (encoded
[i
+ 1]))
1514 if (convert_from_hex_encoded (decoded
, &encoded
[i
+ 1], 4))
1520 else if (i
< len0
+ 10 && encoded
[i
] == 'W' && encoded
[i
+ 1] == 'W'
1521 && isxdigit (encoded
[i
+ 2]))
1523 if (convert_from_hex_encoded (decoded
, &encoded
[i
+ 2], 8))
1530 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1532 /* This is a X[bn]* sequence not separated from the previous
1533 part of the name with a non-alpha-numeric character (in other
1534 words, immediately following an alpha-numeric character), then
1535 verify that it is placed at the end of the encoded name. If
1536 not, then the encoding is not valid and we should abort the
1537 decoding. Otherwise, just skip it, it is used in body-nested
1541 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1545 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1547 /* Replace '__' by '.'. */
1548 decoded
.push_back ('.');
1554 /* It's a character part of the decoded name, so just copy it
1556 decoded
.push_back (encoded
[i
]);
1561 /* Decoded names should never contain any uppercase character.
1562 Double-check this, and abort the decoding if we find one. */
1566 for (i
= 0; i
< decoded
.length(); ++i
)
1567 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1571 /* If the compiler added a suffix, append it now. */
1573 decoded
= decoded
+ "[" + &encoded
[suffix
] + "]";
1581 if (encoded
[0] == '<')
1584 decoded
= '<' + std::string(encoded
) + '>';
1588 /* Table for keeping permanent unique copies of decoded names. Once
1589 allocated, names in this table are never released. While this is a
1590 storage leak, it should not be significant unless there are massive
1591 changes in the set of decoded names in successive versions of a
1592 symbol table loaded during a single session. */
1593 static struct htab
*decoded_names_store
;
1595 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1596 in the language-specific part of GSYMBOL, if it has not been
1597 previously computed. Tries to save the decoded name in the same
1598 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1599 in any case, the decoded symbol has a lifetime at least that of
1601 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1602 const, but nevertheless modified to a semantically equivalent form
1603 when a decoded name is cached in it. */
1606 ada_decode_symbol (const struct general_symbol_info
*arg
)
1608 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1609 const char **resultp
=
1610 &gsymbol
->language_specific
.demangled_name
;
1612 if (!gsymbol
->ada_mangled
)
1614 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1615 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1617 gsymbol
->ada_mangled
= 1;
1619 if (obstack
!= NULL
)
1620 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1623 /* Sometimes, we can't find a corresponding objfile, in
1624 which case, we put the result on the heap. Since we only
1625 decode when needed, we hope this usually does not cause a
1626 significant memory leak (FIXME). */
1628 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1629 decoded
.c_str (), INSERT
);
1632 *slot
= xstrdup (decoded
.c_str ());
1644 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1645 generated by the GNAT compiler to describe the index type used
1646 for each dimension of an array, check whether it follows the latest
1647 known encoding. If not, fix it up to conform to the latest encoding.
1648 Otherwise, do nothing. This function also does nothing if
1649 INDEX_DESC_TYPE is NULL.
1651 The GNAT encoding used to describe the array index type evolved a bit.
1652 Initially, the information would be provided through the name of each
1653 field of the structure type only, while the type of these fields was
1654 described as unspecified and irrelevant. The debugger was then expected
1655 to perform a global type lookup using the name of that field in order
1656 to get access to the full index type description. Because these global
1657 lookups can be very expensive, the encoding was later enhanced to make
1658 the global lookup unnecessary by defining the field type as being
1659 the full index type description.
1661 The purpose of this routine is to allow us to support older versions
1662 of the compiler by detecting the use of the older encoding, and by
1663 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1664 we essentially replace each field's meaningless type by the associated
1668 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1672 if (index_desc_type
== NULL
)
1674 gdb_assert (index_desc_type
->num_fields () > 0);
1676 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1677 to check one field only, no need to check them all). If not, return
1680 If our INDEX_DESC_TYPE was generated using the older encoding,
1681 the field type should be a meaningless integer type whose name
1682 is not equal to the field name. */
1683 if (index_desc_type
->field (0).type ()->name () != NULL
1684 && strcmp (index_desc_type
->field (0).type ()->name (),
1685 index_desc_type
->field (0).name ()) == 0)
1688 /* Fixup each field of INDEX_DESC_TYPE. */
1689 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1691 const char *name
= index_desc_type
->field (i
).name ();
1692 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1695 index_desc_type
->field (i
).set_type (raw_type
);
1699 /* The desc_* routines return primitive portions of array descriptors
1702 /* The descriptor or array type, if any, indicated by TYPE; removes
1703 level of indirection, if needed. */
1705 static struct type
*
1706 desc_base_type (struct type
*type
)
1710 type
= ada_check_typedef (type
);
1711 if (type
->code () == TYPE_CODE_TYPEDEF
)
1712 type
= ada_typedef_target_type (type
);
1715 && (type
->code () == TYPE_CODE_PTR
1716 || type
->code () == TYPE_CODE_REF
))
1717 return ada_check_typedef (type
->target_type ());
1722 /* True iff TYPE indicates a "thin" array pointer type. */
1725 is_thin_pntr (struct type
*type
)
1728 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1729 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1732 /* The descriptor type for thin pointer type TYPE. */
1734 static struct type
*
1735 thin_descriptor_type (struct type
*type
)
1737 struct type
*base_type
= desc_base_type (type
);
1739 if (base_type
== NULL
)
1741 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1745 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1747 if (alt_type
== NULL
)
1754 /* A pointer to the array data for thin-pointer value VAL. */
1756 static struct value
*
1757 thin_data_pntr (struct value
*val
)
1759 struct type
*type
= ada_check_typedef (val
->type ());
1760 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1762 data_type
= lookup_pointer_type (data_type
);
1764 if (type
->code () == TYPE_CODE_PTR
)
1765 return value_cast (data_type
, value_copy (val
));
1767 return value_from_longest (data_type
, value_address (val
));
1770 /* True iff TYPE indicates a "thick" array pointer type. */
1773 is_thick_pntr (struct type
*type
)
1775 type
= desc_base_type (type
);
1776 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1777 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1780 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1781 pointer to one, the type of its bounds data; otherwise, NULL. */
1783 static struct type
*
1784 desc_bounds_type (struct type
*type
)
1788 type
= desc_base_type (type
);
1792 else if (is_thin_pntr (type
))
1794 type
= thin_descriptor_type (type
);
1797 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1799 return ada_check_typedef (r
);
1801 else if (type
->code () == TYPE_CODE_STRUCT
)
1803 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1805 return ada_check_typedef (ada_check_typedef (r
)->target_type ());
1810 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1811 one, a pointer to its bounds data. Otherwise NULL. */
1813 static struct value
*
1814 desc_bounds (struct value
*arr
)
1816 struct type
*type
= ada_check_typedef (arr
->type ());
1818 if (is_thin_pntr (type
))
1820 struct type
*bounds_type
=
1821 desc_bounds_type (thin_descriptor_type (type
));
1824 if (bounds_type
== NULL
)
1825 error (_("Bad GNAT array descriptor"));
1827 /* NOTE: The following calculation is not really kosher, but
1828 since desc_type is an XVE-encoded type (and shouldn't be),
1829 the correct calculation is a real pain. FIXME (and fix GCC). */
1830 if (type
->code () == TYPE_CODE_PTR
)
1831 addr
= value_as_long (arr
);
1833 addr
= value_address (arr
);
1836 value_from_longest (lookup_pointer_type (bounds_type
),
1837 addr
- bounds_type
->length ());
1840 else if (is_thick_pntr (type
))
1842 struct value
*p_bounds
= value_struct_elt (&arr
, {}, "P_BOUNDS", NULL
,
1843 _("Bad GNAT array descriptor"));
1844 struct type
*p_bounds_type
= p_bounds
->type ();
1847 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1849 struct type
*target_type
= p_bounds_type
->target_type ();
1851 if (target_type
->is_stub ())
1852 p_bounds
= value_cast (lookup_pointer_type
1853 (ada_check_typedef (target_type
)),
1857 error (_("Bad GNAT array descriptor"));
1865 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1866 position of the field containing the address of the bounds data. */
1869 fat_pntr_bounds_bitpos (struct type
*type
)
1871 return desc_base_type (type
)->field (1).loc_bitpos ();
1874 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1875 size of the field containing the address of the bounds data. */
1878 fat_pntr_bounds_bitsize (struct type
*type
)
1880 type
= desc_base_type (type
);
1882 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1883 return TYPE_FIELD_BITSIZE (type
, 1);
1885 return 8 * ada_check_typedef (type
->field (1).type ())->length ();
1888 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1889 pointer to one, the type of its array data (a array-with-no-bounds type);
1890 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1893 static struct type
*
1894 desc_data_target_type (struct type
*type
)
1896 type
= desc_base_type (type
);
1898 /* NOTE: The following is bogus; see comment in desc_bounds. */
1899 if (is_thin_pntr (type
))
1900 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1901 else if (is_thick_pntr (type
))
1903 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1906 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1907 return ada_check_typedef (data_type
->target_type ());
1913 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1916 static struct value
*
1917 desc_data (struct value
*arr
)
1919 struct type
*type
= arr
->type ();
1921 if (is_thin_pntr (type
))
1922 return thin_data_pntr (arr
);
1923 else if (is_thick_pntr (type
))
1924 return value_struct_elt (&arr
, {}, "P_ARRAY", NULL
,
1925 _("Bad GNAT array descriptor"));
1931 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1932 position of the field containing the address of the data. */
1935 fat_pntr_data_bitpos (struct type
*type
)
1937 return desc_base_type (type
)->field (0).loc_bitpos ();
1940 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1941 size of the field containing the address of the data. */
1944 fat_pntr_data_bitsize (struct type
*type
)
1946 type
= desc_base_type (type
);
1948 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1949 return TYPE_FIELD_BITSIZE (type
, 0);
1951 return TARGET_CHAR_BIT
* type
->field (0).type ()->length ();
1954 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1955 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1956 bound, if WHICH is 1. The first bound is I=1. */
1958 static struct value
*
1959 desc_one_bound (struct value
*bounds
, int i
, int which
)
1961 char bound_name
[20];
1962 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1963 which
? 'U' : 'L', i
- 1);
1964 return value_struct_elt (&bounds
, {}, bound_name
, NULL
,
1965 _("Bad GNAT array descriptor bounds"));
1968 /* If BOUNDS is an array-bounds structure type, return the bit position
1969 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1970 bound, if WHICH is 1. The first bound is I=1. */
1973 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1975 return desc_base_type (type
)->field (2 * i
+ which
- 2).loc_bitpos ();
1978 /* If BOUNDS is an array-bounds structure type, return the bit field size
1979 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1980 bound, if WHICH is 1. The first bound is I=1. */
1983 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1985 type
= desc_base_type (type
);
1987 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1988 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1990 return 8 * type
->field (2 * i
+ which
- 2).type ()->length ();
1993 /* If TYPE is the type of an array-bounds structure, the type of its
1994 Ith bound (numbering from 1). Otherwise, NULL. */
1996 static struct type
*
1997 desc_index_type (struct type
*type
, int i
)
1999 type
= desc_base_type (type
);
2001 if (type
->code () == TYPE_CODE_STRUCT
)
2003 char bound_name
[20];
2004 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
2005 return lookup_struct_elt_type (type
, bound_name
, 1);
2011 /* The number of index positions in the array-bounds type TYPE.
2012 Return 0 if TYPE is NULL. */
2015 desc_arity (struct type
*type
)
2017 type
= desc_base_type (type
);
2020 return type
->num_fields () / 2;
2024 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
2025 an array descriptor type (representing an unconstrained array
2029 ada_is_direct_array_type (struct type
*type
)
2033 type
= ada_check_typedef (type
);
2034 return (type
->code () == TYPE_CODE_ARRAY
2035 || ada_is_array_descriptor_type (type
));
2038 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2042 ada_is_array_type (struct type
*type
)
2045 && (type
->code () == TYPE_CODE_PTR
2046 || type
->code () == TYPE_CODE_REF
))
2047 type
= type
->target_type ();
2048 return ada_is_direct_array_type (type
);
2051 /* Non-zero iff TYPE is a simple array type or pointer to one. */
2054 ada_is_simple_array_type (struct type
*type
)
2058 type
= ada_check_typedef (type
);
2059 return (type
->code () == TYPE_CODE_ARRAY
2060 || (type
->code () == TYPE_CODE_PTR
2061 && (ada_check_typedef (type
->target_type ())->code ()
2062 == TYPE_CODE_ARRAY
)));
2065 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
2068 ada_is_array_descriptor_type (struct type
*type
)
2070 struct type
*data_type
= desc_data_target_type (type
);
2074 type
= ada_check_typedef (type
);
2075 return (data_type
!= NULL
2076 && data_type
->code () == TYPE_CODE_ARRAY
2077 && desc_arity (desc_bounds_type (type
)) > 0);
2080 /* Non-zero iff type is a partially mal-formed GNAT array
2081 descriptor. FIXME: This is to compensate for some problems with
2082 debugging output from GNAT. Re-examine periodically to see if it
2086 ada_is_bogus_array_descriptor (struct type
*type
)
2090 && type
->code () == TYPE_CODE_STRUCT
2091 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
2092 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
2093 && !ada_is_array_descriptor_type (type
);
2097 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2098 (fat pointer) returns the type of the array data described---specifically,
2099 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
2100 in from the descriptor; otherwise, they are left unspecified. If
2101 the ARR denotes a null array descriptor and BOUNDS is non-zero,
2102 returns NULL. The result is simply the type of ARR if ARR is not
2105 static struct type
*
2106 ada_type_of_array (struct value
*arr
, int bounds
)
2108 if (ada_is_constrained_packed_array_type (arr
->type ()))
2109 return decode_constrained_packed_array_type (arr
->type ());
2111 if (!ada_is_array_descriptor_type (arr
->type ()))
2112 return arr
->type ();
2116 struct type
*array_type
=
2117 ada_check_typedef (desc_data_target_type (arr
->type ()));
2119 if (ada_is_unconstrained_packed_array_type (arr
->type ()))
2120 TYPE_FIELD_BITSIZE (array_type
, 0) =
2121 decode_packed_array_bitsize (arr
->type ());
2127 struct type
*elt_type
;
2129 struct value
*descriptor
;
2131 elt_type
= ada_array_element_type (arr
->type (), -1);
2132 arity
= ada_array_arity (arr
->type ());
2134 if (elt_type
== NULL
|| arity
== 0)
2135 return ada_check_typedef (arr
->type ());
2137 descriptor
= desc_bounds (arr
);
2138 if (value_as_long (descriptor
) == 0)
2142 struct type
*range_type
= alloc_type_copy (arr
->type ());
2143 struct type
*array_type
= alloc_type_copy (arr
->type ());
2144 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
2145 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
2148 create_static_range_type (range_type
, low
->type (),
2149 longest_to_int (value_as_long (low
)),
2150 longest_to_int (value_as_long (high
)));
2151 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
2153 if (ada_is_unconstrained_packed_array_type (arr
->type ()))
2155 /* We need to store the element packed bitsize, as well as
2156 recompute the array size, because it was previously
2157 computed based on the unpacked element size. */
2158 LONGEST lo
= value_as_long (low
);
2159 LONGEST hi
= value_as_long (high
);
2161 TYPE_FIELD_BITSIZE (elt_type
, 0) =
2162 decode_packed_array_bitsize (arr
->type ());
2163 /* If the array has no element, then the size is already
2164 zero, and does not need to be recomputed. */
2168 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
2170 array_type
->set_length ((array_bitsize
+ 7) / 8);
2175 return lookup_pointer_type (elt_type
);
2179 /* If ARR does not represent an array, returns ARR unchanged.
2180 Otherwise, returns either a standard GDB array with bounds set
2181 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2182 GDB array. Returns NULL if ARR is a null fat pointer. */
2185 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2187 if (ada_is_array_descriptor_type (arr
->type ()))
2189 struct type
*arrType
= ada_type_of_array (arr
, 1);
2191 if (arrType
== NULL
)
2193 return value_cast (arrType
, value_copy (desc_data (arr
)));
2195 else if (ada_is_constrained_packed_array_type (arr
->type ()))
2196 return decode_constrained_packed_array (arr
);
2201 /* If ARR does not represent an array, returns ARR unchanged.
2202 Otherwise, returns a standard GDB array describing ARR (which may
2203 be ARR itself if it already is in the proper form). */
2206 ada_coerce_to_simple_array (struct value
*arr
)
2208 if (ada_is_array_descriptor_type (arr
->type ()))
2210 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2213 error (_("Bounds unavailable for null array pointer."));
2214 return value_ind (arrVal
);
2216 else if (ada_is_constrained_packed_array_type (arr
->type ()))
2217 return decode_constrained_packed_array (arr
);
2222 /* If TYPE represents a GNAT array type, return it translated to an
2223 ordinary GDB array type (possibly with BITSIZE fields indicating
2224 packing). For other types, is the identity. */
2227 ada_coerce_to_simple_array_type (struct type
*type
)
2229 if (ada_is_constrained_packed_array_type (type
))
2230 return decode_constrained_packed_array_type (type
);
2232 if (ada_is_array_descriptor_type (type
))
2233 return ada_check_typedef (desc_data_target_type (type
));
2238 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2241 ada_is_gnat_encoded_packed_array_type (struct type
*type
)
2245 type
= desc_base_type (type
);
2246 type
= ada_check_typedef (type
);
2248 ada_type_name (type
) != NULL
2249 && strstr (ada_type_name (type
), "___XP") != NULL
;
2252 /* Non-zero iff TYPE represents a standard GNAT constrained
2253 packed-array type. */
2256 ada_is_constrained_packed_array_type (struct type
*type
)
2258 return ada_is_gnat_encoded_packed_array_type (type
)
2259 && !ada_is_array_descriptor_type (type
);
2262 /* Non-zero iff TYPE represents an array descriptor for a
2263 unconstrained packed-array type. */
2266 ada_is_unconstrained_packed_array_type (struct type
*type
)
2268 if (!ada_is_array_descriptor_type (type
))
2271 if (ada_is_gnat_encoded_packed_array_type (type
))
2274 /* If we saw GNAT encodings, then the above code is sufficient.
2275 However, with minimal encodings, we will just have a thick
2277 if (is_thick_pntr (type
))
2279 type
= desc_base_type (type
);
2280 /* The structure's first field is a pointer to an array, so this
2281 fetches the array type. */
2282 type
= type
->field (0).type ()->target_type ();
2283 if (type
->code () == TYPE_CODE_TYPEDEF
)
2284 type
= ada_typedef_target_type (type
);
2285 /* Now we can see if the array elements are packed. */
2286 return TYPE_FIELD_BITSIZE (type
, 0) > 0;
2292 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2293 type, or if it is an ordinary (non-Gnat-encoded) packed array. */
2296 ada_is_any_packed_array_type (struct type
*type
)
2298 return (ada_is_constrained_packed_array_type (type
)
2299 || (type
->code () == TYPE_CODE_ARRAY
2300 && TYPE_FIELD_BITSIZE (type
, 0) % 8 != 0));
2303 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2304 return the size of its elements in bits. */
2307 decode_packed_array_bitsize (struct type
*type
)
2309 const char *raw_name
;
2313 /* Access to arrays implemented as fat pointers are encoded as a typedef
2314 of the fat pointer type. We need the name of the fat pointer type
2315 to do the decoding, so strip the typedef layer. */
2316 if (type
->code () == TYPE_CODE_TYPEDEF
)
2317 type
= ada_typedef_target_type (type
);
2319 raw_name
= ada_type_name (ada_check_typedef (type
));
2321 raw_name
= ada_type_name (desc_base_type (type
));
2326 tail
= strstr (raw_name
, "___XP");
2327 if (tail
== nullptr)
2329 gdb_assert (is_thick_pntr (type
));
2330 /* The structure's first field is a pointer to an array, so this
2331 fetches the array type. */
2332 type
= type
->field (0).type ()->target_type ();
2333 /* Now we can see if the array elements are packed. */
2334 return TYPE_FIELD_BITSIZE (type
, 0);
2337 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2340 (_("could not understand bit size information on packed array"));
2347 /* Given that TYPE is a standard GDB array type with all bounds filled
2348 in, and that the element size of its ultimate scalar constituents
2349 (that is, either its elements, or, if it is an array of arrays, its
2350 elements' elements, etc.) is *ELT_BITS, return an identical type,
2351 but with the bit sizes of its elements (and those of any
2352 constituent arrays) recorded in the BITSIZE components of its
2353 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2356 Note that, for arrays whose index type has an XA encoding where
2357 a bound references a record discriminant, getting that discriminant,
2358 and therefore the actual value of that bound, is not possible
2359 because none of the given parameters gives us access to the record.
2360 This function assumes that it is OK in the context where it is being
2361 used to return an array whose bounds are still dynamic and where
2362 the length is arbitrary. */
2364 static struct type
*
2365 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2367 struct type
*new_elt_type
;
2368 struct type
*new_type
;
2369 struct type
*index_type_desc
;
2370 struct type
*index_type
;
2371 LONGEST low_bound
, high_bound
;
2373 type
= ada_check_typedef (type
);
2374 if (type
->code () != TYPE_CODE_ARRAY
)
2377 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2378 if (index_type_desc
)
2379 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2382 index_type
= type
->index_type ();
2384 new_type
= alloc_type_copy (type
);
2386 constrained_packed_array_type (ada_check_typedef (type
->target_type ()),
2388 create_array_type (new_type
, new_elt_type
, index_type
);
2389 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2390 new_type
->set_name (ada_type_name (type
));
2392 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2393 && is_dynamic_type (check_typedef (index_type
)))
2394 || !get_discrete_bounds (index_type
, &low_bound
, &high_bound
))
2395 low_bound
= high_bound
= 0;
2396 if (high_bound
< low_bound
)
2399 new_type
->set_length (0);
2403 *elt_bits
*= (high_bound
- low_bound
+ 1);
2404 new_type
->set_length ((*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
);
2407 new_type
->set_is_fixed_instance (true);
2411 /* The array type encoded by TYPE, where
2412 ada_is_constrained_packed_array_type (TYPE). */
2414 static struct type
*
2415 decode_constrained_packed_array_type (struct type
*type
)
2417 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2420 struct type
*shadow_type
;
2424 raw_name
= ada_type_name (desc_base_type (type
));
2429 name
= (char *) alloca (strlen (raw_name
) + 1);
2430 tail
= strstr (raw_name
, "___XP");
2431 type
= desc_base_type (type
);
2433 memcpy (name
, raw_name
, tail
- raw_name
);
2434 name
[tail
- raw_name
] = '\000';
2436 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2438 if (shadow_type
== NULL
)
2440 lim_warning (_("could not find bounds information on packed array"));
2443 shadow_type
= check_typedef (shadow_type
);
2445 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2447 lim_warning (_("could not understand bounds "
2448 "information on packed array"));
2452 bits
= decode_packed_array_bitsize (type
);
2453 return constrained_packed_array_type (shadow_type
, &bits
);
2456 /* Helper function for decode_constrained_packed_array. Set the field
2457 bitsize on a series of packed arrays. Returns the number of
2458 elements in TYPE. */
2461 recursively_update_array_bitsize (struct type
*type
)
2463 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2466 if (!get_discrete_bounds (type
->index_type (), &low
, &high
)
2469 LONGEST our_len
= high
- low
+ 1;
2471 struct type
*elt_type
= type
->target_type ();
2472 if (elt_type
->code () == TYPE_CODE_ARRAY
)
2474 LONGEST elt_len
= recursively_update_array_bitsize (elt_type
);
2475 LONGEST elt_bitsize
= elt_len
* TYPE_FIELD_BITSIZE (elt_type
, 0);
2476 TYPE_FIELD_BITSIZE (type
, 0) = elt_bitsize
;
2478 type
->set_length (((our_len
* elt_bitsize
+ HOST_CHAR_BIT
- 1)
2485 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2486 array, returns a simple array that denotes that array. Its type is a
2487 standard GDB array type except that the BITSIZEs of the array
2488 target types are set to the number of bits in each element, and the
2489 type length is set appropriately. */
2491 static struct value
*
2492 decode_constrained_packed_array (struct value
*arr
)
2496 /* If our value is a pointer, then dereference it. Likewise if
2497 the value is a reference. Make sure that this operation does not
2498 cause the target type to be fixed, as this would indirectly cause
2499 this array to be decoded. The rest of the routine assumes that
2500 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2501 and "value_ind" routines to perform the dereferencing, as opposed
2502 to using "ada_coerce_ref" or "ada_value_ind". */
2503 arr
= coerce_ref (arr
);
2504 if (ada_check_typedef (arr
->type ())->code () == TYPE_CODE_PTR
)
2505 arr
= value_ind (arr
);
2507 type
= decode_constrained_packed_array_type (arr
->type ());
2510 error (_("can't unpack array"));
2514 /* Decoding the packed array type could not correctly set the field
2515 bitsizes for any dimension except the innermost, because the
2516 bounds may be variable and were not passed to that function. So,
2517 we further resolve the array bounds here and then update the
2519 const gdb_byte
*valaddr
= value_contents_for_printing (arr
).data ();
2520 CORE_ADDR address
= value_address (arr
);
2521 gdb::array_view
<const gdb_byte
> view
2522 = gdb::make_array_view (valaddr
, type
->length ());
2523 type
= resolve_dynamic_type (type
, view
, address
);
2524 recursively_update_array_bitsize (type
);
2526 if (type_byte_order (arr
->type ()) == BFD_ENDIAN_BIG
2527 && ada_is_modular_type (arr
->type ()))
2529 /* This is a (right-justified) modular type representing a packed
2530 array with no wrapper. In order to interpret the value through
2531 the (left-justified) packed array type we just built, we must
2532 first left-justify it. */
2533 int bit_size
, bit_pos
;
2536 mod
= ada_modulus (arr
->type ()) - 1;
2543 bit_pos
= HOST_CHAR_BIT
* arr
->type ()->length () - bit_size
;
2544 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2545 bit_pos
/ HOST_CHAR_BIT
,
2546 bit_pos
% HOST_CHAR_BIT
,
2551 return coerce_unspec_val_to_type (arr
, type
);
2555 /* The value of the element of packed array ARR at the ARITY indices
2556 given in IND. ARR must be a simple array. */
2558 static struct value
*
2559 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2562 int bits
, elt_off
, bit_off
;
2563 long elt_total_bit_offset
;
2564 struct type
*elt_type
;
2568 elt_total_bit_offset
= 0;
2569 elt_type
= ada_check_typedef (arr
->type ());
2570 for (i
= 0; i
< arity
; i
+= 1)
2572 if (elt_type
->code () != TYPE_CODE_ARRAY
2573 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2575 (_("attempt to do packed indexing of "
2576 "something other than a packed array"));
2579 struct type
*range_type
= elt_type
->index_type ();
2580 LONGEST lowerbound
, upperbound
;
2583 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2585 lim_warning (_("don't know bounds of array"));
2586 lowerbound
= upperbound
= 0;
2589 idx
= pos_atr (ind
[i
]);
2590 if (idx
< lowerbound
|| idx
> upperbound
)
2591 lim_warning (_("packed array index %ld out of bounds"),
2593 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2594 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2595 elt_type
= ada_check_typedef (elt_type
->target_type ());
2598 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2599 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2601 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2606 /* Non-zero iff TYPE includes negative integer values. */
2609 has_negatives (struct type
*type
)
2611 switch (type
->code ())
2616 return !type
->is_unsigned ();
2617 case TYPE_CODE_RANGE
:
2618 return type
->bounds ()->low
.const_val () - type
->bounds ()->bias
< 0;
2622 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2623 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2624 the unpacked buffer.
2626 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2627 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2629 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2632 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2634 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2637 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2638 gdb_byte
*unpacked
, int unpacked_len
,
2639 int is_big_endian
, int is_signed_type
,
2642 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2643 int src_idx
; /* Index into the source area */
2644 int src_bytes_left
; /* Number of source bytes left to process. */
2645 int srcBitsLeft
; /* Number of source bits left to move */
2646 int unusedLS
; /* Number of bits in next significant
2647 byte of source that are unused */
2649 int unpacked_idx
; /* Index into the unpacked buffer */
2650 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2652 unsigned long accum
; /* Staging area for bits being transferred */
2653 int accumSize
; /* Number of meaningful bits in accum */
2656 /* Transmit bytes from least to most significant; delta is the direction
2657 the indices move. */
2658 int delta
= is_big_endian
? -1 : 1;
2660 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2662 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2663 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2664 bit_size
, unpacked_len
);
2666 srcBitsLeft
= bit_size
;
2667 src_bytes_left
= src_len
;
2668 unpacked_bytes_left
= unpacked_len
;
2673 src_idx
= src_len
- 1;
2675 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2679 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2685 unpacked_idx
= unpacked_len
- 1;
2689 /* Non-scalar values must be aligned at a byte boundary... */
2691 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2692 /* ... And are placed at the beginning (most-significant) bytes
2694 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2695 unpacked_bytes_left
= unpacked_idx
+ 1;
2700 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2702 src_idx
= unpacked_idx
= 0;
2703 unusedLS
= bit_offset
;
2706 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2711 while (src_bytes_left
> 0)
2713 /* Mask for removing bits of the next source byte that are not
2714 part of the value. */
2715 unsigned int unusedMSMask
=
2716 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2718 /* Sign-extend bits for this byte. */
2719 unsigned int signMask
= sign
& ~unusedMSMask
;
2722 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2723 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2724 if (accumSize
>= HOST_CHAR_BIT
)
2726 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2727 accumSize
-= HOST_CHAR_BIT
;
2728 accum
>>= HOST_CHAR_BIT
;
2729 unpacked_bytes_left
-= 1;
2730 unpacked_idx
+= delta
;
2732 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2734 src_bytes_left
-= 1;
2737 while (unpacked_bytes_left
> 0)
2739 accum
|= sign
<< accumSize
;
2740 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2741 accumSize
-= HOST_CHAR_BIT
;
2744 accum
>>= HOST_CHAR_BIT
;
2745 unpacked_bytes_left
-= 1;
2746 unpacked_idx
+= delta
;
2750 /* Create a new value of type TYPE from the contents of OBJ starting
2751 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2752 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2753 assigning through the result will set the field fetched from.
2754 VALADDR is ignored unless OBJ is NULL, in which case,
2755 VALADDR+OFFSET must address the start of storage containing the
2756 packed value. The value returned in this case is never an lval.
2757 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2760 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2761 long offset
, int bit_offset
, int bit_size
,
2765 const gdb_byte
*src
; /* First byte containing data to unpack */
2767 const int is_scalar
= is_scalar_type (type
);
2768 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2769 gdb::byte_vector staging
;
2771 type
= ada_check_typedef (type
);
2774 src
= valaddr
+ offset
;
2776 src
= value_contents (obj
).data () + offset
;
2778 if (is_dynamic_type (type
))
2780 /* The length of TYPE might by dynamic, so we need to resolve
2781 TYPE in order to know its actual size, which we then use
2782 to create the contents buffer of the value we return.
2783 The difficulty is that the data containing our object is
2784 packed, and therefore maybe not at a byte boundary. So, what
2785 we do, is unpack the data into a byte-aligned buffer, and then
2786 use that buffer as our object's value for resolving the type. */
2787 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2788 staging
.resize (staging_len
);
2790 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2791 staging
.data (), staging
.size (),
2792 is_big_endian
, has_negatives (type
),
2794 type
= resolve_dynamic_type (type
, staging
, 0);
2795 if (type
->length () < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2797 /* This happens when the length of the object is dynamic,
2798 and is actually smaller than the space reserved for it.
2799 For instance, in an array of variant records, the bit_size
2800 we're given is the array stride, which is constant and
2801 normally equal to the maximum size of its element.
2802 But, in reality, each element only actually spans a portion
2804 bit_size
= type
->length () * HOST_CHAR_BIT
;
2810 v
= allocate_value (type
);
2811 src
= valaddr
+ offset
;
2813 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2815 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2818 v
= value_at (type
, value_address (obj
) + offset
);
2819 buf
= (gdb_byte
*) alloca (src_len
);
2820 read_memory (value_address (v
), buf
, src_len
);
2825 v
= allocate_value (type
);
2826 src
= value_contents (obj
).data () + offset
;
2831 long new_offset
= offset
;
2833 set_value_component_location (v
, obj
);
2834 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2835 set_value_bitsize (v
, bit_size
);
2836 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2839 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2841 set_value_offset (v
, new_offset
);
2843 /* Also set the parent value. This is needed when trying to
2844 assign a new value (in inferior memory). */
2845 set_value_parent (v
, obj
);
2848 set_value_bitsize (v
, bit_size
);
2849 unpacked
= value_contents_writeable (v
).data ();
2853 memset (unpacked
, 0, type
->length ());
2857 if (staging
.size () == type
->length ())
2859 /* Small short-cut: If we've unpacked the data into a buffer
2860 of the same size as TYPE's length, then we can reuse that,
2861 instead of doing the unpacking again. */
2862 memcpy (unpacked
, staging
.data (), staging
.size ());
2865 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2866 unpacked
, type
->length (),
2867 is_big_endian
, has_negatives (type
), is_scalar
);
2872 /* Store the contents of FROMVAL into the location of TOVAL.
2873 Return a new value with the location of TOVAL and contents of
2874 FROMVAL. Handles assignment into packed fields that have
2875 floating-point or non-scalar types. */
2877 static struct value
*
2878 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2880 struct type
*type
= toval
->type ();
2881 int bits
= value_bitsize (toval
);
2883 toval
= ada_coerce_ref (toval
);
2884 fromval
= ada_coerce_ref (fromval
);
2886 if (ada_is_direct_array_type (toval
->type ()))
2887 toval
= ada_coerce_to_simple_array (toval
);
2888 if (ada_is_direct_array_type (fromval
->type ()))
2889 fromval
= ada_coerce_to_simple_array (fromval
);
2891 if (!deprecated_value_modifiable (toval
))
2892 error (_("Left operand of assignment is not a modifiable lvalue."));
2894 if (VALUE_LVAL (toval
) == lval_memory
2896 && (type
->code () == TYPE_CODE_FLT
2897 || type
->code () == TYPE_CODE_STRUCT
))
2899 int len
= (value_bitpos (toval
)
2900 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2902 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2904 CORE_ADDR to_addr
= value_address (toval
);
2906 if (type
->code () == TYPE_CODE_FLT
)
2907 fromval
= value_cast (type
, fromval
);
2909 read_memory (to_addr
, buffer
, len
);
2910 from_size
= value_bitsize (fromval
);
2912 from_size
= fromval
->type ()->length () * TARGET_CHAR_BIT
;
2914 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2915 ULONGEST from_offset
= 0;
2916 if (is_big_endian
&& is_scalar_type (fromval
->type ()))
2917 from_offset
= from_size
- bits
;
2918 copy_bitwise (buffer
, value_bitpos (toval
),
2919 value_contents (fromval
).data (), from_offset
,
2920 bits
, is_big_endian
);
2921 write_memory_with_notification (to_addr
, buffer
, len
);
2923 val
= value_copy (toval
);
2924 memcpy (value_contents_raw (val
).data (),
2925 value_contents (fromval
).data (),
2927 deprecated_set_value_type (val
, type
);
2932 return value_assign (toval
, fromval
);
2936 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2937 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2938 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2939 COMPONENT, and not the inferior's memory. The current contents
2940 of COMPONENT are ignored.
2942 Although not part of the initial design, this function also works
2943 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2944 had a null address, and COMPONENT had an address which is equal to
2945 its offset inside CONTAINER. */
2948 value_assign_to_component (struct value
*container
, struct value
*component
,
2951 LONGEST offset_in_container
=
2952 (LONGEST
) (value_address (component
) - value_address (container
));
2953 int bit_offset_in_container
=
2954 value_bitpos (component
) - value_bitpos (container
);
2957 val
= value_cast (component
->type (), val
);
2959 if (value_bitsize (component
) == 0)
2960 bits
= TARGET_CHAR_BIT
* component
->type ()->length ();
2962 bits
= value_bitsize (component
);
2964 if (type_byte_order (container
->type ()) == BFD_ENDIAN_BIG
)
2968 if (is_scalar_type (check_typedef (component
->type ())))
2970 = component
->type ()->length () * TARGET_CHAR_BIT
- bits
;
2973 copy_bitwise ((value_contents_writeable (container
).data ()
2974 + offset_in_container
),
2975 value_bitpos (container
) + bit_offset_in_container
,
2976 value_contents (val
).data (), src_offset
, bits
, 1);
2979 copy_bitwise ((value_contents_writeable (container
).data ()
2980 + offset_in_container
),
2981 value_bitpos (container
) + bit_offset_in_container
,
2982 value_contents (val
).data (), 0, bits
, 0);
2985 /* Determine if TYPE is an access to an unconstrained array. */
2988 ada_is_access_to_unconstrained_array (struct type
*type
)
2990 return (type
->code () == TYPE_CODE_TYPEDEF
2991 && is_thick_pntr (ada_typedef_target_type (type
)));
2994 /* The value of the element of array ARR at the ARITY indices given in IND.
2995 ARR may be either a simple array, GNAT array descriptor, or pointer
2999 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
3003 struct type
*elt_type
;
3005 elt
= ada_coerce_to_simple_array (arr
);
3007 elt_type
= ada_check_typedef (elt
->type ());
3008 if (elt_type
->code () == TYPE_CODE_ARRAY
3009 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
3010 return value_subscript_packed (elt
, arity
, ind
);
3012 for (k
= 0; k
< arity
; k
+= 1)
3014 struct type
*saved_elt_type
= elt_type
->target_type ();
3016 if (elt_type
->code () != TYPE_CODE_ARRAY
)
3017 error (_("too many subscripts (%d expected)"), k
);
3019 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
3021 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
3022 && elt
->type ()->code () != TYPE_CODE_TYPEDEF
)
3024 /* The element is a typedef to an unconstrained array,
3025 except that the value_subscript call stripped the
3026 typedef layer. The typedef layer is GNAT's way to
3027 specify that the element is, at the source level, an
3028 access to the unconstrained array, rather than the
3029 unconstrained array. So, we need to restore that
3030 typedef layer, which we can do by forcing the element's
3031 type back to its original type. Otherwise, the returned
3032 value is going to be printed as the array, rather
3033 than as an access. Another symptom of the same issue
3034 would be that an expression trying to dereference the
3035 element would also be improperly rejected. */
3036 deprecated_set_value_type (elt
, saved_elt_type
);
3039 elt_type
= ada_check_typedef (elt
->type ());
3045 /* Assuming ARR is a pointer to a GDB array, the value of the element
3046 of *ARR at the ARITY indices given in IND.
3047 Does not read the entire array into memory.
3049 Note: Unlike what one would expect, this function is used instead of
3050 ada_value_subscript for basically all non-packed array types. The reason
3051 for this is that a side effect of doing our own pointer arithmetics instead
3052 of relying on value_subscript is that there is no implicit typedef peeling.
3053 This is important for arrays of array accesses, where it allows us to
3054 preserve the fact that the array's element is an array access, where the
3055 access part os encoded in a typedef layer. */
3057 static struct value
*
3058 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
3061 struct value
*array_ind
= ada_value_ind (arr
);
3063 = check_typedef (value_enclosing_type (array_ind
));
3065 if (type
->code () == TYPE_CODE_ARRAY
3066 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
3067 return value_subscript_packed (array_ind
, arity
, ind
);
3069 for (k
= 0; k
< arity
; k
+= 1)
3073 if (type
->code () != TYPE_CODE_ARRAY
)
3074 error (_("too many subscripts (%d expected)"), k
);
3075 arr
= value_cast (lookup_pointer_type (type
->target_type ()),
3077 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
3078 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
3079 type
= type
->target_type ();
3082 return value_ind (arr
);
3085 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3086 actual type of ARRAY_PTR is ignored), returns the Ada slice of
3087 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
3088 this array is LOW, as per Ada rules. */
3089 static struct value
*
3090 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
3093 struct type
*type0
= ada_check_typedef (type
);
3094 struct type
*base_index_type
= type0
->index_type ()->target_type ();
3095 struct type
*index_type
3096 = create_static_range_type (NULL
, base_index_type
, low
, high
);
3097 struct type
*slice_type
= create_array_type_with_stride
3098 (NULL
, type0
->target_type (), index_type
,
3099 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
3100 TYPE_FIELD_BITSIZE (type0
, 0));
3101 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
3102 gdb::optional
<LONGEST
> base_low_pos
, low_pos
;
3105 low_pos
= discrete_position (base_index_type
, low
);
3106 base_low_pos
= discrete_position (base_index_type
, base_low
);
3108 if (!low_pos
.has_value () || !base_low_pos
.has_value ())
3110 warning (_("unable to get positions in slice, use bounds instead"));
3112 base_low_pos
= base_low
;
3115 ULONGEST stride
= TYPE_FIELD_BITSIZE (slice_type
, 0) / 8;
3117 stride
= type0
->target_type ()->length ();
3119 base
= value_as_address (array_ptr
) + (*low_pos
- *base_low_pos
) * stride
;
3120 return value_at_lazy (slice_type
, base
);
3124 static struct value
*
3125 ada_value_slice (struct value
*array
, int low
, int high
)
3127 struct type
*type
= ada_check_typedef (array
->type ());
3128 struct type
*base_index_type
= type
->index_type ()->target_type ();
3129 struct type
*index_type
3130 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
3131 struct type
*slice_type
= create_array_type_with_stride
3132 (NULL
, type
->target_type (), index_type
,
3133 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
3134 TYPE_FIELD_BITSIZE (type
, 0));
3135 gdb::optional
<LONGEST
> low_pos
, high_pos
;
3138 low_pos
= discrete_position (base_index_type
, low
);
3139 high_pos
= discrete_position (base_index_type
, high
);
3141 if (!low_pos
.has_value () || !high_pos
.has_value ())
3143 warning (_("unable to get positions in slice, use bounds instead"));
3148 return value_cast (slice_type
,
3149 value_slice (array
, low
, *high_pos
- *low_pos
+ 1));
3152 /* If type is a record type in the form of a standard GNAT array
3153 descriptor, returns the number of dimensions for type. If arr is a
3154 simple array, returns the number of "array of"s that prefix its
3155 type designation. Otherwise, returns 0. */
3158 ada_array_arity (struct type
*type
)
3165 type
= desc_base_type (type
);
3168 if (type
->code () == TYPE_CODE_STRUCT
)
3169 return desc_arity (desc_bounds_type (type
));
3171 while (type
->code () == TYPE_CODE_ARRAY
)
3174 type
= ada_check_typedef (type
->target_type ());
3180 /* If TYPE is a record type in the form of a standard GNAT array
3181 descriptor or a simple array type, returns the element type for
3182 TYPE after indexing by NINDICES indices, or by all indices if
3183 NINDICES is -1. Otherwise, returns NULL. */
3186 ada_array_element_type (struct type
*type
, int nindices
)
3188 type
= desc_base_type (type
);
3190 if (type
->code () == TYPE_CODE_STRUCT
)
3193 struct type
*p_array_type
;
3195 p_array_type
= desc_data_target_type (type
);
3197 k
= ada_array_arity (type
);
3201 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3202 if (nindices
>= 0 && k
> nindices
)
3204 while (k
> 0 && p_array_type
!= NULL
)
3206 p_array_type
= ada_check_typedef (p_array_type
->target_type ());
3209 return p_array_type
;
3211 else if (type
->code () == TYPE_CODE_ARRAY
)
3213 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
3215 type
= type
->target_type ();
3216 /* A multi-dimensional array is represented using a sequence
3217 of array types. If one of these types has a name, then
3218 it is not another dimension of the outer array, but
3219 rather the element type of the outermost array. */
3220 if (type
->name () != nullptr)
3230 /* See ada-lang.h. */
3233 ada_index_type (struct type
*type
, int n
, const char *name
)
3235 struct type
*result_type
;
3237 type
= desc_base_type (type
);
3239 if (n
< 0 || n
> ada_array_arity (type
))
3240 error (_("invalid dimension number to '%s"), name
);
3242 if (ada_is_simple_array_type (type
))
3246 for (i
= 1; i
< n
; i
+= 1)
3248 type
= ada_check_typedef (type
);
3249 type
= type
->target_type ();
3251 result_type
= ada_check_typedef (type
)->index_type ()->target_type ();
3252 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3253 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3254 perhaps stabsread.c would make more sense. */
3255 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
3260 result_type
= desc_index_type (desc_bounds_type (type
), n
);
3261 if (result_type
== NULL
)
3262 error (_("attempt to take bound of something that is not an array"));
3268 /* Given that arr is an array type, returns the lower bound of the
3269 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3270 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3271 array-descriptor type. It works for other arrays with bounds supplied
3272 by run-time quantities other than discriminants. */
3275 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
3277 struct type
*type
, *index_type_desc
, *index_type
;
3280 gdb_assert (which
== 0 || which
== 1);
3282 if (ada_is_constrained_packed_array_type (arr_type
))
3283 arr_type
= decode_constrained_packed_array_type (arr_type
);
3285 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
3286 return (LONGEST
) - which
;
3288 if (arr_type
->code () == TYPE_CODE_PTR
)
3289 type
= arr_type
->target_type ();
3293 if (type
->is_fixed_instance ())
3295 /* The array has already been fixed, so we do not need to
3296 check the parallel ___XA type again. That encoding has
3297 already been applied, so ignore it now. */
3298 index_type_desc
= NULL
;
3302 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3303 ada_fixup_array_indexes_type (index_type_desc
);
3306 if (index_type_desc
!= NULL
)
3307 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
3311 struct type
*elt_type
= check_typedef (type
);
3313 for (i
= 1; i
< n
; i
++)
3314 elt_type
= check_typedef (elt_type
->target_type ());
3316 index_type
= elt_type
->index_type ();
3320 (LONGEST
) (which
== 0
3321 ? ada_discrete_type_low_bound (index_type
)
3322 : ada_discrete_type_high_bound (index_type
));
3325 /* Given that arr is an array value, returns the lower bound of the
3326 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3327 WHICH is 1. This routine will also work for arrays with bounds
3328 supplied by run-time quantities other than discriminants. */
3331 ada_array_bound (struct value
*arr
, int n
, int which
)
3333 struct type
*arr_type
;
3335 if (check_typedef (arr
->type ())->code () == TYPE_CODE_PTR
)
3336 arr
= value_ind (arr
);
3337 arr_type
= value_enclosing_type (arr
);
3339 if (ada_is_constrained_packed_array_type (arr_type
))
3340 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3341 else if (ada_is_simple_array_type (arr_type
))
3342 return ada_array_bound_from_type (arr_type
, n
, which
);
3344 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3347 /* Given that arr is an array value, returns the length of the
3348 nth index. This routine will also work for arrays with bounds
3349 supplied by run-time quantities other than discriminants.
3350 Does not work for arrays indexed by enumeration types with representation
3351 clauses at the moment. */
3354 ada_array_length (struct value
*arr
, int n
)
3356 struct type
*arr_type
, *index_type
;
3359 if (check_typedef (arr
->type ())->code () == TYPE_CODE_PTR
)
3360 arr
= value_ind (arr
);
3361 arr_type
= value_enclosing_type (arr
);
3363 if (ada_is_constrained_packed_array_type (arr_type
))
3364 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3366 if (ada_is_simple_array_type (arr_type
))
3368 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3369 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3373 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3374 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3377 arr_type
= check_typedef (arr_type
);
3378 index_type
= ada_index_type (arr_type
, n
, "length");
3379 if (index_type
!= NULL
)
3381 struct type
*base_type
;
3382 if (index_type
->code () == TYPE_CODE_RANGE
)
3383 base_type
= index_type
->target_type ();
3385 base_type
= index_type
;
3387 low
= pos_atr (value_from_longest (base_type
, low
));
3388 high
= pos_atr (value_from_longest (base_type
, high
));
3390 return high
- low
+ 1;
3393 /* An array whose type is that of ARR_TYPE (an array type), with
3394 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3395 less than LOW, then LOW-1 is used. */
3397 static struct value
*
3398 empty_array (struct type
*arr_type
, int low
, int high
)
3400 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3401 struct type
*index_type
3402 = create_static_range_type
3403 (NULL
, arr_type0
->index_type ()->target_type (), low
,
3404 high
< low
? low
- 1 : high
);
3405 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3407 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3411 /* Name resolution */
3413 /* The "decoded" name for the user-definable Ada operator corresponding
3417 ada_decoded_op_name (enum exp_opcode op
)
3421 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3423 if (ada_opname_table
[i
].op
== op
)
3424 return ada_opname_table
[i
].decoded
;
3426 error (_("Could not find operator name for opcode"));
3429 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3430 in a listing of choices during disambiguation (see sort_choices, below).
3431 The idea is that overloadings of a subprogram name from the
3432 same package should sort in their source order. We settle for ordering
3433 such symbols by their trailing number (__N or $N). */
3436 encoded_ordered_before (const char *N0
, const char *N1
)
3440 else if (N0
== NULL
)
3446 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3448 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3450 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3451 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3456 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3459 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3461 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3462 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3464 return (strcmp (N0
, N1
) < 0);
3468 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3472 sort_choices (struct block_symbol syms
[], int nsyms
)
3476 for (i
= 1; i
< nsyms
; i
+= 1)
3478 struct block_symbol sym
= syms
[i
];
3481 for (j
= i
- 1; j
>= 0; j
-= 1)
3483 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3484 sym
.symbol
->linkage_name ()))
3486 syms
[j
+ 1] = syms
[j
];
3492 /* Whether GDB should display formals and return types for functions in the
3493 overloads selection menu. */
3494 static bool print_signatures
= true;
3496 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3497 all but functions, the signature is just the name of the symbol. For
3498 functions, this is the name of the function, the list of types for formals
3499 and the return type (if any). */
3502 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3503 const struct type_print_options
*flags
)
3505 struct type
*type
= sym
->type ();
3507 gdb_printf (stream
, "%s", sym
->print_name ());
3508 if (!print_signatures
3510 || type
->code () != TYPE_CODE_FUNC
)
3513 if (type
->num_fields () > 0)
3517 gdb_printf (stream
, " (");
3518 for (i
= 0; i
< type
->num_fields (); ++i
)
3521 gdb_printf (stream
, "; ");
3522 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3525 gdb_printf (stream
, ")");
3527 if (type
->target_type () != NULL
3528 && type
->target_type ()->code () != TYPE_CODE_VOID
)
3530 gdb_printf (stream
, " return ");
3531 ada_print_type (type
->target_type (), NULL
, stream
, -1, 0, flags
);
3535 /* Read and validate a set of numeric choices from the user in the
3536 range 0 .. N_CHOICES-1. Place the results in increasing
3537 order in CHOICES[0 .. N-1], and return N.
3539 The user types choices as a sequence of numbers on one line
3540 separated by blanks, encoding them as follows:
3542 + A choice of 0 means to cancel the selection, throwing an error.
3543 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3544 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3546 The user is not allowed to choose more than MAX_RESULTS values.
3548 ANNOTATION_SUFFIX, if present, is used to annotate the input
3549 prompts (for use with the -f switch). */
3552 get_selections (int *choices
, int n_choices
, int max_results
,
3553 int is_all_choice
, const char *annotation_suffix
)
3558 int first_choice
= is_all_choice
? 2 : 1;
3560 prompt
= getenv ("PS2");
3565 args
= command_line_input (buffer
, prompt
, annotation_suffix
);
3568 error_no_arg (_("one or more choice numbers"));
3572 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3573 order, as given in args. Choices are validated. */
3579 args
= skip_spaces (args
);
3580 if (*args
== '\0' && n_chosen
== 0)
3581 error_no_arg (_("one or more choice numbers"));
3582 else if (*args
== '\0')
3585 choice
= strtol (args
, &args2
, 10);
3586 if (args
== args2
|| choice
< 0
3587 || choice
> n_choices
+ first_choice
- 1)
3588 error (_("Argument must be choice number"));
3592 error (_("cancelled"));
3594 if (choice
< first_choice
)
3596 n_chosen
= n_choices
;
3597 for (j
= 0; j
< n_choices
; j
+= 1)
3601 choice
-= first_choice
;
3603 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3607 if (j
< 0 || choice
!= choices
[j
])
3611 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3612 choices
[k
+ 1] = choices
[k
];
3613 choices
[j
+ 1] = choice
;
3618 if (n_chosen
> max_results
)
3619 error (_("Select no more than %d of the above"), max_results
);
3624 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3625 by asking the user (if necessary), returning the number selected,
3626 and setting the first elements of SYMS items. Error if no symbols
3629 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3630 to be re-integrated one of these days. */
3633 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3636 int *chosen
= XALLOCAVEC (int , nsyms
);
3638 int first_choice
= (max_results
== 1) ? 1 : 2;
3639 const char *select_mode
= multiple_symbols_select_mode ();
3641 if (max_results
< 1)
3642 error (_("Request to select 0 symbols!"));
3646 if (select_mode
== multiple_symbols_cancel
)
3648 canceled because the command is ambiguous\n\
3649 See set/show multiple-symbol."));
3651 /* If select_mode is "all", then return all possible symbols.
3652 Only do that if more than one symbol can be selected, of course.
3653 Otherwise, display the menu as usual. */
3654 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3657 gdb_printf (_("[0] cancel\n"));
3658 if (max_results
> 1)
3659 gdb_printf (_("[1] all\n"));
3661 sort_choices (syms
, nsyms
);
3663 for (i
= 0; i
< nsyms
; i
+= 1)
3665 if (syms
[i
].symbol
== NULL
)
3668 if (syms
[i
].symbol
->aclass () == LOC_BLOCK
)
3670 struct symtab_and_line sal
=
3671 find_function_start_sal (syms
[i
].symbol
, 1);
3673 gdb_printf ("[%d] ", i
+ first_choice
);
3674 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3675 &type_print_raw_options
);
3676 if (sal
.symtab
== NULL
)
3677 gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3678 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3682 styled_string (file_name_style
.style (),
3683 symtab_to_filename_for_display (sal
.symtab
)),
3690 (syms
[i
].symbol
->aclass () == LOC_CONST
3691 && syms
[i
].symbol
->type () != NULL
3692 && syms
[i
].symbol
->type ()->code () == TYPE_CODE_ENUM
);
3693 struct symtab
*symtab
= NULL
;
3695 if (syms
[i
].symbol
->is_objfile_owned ())
3696 symtab
= syms
[i
].symbol
->symtab ();
3698 if (syms
[i
].symbol
->line () != 0 && symtab
!= NULL
)
3700 gdb_printf ("[%d] ", i
+ first_choice
);
3701 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3702 &type_print_raw_options
);
3703 gdb_printf (_(" at %s:%d\n"),
3704 symtab_to_filename_for_display (symtab
),
3705 syms
[i
].symbol
->line ());
3707 else if (is_enumeral
3708 && syms
[i
].symbol
->type ()->name () != NULL
)
3710 gdb_printf (("[%d] "), i
+ first_choice
);
3711 ada_print_type (syms
[i
].symbol
->type (), NULL
,
3712 gdb_stdout
, -1, 0, &type_print_raw_options
);
3713 gdb_printf (_("'(%s) (enumeral)\n"),
3714 syms
[i
].symbol
->print_name ());
3718 gdb_printf ("[%d] ", i
+ first_choice
);
3719 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3720 &type_print_raw_options
);
3723 gdb_printf (is_enumeral
3724 ? _(" in %s (enumeral)\n")
3726 symtab_to_filename_for_display (symtab
));
3728 gdb_printf (is_enumeral
3729 ? _(" (enumeral)\n")
3735 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3738 for (i
= 0; i
< n_chosen
; i
+= 1)
3739 syms
[i
] = syms
[chosen
[i
]];
3744 /* See ada-lang.h. */
3747 ada_find_operator_symbol (enum exp_opcode op
, bool parse_completion
,
3748 int nargs
, value
*argvec
[])
3750 if (possible_user_operator_p (op
, argvec
))
3752 std::vector
<struct block_symbol
> candidates
3753 = ada_lookup_symbol_list (ada_decoded_op_name (op
),
3756 int i
= ada_resolve_function (candidates
, argvec
,
3757 nargs
, ada_decoded_op_name (op
), NULL
,
3760 return candidates
[i
];
3765 /* See ada-lang.h. */
3768 ada_resolve_funcall (struct symbol
*sym
, const struct block
*block
,
3769 struct type
*context_type
,
3770 bool parse_completion
,
3771 int nargs
, value
*argvec
[],
3772 innermost_block_tracker
*tracker
)
3774 std::vector
<struct block_symbol
> candidates
3775 = ada_lookup_symbol_list (sym
->linkage_name (), block
, VAR_DOMAIN
);
3778 if (candidates
.size () == 1)
3782 i
= ada_resolve_function
3785 sym
->linkage_name (),
3786 context_type
, parse_completion
);
3788 error (_("Could not find a match for %s"), sym
->print_name ());
3791 tracker
->update (candidates
[i
]);
3792 return candidates
[i
];
3795 /* Resolve a mention of a name where the context type is an
3796 enumeration type. */
3799 ada_resolve_enum (std::vector
<struct block_symbol
> &syms
,
3800 const char *name
, struct type
*context_type
,
3801 bool parse_completion
)
3803 gdb_assert (context_type
->code () == TYPE_CODE_ENUM
);
3804 context_type
= ada_check_typedef (context_type
);
3806 for (int i
= 0; i
< syms
.size (); ++i
)
3808 /* We already know the name matches, so we're just looking for
3809 an element of the correct enum type. */
3810 if (ada_check_typedef (syms
[i
].symbol
->type ()) == context_type
)
3814 error (_("No name '%s' in enumeration type '%s'"), name
,
3815 ada_type_name (context_type
));
3818 /* See ada-lang.h. */
3821 ada_resolve_variable (struct symbol
*sym
, const struct block
*block
,
3822 struct type
*context_type
,
3823 bool parse_completion
,
3825 innermost_block_tracker
*tracker
)
3827 std::vector
<struct block_symbol
> candidates
3828 = ada_lookup_symbol_list (sym
->linkage_name (), block
, VAR_DOMAIN
);
3830 if (std::any_of (candidates
.begin (),
3832 [] (block_symbol
&bsym
)
3834 switch (bsym
.symbol
->aclass ())
3839 case LOC_REGPARM_ADDR
:
3848 /* Types tend to get re-introduced locally, so if there
3849 are any local symbols that are not types, first filter
3853 (candidates
.begin (),
3855 [] (block_symbol
&bsym
)
3857 return bsym
.symbol
->aclass () == LOC_TYPEDEF
;
3862 /* Filter out artificial symbols. */
3865 (candidates
.begin (),
3867 [] (block_symbol
&bsym
)
3869 return bsym
.symbol
->is_artificial ();
3874 if (candidates
.empty ())
3875 error (_("No definition found for %s"), sym
->print_name ());
3876 else if (candidates
.size () == 1)
3878 else if (context_type
!= nullptr
3879 && context_type
->code () == TYPE_CODE_ENUM
)
3880 i
= ada_resolve_enum (candidates
, sym
->linkage_name (), context_type
,
3882 else if (deprocedure_p
&& !is_nonfunction (candidates
))
3884 i
= ada_resolve_function
3885 (candidates
, NULL
, 0,
3886 sym
->linkage_name (),
3887 context_type
, parse_completion
);
3889 error (_("Could not find a match for %s"), sym
->print_name ());
3893 gdb_printf (_("Multiple matches for %s\n"), sym
->print_name ());
3894 user_select_syms (candidates
.data (), candidates
.size (), 1);
3898 tracker
->update (candidates
[i
]);
3899 return candidates
[i
];
3902 /* Return non-zero if formal type FTYPE matches actual type ATYPE. */
3903 /* The term "match" here is rather loose. The match is heuristic and
3907 ada_type_match (struct type
*ftype
, struct type
*atype
)
3909 ftype
= ada_check_typedef (ftype
);
3910 atype
= ada_check_typedef (atype
);
3912 if (ftype
->code () == TYPE_CODE_REF
)
3913 ftype
= ftype
->target_type ();
3914 if (atype
->code () == TYPE_CODE_REF
)
3915 atype
= atype
->target_type ();
3917 switch (ftype
->code ())
3920 return ftype
->code () == atype
->code ();
3922 if (atype
->code () != TYPE_CODE_PTR
)
3924 atype
= atype
->target_type ();
3925 /* This can only happen if the actual argument is 'null'. */
3926 if (atype
->code () == TYPE_CODE_INT
&& atype
->length () == 0)
3928 return ada_type_match (ftype
->target_type (), atype
);
3930 case TYPE_CODE_ENUM
:
3931 case TYPE_CODE_RANGE
:
3932 switch (atype
->code ())
3935 case TYPE_CODE_ENUM
:
3936 case TYPE_CODE_RANGE
:
3942 case TYPE_CODE_ARRAY
:
3943 return (atype
->code () == TYPE_CODE_ARRAY
3944 || ada_is_array_descriptor_type (atype
));
3946 case TYPE_CODE_STRUCT
:
3947 if (ada_is_array_descriptor_type (ftype
))
3948 return (atype
->code () == TYPE_CODE_ARRAY
3949 || ada_is_array_descriptor_type (atype
));
3951 return (atype
->code () == TYPE_CODE_STRUCT
3952 && !ada_is_array_descriptor_type (atype
));
3954 case TYPE_CODE_UNION
:
3956 return (atype
->code () == ftype
->code ());
3960 /* Return non-zero if the formals of FUNC "sufficiently match" the
3961 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3962 may also be an enumeral, in which case it is treated as a 0-
3963 argument function. */
3966 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3969 struct type
*func_type
= func
->type ();
3971 if (func
->aclass () == LOC_CONST
3972 && func_type
->code () == TYPE_CODE_ENUM
)
3973 return (n_actuals
== 0);
3974 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3977 if (func_type
->num_fields () != n_actuals
)
3980 for (i
= 0; i
< n_actuals
; i
+= 1)
3982 if (actuals
[i
] == NULL
)
3986 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3987 struct type
*atype
= ada_check_typedef (actuals
[i
]->type ());
3989 if (!ada_type_match (ftype
, atype
))
3996 /* False iff function type FUNC_TYPE definitely does not produce a value
3997 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3998 FUNC_TYPE is not a valid function type with a non-null return type
3999 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
4002 return_match (struct type
*func_type
, struct type
*context_type
)
4004 struct type
*return_type
;
4006 if (func_type
== NULL
)
4009 if (func_type
->code () == TYPE_CODE_FUNC
)
4010 return_type
= get_base_type (func_type
->target_type ());
4012 return_type
= get_base_type (func_type
);
4013 if (return_type
== NULL
)
4016 context_type
= get_base_type (context_type
);
4018 if (return_type
->code () == TYPE_CODE_ENUM
)
4019 return context_type
== NULL
|| return_type
== context_type
;
4020 else if (context_type
== NULL
)
4021 return return_type
->code () != TYPE_CODE_VOID
;
4023 return return_type
->code () == context_type
->code ();
4027 /* Returns the index in SYMS that contains the symbol for the
4028 function (if any) that matches the types of the NARGS arguments in
4029 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
4030 that returns that type, then eliminate matches that don't. If
4031 CONTEXT_TYPE is void and there is at least one match that does not
4032 return void, eliminate all matches that do.
4034 Asks the user if there is more than one match remaining. Returns -1
4035 if there is no such symbol or none is selected. NAME is used
4036 solely for messages. May re-arrange and modify SYMS in
4037 the process; the index returned is for the modified vector. */
4040 ada_resolve_function (std::vector
<struct block_symbol
> &syms
,
4041 struct value
**args
, int nargs
,
4042 const char *name
, struct type
*context_type
,
4043 bool parse_completion
)
4047 int m
; /* Number of hits */
4050 /* In the first pass of the loop, we only accept functions matching
4051 context_type. If none are found, we add a second pass of the loop
4052 where every function is accepted. */
4053 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
4055 for (k
= 0; k
< syms
.size (); k
+= 1)
4057 struct type
*type
= ada_check_typedef (syms
[k
].symbol
->type ());
4059 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
4060 && (fallback
|| return_match (type
, context_type
)))
4068 /* If we got multiple matches, ask the user which one to use. Don't do this
4069 interactive thing during completion, though, as the purpose of the
4070 completion is providing a list of all possible matches. Prompting the
4071 user to filter it down would be completely unexpected in this case. */
4074 else if (m
> 1 && !parse_completion
)
4076 gdb_printf (_("Multiple matches for %s\n"), name
);
4077 user_select_syms (syms
.data (), m
, 1);
4083 /* Type-class predicates */
4085 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4089 numeric_type_p (struct type
*type
)
4095 switch (type
->code ())
4099 case TYPE_CODE_FIXED_POINT
:
4101 case TYPE_CODE_RANGE
:
4102 return (type
== type
->target_type ()
4103 || numeric_type_p (type
->target_type ()));
4110 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4113 integer_type_p (struct type
*type
)
4119 switch (type
->code ())
4123 case TYPE_CODE_RANGE
:
4124 return (type
== type
->target_type ()
4125 || integer_type_p (type
->target_type ()));
4132 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4135 scalar_type_p (struct type
*type
)
4141 switch (type
->code ())
4144 case TYPE_CODE_RANGE
:
4145 case TYPE_CODE_ENUM
:
4147 case TYPE_CODE_FIXED_POINT
:
4155 /* True iff TYPE is discrete, as defined in the Ada Reference Manual.
4156 This essentially means one of (INT, RANGE, ENUM) -- but note that
4157 "enum" includes character and boolean as well. */
4160 discrete_type_p (struct type
*type
)
4166 switch (type
->code ())
4169 case TYPE_CODE_RANGE
:
4170 case TYPE_CODE_ENUM
:
4171 case TYPE_CODE_BOOL
:
4172 case TYPE_CODE_CHAR
:
4180 /* Returns non-zero if OP with operands in the vector ARGS could be
4181 a user-defined function. Errs on the side of pre-defined operators
4182 (i.e., result 0). */
4185 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4187 struct type
*type0
=
4188 (args
[0] == NULL
) ? NULL
: ada_check_typedef (args
[0]->type ());
4189 struct type
*type1
=
4190 (args
[1] == NULL
) ? NULL
: ada_check_typedef (args
[1]->type ());
4204 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4208 case BINOP_BITWISE_AND
:
4209 case BINOP_BITWISE_IOR
:
4210 case BINOP_BITWISE_XOR
:
4211 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4214 case BINOP_NOTEQUAL
:
4219 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4222 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4225 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4229 case UNOP_LOGICAL_NOT
:
4231 return (!numeric_type_p (type0
));
4240 1. In the following, we assume that a renaming type's name may
4241 have an ___XD suffix. It would be nice if this went away at some
4243 2. We handle both the (old) purely type-based representation of
4244 renamings and the (new) variable-based encoding. At some point,
4245 it is devoutly to be hoped that the former goes away
4246 (FIXME: hilfinger-2007-07-09).
4247 3. Subprogram renamings are not implemented, although the XRS
4248 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4250 /* If SYM encodes a renaming,
4252 <renaming> renames <renamed entity>,
4254 sets *LEN to the length of the renamed entity's name,
4255 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4256 the string describing the subcomponent selected from the renamed
4257 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4258 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4259 are undefined). Otherwise, returns a value indicating the category
4260 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4261 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4262 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4263 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4264 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4265 may be NULL, in which case they are not assigned.
4267 [Currently, however, GCC does not generate subprogram renamings.] */
4269 enum ada_renaming_category
4270 ada_parse_renaming (struct symbol
*sym
,
4271 const char **renamed_entity
, int *len
,
4272 const char **renaming_expr
)
4274 enum ada_renaming_category kind
;
4279 return ADA_NOT_RENAMING
;
4280 switch (sym
->aclass ())
4283 return ADA_NOT_RENAMING
;
4287 case LOC_OPTIMIZED_OUT
:
4288 info
= strstr (sym
->linkage_name (), "___XR");
4290 return ADA_NOT_RENAMING
;
4294 kind
= ADA_OBJECT_RENAMING
;
4298 kind
= ADA_EXCEPTION_RENAMING
;
4302 kind
= ADA_PACKAGE_RENAMING
;
4306 kind
= ADA_SUBPROGRAM_RENAMING
;
4310 return ADA_NOT_RENAMING
;
4314 if (renamed_entity
!= NULL
)
4315 *renamed_entity
= info
;
4316 suffix
= strstr (info
, "___XE");
4317 if (suffix
== NULL
|| suffix
== info
)
4318 return ADA_NOT_RENAMING
;
4320 *len
= strlen (info
) - strlen (suffix
);
4322 if (renaming_expr
!= NULL
)
4323 *renaming_expr
= suffix
;
4327 /* Compute the value of the given RENAMING_SYM, which is expected to
4328 be a symbol encoding a renaming expression. BLOCK is the block
4329 used to evaluate the renaming. */
4331 static struct value
*
4332 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4333 const struct block
*block
)
4335 const char *sym_name
;
4337 sym_name
= renaming_sym
->linkage_name ();
4338 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4339 return evaluate_expression (expr
.get ());
4343 /* Evaluation: Function Calls */
4345 /* Return an lvalue containing the value VAL. This is the identity on
4346 lvalues, and otherwise has the side-effect of allocating memory
4347 in the inferior where a copy of the value contents is copied. */
4349 static struct value
*
4350 ensure_lval (struct value
*val
)
4352 if (VALUE_LVAL (val
) == not_lval
4353 || VALUE_LVAL (val
) == lval_internalvar
)
4355 int len
= ada_check_typedef (val
->type ())->length ();
4356 const CORE_ADDR addr
=
4357 value_as_long (value_allocate_space_in_inferior (len
));
4359 VALUE_LVAL (val
) = lval_memory
;
4360 set_value_address (val
, addr
);
4361 write_memory (addr
, value_contents (val
).data (), len
);
4367 /* Given ARG, a value of type (pointer or reference to a)*
4368 structure/union, extract the component named NAME from the ultimate
4369 target structure/union and return it as a value with its
4372 The routine searches for NAME among all members of the structure itself
4373 and (recursively) among all members of any wrapper members
4376 If NO_ERR, then simply return NULL in case of error, rather than
4379 static struct value
*
4380 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4382 struct type
*t
, *t1
;
4387 t1
= t
= ada_check_typedef (arg
->type ());
4388 if (t
->code () == TYPE_CODE_REF
)
4390 t1
= t
->target_type ();
4393 t1
= ada_check_typedef (t1
);
4394 if (t1
->code () == TYPE_CODE_PTR
)
4396 arg
= coerce_ref (arg
);
4401 while (t
->code () == TYPE_CODE_PTR
)
4403 t1
= t
->target_type ();
4406 t1
= ada_check_typedef (t1
);
4407 if (t1
->code () == TYPE_CODE_PTR
)
4409 arg
= value_ind (arg
);
4416 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4420 v
= ada_search_struct_field (name
, arg
, 0, t
);
4423 int bit_offset
, bit_size
, byte_offset
;
4424 struct type
*field_type
;
4427 if (t
->code () == TYPE_CODE_PTR
)
4428 address
= value_address (ada_value_ind (arg
));
4430 address
= value_address (ada_coerce_ref (arg
));
4432 /* Check to see if this is a tagged type. We also need to handle
4433 the case where the type is a reference to a tagged type, but
4434 we have to be careful to exclude pointers to tagged types.
4435 The latter should be shown as usual (as a pointer), whereas
4436 a reference should mostly be transparent to the user. */
4438 if (ada_is_tagged_type (t1
, 0)
4439 || (t1
->code () == TYPE_CODE_REF
4440 && ada_is_tagged_type (t1
->target_type (), 0)))
4442 /* We first try to find the searched field in the current type.
4443 If not found then let's look in the fixed type. */
4445 if (!find_struct_field (name
, t1
, 0,
4446 nullptr, nullptr, nullptr,
4455 /* Convert to fixed type in all cases, so that we have proper
4456 offsets to each field in unconstrained record types. */
4457 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4458 address
, NULL
, check_tag
);
4460 /* Resolve the dynamic type as well. */
4461 arg
= value_from_contents_and_address (t1
, nullptr, address
);
4464 if (find_struct_field (name
, t1
, 0,
4465 &field_type
, &byte_offset
, &bit_offset
,
4470 if (t
->code () == TYPE_CODE_REF
)
4471 arg
= ada_coerce_ref (arg
);
4473 arg
= ada_value_ind (arg
);
4474 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4475 bit_offset
, bit_size
,
4479 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4483 if (v
!= NULL
|| no_err
)
4486 error (_("There is no member named %s."), name
);
4492 error (_("Attempt to extract a component of "
4493 "a value that is not a record."));
4496 /* Return the value ACTUAL, converted to be an appropriate value for a
4497 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4498 allocating any necessary descriptors (fat pointers), or copies of
4499 values not residing in memory, updating it as needed. */
4502 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4504 struct type
*actual_type
= ada_check_typedef (actual
->type ());
4505 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4506 struct type
*formal_target
=
4507 formal_type
->code () == TYPE_CODE_PTR
4508 ? ada_check_typedef (formal_type
->target_type ()) : formal_type
;
4509 struct type
*actual_target
=
4510 actual_type
->code () == TYPE_CODE_PTR
4511 ? ada_check_typedef (actual_type
->target_type ()) : actual_type
;
4513 if (ada_is_array_descriptor_type (formal_target
)
4514 && actual_target
->code () == TYPE_CODE_ARRAY
)
4515 return make_array_descriptor (formal_type
, actual
);
4516 else if (formal_type
->code () == TYPE_CODE_PTR
4517 || formal_type
->code () == TYPE_CODE_REF
)
4519 struct value
*result
;
4521 if (formal_target
->code () == TYPE_CODE_ARRAY
4522 && ada_is_array_descriptor_type (actual_target
))
4523 result
= desc_data (actual
);
4524 else if (formal_type
->code () != TYPE_CODE_PTR
)
4526 if (VALUE_LVAL (actual
) != lval_memory
)
4530 actual_type
= ada_check_typedef (actual
->type ());
4531 val
= allocate_value (actual_type
);
4532 copy (value_contents (actual
), value_contents_raw (val
));
4533 actual
= ensure_lval (val
);
4535 result
= value_addr (actual
);
4539 return value_cast_pointers (formal_type
, result
, 0);
4541 else if (actual_type
->code () == TYPE_CODE_PTR
)
4542 return ada_value_ind (actual
);
4543 else if (ada_is_aligner_type (formal_type
))
4545 /* We need to turn this parameter into an aligner type
4547 struct value
*aligner
= allocate_value (formal_type
);
4548 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4550 value_assign_to_component (aligner
, component
, actual
);
4557 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4558 type TYPE. This is usually an inefficient no-op except on some targets
4559 (such as AVR) where the representation of a pointer and an address
4563 value_pointer (struct value
*value
, struct type
*type
)
4565 unsigned len
= type
->length ();
4566 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4569 addr
= value_address (value
);
4570 gdbarch_address_to_pointer (type
->arch (), type
, buf
, addr
);
4571 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4576 /* Push a descriptor of type TYPE for array value ARR on the stack at
4577 *SP, updating *SP to reflect the new descriptor. Return either
4578 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4579 to-descriptor type rather than a descriptor type), a struct value *
4580 representing a pointer to this descriptor. */
4582 static struct value
*
4583 make_array_descriptor (struct type
*type
, struct value
*arr
)
4585 struct type
*bounds_type
= desc_bounds_type (type
);
4586 struct type
*desc_type
= desc_base_type (type
);
4587 struct value
*descriptor
= allocate_value (desc_type
);
4588 struct value
*bounds
= allocate_value (bounds_type
);
4591 for (i
= ada_array_arity (ada_check_typedef (arr
->type ()));
4594 modify_field (bounds
->type (),
4595 value_contents_writeable (bounds
).data (),
4596 ada_array_bound (arr
, i
, 0),
4597 desc_bound_bitpos (bounds_type
, i
, 0),
4598 desc_bound_bitsize (bounds_type
, i
, 0));
4599 modify_field (bounds
->type (),
4600 value_contents_writeable (bounds
).data (),
4601 ada_array_bound (arr
, i
, 1),
4602 desc_bound_bitpos (bounds_type
, i
, 1),
4603 desc_bound_bitsize (bounds_type
, i
, 1));
4606 bounds
= ensure_lval (bounds
);
4608 modify_field (descriptor
->type (),
4609 value_contents_writeable (descriptor
).data (),
4610 value_pointer (ensure_lval (arr
),
4611 desc_type
->field (0).type ()),
4612 fat_pntr_data_bitpos (desc_type
),
4613 fat_pntr_data_bitsize (desc_type
));
4615 modify_field (descriptor
->type (),
4616 value_contents_writeable (descriptor
).data (),
4617 value_pointer (bounds
,
4618 desc_type
->field (1).type ()),
4619 fat_pntr_bounds_bitpos (desc_type
),
4620 fat_pntr_bounds_bitsize (desc_type
));
4622 descriptor
= ensure_lval (descriptor
);
4624 if (type
->code () == TYPE_CODE_PTR
)
4625 return value_addr (descriptor
);
4630 /* Symbol Cache Module */
4632 /* Performance measurements made as of 2010-01-15 indicate that
4633 this cache does bring some noticeable improvements. Depending
4634 on the type of entity being printed, the cache can make it as much
4635 as an order of magnitude faster than without it.
4637 The descriptive type DWARF extension has significantly reduced
4638 the need for this cache, at least when DWARF is being used. However,
4639 even in this case, some expensive name-based symbol searches are still
4640 sometimes necessary - to find an XVZ variable, mostly. */
4642 /* Return the symbol cache associated to the given program space PSPACE.
4643 If not allocated for this PSPACE yet, allocate and initialize one. */
4645 static struct ada_symbol_cache
*
4646 ada_get_symbol_cache (struct program_space
*pspace
)
4648 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4650 if (pspace_data
->sym_cache
== nullptr)
4651 pspace_data
->sym_cache
.reset (new ada_symbol_cache
);
4653 return pspace_data
->sym_cache
.get ();
4656 /* Clear all entries from the symbol cache. */
4659 ada_clear_symbol_cache ()
4661 struct ada_pspace_data
*pspace_data
4662 = get_ada_pspace_data (current_program_space
);
4664 if (pspace_data
->sym_cache
!= nullptr)
4665 pspace_data
->sym_cache
.reset ();
4668 /* Search our cache for an entry matching NAME and DOMAIN.
4669 Return it if found, or NULL otherwise. */
4671 static struct cache_entry
**
4672 find_entry (const char *name
, domain_enum domain
)
4674 struct ada_symbol_cache
*sym_cache
4675 = ada_get_symbol_cache (current_program_space
);
4676 int h
= msymbol_hash (name
) % HASH_SIZE
;
4677 struct cache_entry
**e
;
4679 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4681 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4687 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4688 Return 1 if found, 0 otherwise.
4690 If an entry was found and SYM is not NULL, set *SYM to the entry's
4691 SYM. Same principle for BLOCK if not NULL. */
4694 lookup_cached_symbol (const char *name
, domain_enum domain
,
4695 struct symbol
**sym
, const struct block
**block
)
4697 struct cache_entry
**e
= find_entry (name
, domain
);
4704 *block
= (*e
)->block
;
4708 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4709 in domain DOMAIN, save this result in our symbol cache. */
4712 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4713 const struct block
*block
)
4715 struct ada_symbol_cache
*sym_cache
4716 = ada_get_symbol_cache (current_program_space
);
4718 struct cache_entry
*e
;
4720 /* Symbols for builtin types don't have a block.
4721 For now don't cache such symbols. */
4722 if (sym
!= NULL
&& !sym
->is_objfile_owned ())
4725 /* If the symbol is a local symbol, then do not cache it, as a search
4726 for that symbol depends on the context. To determine whether
4727 the symbol is local or not, we check the block where we found it
4728 against the global and static blocks of its associated symtab. */
4731 const blockvector
&bv
= *sym
->symtab ()->compunit ()->blockvector ();
4733 if (bv
.global_block () != block
&& bv
.static_block () != block
)
4737 h
= msymbol_hash (name
) % HASH_SIZE
;
4738 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4739 e
->next
= sym_cache
->root
[h
];
4740 sym_cache
->root
[h
] = e
;
4741 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4749 /* Return the symbol name match type that should be used used when
4750 searching for all symbols matching LOOKUP_NAME.
4752 LOOKUP_NAME is expected to be a symbol name after transformation
4755 static symbol_name_match_type
4756 name_match_type_from_name (const char *lookup_name
)
4758 return (strstr (lookup_name
, "__") == NULL
4759 ? symbol_name_match_type::WILD
4760 : symbol_name_match_type::FULL
);
4763 /* Return the result of a standard (literal, C-like) lookup of NAME in
4764 given DOMAIN, visible from lexical block BLOCK. */
4766 static struct symbol
*
4767 standard_lookup (const char *name
, const struct block
*block
,
4770 /* Initialize it just to avoid a GCC false warning. */
4771 struct block_symbol sym
= {};
4773 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4775 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4776 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4781 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4782 in the symbol fields of SYMS. We treat enumerals as functions,
4783 since they contend in overloading in the same way. */
4785 is_nonfunction (const std::vector
<struct block_symbol
> &syms
)
4787 for (const block_symbol
&sym
: syms
)
4788 if (sym
.symbol
->type ()->code () != TYPE_CODE_FUNC
4789 && (sym
.symbol
->type ()->code () != TYPE_CODE_ENUM
4790 || sym
.symbol
->aclass () != LOC_CONST
))
4796 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4797 struct types. Otherwise, they may not. */
4800 equiv_types (struct type
*type0
, struct type
*type1
)
4804 if (type0
== NULL
|| type1
== NULL
4805 || type0
->code () != type1
->code ())
4807 if ((type0
->code () == TYPE_CODE_STRUCT
4808 || type0
->code () == TYPE_CODE_ENUM
)
4809 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4810 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4816 /* True iff SYM0 represents the same entity as SYM1, or one that is
4817 no more defined than that of SYM1. */
4820 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4824 if (sym0
->domain () != sym1
->domain ()
4825 || sym0
->aclass () != sym1
->aclass ())
4828 switch (sym0
->aclass ())
4834 struct type
*type0
= sym0
->type ();
4835 struct type
*type1
= sym1
->type ();
4836 const char *name0
= sym0
->linkage_name ();
4837 const char *name1
= sym1
->linkage_name ();
4838 int len0
= strlen (name0
);
4841 type0
->code () == type1
->code ()
4842 && (equiv_types (type0
, type1
)
4843 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4844 && startswith (name1
+ len0
, "___XV")));
4847 return sym0
->value_longest () == sym1
->value_longest ()
4848 && equiv_types (sym0
->type (), sym1
->type ());
4852 const char *name0
= sym0
->linkage_name ();
4853 const char *name1
= sym1
->linkage_name ();
4854 return (strcmp (name0
, name1
) == 0
4855 && sym0
->value_address () == sym1
->value_address ());
4863 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4864 records in RESULT. Do nothing if SYM is a duplicate. */
4867 add_defn_to_vec (std::vector
<struct block_symbol
> &result
,
4869 const struct block
*block
)
4871 /* Do not try to complete stub types, as the debugger is probably
4872 already scanning all symbols matching a certain name at the
4873 time when this function is called. Trying to replace the stub
4874 type by its associated full type will cause us to restart a scan
4875 which may lead to an infinite recursion. Instead, the client
4876 collecting the matching symbols will end up collecting several
4877 matches, with at least one of them complete. It can then filter
4878 out the stub ones if needed. */
4880 for (int i
= result
.size () - 1; i
>= 0; i
-= 1)
4882 if (lesseq_defined_than (sym
, result
[i
].symbol
))
4884 else if (lesseq_defined_than (result
[i
].symbol
, sym
))
4886 result
[i
].symbol
= sym
;
4887 result
[i
].block
= block
;
4892 struct block_symbol info
;
4895 result
.push_back (info
);
4898 /* Return a bound minimal symbol matching NAME according to Ada
4899 decoding rules. Returns an invalid symbol if there is no such
4900 minimal symbol. Names prefixed with "standard__" are handled
4901 specially: "standard__" is first stripped off, and only static and
4902 global symbols are searched. */
4904 struct bound_minimal_symbol
4905 ada_lookup_simple_minsym (const char *name
, struct objfile
*objfile
)
4907 struct bound_minimal_symbol result
;
4909 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4910 lookup_name_info
lookup_name (name
, match_type
);
4912 symbol_name_matcher_ftype
*match_name
4913 = ada_get_symbol_name_matcher (lookup_name
);
4915 gdbarch_iterate_over_objfiles_in_search_order
4916 (objfile
!= NULL
? objfile
->arch () : target_gdbarch (),
4917 [&result
, lookup_name
, match_name
] (struct objfile
*obj
)
4919 for (minimal_symbol
*msymbol
: obj
->msymbols ())
4921 if (match_name (msymbol
->linkage_name (), lookup_name
, nullptr)
4922 && msymbol
->type () != mst_solib_trampoline
)
4924 result
.minsym
= msymbol
;
4925 result
.objfile
= obj
;
4936 /* True if TYPE is definitely an artificial type supplied to a symbol
4937 for which no debugging information was given in the symbol file. */
4940 is_nondebugging_type (struct type
*type
)
4942 const char *name
= ada_type_name (type
);
4944 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4947 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4948 that are deemed "identical" for practical purposes.
4950 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4951 types and that their number of enumerals is identical (in other
4952 words, type1->num_fields () == type2->num_fields ()). */
4955 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4959 /* The heuristic we use here is fairly conservative. We consider
4960 that 2 enumerate types are identical if they have the same
4961 number of enumerals and that all enumerals have the same
4962 underlying value and name. */
4964 /* All enums in the type should have an identical underlying value. */
4965 for (i
= 0; i
< type1
->num_fields (); i
++)
4966 if (type1
->field (i
).loc_enumval () != type2
->field (i
).loc_enumval ())
4969 /* All enumerals should also have the same name (modulo any numerical
4971 for (i
= 0; i
< type1
->num_fields (); i
++)
4973 const char *name_1
= type1
->field (i
).name ();
4974 const char *name_2
= type2
->field (i
).name ();
4975 int len_1
= strlen (name_1
);
4976 int len_2
= strlen (name_2
);
4978 ada_remove_trailing_digits (type1
->field (i
).name (), &len_1
);
4979 ada_remove_trailing_digits (type2
->field (i
).name (), &len_2
);
4981 || strncmp (type1
->field (i
).name (),
4982 type2
->field (i
).name (),
4990 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4991 that are deemed "identical" for practical purposes. Sometimes,
4992 enumerals are not strictly identical, but their types are so similar
4993 that they can be considered identical.
4995 For instance, consider the following code:
4997 type Color is (Black, Red, Green, Blue, White);
4998 type RGB_Color is new Color range Red .. Blue;
5000 Type RGB_Color is a subrange of an implicit type which is a copy
5001 of type Color. If we call that implicit type RGB_ColorB ("B" is
5002 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5003 As a result, when an expression references any of the enumeral
5004 by name (Eg. "print green"), the expression is technically
5005 ambiguous and the user should be asked to disambiguate. But
5006 doing so would only hinder the user, since it wouldn't matter
5007 what choice he makes, the outcome would always be the same.
5008 So, for practical purposes, we consider them as the same. */
5011 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5015 /* Before performing a thorough comparison check of each type,
5016 we perform a series of inexpensive checks. We expect that these
5017 checks will quickly fail in the vast majority of cases, and thus
5018 help prevent the unnecessary use of a more expensive comparison.
5019 Said comparison also expects us to make some of these checks
5020 (see ada_identical_enum_types_p). */
5022 /* Quick check: All symbols should have an enum type. */
5023 for (i
= 0; i
< syms
.size (); i
++)
5024 if (syms
[i
].symbol
->type ()->code () != TYPE_CODE_ENUM
)
5027 /* Quick check: They should all have the same value. */
5028 for (i
= 1; i
< syms
.size (); i
++)
5029 if (syms
[i
].symbol
->value_longest () != syms
[0].symbol
->value_longest ())
5032 /* Quick check: They should all have the same number of enumerals. */
5033 for (i
= 1; i
< syms
.size (); i
++)
5034 if (syms
[i
].symbol
->type ()->num_fields ()
5035 != syms
[0].symbol
->type ()->num_fields ())
5038 /* All the sanity checks passed, so we might have a set of
5039 identical enumeration types. Perform a more complete
5040 comparison of the type of each symbol. */
5041 for (i
= 1; i
< syms
.size (); i
++)
5042 if (!ada_identical_enum_types_p (syms
[i
].symbol
->type (),
5043 syms
[0].symbol
->type ()))
5049 /* Remove any non-debugging symbols in SYMS that definitely
5050 duplicate other symbols in the list (The only case I know of where
5051 this happens is when object files containing stabs-in-ecoff are
5052 linked with files containing ordinary ecoff debugging symbols (or no
5053 debugging symbols)). Modifies SYMS to squeeze out deleted entries. */
5056 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5060 /* We should never be called with less than 2 symbols, as there
5061 cannot be any extra symbol in that case. But it's easy to
5062 handle, since we have nothing to do in that case. */
5063 if (syms
->size () < 2)
5067 while (i
< syms
->size ())
5071 /* If two symbols have the same name and one of them is a stub type,
5072 the get rid of the stub. */
5074 if ((*syms
)[i
].symbol
->type ()->is_stub ()
5075 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5077 for (j
= 0; j
< syms
->size (); j
++)
5080 && !(*syms
)[j
].symbol
->type ()->is_stub ()
5081 && (*syms
)[j
].symbol
->linkage_name () != NULL
5082 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5083 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5088 /* Two symbols with the same name, same class and same address
5089 should be identical. */
5091 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5092 && (*syms
)[i
].symbol
->aclass () == LOC_STATIC
5093 && is_nondebugging_type ((*syms
)[i
].symbol
->type ()))
5095 for (j
= 0; j
< syms
->size (); j
+= 1)
5098 && (*syms
)[j
].symbol
->linkage_name () != NULL
5099 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5100 (*syms
)[j
].symbol
->linkage_name ()) == 0
5101 && ((*syms
)[i
].symbol
->aclass ()
5102 == (*syms
)[j
].symbol
->aclass ())
5103 && (*syms
)[i
].symbol
->value_address ()
5104 == (*syms
)[j
].symbol
->value_address ())
5110 syms
->erase (syms
->begin () + i
);
5115 /* If all the remaining symbols are identical enumerals, then
5116 just keep the first one and discard the rest.
5118 Unlike what we did previously, we do not discard any entry
5119 unless they are ALL identical. This is because the symbol
5120 comparison is not a strict comparison, but rather a practical
5121 comparison. If all symbols are considered identical, then
5122 we can just go ahead and use the first one and discard the rest.
5123 But if we cannot reduce the list to a single element, we have
5124 to ask the user to disambiguate anyways. And if we have to
5125 present a multiple-choice menu, it's less confusing if the list
5126 isn't missing some choices that were identical and yet distinct. */
5127 if (symbols_are_identical_enums (*syms
))
5131 /* Given a type that corresponds to a renaming entity, use the type name
5132 to extract the scope (package name or function name, fully qualified,
5133 and following the GNAT encoding convention) where this renaming has been
5137 xget_renaming_scope (struct type
*renaming_type
)
5139 /* The renaming types adhere to the following convention:
5140 <scope>__<rename>___<XR extension>.
5141 So, to extract the scope, we search for the "___XR" extension,
5142 and then backtrack until we find the first "__". */
5144 const char *name
= renaming_type
->name ();
5145 const char *suffix
= strstr (name
, "___XR");
5148 /* Now, backtrack a bit until we find the first "__". Start looking
5149 at suffix - 3, as the <rename> part is at least one character long. */
5151 for (last
= suffix
- 3; last
> name
; last
--)
5152 if (last
[0] == '_' && last
[1] == '_')
5155 /* Make a copy of scope and return it. */
5156 return std::string (name
, last
);
5159 /* Return nonzero if NAME corresponds to a package name. */
5162 is_package_name (const char *name
)
5164 /* Here, We take advantage of the fact that no symbols are generated
5165 for packages, while symbols are generated for each function.
5166 So the condition for NAME represent a package becomes equivalent
5167 to NAME not existing in our list of symbols. There is only one
5168 small complication with library-level functions (see below). */
5170 /* If it is a function that has not been defined at library level,
5171 then we should be able to look it up in the symbols. */
5172 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5175 /* Library-level function names start with "_ada_". See if function
5176 "_ada_" followed by NAME can be found. */
5178 /* Do a quick check that NAME does not contain "__", since library-level
5179 functions names cannot contain "__" in them. */
5180 if (strstr (name
, "__") != NULL
)
5183 std::string fun_name
= string_printf ("_ada_%s", name
);
5185 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5188 /* Return nonzero if SYM corresponds to a renaming entity that is
5189 not visible from FUNCTION_NAME. */
5192 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5194 if (sym
->aclass () != LOC_TYPEDEF
)
5197 std::string scope
= xget_renaming_scope (sym
->type ());
5199 /* If the rename has been defined in a package, then it is visible. */
5200 if (is_package_name (scope
.c_str ()))
5203 /* Check that the rename is in the current function scope by checking
5204 that its name starts with SCOPE. */
5206 /* If the function name starts with "_ada_", it means that it is
5207 a library-level function. Strip this prefix before doing the
5208 comparison, as the encoding for the renaming does not contain
5210 if (startswith (function_name
, "_ada_"))
5213 return !startswith (function_name
, scope
.c_str ());
5216 /* Remove entries from SYMS that corresponds to a renaming entity that
5217 is not visible from the function associated with CURRENT_BLOCK or
5218 that is superfluous due to the presence of more specific renaming
5219 information. Places surviving symbols in the initial entries of
5223 First, in cases where an object renaming is implemented as a
5224 reference variable, GNAT may produce both the actual reference
5225 variable and the renaming encoding. In this case, we discard the
5228 Second, GNAT emits a type following a specified encoding for each renaming
5229 entity. Unfortunately, STABS currently does not support the definition
5230 of types that are local to a given lexical block, so all renamings types
5231 are emitted at library level. As a consequence, if an application
5232 contains two renaming entities using the same name, and a user tries to
5233 print the value of one of these entities, the result of the ada symbol
5234 lookup will also contain the wrong renaming type.
5236 This function partially covers for this limitation by attempting to
5237 remove from the SYMS list renaming symbols that should be visible
5238 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5239 method with the current information available. The implementation
5240 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5242 - When the user tries to print a rename in a function while there
5243 is another rename entity defined in a package: Normally, the
5244 rename in the function has precedence over the rename in the
5245 package, so the latter should be removed from the list. This is
5246 currently not the case.
5248 - This function will incorrectly remove valid renames if
5249 the CURRENT_BLOCK corresponds to a function which symbol name
5250 has been changed by an "Export" pragma. As a consequence,
5251 the user will be unable to print such rename entities. */
5254 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5255 const struct block
*current_block
)
5257 struct symbol
*current_function
;
5258 const char *current_function_name
;
5260 int is_new_style_renaming
;
5262 /* If there is both a renaming foo___XR... encoded as a variable and
5263 a simple variable foo in the same block, discard the latter.
5264 First, zero out such symbols, then compress. */
5265 is_new_style_renaming
= 0;
5266 for (i
= 0; i
< syms
->size (); i
+= 1)
5268 struct symbol
*sym
= (*syms
)[i
].symbol
;
5269 const struct block
*block
= (*syms
)[i
].block
;
5273 if (sym
== NULL
|| sym
->aclass () == LOC_TYPEDEF
)
5275 name
= sym
->linkage_name ();
5276 suffix
= strstr (name
, "___XR");
5280 int name_len
= suffix
- name
;
5283 is_new_style_renaming
= 1;
5284 for (j
= 0; j
< syms
->size (); j
+= 1)
5285 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5286 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5288 && block
== (*syms
)[j
].block
)
5289 (*syms
)[j
].symbol
= NULL
;
5292 if (is_new_style_renaming
)
5296 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5297 if ((*syms
)[j
].symbol
!= NULL
)
5299 (*syms
)[k
] = (*syms
)[j
];
5306 /* Extract the function name associated to CURRENT_BLOCK.
5307 Abort if unable to do so. */
5309 if (current_block
== NULL
)
5312 current_function
= block_linkage_function (current_block
);
5313 if (current_function
== NULL
)
5316 current_function_name
= current_function
->linkage_name ();
5317 if (current_function_name
== NULL
)
5320 /* Check each of the symbols, and remove it from the list if it is
5321 a type corresponding to a renaming that is out of the scope of
5322 the current block. */
5325 while (i
< syms
->size ())
5327 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5328 == ADA_OBJECT_RENAMING
5329 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5330 current_function_name
))
5331 syms
->erase (syms
->begin () + i
);
5337 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5338 whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5340 Note: This function assumes that RESULT is empty. */
5343 ada_add_local_symbols (std::vector
<struct block_symbol
> &result
,
5344 const lookup_name_info
&lookup_name
,
5345 const struct block
*block
, domain_enum domain
)
5347 while (block
!= NULL
)
5349 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5351 /* If we found a non-function match, assume that's the one. We
5352 only check this when finding a function boundary, so that we
5353 can accumulate all results from intervening blocks first. */
5354 if (block
->function () != nullptr && is_nonfunction (result
))
5357 block
= block
->superblock ();
5361 /* An object of this type is used as the callback argument when
5362 calling the map_matching_symbols method. */
5366 explicit match_data (std::vector
<struct block_symbol
> *rp
)
5370 DISABLE_COPY_AND_ASSIGN (match_data
);
5372 bool operator() (struct block_symbol
*bsym
);
5374 struct objfile
*objfile
= nullptr;
5375 std::vector
<struct block_symbol
> *resultp
;
5376 struct symbol
*arg_sym
= nullptr;
5377 bool found_sym
= false;
5380 /* A callback for add_nonlocal_symbols that adds symbol, found in
5381 BSYM, to a list of symbols. */
5384 match_data::operator() (struct block_symbol
*bsym
)
5386 const struct block
*block
= bsym
->block
;
5387 struct symbol
*sym
= bsym
->symbol
;
5391 if (!found_sym
&& arg_sym
!= NULL
)
5392 add_defn_to_vec (*resultp
, arg_sym
, block
);
5398 if (sym
->aclass () == LOC_UNRESOLVED
)
5400 else if (sym
->is_argument ())
5405 add_defn_to_vec (*resultp
, sym
, block
);
5411 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5412 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5413 symbols to RESULT. Return whether we found such symbols. */
5416 ada_add_block_renamings (std::vector
<struct block_symbol
> &result
,
5417 const struct block
*block
,
5418 const lookup_name_info
&lookup_name
,
5421 struct using_direct
*renaming
;
5422 int defns_mark
= result
.size ();
5424 symbol_name_matcher_ftype
*name_match
5425 = ada_get_symbol_name_matcher (lookup_name
);
5427 for (renaming
= block_using (block
);
5429 renaming
= renaming
->next
)
5433 /* Avoid infinite recursions: skip this renaming if we are actually
5434 already traversing it.
5436 Currently, symbol lookup in Ada don't use the namespace machinery from
5437 C++/Fortran support: skip namespace imports that use them. */
5438 if (renaming
->searched
5439 || (renaming
->import_src
!= NULL
5440 && renaming
->import_src
[0] != '\0')
5441 || (renaming
->import_dest
!= NULL
5442 && renaming
->import_dest
[0] != '\0'))
5444 renaming
->searched
= 1;
5446 /* TODO: here, we perform another name-based symbol lookup, which can
5447 pull its own multiple overloads. In theory, we should be able to do
5448 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5449 not a simple name. But in order to do this, we would need to enhance
5450 the DWARF reader to associate a symbol to this renaming, instead of a
5451 name. So, for now, we do something simpler: re-use the C++/Fortran
5452 namespace machinery. */
5453 r_name
= (renaming
->alias
!= NULL
5455 : renaming
->declaration
);
5456 if (name_match (r_name
, lookup_name
, NULL
))
5458 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5459 lookup_name
.match_type ());
5460 ada_add_all_symbols (result
, block
, decl_lookup_name
, domain
,
5463 renaming
->searched
= 0;
5465 return result
.size () != defns_mark
;
5468 /* Implements compare_names, but only applying the comparision using
5469 the given CASING. */
5472 compare_names_with_case (const char *string1
, const char *string2
,
5473 enum case_sensitivity casing
)
5475 while (*string1
!= '\0' && *string2
!= '\0')
5479 if (isspace (*string1
) || isspace (*string2
))
5480 return strcmp_iw_ordered (string1
, string2
);
5482 if (casing
== case_sensitive_off
)
5484 c1
= tolower (*string1
);
5485 c2
= tolower (*string2
);
5502 return strcmp_iw_ordered (string1
, string2
);
5504 if (*string2
== '\0')
5506 if (is_name_suffix (string1
))
5513 if (*string2
== '(')
5514 return strcmp_iw_ordered (string1
, string2
);
5517 if (casing
== case_sensitive_off
)
5518 return tolower (*string1
) - tolower (*string2
);
5520 return *string1
- *string2
;
5525 /* Compare STRING1 to STRING2, with results as for strcmp.
5526 Compatible with strcmp_iw_ordered in that...
5528 strcmp_iw_ordered (STRING1, STRING2) <= 0
5532 compare_names (STRING1, STRING2) <= 0
5534 (they may differ as to what symbols compare equal). */
5537 compare_names (const char *string1
, const char *string2
)
5541 /* Similar to what strcmp_iw_ordered does, we need to perform
5542 a case-insensitive comparison first, and only resort to
5543 a second, case-sensitive, comparison if the first one was
5544 not sufficient to differentiate the two strings. */
5546 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5548 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5553 /* Convenience function to get at the Ada encoded lookup name for
5554 LOOKUP_NAME, as a C string. */
5557 ada_lookup_name (const lookup_name_info
&lookup_name
)
5559 return lookup_name
.ada ().lookup_name ().c_str ();
5562 /* A helper for add_nonlocal_symbols. Call expand_matching_symbols
5563 for OBJFILE, then walk the objfile's symtabs and update the
5567 map_matching_symbols (struct objfile
*objfile
,
5568 const lookup_name_info
&lookup_name
,
5574 data
.objfile
= objfile
;
5575 objfile
->expand_matching_symbols (lookup_name
, domain
, global
,
5576 is_wild_match
? nullptr : compare_names
);
5578 const int block_kind
= global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
5579 for (compunit_symtab
*symtab
: objfile
->compunits ())
5581 const struct block
*block
5582 = symtab
->blockvector ()->block (block_kind
);
5583 if (!iterate_over_symbols_terminated (block
, lookup_name
,
5589 /* Add to RESULT all non-local symbols whose name and domain match
5590 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5591 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5592 symbols otherwise. */
5595 add_nonlocal_symbols (std::vector
<struct block_symbol
> &result
,
5596 const lookup_name_info
&lookup_name
,
5597 domain_enum domain
, int global
)
5599 struct match_data
data (&result
);
5601 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5603 for (objfile
*objfile
: current_program_space
->objfiles ())
5605 map_matching_symbols (objfile
, lookup_name
, is_wild_match
, domain
,
5608 for (compunit_symtab
*cu
: objfile
->compunits ())
5610 const struct block
*global_block
5611 = cu
->blockvector ()->global_block ();
5613 if (ada_add_block_renamings (result
, global_block
, lookup_name
,
5615 data
.found_sym
= true;
5619 if (result
.empty () && global
&& !is_wild_match
)
5621 const char *name
= ada_lookup_name (lookup_name
);
5622 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5623 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5625 for (objfile
*objfile
: current_program_space
->objfiles ())
5626 map_matching_symbols (objfile
, name1
, false, domain
, global
, data
);
5630 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5631 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5632 returning the number of matches. Add these to RESULT.
5634 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5635 symbol match within the nest of blocks whose innermost member is BLOCK,
5636 is the one match returned (no other matches in that or
5637 enclosing blocks is returned). If there are any matches in or
5638 surrounding BLOCK, then these alone are returned.
5640 Names prefixed with "standard__" are handled specially:
5641 "standard__" is first stripped off (by the lookup_name
5642 constructor), and only static and global symbols are searched.
5644 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5645 to lookup global symbols. */
5648 ada_add_all_symbols (std::vector
<struct block_symbol
> &result
,
5649 const struct block
*block
,
5650 const lookup_name_info
&lookup_name
,
5653 int *made_global_lookup_p
)
5657 if (made_global_lookup_p
)
5658 *made_global_lookup_p
= 0;
5660 /* Special case: If the user specifies a symbol name inside package
5661 Standard, do a non-wild matching of the symbol name without
5662 the "standard__" prefix. This was primarily introduced in order
5663 to allow the user to specifically access the standard exceptions
5664 using, for instance, Standard.Constraint_Error when Constraint_Error
5665 is ambiguous (due to the user defining its own Constraint_Error
5666 entity inside its program). */
5667 if (lookup_name
.ada ().standard_p ())
5670 /* Check the non-global symbols. If we have ANY match, then we're done. */
5675 ada_add_local_symbols (result
, lookup_name
, block
, domain
);
5678 /* In the !full_search case we're are being called by
5679 iterate_over_symbols, and we don't want to search
5681 ada_add_block_symbols (result
, block
, lookup_name
, domain
, NULL
);
5683 if (!result
.empty () || !full_search
)
5687 /* No non-global symbols found. Check our cache to see if we have
5688 already performed this search before. If we have, then return
5691 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5692 domain
, &sym
, &block
))
5695 add_defn_to_vec (result
, sym
, block
);
5699 if (made_global_lookup_p
)
5700 *made_global_lookup_p
= 1;
5702 /* Search symbols from all global blocks. */
5704 add_nonlocal_symbols (result
, lookup_name
, domain
, 1);
5706 /* Now add symbols from all per-file blocks if we've gotten no hits
5707 (not strictly correct, but perhaps better than an error). */
5709 if (result
.empty ())
5710 add_nonlocal_symbols (result
, lookup_name
, domain
, 0);
5713 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5714 is non-zero, enclosing scope and in global scopes.
5716 Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5717 blocks and symbol tables (if any) in which they were found.
5719 When full_search is non-zero, any non-function/non-enumeral
5720 symbol match within the nest of blocks whose innermost member is BLOCK,
5721 is the one match returned (no other matches in that or
5722 enclosing blocks is returned). If there are any matches in or
5723 surrounding BLOCK, then these alone are returned.
5725 Names prefixed with "standard__" are handled specially: "standard__"
5726 is first stripped off, and only static and global symbols are searched. */
5728 static std::vector
<struct block_symbol
>
5729 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5730 const struct block
*block
,
5734 int syms_from_global_search
;
5735 std::vector
<struct block_symbol
> results
;
5737 ada_add_all_symbols (results
, block
, lookup_name
,
5738 domain
, full_search
, &syms_from_global_search
);
5740 remove_extra_symbols (&results
);
5742 if (results
.empty () && full_search
&& syms_from_global_search
)
5743 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5745 if (results
.size () == 1 && full_search
&& syms_from_global_search
)
5746 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5747 results
[0].symbol
, results
[0].block
);
5749 remove_irrelevant_renamings (&results
, block
);
5753 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5754 in global scopes, returning (SYM,BLOCK) tuples.
5756 See ada_lookup_symbol_list_worker for further details. */
5758 std::vector
<struct block_symbol
>
5759 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5762 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5763 lookup_name_info
lookup_name (name
, name_match_type
);
5765 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, 1);
5768 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5769 to 1, but choosing the first symbol found if there are multiple
5772 The result is stored in *INFO, which must be non-NULL.
5773 If no match is found, INFO->SYM is set to NULL. */
5776 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5778 struct block_symbol
*info
)
5780 /* Since we already have an encoded name, wrap it in '<>' to force a
5781 verbatim match. Otherwise, if the name happens to not look like
5782 an encoded name (because it doesn't include a "__"),
5783 ada_lookup_name_info would re-encode/fold it again, and that
5784 would e.g., incorrectly lowercase object renaming names like
5785 "R28b" -> "r28b". */
5786 std::string verbatim
= add_angle_brackets (name
);
5788 gdb_assert (info
!= NULL
);
5789 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5792 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5793 scope and in global scopes, or NULL if none. NAME is folded and
5794 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5795 choosing the first symbol if there are multiple choices. */
5798 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5801 std::vector
<struct block_symbol
> candidates
5802 = ada_lookup_symbol_list (name
, block0
, domain
);
5804 if (candidates
.empty ())
5807 return candidates
[0];
5811 /* True iff STR is a possible encoded suffix of a normal Ada name
5812 that is to be ignored for matching purposes. Suffixes of parallel
5813 names (e.g., XVE) are not included here. Currently, the possible suffixes
5814 are given by any of the regular expressions:
5816 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5817 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5818 TKB [subprogram suffix for task bodies]
5819 _E[0-9]+[bs]$ [protected object entry suffixes]
5820 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5822 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5823 match is performed. This sequence is used to differentiate homonyms,
5824 is an optional part of a valid name suffix. */
5827 is_name_suffix (const char *str
)
5830 const char *matching
;
5831 const int len
= strlen (str
);
5833 /* Skip optional leading __[0-9]+. */
5835 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5838 while (isdigit (str
[0]))
5844 if (str
[0] == '.' || str
[0] == '$')
5847 while (isdigit (matching
[0]))
5849 if (matching
[0] == '\0')
5855 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5858 while (isdigit (matching
[0]))
5860 if (matching
[0] == '\0')
5864 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5866 if (strcmp (str
, "TKB") == 0)
5870 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5871 with a N at the end. Unfortunately, the compiler uses the same
5872 convention for other internal types it creates. So treating
5873 all entity names that end with an "N" as a name suffix causes
5874 some regressions. For instance, consider the case of an enumerated
5875 type. To support the 'Image attribute, it creates an array whose
5877 Having a single character like this as a suffix carrying some
5878 information is a bit risky. Perhaps we should change the encoding
5879 to be something like "_N" instead. In the meantime, do not do
5880 the following check. */
5881 /* Protected Object Subprograms */
5882 if (len
== 1 && str
[0] == 'N')
5887 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5890 while (isdigit (matching
[0]))
5892 if ((matching
[0] == 'b' || matching
[0] == 's')
5893 && matching
[1] == '\0')
5897 /* ??? We should not modify STR directly, as we are doing below. This
5898 is fine in this case, but may become problematic later if we find
5899 that this alternative did not work, and want to try matching
5900 another one from the begining of STR. Since we modified it, we
5901 won't be able to find the begining of the string anymore! */
5905 while (str
[0] != '_' && str
[0] != '\0')
5907 if (str
[0] != 'n' && str
[0] != 'b')
5913 if (str
[0] == '\000')
5918 if (str
[1] != '_' || str
[2] == '\000')
5922 if (strcmp (str
+ 3, "JM") == 0)
5924 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5925 the LJM suffix in favor of the JM one. But we will
5926 still accept LJM as a valid suffix for a reasonable
5927 amount of time, just to allow ourselves to debug programs
5928 compiled using an older version of GNAT. */
5929 if (strcmp (str
+ 3, "LJM") == 0)
5933 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5934 || str
[4] == 'U' || str
[4] == 'P')
5936 if (str
[4] == 'R' && str
[5] != 'T')
5940 if (!isdigit (str
[2]))
5942 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5943 if (!isdigit (str
[k
]) && str
[k
] != '_')
5947 if (str
[0] == '$' && isdigit (str
[1]))
5949 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5950 if (!isdigit (str
[k
]) && str
[k
] != '_')
5957 /* Return non-zero if the string starting at NAME and ending before
5958 NAME_END contains no capital letters. */
5961 is_valid_name_for_wild_match (const char *name0
)
5963 std::string decoded_name
= ada_decode (name0
);
5966 /* If the decoded name starts with an angle bracket, it means that
5967 NAME0 does not follow the GNAT encoding format. It should then
5968 not be allowed as a possible wild match. */
5969 if (decoded_name
[0] == '<')
5972 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5973 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5979 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5980 character which could start a simple name. Assumes that *NAMEP points
5981 somewhere inside the string beginning at NAME0. */
5984 advance_wild_match (const char **namep
, const char *name0
, char target0
)
5986 const char *name
= *namep
;
5996 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5999 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6004 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6005 || name
[2] == target0
))
6010 else if (t1
== '_' && name
[2] == 'B' && name
[3] == '_')
6012 /* Names like "pkg__B_N__name", where N is a number, are
6013 block-local. We can handle these by simply skipping
6020 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6030 /* Return true iff NAME encodes a name of the form prefix.PATN.
6031 Ignores any informational suffixes of NAME (i.e., for which
6032 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6036 wild_match (const char *name
, const char *patn
)
6039 const char *name0
= name
;
6041 if (startswith (name
, "___ghost_"))
6046 const char *match
= name
;
6050 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6053 if (*p
== '\0' && is_name_suffix (name
))
6054 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6056 if (name
[-1] == '_')
6059 if (!advance_wild_match (&name
, name0
, *patn
))
6064 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6065 necessary). OBJFILE is the section containing BLOCK. */
6068 ada_add_block_symbols (std::vector
<struct block_symbol
> &result
,
6069 const struct block
*block
,
6070 const lookup_name_info
&lookup_name
,
6071 domain_enum domain
, struct objfile
*objfile
)
6073 struct block_iterator iter
;
6074 /* A matching argument symbol, if any. */
6075 struct symbol
*arg_sym
;
6076 /* Set true when we find a matching non-argument symbol. */
6082 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6084 sym
= block_iter_match_next (lookup_name
, &iter
))
6086 if (symbol_matches_domain (sym
->language (), sym
->domain (), domain
))
6088 if (sym
->aclass () != LOC_UNRESOLVED
)
6090 if (sym
->is_argument ())
6095 add_defn_to_vec (result
, sym
, block
);
6101 /* Handle renamings. */
6103 if (ada_add_block_renamings (result
, block
, lookup_name
, domain
))
6106 if (!found_sym
&& arg_sym
!= NULL
)
6108 add_defn_to_vec (result
, arg_sym
, block
);
6111 if (!lookup_name
.ada ().wild_match_p ())
6115 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6116 const char *name
= ada_lookup_name
.c_str ();
6117 size_t name_len
= ada_lookup_name
.size ();
6119 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6121 if (symbol_matches_domain (sym
->language (),
6122 sym
->domain (), domain
))
6126 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6129 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6131 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6136 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6138 if (sym
->aclass () != LOC_UNRESOLVED
)
6140 if (sym
->is_argument ())
6145 add_defn_to_vec (result
, sym
, block
);
6152 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6153 They aren't parameters, right? */
6154 if (!found_sym
&& arg_sym
!= NULL
)
6156 add_defn_to_vec (result
, arg_sym
, block
);
6162 /* Symbol Completion */
6167 ada_lookup_name_info::matches
6168 (const char *sym_name
,
6169 symbol_name_match_type match_type
,
6170 completion_match_result
*comp_match_res
) const
6173 const char *text
= m_encoded_name
.c_str ();
6174 size_t text_len
= m_encoded_name
.size ();
6176 /* First, test against the fully qualified name of the symbol. */
6178 if (strncmp (sym_name
, text
, text_len
) == 0)
6181 std::string decoded_name
= ada_decode (sym_name
);
6182 if (match
&& !m_encoded_p
)
6184 /* One needed check before declaring a positive match is to verify
6185 that iff we are doing a verbatim match, the decoded version
6186 of the symbol name starts with '<'. Otherwise, this symbol name
6187 is not a suitable completion. */
6189 bool has_angle_bracket
= (decoded_name
[0] == '<');
6190 match
= (has_angle_bracket
== m_verbatim_p
);
6193 if (match
&& !m_verbatim_p
)
6195 /* When doing non-verbatim match, another check that needs to
6196 be done is to verify that the potentially matching symbol name
6197 does not include capital letters, because the ada-mode would
6198 not be able to understand these symbol names without the
6199 angle bracket notation. */
6202 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6207 /* Second: Try wild matching... */
6209 if (!match
&& m_wild_match_p
)
6211 /* Since we are doing wild matching, this means that TEXT
6212 may represent an unqualified symbol name. We therefore must
6213 also compare TEXT against the unqualified name of the symbol. */
6214 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6216 if (strncmp (sym_name
, text
, text_len
) == 0)
6220 /* Finally: If we found a match, prepare the result to return. */
6225 if (comp_match_res
!= NULL
)
6227 std::string
&match_str
= comp_match_res
->match
.storage ();
6230 match_str
= ada_decode (sym_name
);
6234 match_str
= add_angle_brackets (sym_name
);
6236 match_str
= sym_name
;
6240 comp_match_res
->set_match (match_str
.c_str ());
6248 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6249 for tagged types. */
6252 ada_is_dispatch_table_ptr_type (struct type
*type
)
6256 if (type
->code () != TYPE_CODE_PTR
)
6259 name
= type
->target_type ()->name ();
6263 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6266 /* Return non-zero if TYPE is an interface tag. */
6269 ada_is_interface_tag (struct type
*type
)
6271 const char *name
= type
->name ();
6276 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6279 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6280 to be invisible to users. */
6283 ada_is_ignored_field (struct type
*type
, int field_num
)
6285 if (field_num
< 0 || field_num
> type
->num_fields ())
6288 /* Check the name of that field. */
6290 const char *name
= type
->field (field_num
).name ();
6292 /* Anonymous field names should not be printed.
6293 brobecker/2007-02-20: I don't think this can actually happen
6294 but we don't want to print the value of anonymous fields anyway. */
6298 /* Normally, fields whose name start with an underscore ("_")
6299 are fields that have been internally generated by the compiler,
6300 and thus should not be printed. The "_parent" field is special,
6301 however: This is a field internally generated by the compiler
6302 for tagged types, and it contains the components inherited from
6303 the parent type. This field should not be printed as is, but
6304 should not be ignored either. */
6305 if (name
[0] == '_' && !startswith (name
, "_parent"))
6308 /* The compiler doesn't document this, but sometimes it emits
6309 a field whose name starts with a capital letter, like 'V148s'.
6310 These aren't marked as artificial in any way, but we know they
6311 should be ignored. However, wrapper fields should not be
6313 if (name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O')
6315 /* Wrapper field. */
6317 else if (isupper (name
[0]))
6321 /* If this is the dispatch table of a tagged type or an interface tag,
6323 if (ada_is_tagged_type (type
, 1)
6324 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6325 || ada_is_interface_tag (type
->field (field_num
).type ())))
6328 /* Not a special field, so it should not be ignored. */
6332 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6333 pointer or reference type whose ultimate target has a tag field. */
6336 ada_is_tagged_type (struct type
*type
, int refok
)
6338 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6341 /* True iff TYPE represents the type of X'Tag */
6344 ada_is_tag_type (struct type
*type
)
6346 type
= ada_check_typedef (type
);
6348 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6352 const char *name
= ada_type_name (type
->target_type ());
6354 return (name
!= NULL
6355 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6359 /* The type of the tag on VAL. */
6361 static struct type
*
6362 ada_tag_type (struct value
*val
)
6364 return ada_lookup_struct_elt_type (val
->type (), "_tag", 1, 0);
6367 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6368 retired at Ada 05). */
6371 is_ada95_tag (struct value
*tag
)
6373 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6376 /* The value of the tag on VAL. */
6378 static struct value
*
6379 ada_value_tag (struct value
*val
)
6381 return ada_value_struct_elt (val
, "_tag", 0);
6384 /* The value of the tag on the object of type TYPE whose contents are
6385 saved at VALADDR, if it is non-null, or is at memory address
6388 static struct value
*
6389 value_tag_from_contents_and_address (struct type
*type
,
6390 const gdb_byte
*valaddr
,
6393 int tag_byte_offset
;
6394 struct type
*tag_type
;
6396 gdb::array_view
<const gdb_byte
> contents
;
6397 if (valaddr
!= nullptr)
6398 contents
= gdb::make_array_view (valaddr
, type
->length ());
6399 struct type
*resolved_type
= resolve_dynamic_type (type
, contents
, address
);
6400 if (find_struct_field ("_tag", resolved_type
, 0, &tag_type
, &tag_byte_offset
,
6403 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6405 : valaddr
+ tag_byte_offset
);
6406 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6408 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6413 static struct type
*
6414 type_from_tag (struct value
*tag
)
6416 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6418 if (type_name
!= NULL
)
6419 return ada_find_any_type (ada_encode (type_name
.get ()).c_str ());
6423 /* Given a value OBJ of a tagged type, return a value of this
6424 type at the base address of the object. The base address, as
6425 defined in Ada.Tags, it is the address of the primary tag of
6426 the object, and therefore where the field values of its full
6427 view can be fetched. */
6430 ada_tag_value_at_base_address (struct value
*obj
)
6433 LONGEST offset_to_top
= 0;
6434 struct type
*ptr_type
, *obj_type
;
6436 CORE_ADDR base_address
;
6438 obj_type
= obj
->type ();
6440 /* It is the responsability of the caller to deref pointers. */
6442 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6445 tag
= ada_value_tag (obj
);
6449 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6451 if (is_ada95_tag (tag
))
6454 struct type
*offset_type
6455 = language_lookup_primitive_type (language_def (language_ada
),
6456 target_gdbarch(), "storage_offset");
6457 ptr_type
= lookup_pointer_type (offset_type
);
6458 val
= value_cast (ptr_type
, tag
);
6462 /* It is perfectly possible that an exception be raised while
6463 trying to determine the base address, just like for the tag;
6464 see ada_tag_name for more details. We do not print the error
6465 message for the same reason. */
6469 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6472 catch (const gdb_exception_error
&e
)
6477 /* If offset is null, nothing to do. */
6479 if (offset_to_top
== 0)
6482 /* -1 is a special case in Ada.Tags; however, what should be done
6483 is not quite clear from the documentation. So do nothing for
6486 if (offset_to_top
== -1)
6489 /* Storage_Offset'Last is used to indicate that a dynamic offset to
6490 top is used. In this situation the offset is stored just after
6491 the tag, in the object itself. */
6492 ULONGEST last
= (((ULONGEST
) 1) << (8 * offset_type
->length () - 1)) - 1;
6493 if (offset_to_top
== last
)
6495 struct value
*tem
= value_addr (tag
);
6496 tem
= value_ptradd (tem
, 1);
6497 tem
= value_cast (ptr_type
, tem
);
6498 offset_to_top
= value_as_long (value_ind (tem
));
6501 if (offset_to_top
> 0)
6503 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6504 from the base address. This was however incompatible with
6505 C++ dispatch table: C++ uses a *negative* value to *add*
6506 to the base address. Ada's convention has therefore been
6507 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6508 use the same convention. Here, we support both cases by
6509 checking the sign of OFFSET_TO_TOP. */
6510 offset_to_top
= -offset_to_top
;
6513 base_address
= value_address (obj
) + offset_to_top
;
6514 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6516 /* Make sure that we have a proper tag at the new address.
6517 Otherwise, offset_to_top is bogus (which can happen when
6518 the object is not initialized yet). */
6523 obj_type
= type_from_tag (tag
);
6528 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6531 /* Return the "ada__tags__type_specific_data" type. */
6533 static struct type
*
6534 ada_get_tsd_type (struct inferior
*inf
)
6536 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6538 if (data
->tsd_type
== 0)
6539 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6540 return data
->tsd_type
;
6543 /* Return the TSD (type-specific data) associated to the given TAG.
6544 TAG is assumed to be the tag of a tagged-type entity.
6546 May return NULL if we are unable to get the TSD. */
6548 static struct value
*
6549 ada_get_tsd_from_tag (struct value
*tag
)
6554 /* First option: The TSD is simply stored as a field of our TAG.
6555 Only older versions of GNAT would use this format, but we have
6556 to test it first, because there are no visible markers for
6557 the current approach except the absence of that field. */
6559 val
= ada_value_struct_elt (tag
, "tsd", 1);
6563 /* Try the second representation for the dispatch table (in which
6564 there is no explicit 'tsd' field in the referent of the tag pointer,
6565 and instead the tsd pointer is stored just before the dispatch
6568 type
= ada_get_tsd_type (current_inferior());
6571 type
= lookup_pointer_type (lookup_pointer_type (type
));
6572 val
= value_cast (type
, tag
);
6575 return value_ind (value_ptradd (val
, -1));
6578 /* Given the TSD of a tag (type-specific data), return a string
6579 containing the name of the associated type.
6581 May return NULL if we are unable to determine the tag name. */
6583 static gdb::unique_xmalloc_ptr
<char>
6584 ada_tag_name_from_tsd (struct value
*tsd
)
6588 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6591 gdb::unique_xmalloc_ptr
<char> buffer
6592 = target_read_string (value_as_address (val
), INT_MAX
);
6593 if (buffer
== nullptr)
6598 /* Let this throw an exception on error. If the data is
6599 uninitialized, we'd rather not have the user see a
6601 const char *folded
= ada_fold_name (buffer
.get (), true);
6602 return make_unique_xstrdup (folded
);
6604 catch (const gdb_exception
&)
6610 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6613 Return NULL if the TAG is not an Ada tag, or if we were unable to
6614 determine the name of that tag. */
6616 gdb::unique_xmalloc_ptr
<char>
6617 ada_tag_name (struct value
*tag
)
6619 gdb::unique_xmalloc_ptr
<char> name
;
6621 if (!ada_is_tag_type (tag
->type ()))
6624 /* It is perfectly possible that an exception be raised while trying
6625 to determine the TAG's name, even under normal circumstances:
6626 The associated variable may be uninitialized or corrupted, for
6627 instance. We do not let any exception propagate past this point.
6628 instead we return NULL.
6630 We also do not print the error message either (which often is very
6631 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6632 the caller print a more meaningful message if necessary. */
6635 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6638 name
= ada_tag_name_from_tsd (tsd
);
6640 catch (const gdb_exception_error
&e
)
6647 /* The parent type of TYPE, or NULL if none. */
6650 ada_parent_type (struct type
*type
)
6654 type
= ada_check_typedef (type
);
6656 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6659 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6660 if (ada_is_parent_field (type
, i
))
6662 struct type
*parent_type
= type
->field (i
).type ();
6664 /* If the _parent field is a pointer, then dereference it. */
6665 if (parent_type
->code () == TYPE_CODE_PTR
)
6666 parent_type
= parent_type
->target_type ();
6667 /* If there is a parallel XVS type, get the actual base type. */
6668 parent_type
= ada_get_base_type (parent_type
);
6670 return ada_check_typedef (parent_type
);
6676 /* True iff field number FIELD_NUM of structure type TYPE contains the
6677 parent-type (inherited) fields of a derived type. Assumes TYPE is
6678 a structure type with at least FIELD_NUM+1 fields. */
6681 ada_is_parent_field (struct type
*type
, int field_num
)
6683 const char *name
= ada_check_typedef (type
)->field (field_num
).name ();
6685 return (name
!= NULL
6686 && (startswith (name
, "PARENT")
6687 || startswith (name
, "_parent")));
6690 /* True iff field number FIELD_NUM of structure type TYPE is a
6691 transparent wrapper field (which should be silently traversed when doing
6692 field selection and flattened when printing). Assumes TYPE is a
6693 structure type with at least FIELD_NUM+1 fields. Such fields are always
6697 ada_is_wrapper_field (struct type
*type
, int field_num
)
6699 const char *name
= type
->field (field_num
).name ();
6701 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6703 /* This happens in functions with "out" or "in out" parameters
6704 which are passed by copy. For such functions, GNAT describes
6705 the function's return type as being a struct where the return
6706 value is in a field called RETVAL, and where the other "out"
6707 or "in out" parameters are fields of that struct. This is not
6712 return (name
!= NULL
6713 && (startswith (name
, "PARENT")
6714 || strcmp (name
, "REP") == 0
6715 || startswith (name
, "_parent")
6716 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6719 /* True iff field number FIELD_NUM of structure or union type TYPE
6720 is a variant wrapper. Assumes TYPE is a structure type with at least
6721 FIELD_NUM+1 fields. */
6724 ada_is_variant_part (struct type
*type
, int field_num
)
6726 /* Only Ada types are eligible. */
6727 if (!ADA_TYPE_P (type
))
6730 struct type
*field_type
= type
->field (field_num
).type ();
6732 return (field_type
->code () == TYPE_CODE_UNION
6733 || (is_dynamic_field (type
, field_num
)
6734 && (field_type
->target_type ()->code ()
6735 == TYPE_CODE_UNION
)));
6738 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6739 whose discriminants are contained in the record type OUTER_TYPE,
6740 returns the type of the controlling discriminant for the variant.
6741 May return NULL if the type could not be found. */
6744 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6746 const char *name
= ada_variant_discrim_name (var_type
);
6748 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6751 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6752 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6753 represents a 'when others' clause; otherwise 0. */
6756 ada_is_others_clause (struct type
*type
, int field_num
)
6758 const char *name
= type
->field (field_num
).name ();
6760 return (name
!= NULL
&& name
[0] == 'O');
6763 /* Assuming that TYPE0 is the type of the variant part of a record,
6764 returns the name of the discriminant controlling the variant.
6765 The value is valid until the next call to ada_variant_discrim_name. */
6768 ada_variant_discrim_name (struct type
*type0
)
6770 static std::string result
;
6773 const char *discrim_end
;
6774 const char *discrim_start
;
6776 if (type0
->code () == TYPE_CODE_PTR
)
6777 type
= type0
->target_type ();
6781 name
= ada_type_name (type
);
6783 if (name
== NULL
|| name
[0] == '\000')
6786 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6789 if (startswith (discrim_end
, "___XVN"))
6792 if (discrim_end
== name
)
6795 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6798 if (discrim_start
== name
+ 1)
6800 if ((discrim_start
> name
+ 3
6801 && startswith (discrim_start
- 3, "___"))
6802 || discrim_start
[-1] == '.')
6806 result
= std::string (discrim_start
, discrim_end
- discrim_start
);
6807 return result
.c_str ();
6810 /* Scan STR for a subtype-encoded number, beginning at position K.
6811 Put the position of the character just past the number scanned in
6812 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6813 Return 1 if there was a valid number at the given position, and 0
6814 otherwise. A "subtype-encoded" number consists of the absolute value
6815 in decimal, followed by the letter 'm' to indicate a negative number.
6816 Assumes 0m does not occur. */
6819 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6823 if (!isdigit (str
[k
]))
6826 /* Do it the hard way so as not to make any assumption about
6827 the relationship of unsigned long (%lu scan format code) and
6830 while (isdigit (str
[k
]))
6832 RU
= RU
* 10 + (str
[k
] - '0');
6839 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6845 /* NOTE on the above: Technically, C does not say what the results of
6846 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6847 number representable as a LONGEST (although either would probably work
6848 in most implementations). When RU>0, the locution in the then branch
6849 above is always equivalent to the negative of RU. */
6856 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6857 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6858 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6861 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6863 const char *name
= type
->field (field_num
).name ();
6877 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6887 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6888 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6890 if (val
>= L
&& val
<= U
)
6902 /* FIXME: Lots of redundancy below. Try to consolidate. */
6904 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6905 ARG_TYPE, extract and return the value of one of its (non-static)
6906 fields. FIELDNO says which field. Differs from value_primitive_field
6907 only in that it can handle packed values of arbitrary type. */
6910 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6911 struct type
*arg_type
)
6915 arg_type
= ada_check_typedef (arg_type
);
6916 type
= arg_type
->field (fieldno
).type ();
6918 /* Handle packed fields. It might be that the field is not packed
6919 relative to its containing structure, but the structure itself is
6920 packed; in this case we must take the bit-field path. */
6921 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6923 int bit_pos
= arg_type
->field (fieldno
).loc_bitpos ();
6924 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6926 return ada_value_primitive_packed_val (arg1
,
6927 value_contents (arg1
).data (),
6928 offset
+ bit_pos
/ 8,
6929 bit_pos
% 8, bit_size
, type
);
6932 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6935 /* Find field with name NAME in object of type TYPE. If found,
6936 set the following for each argument that is non-null:
6937 - *FIELD_TYPE_P to the field's type;
6938 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6939 an object of that type;
6940 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6941 - *BIT_SIZE_P to its size in bits if the field is packed, and
6943 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6944 fields up to but not including the desired field, or by the total
6945 number of fields if not found. A NULL value of NAME never
6946 matches; the function just counts visible fields in this case.
6948 Notice that we need to handle when a tagged record hierarchy
6949 has some components with the same name, like in this scenario:
6951 type Top_T is tagged record
6957 type Middle_T is new Top.Top_T with record
6958 N : Character := 'a';
6962 type Bottom_T is new Middle.Middle_T with record
6964 C : Character := '5';
6966 A : Character := 'J';
6969 Let's say we now have a variable declared and initialized as follow:
6971 TC : Top_A := new Bottom_T;
6973 And then we use this variable to call this function
6975 procedure Assign (Obj: in out Top_T; TV : Integer);
6979 Assign (Top_T (B), 12);
6981 Now, we're in the debugger, and we're inside that procedure
6982 then and we want to print the value of obj.c:
6984 Usually, the tagged record or one of the parent type owns the
6985 component to print and there's no issue but in this particular
6986 case, what does it mean to ask for Obj.C? Since the actual
6987 type for object is type Bottom_T, it could mean two things: type
6988 component C from the Middle_T view, but also component C from
6989 Bottom_T. So in that "undefined" case, when the component is
6990 not found in the non-resolved type (which includes all the
6991 components of the parent type), then resolve it and see if we
6992 get better luck once expanded.
6994 In the case of homonyms in the derived tagged type, we don't
6995 guaranty anything, and pick the one that's easiest for us
6998 Returns 1 if found, 0 otherwise. */
7001 find_struct_field (const char *name
, struct type
*type
, int offset
,
7002 struct type
**field_type_p
,
7003 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7007 int parent_offset
= -1;
7009 type
= ada_check_typedef (type
);
7011 if (field_type_p
!= NULL
)
7012 *field_type_p
= NULL
;
7013 if (byte_offset_p
!= NULL
)
7015 if (bit_offset_p
!= NULL
)
7017 if (bit_size_p
!= NULL
)
7020 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7022 /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7023 type. However, we only need the values to be correct when
7024 the caller asks for them. */
7025 int bit_pos
= 0, fld_offset
= 0;
7026 if (byte_offset_p
!= nullptr || bit_offset_p
!= nullptr)
7028 bit_pos
= type
->field (i
).loc_bitpos ();
7029 fld_offset
= offset
+ bit_pos
/ 8;
7032 const char *t_field_name
= type
->field (i
).name ();
7034 if (t_field_name
== NULL
)
7037 else if (ada_is_parent_field (type
, i
))
7039 /* This is a field pointing us to the parent type of a tagged
7040 type. As hinted in this function's documentation, we give
7041 preference to fields in the current record first, so what
7042 we do here is just record the index of this field before
7043 we skip it. If it turns out we couldn't find our field
7044 in the current record, then we'll get back to it and search
7045 inside it whether the field might exist in the parent. */
7051 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7053 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7055 if (field_type_p
!= NULL
)
7056 *field_type_p
= type
->field (i
).type ();
7057 if (byte_offset_p
!= NULL
)
7058 *byte_offset_p
= fld_offset
;
7059 if (bit_offset_p
!= NULL
)
7060 *bit_offset_p
= bit_pos
% 8;
7061 if (bit_size_p
!= NULL
)
7062 *bit_size_p
= bit_size
;
7065 else if (ada_is_wrapper_field (type
, i
))
7067 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7068 field_type_p
, byte_offset_p
, bit_offset_p
,
7069 bit_size_p
, index_p
))
7072 else if (ada_is_variant_part (type
, i
))
7074 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7077 struct type
*field_type
7078 = ada_check_typedef (type
->field (i
).type ());
7080 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7082 if (find_struct_field (name
, field_type
->field (j
).type (),
7084 + field_type
->field (j
).loc_bitpos () / 8,
7085 field_type_p
, byte_offset_p
,
7086 bit_offset_p
, bit_size_p
, index_p
))
7090 else if (index_p
!= NULL
)
7094 /* Field not found so far. If this is a tagged type which
7095 has a parent, try finding that field in the parent now. */
7097 if (parent_offset
!= -1)
7099 /* As above, only compute the offset when truly needed. */
7100 int fld_offset
= offset
;
7101 if (byte_offset_p
!= nullptr || bit_offset_p
!= nullptr)
7103 int bit_pos
= type
->field (parent_offset
).loc_bitpos ();
7104 fld_offset
+= bit_pos
/ 8;
7107 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7108 fld_offset
, field_type_p
, byte_offset_p
,
7109 bit_offset_p
, bit_size_p
, index_p
))
7116 /* Number of user-visible fields in record type TYPE. */
7119 num_visible_fields (struct type
*type
)
7124 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7128 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7129 and search in it assuming it has (class) type TYPE.
7130 If found, return value, else return NULL.
7132 Searches recursively through wrapper fields (e.g., '_parent').
7134 In the case of homonyms in the tagged types, please refer to the
7135 long explanation in find_struct_field's function documentation. */
7137 static struct value
*
7138 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7142 int parent_offset
= -1;
7144 type
= ada_check_typedef (type
);
7145 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7147 const char *t_field_name
= type
->field (i
).name ();
7149 if (t_field_name
== NULL
)
7152 else if (ada_is_parent_field (type
, i
))
7154 /* This is a field pointing us to the parent type of a tagged
7155 type. As hinted in this function's documentation, we give
7156 preference to fields in the current record first, so what
7157 we do here is just record the index of this field before
7158 we skip it. If it turns out we couldn't find our field
7159 in the current record, then we'll get back to it and search
7160 inside it whether the field might exist in the parent. */
7166 else if (field_name_match (t_field_name
, name
))
7167 return ada_value_primitive_field (arg
, offset
, i
, type
);
7169 else if (ada_is_wrapper_field (type
, i
))
7171 struct value
*v
= /* Do not let indent join lines here. */
7172 ada_search_struct_field (name
, arg
,
7173 offset
+ type
->field (i
).loc_bitpos () / 8,
7174 type
->field (i
).type ());
7180 else if (ada_is_variant_part (type
, i
))
7182 /* PNH: Do we ever get here? See find_struct_field. */
7184 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7185 int var_offset
= offset
+ type
->field (i
).loc_bitpos () / 8;
7187 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7189 struct value
*v
= ada_search_struct_field
/* Force line
7192 var_offset
+ field_type
->field (j
).loc_bitpos () / 8,
7193 field_type
->field (j
).type ());
7201 /* Field not found so far. If this is a tagged type which
7202 has a parent, try finding that field in the parent now. */
7204 if (parent_offset
!= -1)
7206 struct value
*v
= ada_search_struct_field (
7207 name
, arg
, offset
+ type
->field (parent_offset
).loc_bitpos () / 8,
7208 type
->field (parent_offset
).type ());
7217 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7218 int, struct type
*);
7221 /* Return field #INDEX in ARG, where the index is that returned by
7222 * find_struct_field through its INDEX_P argument. Adjust the address
7223 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7224 * If found, return value, else return NULL. */
7226 static struct value
*
7227 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7230 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7234 /* Auxiliary function for ada_index_struct_field. Like
7235 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7238 static struct value
*
7239 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7243 type
= ada_check_typedef (type
);
7245 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7247 if (type
->field (i
).name () == NULL
)
7249 else if (ada_is_wrapper_field (type
, i
))
7251 struct value
*v
= /* Do not let indent join lines here. */
7252 ada_index_struct_field_1 (index_p
, arg
,
7253 offset
+ type
->field (i
).loc_bitpos () / 8,
7254 type
->field (i
).type ());
7260 else if (ada_is_variant_part (type
, i
))
7262 /* PNH: Do we ever get here? See ada_search_struct_field,
7263 find_struct_field. */
7264 error (_("Cannot assign this kind of variant record"));
7266 else if (*index_p
== 0)
7267 return ada_value_primitive_field (arg
, offset
, i
, type
);
7274 /* Return a string representation of type TYPE. */
7277 type_as_string (struct type
*type
)
7279 string_file tmp_stream
;
7281 type_print (type
, "", &tmp_stream
, -1);
7283 return tmp_stream
.release ();
7286 /* Given a type TYPE, look up the type of the component of type named NAME.
7287 If DISPP is non-null, add its byte displacement from the beginning of a
7288 structure (pointed to by a value) of type TYPE to *DISPP (does not
7289 work for packed fields).
7291 Matches any field whose name has NAME as a prefix, possibly
7294 TYPE can be either a struct or union. If REFOK, TYPE may also
7295 be a (pointer or reference)+ to a struct or union, and the
7296 ultimate target type will be searched.
7298 Looks recursively into variant clauses and parent types.
7300 In the case of homonyms in the tagged types, please refer to the
7301 long explanation in find_struct_field's function documentation.
7303 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7304 TYPE is not a type of the right kind. */
7306 static struct type
*
7307 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7311 int parent_offset
= -1;
7316 if (refok
&& type
!= NULL
)
7319 type
= ada_check_typedef (type
);
7320 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7322 type
= type
->target_type ();
7326 || (type
->code () != TYPE_CODE_STRUCT
7327 && type
->code () != TYPE_CODE_UNION
))
7332 error (_("Type %s is not a structure or union type"),
7333 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7336 type
= to_static_fixed_type (type
);
7338 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7340 const char *t_field_name
= type
->field (i
).name ();
7343 if (t_field_name
== NULL
)
7346 else if (ada_is_parent_field (type
, i
))
7348 /* This is a field pointing us to the parent type of a tagged
7349 type. As hinted in this function's documentation, we give
7350 preference to fields in the current record first, so what
7351 we do here is just record the index of this field before
7352 we skip it. If it turns out we couldn't find our field
7353 in the current record, then we'll get back to it and search
7354 inside it whether the field might exist in the parent. */
7360 else if (field_name_match (t_field_name
, name
))
7361 return type
->field (i
).type ();
7363 else if (ada_is_wrapper_field (type
, i
))
7365 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7371 else if (ada_is_variant_part (type
, i
))
7374 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7376 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7378 /* FIXME pnh 2008/01/26: We check for a field that is
7379 NOT wrapped in a struct, since the compiler sometimes
7380 generates these for unchecked variant types. Revisit
7381 if the compiler changes this practice. */
7382 const char *v_field_name
= field_type
->field (j
).name ();
7384 if (v_field_name
!= NULL
7385 && field_name_match (v_field_name
, name
))
7386 t
= field_type
->field (j
).type ();
7388 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7398 /* Field not found so far. If this is a tagged type which
7399 has a parent, try finding that field in the parent now. */
7401 if (parent_offset
!= -1)
7405 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7414 const char *name_str
= name
!= NULL
? name
: _("<null>");
7416 error (_("Type %s has no component named %s"),
7417 type_as_string (type
).c_str (), name_str
);
7423 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7424 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7425 represents an unchecked union (that is, the variant part of a
7426 record that is named in an Unchecked_Union pragma). */
7429 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7431 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7433 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7437 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7438 within OUTER, determine which variant clause (field number in VAR_TYPE,
7439 numbering from 0) is applicable. Returns -1 if none are. */
7442 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7446 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7447 struct value
*discrim
;
7448 LONGEST discrim_val
;
7450 /* Using plain value_from_contents_and_address here causes problems
7451 because we will end up trying to resolve a type that is currently
7452 being constructed. */
7453 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7454 if (discrim
== NULL
)
7456 discrim_val
= value_as_long (discrim
);
7459 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7461 if (ada_is_others_clause (var_type
, i
))
7463 else if (ada_in_variant (discrim_val
, var_type
, i
))
7467 return others_clause
;
7472 /* Dynamic-Sized Records */
7474 /* Strategy: The type ostensibly attached to a value with dynamic size
7475 (i.e., a size that is not statically recorded in the debugging
7476 data) does not accurately reflect the size or layout of the value.
7477 Our strategy is to convert these values to values with accurate,
7478 conventional types that are constructed on the fly. */
7480 /* There is a subtle and tricky problem here. In general, we cannot
7481 determine the size of dynamic records without its data. However,
7482 the 'struct value' data structure, which GDB uses to represent
7483 quantities in the inferior process (the target), requires the size
7484 of the type at the time of its allocation in order to reserve space
7485 for GDB's internal copy of the data. That's why the
7486 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7487 rather than struct value*s.
7489 However, GDB's internal history variables ($1, $2, etc.) are
7490 struct value*s containing internal copies of the data that are not, in
7491 general, the same as the data at their corresponding addresses in
7492 the target. Fortunately, the types we give to these values are all
7493 conventional, fixed-size types (as per the strategy described
7494 above), so that we don't usually have to perform the
7495 'to_fixed_xxx_type' conversions to look at their values.
7496 Unfortunately, there is one exception: if one of the internal
7497 history variables is an array whose elements are unconstrained
7498 records, then we will need to create distinct fixed types for each
7499 element selected. */
7501 /* The upshot of all of this is that many routines take a (type, host
7502 address, target address) triple as arguments to represent a value.
7503 The host address, if non-null, is supposed to contain an internal
7504 copy of the relevant data; otherwise, the program is to consult the
7505 target at the target address. */
7507 /* Assuming that VAL0 represents a pointer value, the result of
7508 dereferencing it. Differs from value_ind in its treatment of
7509 dynamic-sized types. */
7512 ada_value_ind (struct value
*val0
)
7514 struct value
*val
= value_ind (val0
);
7516 if (ada_is_tagged_type (val
->type (), 0))
7517 val
= ada_tag_value_at_base_address (val
);
7519 return ada_to_fixed_value (val
);
7522 /* The value resulting from dereferencing any "reference to"
7523 qualifiers on VAL0. */
7525 static struct value
*
7526 ada_coerce_ref (struct value
*val0
)
7528 if (val0
->type ()->code () == TYPE_CODE_REF
)
7530 struct value
*val
= val0
;
7532 val
= coerce_ref (val
);
7534 if (ada_is_tagged_type (val
->type (), 0))
7535 val
= ada_tag_value_at_base_address (val
);
7537 return ada_to_fixed_value (val
);
7543 /* Return the bit alignment required for field #F of template type TYPE. */
7546 field_alignment (struct type
*type
, int f
)
7548 const char *name
= type
->field (f
).name ();
7552 /* The field name should never be null, unless the debugging information
7553 is somehow malformed. In this case, we assume the field does not
7554 require any alignment. */
7558 len
= strlen (name
);
7560 if (!isdigit (name
[len
- 1]))
7563 if (isdigit (name
[len
- 2]))
7564 align_offset
= len
- 2;
7566 align_offset
= len
- 1;
7568 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7569 return TARGET_CHAR_BIT
;
7571 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7574 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7576 static struct symbol
*
7577 ada_find_any_type_symbol (const char *name
)
7581 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7582 if (sym
!= NULL
&& sym
->aclass () == LOC_TYPEDEF
)
7585 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7589 /* Find a type named NAME. Ignores ambiguity. This routine will look
7590 solely for types defined by debug info, it will not search the GDB
7593 static struct type
*
7594 ada_find_any_type (const char *name
)
7596 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7599 return sym
->type ();
7604 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7605 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7606 symbol, in which case it is returned. Otherwise, this looks for
7607 symbols whose name is that of NAME_SYM suffixed with "___XR".
7608 Return symbol if found, and NULL otherwise. */
7611 ada_is_renaming_symbol (struct symbol
*name_sym
)
7613 const char *name
= name_sym
->linkage_name ();
7614 return strstr (name
, "___XR") != NULL
;
7617 /* Because of GNAT encoding conventions, several GDB symbols may match a
7618 given type name. If the type denoted by TYPE0 is to be preferred to
7619 that of TYPE1 for purposes of type printing, return non-zero;
7620 otherwise return 0. */
7623 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7627 else if (type0
== NULL
)
7629 else if (type1
->code () == TYPE_CODE_VOID
)
7631 else if (type0
->code () == TYPE_CODE_VOID
)
7633 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7635 else if (ada_is_constrained_packed_array_type (type0
))
7637 else if (ada_is_array_descriptor_type (type0
)
7638 && !ada_is_array_descriptor_type (type1
))
7642 const char *type0_name
= type0
->name ();
7643 const char *type1_name
= type1
->name ();
7645 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7646 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7652 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7656 ada_type_name (struct type
*type
)
7660 return type
->name ();
7663 /* Search the list of "descriptive" types associated to TYPE for a type
7664 whose name is NAME. */
7666 static struct type
*
7667 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7669 struct type
*result
, *tmp
;
7671 if (ada_ignore_descriptive_types_p
)
7674 /* If there no descriptive-type info, then there is no parallel type
7676 if (!HAVE_GNAT_AUX_INFO (type
))
7679 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7680 while (result
!= NULL
)
7682 const char *result_name
= ada_type_name (result
);
7684 if (result_name
== NULL
)
7686 warning (_("unexpected null name on descriptive type"));
7690 /* If the names match, stop. */
7691 if (strcmp (result_name
, name
) == 0)
7694 /* Otherwise, look at the next item on the list, if any. */
7695 if (HAVE_GNAT_AUX_INFO (result
))
7696 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7700 /* If not found either, try after having resolved the typedef. */
7705 result
= check_typedef (result
);
7706 if (HAVE_GNAT_AUX_INFO (result
))
7707 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7713 /* If we didn't find a match, see whether this is a packed array. With
7714 older compilers, the descriptive type information is either absent or
7715 irrelevant when it comes to packed arrays so the above lookup fails.
7716 Fall back to using a parallel lookup by name in this case. */
7717 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7718 return ada_find_any_type (name
);
7723 /* Find a parallel type to TYPE with the specified NAME, using the
7724 descriptive type taken from the debugging information, if available,
7725 and otherwise using the (slower) name-based method. */
7727 static struct type
*
7728 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7730 struct type
*result
= NULL
;
7732 if (HAVE_GNAT_AUX_INFO (type
))
7733 result
= find_parallel_type_by_descriptive_type (type
, name
);
7735 result
= ada_find_any_type (name
);
7740 /* Same as above, but specify the name of the parallel type by appending
7741 SUFFIX to the name of TYPE. */
7744 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7747 const char *type_name
= ada_type_name (type
);
7750 if (type_name
== NULL
)
7753 len
= strlen (type_name
);
7755 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7757 strcpy (name
, type_name
);
7758 strcpy (name
+ len
, suffix
);
7760 return ada_find_parallel_type_with_name (type
, name
);
7763 /* If TYPE is a variable-size record type, return the corresponding template
7764 type describing its fields. Otherwise, return NULL. */
7766 static struct type
*
7767 dynamic_template_type (struct type
*type
)
7769 type
= ada_check_typedef (type
);
7771 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7772 || ada_type_name (type
) == NULL
)
7776 int len
= strlen (ada_type_name (type
));
7778 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7781 return ada_find_parallel_type (type
, "___XVE");
7785 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7786 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7789 is_dynamic_field (struct type
*templ_type
, int field_num
)
7791 const char *name
= templ_type
->field (field_num
).name ();
7794 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7795 && strstr (name
, "___XVL") != NULL
;
7798 /* The index of the variant field of TYPE, or -1 if TYPE does not
7799 represent a variant record type. */
7802 variant_field_index (struct type
*type
)
7806 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7809 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7811 if (ada_is_variant_part (type
, f
))
7817 /* A record type with no fields. */
7819 static struct type
*
7820 empty_record (struct type
*templ
)
7822 struct type
*type
= alloc_type_copy (templ
);
7824 type
->set_code (TYPE_CODE_STRUCT
);
7825 INIT_NONE_SPECIFIC (type
);
7826 type
->set_name ("<empty>");
7827 type
->set_length (0);
7831 /* An ordinary record type (with fixed-length fields) that describes
7832 the value of type TYPE at VALADDR or ADDRESS (see comments at
7833 the beginning of this section) VAL according to GNAT conventions.
7834 DVAL0 should describe the (portion of a) record that contains any
7835 necessary discriminants. It should be NULL if VAL->type () is
7836 an outer-level type (i.e., as opposed to a branch of a variant.) A
7837 variant field (unless unchecked) is replaced by a particular branch
7840 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7841 length are not statically known are discarded. As a consequence,
7842 VALADDR, ADDRESS and DVAL0 are ignored.
7844 NOTE: Limitations: For now, we assume that dynamic fields and
7845 variants occupy whole numbers of bytes. However, they need not be
7849 ada_template_to_fixed_record_type_1 (struct type
*type
,
7850 const gdb_byte
*valaddr
,
7851 CORE_ADDR address
, struct value
*dval0
,
7852 int keep_dynamic_fields
)
7856 int nfields
, bit_len
;
7862 scoped_value_mark mark
;
7864 /* Compute the number of fields in this record type that are going
7865 to be processed: unless keep_dynamic_fields, this includes only
7866 fields whose position and length are static will be processed. */
7867 if (keep_dynamic_fields
)
7868 nfields
= type
->num_fields ();
7872 while (nfields
< type
->num_fields ()
7873 && !ada_is_variant_part (type
, nfields
)
7874 && !is_dynamic_field (type
, nfields
))
7878 rtype
= alloc_type_copy (type
);
7879 rtype
->set_code (TYPE_CODE_STRUCT
);
7880 INIT_NONE_SPECIFIC (rtype
);
7881 rtype
->set_num_fields (nfields
);
7883 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7884 rtype
->set_name (ada_type_name (type
));
7885 rtype
->set_is_fixed_instance (true);
7891 for (f
= 0; f
< nfields
; f
+= 1)
7893 off
= align_up (off
, field_alignment (type
, f
))
7894 + type
->field (f
).loc_bitpos ();
7895 rtype
->field (f
).set_loc_bitpos (off
);
7896 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7898 if (ada_is_variant_part (type
, f
))
7903 else if (is_dynamic_field (type
, f
))
7905 const gdb_byte
*field_valaddr
= valaddr
;
7906 CORE_ADDR field_address
= address
;
7907 struct type
*field_type
= type
->field (f
).type ()->target_type ();
7911 /* Using plain value_from_contents_and_address here
7912 causes problems because we will end up trying to
7913 resolve a type that is currently being
7915 dval
= value_from_contents_and_address_unresolved (rtype
,
7918 rtype
= dval
->type ();
7923 /* If the type referenced by this field is an aligner type, we need
7924 to unwrap that aligner type, because its size might not be set.
7925 Keeping the aligner type would cause us to compute the wrong
7926 size for this field, impacting the offset of the all the fields
7927 that follow this one. */
7928 if (ada_is_aligner_type (field_type
))
7930 long field_offset
= type
->field (f
).loc_bitpos ();
7932 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7933 field_address
= cond_offset_target (field_address
, field_offset
);
7934 field_type
= ada_aligned_type (field_type
);
7937 field_valaddr
= cond_offset_host (field_valaddr
,
7938 off
/ TARGET_CHAR_BIT
);
7939 field_address
= cond_offset_target (field_address
,
7940 off
/ TARGET_CHAR_BIT
);
7942 /* Get the fixed type of the field. Note that, in this case,
7943 we do not want to get the real type out of the tag: if
7944 the current field is the parent part of a tagged record,
7945 we will get the tag of the object. Clearly wrong: the real
7946 type of the parent is not the real type of the child. We
7947 would end up in an infinite loop. */
7948 field_type
= ada_get_base_type (field_type
);
7949 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7950 field_address
, dval
, 0);
7952 rtype
->field (f
).set_type (field_type
);
7953 rtype
->field (f
).set_name (type
->field (f
).name ());
7954 /* The multiplication can potentially overflow. But because
7955 the field length has been size-checked just above, and
7956 assuming that the maximum size is a reasonable value,
7957 an overflow should not happen in practice. So rather than
7958 adding overflow recovery code to this already complex code,
7959 we just assume that it's not going to happen. */
7960 fld_bit_len
= rtype
->field (f
).type ()->length () * TARGET_CHAR_BIT
;
7964 /* Note: If this field's type is a typedef, it is important
7965 to preserve the typedef layer.
7967 Otherwise, we might be transforming a typedef to a fat
7968 pointer (encoding a pointer to an unconstrained array),
7969 into a basic fat pointer (encoding an unconstrained
7970 array). As both types are implemented using the same
7971 structure, the typedef is the only clue which allows us
7972 to distinguish between the two options. Stripping it
7973 would prevent us from printing this field appropriately. */
7974 rtype
->field (f
).set_type (type
->field (f
).type ());
7975 rtype
->field (f
).set_name (type
->field (f
).name ());
7976 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7978 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7981 struct type
*field_type
= type
->field (f
).type ();
7983 /* We need to be careful of typedefs when computing
7984 the length of our field. If this is a typedef,
7985 get the length of the target type, not the length
7987 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7988 field_type
= ada_typedef_target_type (field_type
);
7991 ada_check_typedef (field_type
)->length () * TARGET_CHAR_BIT
;
7994 if (off
+ fld_bit_len
> bit_len
)
7995 bit_len
= off
+ fld_bit_len
;
7997 rtype
->set_length (align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
);
8000 /* We handle the variant part, if any, at the end because of certain
8001 odd cases in which it is re-ordered so as NOT to be the last field of
8002 the record. This can happen in the presence of representation
8004 if (variant_field
>= 0)
8006 struct type
*branch_type
;
8008 off
= rtype
->field (variant_field
).loc_bitpos ();
8012 /* Using plain value_from_contents_and_address here causes
8013 problems because we will end up trying to resolve a type
8014 that is currently being constructed. */
8015 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8017 rtype
= dval
->type ();
8023 to_fixed_variant_branch_type
8024 (type
->field (variant_field
).type (),
8025 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8026 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8027 if (branch_type
== NULL
)
8029 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8030 rtype
->field (f
- 1) = rtype
->field (f
);
8031 rtype
->set_num_fields (rtype
->num_fields () - 1);
8035 rtype
->field (variant_field
).set_type (branch_type
);
8036 rtype
->field (variant_field
).set_name ("S");
8038 rtype
->field (variant_field
).type ()->length () * TARGET_CHAR_BIT
;
8039 if (off
+ fld_bit_len
> bit_len
)
8040 bit_len
= off
+ fld_bit_len
;
8043 (align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
);
8047 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8048 should contain the alignment of that record, which should be a strictly
8049 positive value. If null or negative, then something is wrong, most
8050 probably in the debug info. In that case, we don't round up the size
8051 of the resulting type. If this record is not part of another structure,
8052 the current RTYPE length might be good enough for our purposes. */
8053 if (type
->length () <= 0)
8056 warning (_("Invalid type size for `%s' detected: %s."),
8057 rtype
->name (), pulongest (type
->length ()));
8059 warning (_("Invalid type size for <unnamed> detected: %s."),
8060 pulongest (type
->length ()));
8063 rtype
->set_length (align_up (rtype
->length (), type
->length ()));
8068 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8071 static struct type
*
8072 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8073 CORE_ADDR address
, struct value
*dval0
)
8075 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8079 /* An ordinary record type in which ___XVL-convention fields and
8080 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8081 static approximations, containing all possible fields. Uses
8082 no runtime values. Useless for use in values, but that's OK,
8083 since the results are used only for type determinations. Works on both
8084 structs and unions. Representation note: to save space, we memorize
8085 the result of this function in the type::target_type of the
8088 static struct type
*
8089 template_to_static_fixed_type (struct type
*type0
)
8095 /* No need no do anything if the input type is already fixed. */
8096 if (type0
->is_fixed_instance ())
8099 /* Likewise if we already have computed the static approximation. */
8100 if (type0
->target_type () != NULL
)
8101 return type0
->target_type ();
8103 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8105 nfields
= type0
->num_fields ();
8107 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8108 recompute all over next time. */
8109 type0
->set_target_type (type
);
8111 for (f
= 0; f
< nfields
; f
+= 1)
8113 struct type
*field_type
= type0
->field (f
).type ();
8114 struct type
*new_type
;
8116 if (is_dynamic_field (type0
, f
))
8118 field_type
= ada_check_typedef (field_type
);
8119 new_type
= to_static_fixed_type (field_type
->target_type ());
8122 new_type
= static_unwrap_type (field_type
);
8124 if (new_type
!= field_type
)
8126 /* Clone TYPE0 only the first time we get a new field type. */
8129 type
= alloc_type_copy (type0
);
8130 type0
->set_target_type (type
);
8131 type
->set_code (type0
->code ());
8132 INIT_NONE_SPECIFIC (type
);
8133 type
->set_num_fields (nfields
);
8137 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8138 memcpy (fields
, type0
->fields (),
8139 sizeof (struct field
) * nfields
);
8140 type
->set_fields (fields
);
8142 type
->set_name (ada_type_name (type0
));
8143 type
->set_is_fixed_instance (true);
8144 type
->set_length (0);
8146 type
->field (f
).set_type (new_type
);
8147 type
->field (f
).set_name (type0
->field (f
).name ());
8154 /* Given an object of type TYPE whose contents are at VALADDR and
8155 whose address in memory is ADDRESS, returns a revision of TYPE,
8156 which should be a non-dynamic-sized record, in which the variant
8157 part, if any, is replaced with the appropriate branch. Looks
8158 for discriminant values in DVAL0, which can be NULL if the record
8159 contains the necessary discriminant values. */
8161 static struct type
*
8162 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8163 CORE_ADDR address
, struct value
*dval0
)
8167 struct type
*branch_type
;
8168 int nfields
= type
->num_fields ();
8169 int variant_field
= variant_field_index (type
);
8171 if (variant_field
== -1)
8174 scoped_value_mark mark
;
8177 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8178 type
= dval
->type ();
8183 rtype
= alloc_type_copy (type
);
8184 rtype
->set_code (TYPE_CODE_STRUCT
);
8185 INIT_NONE_SPECIFIC (rtype
);
8186 rtype
->set_num_fields (nfields
);
8189 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8190 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8191 rtype
->set_fields (fields
);
8193 rtype
->set_name (ada_type_name (type
));
8194 rtype
->set_is_fixed_instance (true);
8195 rtype
->set_length (type
->length ());
8197 branch_type
= to_fixed_variant_branch_type
8198 (type
->field (variant_field
).type (),
8199 cond_offset_host (valaddr
,
8200 type
->field (variant_field
).loc_bitpos ()
8202 cond_offset_target (address
,
8203 type
->field (variant_field
).loc_bitpos ()
8204 / TARGET_CHAR_BIT
), dval
);
8205 if (branch_type
== NULL
)
8209 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8210 rtype
->field (f
- 1) = rtype
->field (f
);
8211 rtype
->set_num_fields (rtype
->num_fields () - 1);
8215 rtype
->field (variant_field
).set_type (branch_type
);
8216 rtype
->field (variant_field
).set_name ("S");
8217 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8218 rtype
->set_length (rtype
->length () + branch_type
->length ());
8221 rtype
->set_length (rtype
->length ()
8222 - type
->field (variant_field
).type ()->length ());
8227 /* An ordinary record type (with fixed-length fields) that describes
8228 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8229 beginning of this section]. Any necessary discriminants' values
8230 should be in DVAL, a record value; it may be NULL if the object
8231 at ADDR itself contains any necessary discriminant values.
8232 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8233 values from the record are needed. Except in the case that DVAL,
8234 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8235 unchecked) is replaced by a particular branch of the variant.
8237 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8238 is questionable and may be removed. It can arise during the
8239 processing of an unconstrained-array-of-record type where all the
8240 variant branches have exactly the same size. This is because in
8241 such cases, the compiler does not bother to use the XVS convention
8242 when encoding the record. I am currently dubious of this
8243 shortcut and suspect the compiler should be altered. FIXME. */
8245 static struct type
*
8246 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8247 CORE_ADDR address
, struct value
*dval
)
8249 struct type
*templ_type
;
8251 if (type0
->is_fixed_instance ())
8254 templ_type
= dynamic_template_type (type0
);
8256 if (templ_type
!= NULL
)
8257 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8258 else if (variant_field_index (type0
) >= 0)
8260 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8262 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8267 type0
->set_is_fixed_instance (true);
8273 /* An ordinary record type (with fixed-length fields) that describes
8274 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8275 union type. Any necessary discriminants' values should be in DVAL,
8276 a record value. That is, this routine selects the appropriate
8277 branch of the union at ADDR according to the discriminant value
8278 indicated in the union's type name. Returns VAR_TYPE0 itself if
8279 it represents a variant subject to a pragma Unchecked_Union. */
8281 static struct type
*
8282 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8283 CORE_ADDR address
, struct value
*dval
)
8286 struct type
*templ_type
;
8287 struct type
*var_type
;
8289 if (var_type0
->code () == TYPE_CODE_PTR
)
8290 var_type
= var_type0
->target_type ();
8292 var_type
= var_type0
;
8294 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8296 if (templ_type
!= NULL
)
8297 var_type
= templ_type
;
8299 if (is_unchecked_variant (var_type
, dval
->type ()))
8301 which
= ada_which_variant_applies (var_type
, dval
);
8304 return empty_record (var_type
);
8305 else if (is_dynamic_field (var_type
, which
))
8306 return to_fixed_record_type
8307 (var_type
->field (which
).type ()->target_type(), valaddr
, address
, dval
);
8308 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8310 to_fixed_record_type
8311 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8313 return var_type
->field (which
).type ();
8316 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8317 ENCODING_TYPE, a type following the GNAT conventions for discrete
8318 type encodings, only carries redundant information. */
8321 ada_is_redundant_range_encoding (struct type
*range_type
,
8322 struct type
*encoding_type
)
8324 const char *bounds_str
;
8328 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8330 if (get_base_type (range_type
)->code ()
8331 != get_base_type (encoding_type
)->code ())
8333 /* The compiler probably used a simple base type to describe
8334 the range type instead of the range's actual base type,
8335 expecting us to get the real base type from the encoding
8336 anyway. In this situation, the encoding cannot be ignored
8341 if (is_dynamic_type (range_type
))
8344 if (encoding_type
->name () == NULL
)
8347 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8348 if (bounds_str
== NULL
)
8351 n
= 8; /* Skip "___XDLU_". */
8352 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8354 if (range_type
->bounds ()->low
.const_val () != lo
)
8357 n
+= 2; /* Skip the "__" separator between the two bounds. */
8358 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8360 if (range_type
->bounds ()->high
.const_val () != hi
)
8366 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8367 a type following the GNAT encoding for describing array type
8368 indices, only carries redundant information. */
8371 ada_is_redundant_index_type_desc (struct type
*array_type
,
8372 struct type
*desc_type
)
8374 struct type
*this_layer
= check_typedef (array_type
);
8377 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8379 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8380 desc_type
->field (i
).type ()))
8382 this_layer
= check_typedef (this_layer
->target_type ());
8388 /* Assuming that TYPE0 is an array type describing the type of a value
8389 at ADDR, and that DVAL describes a record containing any
8390 discriminants used in TYPE0, returns a type for the value that
8391 contains no dynamic components (that is, no components whose sizes
8392 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8393 true, gives an error message if the resulting type's size is over
8396 static struct type
*
8397 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8400 struct type
*index_type_desc
;
8401 struct type
*result
;
8402 int constrained_packed_array_p
;
8403 static const char *xa_suffix
= "___XA";
8405 type0
= ada_check_typedef (type0
);
8406 if (type0
->is_fixed_instance ())
8409 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8410 if (constrained_packed_array_p
)
8412 type0
= decode_constrained_packed_array_type (type0
);
8413 if (type0
== nullptr)
8414 error (_("could not decode constrained packed array type"));
8417 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8419 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8420 encoding suffixed with 'P' may still be generated. If so,
8421 it should be used to find the XA type. */
8423 if (index_type_desc
== NULL
)
8425 const char *type_name
= ada_type_name (type0
);
8427 if (type_name
!= NULL
)
8429 const int len
= strlen (type_name
);
8430 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8432 if (type_name
[len
- 1] == 'P')
8434 strcpy (name
, type_name
);
8435 strcpy (name
+ len
- 1, xa_suffix
);
8436 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8441 ada_fixup_array_indexes_type (index_type_desc
);
8442 if (index_type_desc
!= NULL
8443 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8445 /* Ignore this ___XA parallel type, as it does not bring any
8446 useful information. This allows us to avoid creating fixed
8447 versions of the array's index types, which would be identical
8448 to the original ones. This, in turn, can also help avoid
8449 the creation of fixed versions of the array itself. */
8450 index_type_desc
= NULL
;
8453 if (index_type_desc
== NULL
)
8455 struct type
*elt_type0
= ada_check_typedef (type0
->target_type ());
8457 /* NOTE: elt_type---the fixed version of elt_type0---should never
8458 depend on the contents of the array in properly constructed
8460 /* Create a fixed version of the array element type.
8461 We're not providing the address of an element here,
8462 and thus the actual object value cannot be inspected to do
8463 the conversion. This should not be a problem, since arrays of
8464 unconstrained objects are not allowed. In particular, all
8465 the elements of an array of a tagged type should all be of
8466 the same type specified in the debugging info. No need to
8467 consult the object tag. */
8468 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8470 /* Make sure we always create a new array type when dealing with
8471 packed array types, since we're going to fix-up the array
8472 type length and element bitsize a little further down. */
8473 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8476 result
= create_array_type (alloc_type_copy (type0
),
8477 elt_type
, type0
->index_type ());
8482 struct type
*elt_type0
;
8485 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8486 elt_type0
= elt_type0
->target_type ();
8488 /* NOTE: result---the fixed version of elt_type0---should never
8489 depend on the contents of the array in properly constructed
8491 /* Create a fixed version of the array element type.
8492 We're not providing the address of an element here,
8493 and thus the actual object value cannot be inspected to do
8494 the conversion. This should not be a problem, since arrays of
8495 unconstrained objects are not allowed. In particular, all
8496 the elements of an array of a tagged type should all be of
8497 the same type specified in the debugging info. No need to
8498 consult the object tag. */
8500 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8503 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8505 struct type
*range_type
=
8506 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8508 result
= create_array_type (alloc_type_copy (elt_type0
),
8509 result
, range_type
);
8510 elt_type0
= elt_type0
->target_type ();
8514 /* We want to preserve the type name. This can be useful when
8515 trying to get the type name of a value that has already been
8516 printed (for instance, if the user did "print VAR; whatis $". */
8517 result
->set_name (type0
->name ());
8519 if (constrained_packed_array_p
)
8521 /* So far, the resulting type has been created as if the original
8522 type was a regular (non-packed) array type. As a result, the
8523 bitsize of the array elements needs to be set again, and the array
8524 length needs to be recomputed based on that bitsize. */
8525 int len
= result
->length () / result
->target_type ()->length ();
8526 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8528 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8529 result
->set_length (len
* elt_bitsize
/ HOST_CHAR_BIT
);
8530 if (result
->length () * HOST_CHAR_BIT
< len
* elt_bitsize
)
8531 result
->set_length (result
->length () + 1);
8534 result
->set_is_fixed_instance (true);
8539 /* A standard type (containing no dynamically sized components)
8540 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8541 DVAL describes a record containing any discriminants used in TYPE0,
8542 and may be NULL if there are none, or if the object of type TYPE at
8543 ADDRESS or in VALADDR contains these discriminants.
8545 If CHECK_TAG is not null, in the case of tagged types, this function
8546 attempts to locate the object's tag and use it to compute the actual
8547 type. However, when ADDRESS is null, we cannot use it to determine the
8548 location of the tag, and therefore compute the tagged type's actual type.
8549 So we return the tagged type without consulting the tag. */
8551 static struct type
*
8552 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8553 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8555 type
= ada_check_typedef (type
);
8557 /* Only un-fixed types need to be handled here. */
8558 if (!HAVE_GNAT_AUX_INFO (type
))
8561 switch (type
->code ())
8565 case TYPE_CODE_STRUCT
:
8567 struct type
*static_type
= to_static_fixed_type (type
);
8568 struct type
*fixed_record_type
=
8569 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8571 /* If STATIC_TYPE is a tagged type and we know the object's address,
8572 then we can determine its tag, and compute the object's actual
8573 type from there. Note that we have to use the fixed record
8574 type (the parent part of the record may have dynamic fields
8575 and the way the location of _tag is expressed may depend on
8578 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8581 value_tag_from_contents_and_address
8585 struct type
*real_type
= type_from_tag (tag
);
8587 value_from_contents_and_address (fixed_record_type
,
8590 fixed_record_type
= obj
->type ();
8591 if (real_type
!= NULL
)
8592 return to_fixed_record_type
8594 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8597 /* Check to see if there is a parallel ___XVZ variable.
8598 If there is, then it provides the actual size of our type. */
8599 else if (ada_type_name (fixed_record_type
) != NULL
)
8601 const char *name
= ada_type_name (fixed_record_type
);
8603 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8604 bool xvz_found
= false;
8607 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8610 xvz_found
= get_int_var_value (xvz_name
, size
);
8612 catch (const gdb_exception_error
&except
)
8614 /* We found the variable, but somehow failed to read
8615 its value. Rethrow the same error, but with a little
8616 bit more information, to help the user understand
8617 what went wrong (Eg: the variable might have been
8619 throw_error (except
.error
,
8620 _("unable to read value of %s (%s)"),
8621 xvz_name
, except
.what ());
8624 if (xvz_found
&& fixed_record_type
->length () != size
)
8626 fixed_record_type
= copy_type (fixed_record_type
);
8627 fixed_record_type
->set_length (size
);
8629 /* The FIXED_RECORD_TYPE may have be a stub. We have
8630 observed this when the debugging info is STABS, and
8631 apparently it is something that is hard to fix.
8633 In practice, we don't need the actual type definition
8634 at all, because the presence of the XVZ variable allows us
8635 to assume that there must be a XVS type as well, which we
8636 should be able to use later, when we need the actual type
8639 In the meantime, pretend that the "fixed" type we are
8640 returning is NOT a stub, because this can cause trouble
8641 when using this type to create new types targeting it.
8642 Indeed, the associated creation routines often check
8643 whether the target type is a stub and will try to replace
8644 it, thus using a type with the wrong size. This, in turn,
8645 might cause the new type to have the wrong size too.
8646 Consider the case of an array, for instance, where the size
8647 of the array is computed from the number of elements in
8648 our array multiplied by the size of its element. */
8649 fixed_record_type
->set_is_stub (false);
8652 return fixed_record_type
;
8654 case TYPE_CODE_ARRAY
:
8655 return to_fixed_array_type (type
, dval
, 1);
8656 case TYPE_CODE_UNION
:
8660 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8664 /* The same as ada_to_fixed_type_1, except that it preserves the type
8665 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8667 The typedef layer needs be preserved in order to differentiate between
8668 arrays and array pointers when both types are implemented using the same
8669 fat pointer. In the array pointer case, the pointer is encoded as
8670 a typedef of the pointer type. For instance, considering:
8672 type String_Access is access String;
8673 S1 : String_Access := null;
8675 To the debugger, S1 is defined as a typedef of type String. But
8676 to the user, it is a pointer. So if the user tries to print S1,
8677 we should not dereference the array, but print the array address
8680 If we didn't preserve the typedef layer, we would lose the fact that
8681 the type is to be presented as a pointer (needs de-reference before
8682 being printed). And we would also use the source-level type name. */
8685 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8686 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8689 struct type
*fixed_type
=
8690 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8692 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8693 then preserve the typedef layer.
8695 Implementation note: We can only check the main-type portion of
8696 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8697 from TYPE now returns a type that has the same instance flags
8698 as TYPE. For instance, if TYPE is a "typedef const", and its
8699 target type is a "struct", then the typedef elimination will return
8700 a "const" version of the target type. See check_typedef for more
8701 details about how the typedef layer elimination is done.
8703 brobecker/2010-11-19: It seems to me that the only case where it is
8704 useful to preserve the typedef layer is when dealing with fat pointers.
8705 Perhaps, we could add a check for that and preserve the typedef layer
8706 only in that situation. But this seems unnecessary so far, probably
8707 because we call check_typedef/ada_check_typedef pretty much everywhere.
8709 if (type
->code () == TYPE_CODE_TYPEDEF
8710 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8711 == TYPE_MAIN_TYPE (fixed_type
)))
8717 /* A standard (static-sized) type corresponding as well as possible to
8718 TYPE0, but based on no runtime data. */
8720 static struct type
*
8721 to_static_fixed_type (struct type
*type0
)
8728 if (type0
->is_fixed_instance ())
8731 type0
= ada_check_typedef (type0
);
8733 switch (type0
->code ())
8737 case TYPE_CODE_STRUCT
:
8738 type
= dynamic_template_type (type0
);
8740 return template_to_static_fixed_type (type
);
8742 return template_to_static_fixed_type (type0
);
8743 case TYPE_CODE_UNION
:
8744 type
= ada_find_parallel_type (type0
, "___XVU");
8746 return template_to_static_fixed_type (type
);
8748 return template_to_static_fixed_type (type0
);
8752 /* A static approximation of TYPE with all type wrappers removed. */
8754 static struct type
*
8755 static_unwrap_type (struct type
*type
)
8757 if (ada_is_aligner_type (type
))
8759 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8760 if (ada_type_name (type1
) == NULL
)
8761 type1
->set_name (ada_type_name (type
));
8763 return static_unwrap_type (type1
);
8767 struct type
*raw_real_type
= ada_get_base_type (type
);
8769 if (raw_real_type
== type
)
8772 return to_static_fixed_type (raw_real_type
);
8776 /* In some cases, incomplete and private types require
8777 cross-references that are not resolved as records (for example,
8779 type FooP is access Foo;
8781 type Foo is array ...;
8782 ). In these cases, since there is no mechanism for producing
8783 cross-references to such types, we instead substitute for FooP a
8784 stub enumeration type that is nowhere resolved, and whose tag is
8785 the name of the actual type. Call these types "non-record stubs". */
8787 /* A type equivalent to TYPE that is not a non-record stub, if one
8788 exists, otherwise TYPE. */
8791 ada_check_typedef (struct type
*type
)
8796 /* If our type is an access to an unconstrained array, which is encoded
8797 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8798 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8799 what allows us to distinguish between fat pointers that represent
8800 array types, and fat pointers that represent array access types
8801 (in both cases, the compiler implements them as fat pointers). */
8802 if (ada_is_access_to_unconstrained_array (type
))
8805 type
= check_typedef (type
);
8806 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8807 || !type
->is_stub ()
8808 || type
->name () == NULL
)
8812 const char *name
= type
->name ();
8813 struct type
*type1
= ada_find_any_type (name
);
8818 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8819 stubs pointing to arrays, as we don't create symbols for array
8820 types, only for the typedef-to-array types). If that's the case,
8821 strip the typedef layer. */
8822 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8823 type1
= ada_check_typedef (type1
);
8829 /* A value representing the data at VALADDR/ADDRESS as described by
8830 type TYPE0, but with a standard (static-sized) type that correctly
8831 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8832 type, then return VAL0 [this feature is simply to avoid redundant
8833 creation of struct values]. */
8835 static struct value
*
8836 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8839 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8841 if (type
== type0
&& val0
!= NULL
)
8844 if (VALUE_LVAL (val0
) != lval_memory
)
8846 /* Our value does not live in memory; it could be a convenience
8847 variable, for instance. Create a not_lval value using val0's
8849 return value_from_contents (type
, value_contents (val0
).data ());
8852 return value_from_contents_and_address (type
, 0, address
);
8855 /* A value representing VAL, but with a standard (static-sized) type
8856 that correctly describes it. Does not necessarily create a new
8860 ada_to_fixed_value (struct value
*val
)
8862 val
= unwrap_value (val
);
8863 val
= ada_to_fixed_value_create (val
->type (), value_address (val
), val
);
8870 /* Table mapping attribute numbers to names.
8871 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8873 static const char * const attribute_names
[] = {
8891 ada_attribute_name (enum exp_opcode n
)
8893 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8894 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8896 return attribute_names
[0];
8899 /* Evaluate the 'POS attribute applied to ARG. */
8902 pos_atr (struct value
*arg
)
8904 struct value
*val
= coerce_ref (arg
);
8905 struct type
*type
= val
->type ();
8907 if (!discrete_type_p (type
))
8908 error (_("'POS only defined on discrete types"));
8910 gdb::optional
<LONGEST
> result
= discrete_position (type
, value_as_long (val
));
8911 if (!result
.has_value ())
8912 error (_("enumeration value is invalid: can't find 'POS"));
8918 ada_pos_atr (struct type
*expect_type
,
8919 struct expression
*exp
,
8920 enum noside noside
, enum exp_opcode op
,
8923 struct type
*type
= builtin_type (exp
->gdbarch
)->builtin_int
;
8924 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8925 return value_zero (type
, not_lval
);
8926 return value_from_longest (type
, pos_atr (arg
));
8929 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8931 static struct value
*
8932 val_atr (struct type
*type
, LONGEST val
)
8934 gdb_assert (discrete_type_p (type
));
8935 if (type
->code () == TYPE_CODE_RANGE
)
8936 type
= type
->target_type ();
8937 if (type
->code () == TYPE_CODE_ENUM
)
8939 if (val
< 0 || val
>= type
->num_fields ())
8940 error (_("argument to 'VAL out of range"));
8941 val
= type
->field (val
).loc_enumval ();
8943 return value_from_longest (type
, val
);
8947 ada_val_atr (enum noside noside
, struct type
*type
, struct value
*arg
)
8949 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8950 return value_zero (type
, not_lval
);
8952 if (!discrete_type_p (type
))
8953 error (_("'VAL only defined on discrete types"));
8954 if (!integer_type_p (arg
->type ()))
8955 error (_("'VAL requires integral argument"));
8957 return val_atr (type
, value_as_long (arg
));
8963 /* True if TYPE appears to be an Ada character type.
8964 [At the moment, this is true only for Character and Wide_Character;
8965 It is a heuristic test that could stand improvement]. */
8968 ada_is_character_type (struct type
*type
)
8972 /* If the type code says it's a character, then assume it really is,
8973 and don't check any further. */
8974 if (type
->code () == TYPE_CODE_CHAR
)
8977 /* Otherwise, assume it's a character type iff it is a discrete type
8978 with a known character type name. */
8979 name
= ada_type_name (type
);
8980 return (name
!= NULL
8981 && (type
->code () == TYPE_CODE_INT
8982 || type
->code () == TYPE_CODE_RANGE
)
8983 && (strcmp (name
, "character") == 0
8984 || strcmp (name
, "wide_character") == 0
8985 || strcmp (name
, "wide_wide_character") == 0
8986 || strcmp (name
, "unsigned char") == 0));
8989 /* True if TYPE appears to be an Ada string type. */
8992 ada_is_string_type (struct type
*type
)
8994 type
= ada_check_typedef (type
);
8996 && type
->code () != TYPE_CODE_PTR
8997 && (ada_is_simple_array_type (type
)
8998 || ada_is_array_descriptor_type (type
))
8999 && ada_array_arity (type
) == 1)
9001 struct type
*elttype
= ada_array_element_type (type
, 1);
9003 return ada_is_character_type (elttype
);
9009 /* The compiler sometimes provides a parallel XVS type for a given
9010 PAD type. Normally, it is safe to follow the PAD type directly,
9011 but older versions of the compiler have a bug that causes the offset
9012 of its "F" field to be wrong. Following that field in that case
9013 would lead to incorrect results, but this can be worked around
9014 by ignoring the PAD type and using the associated XVS type instead.
9016 Set to True if the debugger should trust the contents of PAD types.
9017 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9018 static bool trust_pad_over_xvs
= true;
9020 /* True if TYPE is a struct type introduced by the compiler to force the
9021 alignment of a value. Such types have a single field with a
9022 distinctive name. */
9025 ada_is_aligner_type (struct type
*type
)
9027 type
= ada_check_typedef (type
);
9029 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9032 return (type
->code () == TYPE_CODE_STRUCT
9033 && type
->num_fields () == 1
9034 && strcmp (type
->field (0).name (), "F") == 0);
9037 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9038 the parallel type. */
9041 ada_get_base_type (struct type
*raw_type
)
9043 struct type
*real_type_namer
;
9044 struct type
*raw_real_type
;
9046 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9049 if (ada_is_aligner_type (raw_type
))
9050 /* The encoding specifies that we should always use the aligner type.
9051 So, even if this aligner type has an associated XVS type, we should
9054 According to the compiler gurus, an XVS type parallel to an aligner
9055 type may exist because of a stabs limitation. In stabs, aligner
9056 types are empty because the field has a variable-sized type, and
9057 thus cannot actually be used as an aligner type. As a result,
9058 we need the associated parallel XVS type to decode the type.
9059 Since the policy in the compiler is to not change the internal
9060 representation based on the debugging info format, we sometimes
9061 end up having a redundant XVS type parallel to the aligner type. */
9064 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9065 if (real_type_namer
== NULL
9066 || real_type_namer
->code () != TYPE_CODE_STRUCT
9067 || real_type_namer
->num_fields () != 1)
9070 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9072 /* This is an older encoding form where the base type needs to be
9073 looked up by name. We prefer the newer encoding because it is
9075 raw_real_type
= ada_find_any_type (real_type_namer
->field (0).name ());
9076 if (raw_real_type
== NULL
)
9079 return raw_real_type
;
9082 /* The field in our XVS type is a reference to the base type. */
9083 return real_type_namer
->field (0).type ()->target_type ();
9086 /* The type of value designated by TYPE, with all aligners removed. */
9089 ada_aligned_type (struct type
*type
)
9091 if (ada_is_aligner_type (type
))
9092 return ada_aligned_type (type
->field (0).type ());
9094 return ada_get_base_type (type
);
9098 /* The address of the aligned value in an object at address VALADDR
9099 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9102 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9104 if (ada_is_aligner_type (type
))
9105 return ada_aligned_value_addr
9106 (type
->field (0).type (),
9107 valaddr
+ type
->field (0).loc_bitpos () / TARGET_CHAR_BIT
);
9114 /* The printed representation of an enumeration literal with encoded
9115 name NAME. The value is good to the next call of ada_enum_name. */
9117 ada_enum_name (const char *name
)
9119 static std::string storage
;
9122 /* First, unqualify the enumeration name:
9123 1. Search for the last '.' character. If we find one, then skip
9124 all the preceding characters, the unqualified name starts
9125 right after that dot.
9126 2. Otherwise, we may be debugging on a target where the compiler
9127 translates dots into "__". Search forward for double underscores,
9128 but stop searching when we hit an overloading suffix, which is
9129 of the form "__" followed by digits. */
9131 tmp
= strrchr (name
, '.');
9136 while ((tmp
= strstr (name
, "__")) != NULL
)
9138 if (isdigit (tmp
[2]))
9149 if (name
[1] == 'U' || name
[1] == 'W')
9152 if (name
[1] == 'W' && name
[2] == 'W')
9154 /* Also handle the QWW case. */
9157 if (sscanf (name
+ offset
, "%x", &v
) != 1)
9160 else if (((name
[1] >= '0' && name
[1] <= '9')
9161 || (name
[1] >= 'a' && name
[1] <= 'z'))
9164 storage
= string_printf ("'%c'", name
[1]);
9165 return storage
.c_str ();
9170 if (isascii (v
) && isprint (v
))
9171 storage
= string_printf ("'%c'", v
);
9172 else if (name
[1] == 'U')
9173 storage
= string_printf ("'[\"%02x\"]'", v
);
9174 else if (name
[2] != 'W')
9175 storage
= string_printf ("'[\"%04x\"]'", v
);
9177 storage
= string_printf ("'[\"%06x\"]'", v
);
9179 return storage
.c_str ();
9183 tmp
= strstr (name
, "__");
9185 tmp
= strstr (name
, "$");
9188 storage
= std::string (name
, tmp
- name
);
9189 return storage
.c_str ();
9196 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9199 static struct value
*
9200 unwrap_value (struct value
*val
)
9202 struct type
*type
= ada_check_typedef (val
->type ());
9204 if (ada_is_aligner_type (type
))
9206 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9207 struct type
*val_type
= ada_check_typedef (v
->type ());
9209 if (ada_type_name (val_type
) == NULL
)
9210 val_type
->set_name (ada_type_name (type
));
9212 return unwrap_value (v
);
9216 struct type
*raw_real_type
=
9217 ada_check_typedef (ada_get_base_type (type
));
9219 /* If there is no parallel XVS or XVE type, then the value is
9220 already unwrapped. Return it without further modification. */
9221 if ((type
== raw_real_type
)
9222 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9226 coerce_unspec_val_to_type
9227 (val
, ada_to_fixed_type (raw_real_type
, 0,
9228 value_address (val
),
9233 /* Given two array types T1 and T2, return nonzero iff both arrays
9234 contain the same number of elements. */
9237 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9239 LONGEST lo1
, hi1
, lo2
, hi2
;
9241 /* Get the array bounds in order to verify that the size of
9242 the two arrays match. */
9243 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9244 || !get_array_bounds (t2
, &lo2
, &hi2
))
9245 error (_("unable to determine array bounds"));
9247 /* To make things easier for size comparison, normalize a bit
9248 the case of empty arrays by making sure that the difference
9249 between upper bound and lower bound is always -1. */
9255 return (hi1
- lo1
== hi2
- lo2
);
9258 /* Assuming that VAL is an array of integrals, and TYPE represents
9259 an array with the same number of elements, but with wider integral
9260 elements, return an array "casted" to TYPE. In practice, this
9261 means that the returned array is built by casting each element
9262 of the original array into TYPE's (wider) element type. */
9264 static struct value
*
9265 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9267 struct type
*elt_type
= type
->target_type ();
9271 /* Verify that both val and type are arrays of scalars, and
9272 that the size of val's elements is smaller than the size
9273 of type's element. */
9274 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9275 gdb_assert (is_integral_type (type
->target_type ()));
9276 gdb_assert (val
->type ()->code () == TYPE_CODE_ARRAY
);
9277 gdb_assert (is_integral_type (val
->type ()->target_type ()));
9278 gdb_assert (type
->target_type ()->length ()
9279 > val
->type ()->target_type ()->length ());
9281 if (!get_array_bounds (type
, &lo
, &hi
))
9282 error (_("unable to determine array bounds"));
9284 value
*res
= allocate_value (type
);
9285 gdb::array_view
<gdb_byte
> res_contents
= value_contents_writeable (res
);
9287 /* Promote each array element. */
9288 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9290 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9291 int elt_len
= elt_type
->length ();
9293 copy (value_contents_all (elt
), res_contents
.slice (elt_len
* i
, elt_len
));
9299 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9300 return the converted value. */
9302 static struct value
*
9303 coerce_for_assign (struct type
*type
, struct value
*val
)
9305 struct type
*type2
= val
->type ();
9310 type2
= ada_check_typedef (type2
);
9311 type
= ada_check_typedef (type
);
9313 if (type2
->code () == TYPE_CODE_PTR
9314 && type
->code () == TYPE_CODE_ARRAY
)
9316 val
= ada_value_ind (val
);
9317 type2
= val
->type ();
9320 if (type2
->code () == TYPE_CODE_ARRAY
9321 && type
->code () == TYPE_CODE_ARRAY
)
9323 if (!ada_same_array_size_p (type
, type2
))
9324 error (_("cannot assign arrays of different length"));
9326 if (is_integral_type (type
->target_type ())
9327 && is_integral_type (type2
->target_type ())
9328 && type2
->target_type ()->length () < type
->target_type ()->length ())
9330 /* Allow implicit promotion of the array elements to
9332 return ada_promote_array_of_integrals (type
, val
);
9335 if (type2
->target_type ()->length () != type
->target_type ()->length ())
9336 error (_("Incompatible types in assignment"));
9337 deprecated_set_value_type (val
, type
);
9342 static struct value
*
9343 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9346 struct type
*type1
, *type2
;
9349 arg1
= coerce_ref (arg1
);
9350 arg2
= coerce_ref (arg2
);
9351 type1
= get_base_type (ada_check_typedef (arg1
->type ()));
9352 type2
= get_base_type (ada_check_typedef (arg2
->type ()));
9354 if (type1
->code () != TYPE_CODE_INT
9355 || type2
->code () != TYPE_CODE_INT
)
9356 return value_binop (arg1
, arg2
, op
);
9365 return value_binop (arg1
, arg2
, op
);
9368 v2
= value_as_long (arg2
);
9372 if (op
== BINOP_MOD
)
9374 else if (op
== BINOP_DIV
)
9378 gdb_assert (op
== BINOP_REM
);
9382 error (_("second operand of %s must not be zero."), name
);
9385 if (type1
->is_unsigned () || op
== BINOP_MOD
)
9386 return value_binop (arg1
, arg2
, op
);
9388 v1
= value_as_long (arg1
);
9393 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9394 v
+= v
> 0 ? -1 : 1;
9402 /* Should not reach this point. */
9406 val
= allocate_value (type1
);
9407 store_unsigned_integer (value_contents_raw (val
).data (),
9408 val
->type ()->length (),
9409 type_byte_order (type1
), v
);
9414 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9416 if (ada_is_direct_array_type (arg1
->type ())
9417 || ada_is_direct_array_type (arg2
->type ()))
9419 struct type
*arg1_type
, *arg2_type
;
9421 /* Automatically dereference any array reference before
9422 we attempt to perform the comparison. */
9423 arg1
= ada_coerce_ref (arg1
);
9424 arg2
= ada_coerce_ref (arg2
);
9426 arg1
= ada_coerce_to_simple_array (arg1
);
9427 arg2
= ada_coerce_to_simple_array (arg2
);
9429 arg1_type
= ada_check_typedef (arg1
->type ());
9430 arg2_type
= ada_check_typedef (arg2
->type ());
9432 if (arg1_type
->code () != TYPE_CODE_ARRAY
9433 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9434 error (_("Attempt to compare array with non-array"));
9435 /* FIXME: The following works only for types whose
9436 representations use all bits (no padding or undefined bits)
9437 and do not have user-defined equality. */
9438 return (arg1_type
->length () == arg2_type
->length ()
9439 && memcmp (value_contents (arg1
).data (),
9440 value_contents (arg2
).data (),
9441 arg1_type
->length ()) == 0);
9443 return value_equal (arg1
, arg2
);
9450 check_objfile (const std::unique_ptr
<ada_component
> &comp
,
9451 struct objfile
*objfile
)
9453 return comp
->uses_objfile (objfile
);
9456 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9457 component of LHS (a simple array or a record). Does not modify the
9458 inferior's memory, nor does it modify LHS (unless LHS ==
9462 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9463 struct expression
*exp
, operation_up
&arg
)
9465 scoped_value_mark mark
;
9468 struct type
*lhs_type
= check_typedef (lhs
->type ());
9470 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9472 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9473 struct value
*index_val
= value_from_longest (index_type
, index
);
9475 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9479 elt
= ada_index_struct_field (index
, lhs
, 0, lhs
->type ());
9480 elt
= ada_to_fixed_value (elt
);
9483 ada_aggregate_operation
*ag_op
9484 = dynamic_cast<ada_aggregate_operation
*> (arg
.get ());
9485 if (ag_op
!= nullptr)
9486 ag_op
->assign_aggregate (container
, elt
, exp
);
9488 value_assign_to_component (container
, elt
,
9489 arg
->evaluate (nullptr, exp
,
9494 ada_aggregate_component::uses_objfile (struct objfile
*objfile
)
9496 for (const auto &item
: m_components
)
9497 if (item
->uses_objfile (objfile
))
9503 ada_aggregate_component::dump (ui_file
*stream
, int depth
)
9505 gdb_printf (stream
, _("%*sAggregate\n"), depth
, "");
9506 for (const auto &item
: m_components
)
9507 item
->dump (stream
, depth
+ 1);
9511 ada_aggregate_component::assign (struct value
*container
,
9512 struct value
*lhs
, struct expression
*exp
,
9513 std::vector
<LONGEST
> &indices
,
9514 LONGEST low
, LONGEST high
)
9516 for (auto &item
: m_components
)
9517 item
->assign (container
, lhs
, exp
, indices
, low
, high
);
9520 /* See ada-exp.h. */
9523 ada_aggregate_operation::assign_aggregate (struct value
*container
,
9525 struct expression
*exp
)
9527 struct type
*lhs_type
;
9528 LONGEST low_index
, high_index
;
9530 container
= ada_coerce_ref (container
);
9531 if (ada_is_direct_array_type (container
->type ()))
9532 container
= ada_coerce_to_simple_array (container
);
9533 lhs
= ada_coerce_ref (lhs
);
9534 if (!deprecated_value_modifiable (lhs
))
9535 error (_("Left operand of assignment is not a modifiable lvalue."));
9537 lhs_type
= check_typedef (lhs
->type ());
9538 if (ada_is_direct_array_type (lhs_type
))
9540 lhs
= ada_coerce_to_simple_array (lhs
);
9541 lhs_type
= check_typedef (lhs
->type ());
9542 low_index
= lhs_type
->bounds ()->low
.const_val ();
9543 high_index
= lhs_type
->bounds ()->high
.const_val ();
9545 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9548 high_index
= num_visible_fields (lhs_type
) - 1;
9551 error (_("Left-hand side must be array or record."));
9553 std::vector
<LONGEST
> indices (4);
9554 indices
[0] = indices
[1] = low_index
- 1;
9555 indices
[2] = indices
[3] = high_index
+ 1;
9557 std::get
<0> (m_storage
)->assign (container
, lhs
, exp
, indices
,
9558 low_index
, high_index
);
9564 ada_positional_component::uses_objfile (struct objfile
*objfile
)
9566 return m_op
->uses_objfile (objfile
);
9570 ada_positional_component::dump (ui_file
*stream
, int depth
)
9572 gdb_printf (stream
, _("%*sPositional, index = %d\n"),
9573 depth
, "", m_index
);
9574 m_op
->dump (stream
, depth
+ 1);
9577 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9578 construct, given that the positions are relative to lower bound
9579 LOW, where HIGH is the upper bound. Record the position in
9580 INDICES. CONTAINER is as for assign_aggregate. */
9582 ada_positional_component::assign (struct value
*container
,
9583 struct value
*lhs
, struct expression
*exp
,
9584 std::vector
<LONGEST
> &indices
,
9585 LONGEST low
, LONGEST high
)
9587 LONGEST ind
= m_index
+ low
;
9589 if (ind
- 1 == high
)
9590 warning (_("Extra components in aggregate ignored."));
9593 add_component_interval (ind
, ind
, indices
);
9594 assign_component (container
, lhs
, ind
, exp
, m_op
);
9599 ada_discrete_range_association::uses_objfile (struct objfile
*objfile
)
9601 return m_low
->uses_objfile (objfile
) || m_high
->uses_objfile (objfile
);
9605 ada_discrete_range_association::dump (ui_file
*stream
, int depth
)
9607 gdb_printf (stream
, _("%*sDiscrete range:\n"), depth
, "");
9608 m_low
->dump (stream
, depth
+ 1);
9609 m_high
->dump (stream
, depth
+ 1);
9613 ada_discrete_range_association::assign (struct value
*container
,
9615 struct expression
*exp
,
9616 std::vector
<LONGEST
> &indices
,
9617 LONGEST low
, LONGEST high
,
9620 LONGEST lower
= value_as_long (m_low
->evaluate (nullptr, exp
, EVAL_NORMAL
));
9621 LONGEST upper
= value_as_long (m_high
->evaluate (nullptr, exp
, EVAL_NORMAL
));
9623 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9624 error (_("Index in component association out of bounds."));
9626 add_component_interval (lower
, upper
, indices
);
9627 while (lower
<= upper
)
9629 assign_component (container
, lhs
, lower
, exp
, op
);
9635 ada_name_association::uses_objfile (struct objfile
*objfile
)
9637 return m_val
->uses_objfile (objfile
);
9641 ada_name_association::dump (ui_file
*stream
, int depth
)
9643 gdb_printf (stream
, _("%*sName:\n"), depth
, "");
9644 m_val
->dump (stream
, depth
+ 1);
9648 ada_name_association::assign (struct value
*container
,
9650 struct expression
*exp
,
9651 std::vector
<LONGEST
> &indices
,
9652 LONGEST low
, LONGEST high
,
9657 if (ada_is_direct_array_type (lhs
->type ()))
9658 index
= longest_to_int (value_as_long (m_val
->evaluate (nullptr, exp
,
9662 ada_string_operation
*strop
9663 = dynamic_cast<ada_string_operation
*> (m_val
.get ());
9666 if (strop
!= nullptr)
9667 name
= strop
->get_name ();
9670 ada_var_value_operation
*vvo
9671 = dynamic_cast<ada_var_value_operation
*> (m_val
.get ());
9673 error (_("Invalid record component association."));
9674 name
= vvo
->get_symbol ()->natural_name ();
9678 if (! find_struct_field (name
, lhs
->type (), 0,
9679 NULL
, NULL
, NULL
, NULL
, &index
))
9680 error (_("Unknown component name: %s."), name
);
9683 add_component_interval (index
, index
, indices
);
9684 assign_component (container
, lhs
, index
, exp
, op
);
9688 ada_choices_component::uses_objfile (struct objfile
*objfile
)
9690 if (m_op
->uses_objfile (objfile
))
9692 for (const auto &item
: m_assocs
)
9693 if (item
->uses_objfile (objfile
))
9699 ada_choices_component::dump (ui_file
*stream
, int depth
)
9701 gdb_printf (stream
, _("%*sChoices:\n"), depth
, "");
9702 m_op
->dump (stream
, depth
+ 1);
9703 for (const auto &item
: m_assocs
)
9704 item
->dump (stream
, depth
+ 1);
9707 /* Assign into the components of LHS indexed by the OP_CHOICES
9708 construct at *POS, updating *POS past the construct, given that
9709 the allowable indices are LOW..HIGH. Record the indices assigned
9710 to in INDICES. CONTAINER is as for assign_aggregate. */
9712 ada_choices_component::assign (struct value
*container
,
9713 struct value
*lhs
, struct expression
*exp
,
9714 std::vector
<LONGEST
> &indices
,
9715 LONGEST low
, LONGEST high
)
9717 for (auto &item
: m_assocs
)
9718 item
->assign (container
, lhs
, exp
, indices
, low
, high
, m_op
);
9722 ada_others_component::uses_objfile (struct objfile
*objfile
)
9724 return m_op
->uses_objfile (objfile
);
9728 ada_others_component::dump (ui_file
*stream
, int depth
)
9730 gdb_printf (stream
, _("%*sOthers:\n"), depth
, "");
9731 m_op
->dump (stream
, depth
+ 1);
9734 /* Assign the value of the expression in the OP_OTHERS construct in
9735 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9736 have not been previously assigned. The index intervals already assigned
9737 are in INDICES. CONTAINER is as for assign_aggregate. */
9739 ada_others_component::assign (struct value
*container
,
9740 struct value
*lhs
, struct expression
*exp
,
9741 std::vector
<LONGEST
> &indices
,
9742 LONGEST low
, LONGEST high
)
9744 int num_indices
= indices
.size ();
9745 for (int i
= 0; i
< num_indices
- 2; i
+= 2)
9747 for (LONGEST ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9748 assign_component (container
, lhs
, ind
, exp
, m_op
);
9753 ada_assign_operation::evaluate (struct type
*expect_type
,
9754 struct expression
*exp
,
9757 value
*arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
9759 ada_aggregate_operation
*ag_op
9760 = dynamic_cast<ada_aggregate_operation
*> (std::get
<1> (m_storage
).get ());
9761 if (ag_op
!= nullptr)
9763 if (noside
!= EVAL_NORMAL
)
9766 arg1
= ag_op
->assign_aggregate (arg1
, arg1
, exp
);
9767 return ada_value_assign (arg1
, arg1
);
9769 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9770 except if the lhs of our assignment is a convenience variable.
9771 In the case of assigning to a convenience variable, the lhs
9772 should be exactly the result of the evaluation of the rhs. */
9773 struct type
*type
= arg1
->type ();
9774 if (VALUE_LVAL (arg1
) == lval_internalvar
)
9776 value
*arg2
= std::get
<1> (m_storage
)->evaluate (type
, exp
, noside
);
9777 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9779 if (VALUE_LVAL (arg1
) == lval_internalvar
)
9784 arg2
= coerce_for_assign (arg1
->type (), arg2
);
9785 return ada_value_assign (arg1
, arg2
);
9788 } /* namespace expr */
9790 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9791 [ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
9794 add_component_interval (LONGEST low
, LONGEST high
,
9795 std::vector
<LONGEST
> &indices
)
9799 int size
= indices
.size ();
9800 for (i
= 0; i
< size
; i
+= 2) {
9801 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9805 for (kh
= i
+ 2; kh
< size
; kh
+= 2)
9806 if (high
< indices
[kh
])
9808 if (low
< indices
[i
])
9810 indices
[i
+ 1] = indices
[kh
- 1];
9811 if (high
> indices
[i
+ 1])
9812 indices
[i
+ 1] = high
;
9813 memcpy (indices
.data () + i
+ 2, indices
.data () + kh
, size
- kh
);
9814 indices
.resize (kh
- i
- 2);
9817 else if (high
< indices
[i
])
9821 indices
.resize (indices
.size () + 2);
9822 for (j
= indices
.size () - 1; j
>= i
+ 2; j
-= 1)
9823 indices
[j
] = indices
[j
- 2];
9825 indices
[i
+ 1] = high
;
9828 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9831 static struct value
*
9832 ada_value_cast (struct type
*type
, struct value
*arg2
)
9834 if (type
== ada_check_typedef (arg2
->type ()))
9837 return value_cast (type
, arg2
);
9840 /* Evaluating Ada expressions, and printing their result.
9841 ------------------------------------------------------
9846 We usually evaluate an Ada expression in order to print its value.
9847 We also evaluate an expression in order to print its type, which
9848 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9849 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9850 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9851 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9854 Evaluating expressions is a little more complicated for Ada entities
9855 than it is for entities in languages such as C. The main reason for
9856 this is that Ada provides types whose definition might be dynamic.
9857 One example of such types is variant records. Or another example
9858 would be an array whose bounds can only be known at run time.
9860 The following description is a general guide as to what should be
9861 done (and what should NOT be done) in order to evaluate an expression
9862 involving such types, and when. This does not cover how the semantic
9863 information is encoded by GNAT as this is covered separatly. For the
9864 document used as the reference for the GNAT encoding, see exp_dbug.ads
9865 in the GNAT sources.
9867 Ideally, we should embed each part of this description next to its
9868 associated code. Unfortunately, the amount of code is so vast right
9869 now that it's hard to see whether the code handling a particular
9870 situation might be duplicated or not. One day, when the code is
9871 cleaned up, this guide might become redundant with the comments
9872 inserted in the code, and we might want to remove it.
9874 2. ``Fixing'' an Entity, the Simple Case:
9875 -----------------------------------------
9877 When evaluating Ada expressions, the tricky issue is that they may
9878 reference entities whose type contents and size are not statically
9879 known. Consider for instance a variant record:
9881 type Rec (Empty : Boolean := True) is record
9884 when False => Value : Integer;
9887 Yes : Rec := (Empty => False, Value => 1);
9888 No : Rec := (empty => True);
9890 The size and contents of that record depends on the value of the
9891 descriminant (Rec.Empty). At this point, neither the debugging
9892 information nor the associated type structure in GDB are able to
9893 express such dynamic types. So what the debugger does is to create
9894 "fixed" versions of the type that applies to the specific object.
9895 We also informally refer to this operation as "fixing" an object,
9896 which means creating its associated fixed type.
9898 Example: when printing the value of variable "Yes" above, its fixed
9899 type would look like this:
9906 On the other hand, if we printed the value of "No", its fixed type
9913 Things become a little more complicated when trying to fix an entity
9914 with a dynamic type that directly contains another dynamic type,
9915 such as an array of variant records, for instance. There are
9916 two possible cases: Arrays, and records.
9918 3. ``Fixing'' Arrays:
9919 ---------------------
9921 The type structure in GDB describes an array in terms of its bounds,
9922 and the type of its elements. By design, all elements in the array
9923 have the same type and we cannot represent an array of variant elements
9924 using the current type structure in GDB. When fixing an array,
9925 we cannot fix the array element, as we would potentially need one
9926 fixed type per element of the array. As a result, the best we can do
9927 when fixing an array is to produce an array whose bounds and size
9928 are correct (allowing us to read it from memory), but without having
9929 touched its element type. Fixing each element will be done later,
9930 when (if) necessary.
9932 Arrays are a little simpler to handle than records, because the same
9933 amount of memory is allocated for each element of the array, even if
9934 the amount of space actually used by each element differs from element
9935 to element. Consider for instance the following array of type Rec:
9937 type Rec_Array is array (1 .. 2) of Rec;
9939 The actual amount of memory occupied by each element might be different
9940 from element to element, depending on the value of their discriminant.
9941 But the amount of space reserved for each element in the array remains
9942 fixed regardless. So we simply need to compute that size using
9943 the debugging information available, from which we can then determine
9944 the array size (we multiply the number of elements of the array by
9945 the size of each element).
9947 The simplest case is when we have an array of a constrained element
9948 type. For instance, consider the following type declarations:
9950 type Bounded_String (Max_Size : Integer) is
9952 Buffer : String (1 .. Max_Size);
9954 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9956 In this case, the compiler describes the array as an array of
9957 variable-size elements (identified by its XVS suffix) for which
9958 the size can be read in the parallel XVZ variable.
9960 In the case of an array of an unconstrained element type, the compiler
9961 wraps the array element inside a private PAD type. This type should not
9962 be shown to the user, and must be "unwrap"'ed before printing. Note
9963 that we also use the adjective "aligner" in our code to designate
9964 these wrapper types.
9966 In some cases, the size allocated for each element is statically
9967 known. In that case, the PAD type already has the correct size,
9968 and the array element should remain unfixed.
9970 But there are cases when this size is not statically known.
9971 For instance, assuming that "Five" is an integer variable:
9973 type Dynamic is array (1 .. Five) of Integer;
9974 type Wrapper (Has_Length : Boolean := False) is record
9977 when True => Length : Integer;
9981 type Wrapper_Array is array (1 .. 2) of Wrapper;
9983 Hello : Wrapper_Array := (others => (Has_Length => True,
9984 Data => (others => 17),
9988 The debugging info would describe variable Hello as being an
9989 array of a PAD type. The size of that PAD type is not statically
9990 known, but can be determined using a parallel XVZ variable.
9991 In that case, a copy of the PAD type with the correct size should
9992 be used for the fixed array.
9994 3. ``Fixing'' record type objects:
9995 ----------------------------------
9997 Things are slightly different from arrays in the case of dynamic
9998 record types. In this case, in order to compute the associated
9999 fixed type, we need to determine the size and offset of each of
10000 its components. This, in turn, requires us to compute the fixed
10001 type of each of these components.
10003 Consider for instance the example:
10005 type Bounded_String (Max_Size : Natural) is record
10006 Str : String (1 .. Max_Size);
10009 My_String : Bounded_String (Max_Size => 10);
10011 In that case, the position of field "Length" depends on the size
10012 of field Str, which itself depends on the value of the Max_Size
10013 discriminant. In order to fix the type of variable My_String,
10014 we need to fix the type of field Str. Therefore, fixing a variant
10015 record requires us to fix each of its components.
10017 However, if a component does not have a dynamic size, the component
10018 should not be fixed. In particular, fields that use a PAD type
10019 should not fixed. Here is an example where this might happen
10020 (assuming type Rec above):
10022 type Container (Big : Boolean) is record
10026 when True => Another : Integer;
10027 when False => null;
10030 My_Container : Container := (Big => False,
10031 First => (Empty => True),
10034 In that example, the compiler creates a PAD type for component First,
10035 whose size is constant, and then positions the component After just
10036 right after it. The offset of component After is therefore constant
10039 The debugger computes the position of each field based on an algorithm
10040 that uses, among other things, the actual position and size of the field
10041 preceding it. Let's now imagine that the user is trying to print
10042 the value of My_Container. If the type fixing was recursive, we would
10043 end up computing the offset of field After based on the size of the
10044 fixed version of field First. And since in our example First has
10045 only one actual field, the size of the fixed type is actually smaller
10046 than the amount of space allocated to that field, and thus we would
10047 compute the wrong offset of field After.
10049 To make things more complicated, we need to watch out for dynamic
10050 components of variant records (identified by the ___XVL suffix in
10051 the component name). Even if the target type is a PAD type, the size
10052 of that type might not be statically known. So the PAD type needs
10053 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10054 we might end up with the wrong size for our component. This can be
10055 observed with the following type declarations:
10057 type Octal is new Integer range 0 .. 7;
10058 type Octal_Array is array (Positive range <>) of Octal;
10059 pragma Pack (Octal_Array);
10061 type Octal_Buffer (Size : Positive) is record
10062 Buffer : Octal_Array (1 .. Size);
10066 In that case, Buffer is a PAD type whose size is unset and needs
10067 to be computed by fixing the unwrapped type.
10069 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10070 ----------------------------------------------------------
10072 Lastly, when should the sub-elements of an entity that remained unfixed
10073 thus far, be actually fixed?
10075 The answer is: Only when referencing that element. For instance
10076 when selecting one component of a record, this specific component
10077 should be fixed at that point in time. Or when printing the value
10078 of a record, each component should be fixed before its value gets
10079 printed. Similarly for arrays, the element of the array should be
10080 fixed when printing each element of the array, or when extracting
10081 one element out of that array. On the other hand, fixing should
10082 not be performed on the elements when taking a slice of an array!
10084 Note that one of the side effects of miscomputing the offset and
10085 size of each field is that we end up also miscomputing the size
10086 of the containing type. This can have adverse results when computing
10087 the value of an entity. GDB fetches the value of an entity based
10088 on the size of its type, and thus a wrong size causes GDB to fetch
10089 the wrong amount of memory. In the case where the computed size is
10090 too small, GDB fetches too little data to print the value of our
10091 entity. Results in this case are unpredictable, as we usually read
10092 past the buffer containing the data =:-o. */
10094 /* A helper function for TERNOP_IN_RANGE. */
10097 eval_ternop_in_range (struct type
*expect_type
, struct expression
*exp
,
10098 enum noside noside
,
10099 value
*arg1
, value
*arg2
, value
*arg3
)
10101 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10102 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10103 struct type
*type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10105 value_from_longest (type
,
10106 (value_less (arg1
, arg3
)
10107 || value_equal (arg1
, arg3
))
10108 && (value_less (arg2
, arg1
)
10109 || value_equal (arg2
, arg1
)));
10112 /* A helper function for UNOP_NEG. */
10115 ada_unop_neg (struct type
*expect_type
,
10116 struct expression
*exp
,
10117 enum noside noside
, enum exp_opcode op
,
10118 struct value
*arg1
)
10120 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10121 return value_neg (arg1
);
10124 /* A helper function for UNOP_IN_RANGE. */
10127 ada_unop_in_range (struct type
*expect_type
,
10128 struct expression
*exp
,
10129 enum noside noside
, enum exp_opcode op
,
10130 struct value
*arg1
, struct type
*type
)
10132 struct value
*arg2
, *arg3
;
10133 switch (type
->code ())
10136 lim_warning (_("Membership test incompletely implemented; "
10137 "always returns true"));
10138 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10139 return value_from_longest (type
, (LONGEST
) 1);
10141 case TYPE_CODE_RANGE
:
10142 arg2
= value_from_longest (type
,
10143 type
->bounds ()->low
.const_val ());
10144 arg3
= value_from_longest (type
,
10145 type
->bounds ()->high
.const_val ());
10146 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10147 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10148 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10150 value_from_longest (type
,
10151 (value_less (arg1
, arg3
)
10152 || value_equal (arg1
, arg3
))
10153 && (value_less (arg2
, arg1
)
10154 || value_equal (arg2
, arg1
)));
10158 /* A helper function for OP_ATR_TAG. */
10161 ada_atr_tag (struct type
*expect_type
,
10162 struct expression
*exp
,
10163 enum noside noside
, enum exp_opcode op
,
10164 struct value
*arg1
)
10166 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10167 return value_zero (ada_tag_type (arg1
), not_lval
);
10169 return ada_value_tag (arg1
);
10172 /* A helper function for OP_ATR_SIZE. */
10175 ada_atr_size (struct type
*expect_type
,
10176 struct expression
*exp
,
10177 enum noside noside
, enum exp_opcode op
,
10178 struct value
*arg1
)
10180 struct type
*type
= arg1
->type ();
10182 /* If the argument is a reference, then dereference its type, since
10183 the user is really asking for the size of the actual object,
10184 not the size of the pointer. */
10185 if (type
->code () == TYPE_CODE_REF
)
10186 type
= type
->target_type ();
10188 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10189 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10191 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10192 TARGET_CHAR_BIT
* type
->length ());
10195 /* A helper function for UNOP_ABS. */
10198 ada_abs (struct type
*expect_type
,
10199 struct expression
*exp
,
10200 enum noside noside
, enum exp_opcode op
,
10201 struct value
*arg1
)
10203 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10204 if (value_less (arg1
, value_zero (arg1
->type (), not_lval
)))
10205 return value_neg (arg1
);
10210 /* A helper function for BINOP_MUL. */
10213 ada_mult_binop (struct type
*expect_type
,
10214 struct expression
*exp
,
10215 enum noside noside
, enum exp_opcode op
,
10216 struct value
*arg1
, struct value
*arg2
)
10218 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10220 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10221 return value_zero (arg1
->type (), not_lval
);
10225 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10226 return ada_value_binop (arg1
, arg2
, op
);
10230 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
10233 ada_equal_binop (struct type
*expect_type
,
10234 struct expression
*exp
,
10235 enum noside noside
, enum exp_opcode op
,
10236 struct value
*arg1
, struct value
*arg2
)
10239 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10243 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10244 tem
= ada_value_equal (arg1
, arg2
);
10246 if (op
== BINOP_NOTEQUAL
)
10248 struct type
*type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10249 return value_from_longest (type
, (LONGEST
) tem
);
10252 /* A helper function for TERNOP_SLICE. */
10255 ada_ternop_slice (struct expression
*exp
,
10256 enum noside noside
,
10257 struct value
*array
, struct value
*low_bound_val
,
10258 struct value
*high_bound_val
)
10261 LONGEST high_bound
;
10263 low_bound_val
= coerce_ref (low_bound_val
);
10264 high_bound_val
= coerce_ref (high_bound_val
);
10265 low_bound
= value_as_long (low_bound_val
);
10266 high_bound
= value_as_long (high_bound_val
);
10268 /* If this is a reference to an aligner type, then remove all
10270 if (array
->type ()->code () == TYPE_CODE_REF
10271 && ada_is_aligner_type (array
->type ()->target_type ()))
10272 array
->type ()->set_target_type
10273 (ada_aligned_type (array
->type ()->target_type ()));
10275 if (ada_is_any_packed_array_type (array
->type ()))
10276 error (_("cannot slice a packed array"));
10278 /* If this is a reference to an array or an array lvalue,
10279 convert to a pointer. */
10280 if (array
->type ()->code () == TYPE_CODE_REF
10281 || (array
->type ()->code () == TYPE_CODE_ARRAY
10282 && VALUE_LVAL (array
) == lval_memory
))
10283 array
= value_addr (array
);
10285 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10286 && ada_is_array_descriptor_type (ada_check_typedef
10288 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10291 array
= ada_coerce_to_simple_array_ptr (array
);
10293 /* If we have more than one level of pointer indirection,
10294 dereference the value until we get only one level. */
10295 while (array
->type ()->code () == TYPE_CODE_PTR
10296 && (array
->type ()->target_type ()->code ()
10298 array
= value_ind (array
);
10300 /* Make sure we really do have an array type before going further,
10301 to avoid a SEGV when trying to get the index type or the target
10302 type later down the road if the debug info generated by
10303 the compiler is incorrect or incomplete. */
10304 if (!ada_is_simple_array_type (array
->type ()))
10305 error (_("cannot take slice of non-array"));
10307 if (ada_check_typedef (array
->type ())->code ()
10310 struct type
*type0
= ada_check_typedef (array
->type ());
10312 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10313 return empty_array (type0
->target_type (), low_bound
, high_bound
);
10316 struct type
*arr_type0
=
10317 to_fixed_array_type (type0
->target_type (), NULL
, 1);
10319 return ada_value_slice_from_ptr (array
, arr_type0
,
10320 longest_to_int (low_bound
),
10321 longest_to_int (high_bound
));
10324 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10326 else if (high_bound
< low_bound
)
10327 return empty_array (array
->type (), low_bound
, high_bound
);
10329 return ada_value_slice (array
, longest_to_int (low_bound
),
10330 longest_to_int (high_bound
));
10333 /* A helper function for BINOP_IN_BOUNDS. */
10336 ada_binop_in_bounds (struct expression
*exp
, enum noside noside
,
10337 struct value
*arg1
, struct value
*arg2
, int n
)
10339 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10341 struct type
*type
= language_bool_type (exp
->language_defn
,
10343 return value_zero (type
, not_lval
);
10346 struct type
*type
= ada_index_type (arg2
->type (), n
, "range");
10348 type
= arg1
->type ();
10350 value
*arg3
= value_from_longest (type
, ada_array_bound (arg2
, n
, 1));
10351 arg2
= value_from_longest (type
, ada_array_bound (arg2
, n
, 0));
10353 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10354 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10355 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10356 return value_from_longest (type
,
10357 (value_less (arg1
, arg3
)
10358 || value_equal (arg1
, arg3
))
10359 && (value_less (arg2
, arg1
)
10360 || value_equal (arg2
, arg1
)));
10363 /* A helper function for some attribute operations. */
10366 ada_unop_atr (struct expression
*exp
, enum noside noside
, enum exp_opcode op
,
10367 struct value
*arg1
, struct type
*type_arg
, int tem
)
10369 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10371 if (type_arg
== NULL
)
10372 type_arg
= arg1
->type ();
10374 if (ada_is_constrained_packed_array_type (type_arg
))
10375 type_arg
= decode_constrained_packed_array_type (type_arg
);
10377 if (!discrete_type_p (type_arg
))
10381 default: /* Should never happen. */
10382 error (_("unexpected attribute encountered"));
10385 type_arg
= ada_index_type (type_arg
, tem
,
10386 ada_attribute_name (op
));
10388 case OP_ATR_LENGTH
:
10389 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10394 return value_zero (type_arg
, not_lval
);
10396 else if (type_arg
== NULL
)
10398 arg1
= ada_coerce_ref (arg1
);
10400 if (ada_is_constrained_packed_array_type (arg1
->type ()))
10401 arg1
= ada_coerce_to_simple_array (arg1
);
10404 if (op
== OP_ATR_LENGTH
)
10405 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10408 type
= ada_index_type (arg1
->type (), tem
,
10409 ada_attribute_name (op
));
10411 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10416 default: /* Should never happen. */
10417 error (_("unexpected attribute encountered"));
10419 return value_from_longest
10420 (type
, ada_array_bound (arg1
, tem
, 0));
10422 return value_from_longest
10423 (type
, ada_array_bound (arg1
, tem
, 1));
10424 case OP_ATR_LENGTH
:
10425 return value_from_longest
10426 (type
, ada_array_length (arg1
, tem
));
10429 else if (discrete_type_p (type_arg
))
10431 struct type
*range_type
;
10432 const char *name
= ada_type_name (type_arg
);
10435 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10436 range_type
= to_fixed_range_type (type_arg
, NULL
);
10437 if (range_type
== NULL
)
10438 range_type
= type_arg
;
10442 error (_("unexpected attribute encountered"));
10444 return value_from_longest
10445 (range_type
, ada_discrete_type_low_bound (range_type
));
10447 return value_from_longest
10448 (range_type
, ada_discrete_type_high_bound (range_type
));
10449 case OP_ATR_LENGTH
:
10450 error (_("the 'length attribute applies only to array types"));
10453 else if (type_arg
->code () == TYPE_CODE_FLT
)
10454 error (_("unimplemented type attribute"));
10459 if (ada_is_constrained_packed_array_type (type_arg
))
10460 type_arg
= decode_constrained_packed_array_type (type_arg
);
10463 if (op
== OP_ATR_LENGTH
)
10464 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10467 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10469 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10475 error (_("unexpected attribute encountered"));
10477 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10478 return value_from_longest (type
, low
);
10480 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10481 return value_from_longest (type
, high
);
10482 case OP_ATR_LENGTH
:
10483 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10484 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10485 return value_from_longest (type
, high
- low
+ 1);
10490 /* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
10493 ada_binop_minmax (struct type
*expect_type
,
10494 struct expression
*exp
,
10495 enum noside noside
, enum exp_opcode op
,
10496 struct value
*arg1
, struct value
*arg2
)
10498 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10499 return value_zero (arg1
->type (), not_lval
);
10502 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10503 return value_binop (arg1
, arg2
, op
);
10507 /* A helper function for BINOP_EXP. */
10510 ada_binop_exp (struct type
*expect_type
,
10511 struct expression
*exp
,
10512 enum noside noside
, enum exp_opcode op
,
10513 struct value
*arg1
, struct value
*arg2
)
10515 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10516 return value_zero (arg1
->type (), not_lval
);
10519 /* For integer exponentiation operations,
10520 only promote the first argument. */
10521 if (is_integral_type (arg2
->type ()))
10522 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10524 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10526 return value_binop (arg1
, arg2
, op
);
10533 /* See ada-exp.h. */
10536 ada_resolvable::replace (operation_up
&&owner
,
10537 struct expression
*exp
,
10538 bool deprocedure_p
,
10539 bool parse_completion
,
10540 innermost_block_tracker
*tracker
,
10541 struct type
*context_type
)
10543 if (resolve (exp
, deprocedure_p
, parse_completion
, tracker
, context_type
))
10544 return (make_operation
<ada_funcall_operation
>
10545 (std::move (owner
),
10546 std::vector
<operation_up
> ()));
10547 return std::move (owner
);
10550 /* Convert the character literal whose value would be VAL to the
10551 appropriate value of type TYPE, if there is a translation.
10552 Otherwise return VAL. Hence, in an enumeration type ('A', 'B'),
10553 the literal 'A' (VAL == 65), returns 0. */
10556 convert_char_literal (struct type
*type
, LONGEST val
)
10563 type
= check_typedef (type
);
10564 if (type
->code () != TYPE_CODE_ENUM
)
10567 if ((val
>= 'a' && val
<= 'z') || (val
>= '0' && val
<= '9'))
10568 xsnprintf (name
, sizeof (name
), "Q%c", (int) val
);
10569 else if (val
>= 0 && val
< 256)
10570 xsnprintf (name
, sizeof (name
), "QU%02x", (unsigned) val
);
10571 else if (val
>= 0 && val
< 0x10000)
10572 xsnprintf (name
, sizeof (name
), "QW%04x", (unsigned) val
);
10574 xsnprintf (name
, sizeof (name
), "QWW%08lx", (unsigned long) val
);
10575 size_t len
= strlen (name
);
10576 for (f
= 0; f
< type
->num_fields (); f
+= 1)
10578 /* Check the suffix because an enum constant in a package will
10579 have a name like "pkg__QUxx". This is safe enough because we
10580 already have the correct type, and because mangling means
10581 there can't be clashes. */
10582 const char *ename
= type
->field (f
).name ();
10583 size_t elen
= strlen (ename
);
10585 if (elen
>= len
&& strcmp (name
, ename
+ elen
- len
) == 0)
10586 return type
->field (f
).loc_enumval ();
10592 ada_char_operation::evaluate (struct type
*expect_type
,
10593 struct expression
*exp
,
10594 enum noside noside
)
10596 value
*result
= long_const_operation::evaluate (expect_type
, exp
, noside
);
10597 if (expect_type
!= nullptr)
10598 result
= ada_value_cast (expect_type
, result
);
10602 /* See ada-exp.h. */
10605 ada_char_operation::replace (operation_up
&&owner
,
10606 struct expression
*exp
,
10607 bool deprocedure_p
,
10608 bool parse_completion
,
10609 innermost_block_tracker
*tracker
,
10610 struct type
*context_type
)
10612 operation_up result
= std::move (owner
);
10614 if (context_type
!= nullptr && context_type
->code () == TYPE_CODE_ENUM
)
10616 gdb_assert (result
.get () == this);
10617 std::get
<0> (m_storage
) = context_type
;
10618 std::get
<1> (m_storage
)
10619 = convert_char_literal (context_type
, std::get
<1> (m_storage
));
10626 ada_wrapped_operation::evaluate (struct type
*expect_type
,
10627 struct expression
*exp
,
10628 enum noside noside
)
10630 value
*result
= std::get
<0> (m_storage
)->evaluate (expect_type
, exp
, noside
);
10631 if (noside
== EVAL_NORMAL
)
10632 result
= unwrap_value (result
);
10634 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10635 then we need to perform the conversion manually, because
10636 evaluate_subexp_standard doesn't do it. This conversion is
10637 necessary in Ada because the different kinds of float/fixed
10638 types in Ada have different representations.
10640 Similarly, we need to perform the conversion from OP_LONG
10642 if ((opcode () == OP_FLOAT
|| opcode () == OP_LONG
) && expect_type
!= NULL
)
10643 result
= ada_value_cast (expect_type
, result
);
10649 ada_string_operation::evaluate (struct type
*expect_type
,
10650 struct expression
*exp
,
10651 enum noside noside
)
10653 struct type
*char_type
;
10654 if (expect_type
!= nullptr && ada_is_string_type (expect_type
))
10655 char_type
= ada_array_element_type (expect_type
, 1);
10657 char_type
= language_string_char_type (exp
->language_defn
, exp
->gdbarch
);
10659 const std::string
&str
= std::get
<0> (m_storage
);
10660 const char *encoding
;
10661 switch (char_type
->length ())
10665 /* Simply copy over the data -- this isn't perhaps strictly
10666 correct according to the encodings, but it is gdb's
10667 historical behavior. */
10668 struct type
*stringtype
10669 = lookup_array_range_type (char_type
, 1, str
.length ());
10670 struct value
*val
= allocate_value (stringtype
);
10671 memcpy (value_contents_raw (val
).data (), str
.c_str (),
10677 if (gdbarch_byte_order (exp
->gdbarch
) == BFD_ENDIAN_BIG
)
10678 encoding
= "UTF-16BE";
10680 encoding
= "UTF-16LE";
10684 if (gdbarch_byte_order (exp
->gdbarch
) == BFD_ENDIAN_BIG
)
10685 encoding
= "UTF-32BE";
10687 encoding
= "UTF-32LE";
10691 error (_("unexpected character type size %s"),
10692 pulongest (char_type
->length ()));
10695 auto_obstack converted
;
10696 convert_between_encodings (host_charset (), encoding
,
10697 (const gdb_byte
*) str
.c_str (),
10699 &converted
, translit_none
);
10701 struct type
*stringtype
10702 = lookup_array_range_type (char_type
, 1,
10703 obstack_object_size (&converted
)
10704 / char_type
->length ());
10705 struct value
*val
= allocate_value (stringtype
);
10706 memcpy (value_contents_raw (val
).data (),
10707 obstack_base (&converted
),
10708 obstack_object_size (&converted
));
10713 ada_concat_operation::evaluate (struct type
*expect_type
,
10714 struct expression
*exp
,
10715 enum noside noside
)
10717 /* If one side is a literal, evaluate the other side first so that
10718 the expected type can be set properly. */
10719 const operation_up
&lhs_expr
= std::get
<0> (m_storage
);
10720 const operation_up
&rhs_expr
= std::get
<1> (m_storage
);
10723 if (dynamic_cast<ada_string_operation
*> (lhs_expr
.get ()) != nullptr)
10725 rhs
= rhs_expr
->evaluate (nullptr, exp
, noside
);
10726 lhs
= lhs_expr
->evaluate (rhs
->type (), exp
, noside
);
10728 else if (dynamic_cast<ada_char_operation
*> (lhs_expr
.get ()) != nullptr)
10730 rhs
= rhs_expr
->evaluate (nullptr, exp
, noside
);
10731 struct type
*rhs_type
= check_typedef (rhs
->type ());
10732 struct type
*elt_type
= nullptr;
10733 if (rhs_type
->code () == TYPE_CODE_ARRAY
)
10734 elt_type
= rhs_type
->target_type ();
10735 lhs
= lhs_expr
->evaluate (elt_type
, exp
, noside
);
10737 else if (dynamic_cast<ada_string_operation
*> (rhs_expr
.get ()) != nullptr)
10739 lhs
= lhs_expr
->evaluate (nullptr, exp
, noside
);
10740 rhs
= rhs_expr
->evaluate (lhs
->type (), exp
, noside
);
10742 else if (dynamic_cast<ada_char_operation
*> (rhs_expr
.get ()) != nullptr)
10744 lhs
= lhs_expr
->evaluate (nullptr, exp
, noside
);
10745 struct type
*lhs_type
= check_typedef (lhs
->type ());
10746 struct type
*elt_type
= nullptr;
10747 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
10748 elt_type
= lhs_type
->target_type ();
10749 rhs
= rhs_expr
->evaluate (elt_type
, exp
, noside
);
10752 return concat_operation::evaluate (expect_type
, exp
, noside
);
10754 return value_concat (lhs
, rhs
);
10758 ada_qual_operation::evaluate (struct type
*expect_type
,
10759 struct expression
*exp
,
10760 enum noside noside
)
10762 struct type
*type
= std::get
<1> (m_storage
);
10763 return std::get
<0> (m_storage
)->evaluate (type
, exp
, noside
);
10767 ada_ternop_range_operation::evaluate (struct type
*expect_type
,
10768 struct expression
*exp
,
10769 enum noside noside
)
10771 value
*arg0
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
10772 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
10773 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
10774 return eval_ternop_in_range (expect_type
, exp
, noside
, arg0
, arg1
, arg2
);
10778 ada_binop_addsub_operation::evaluate (struct type
*expect_type
,
10779 struct expression
*exp
,
10780 enum noside noside
)
10782 value
*arg1
= std::get
<1> (m_storage
)->evaluate_with_coercion (exp
, noside
);
10783 value
*arg2
= std::get
<2> (m_storage
)->evaluate_with_coercion (exp
, noside
);
10785 auto do_op
= [=] (LONGEST x
, LONGEST y
)
10787 if (std::get
<0> (m_storage
) == BINOP_ADD
)
10792 if (arg1
->type ()->code () == TYPE_CODE_PTR
)
10793 return (value_from_longest
10795 do_op (value_as_long (arg1
), value_as_long (arg2
))));
10796 if (arg2
->type ()->code () == TYPE_CODE_PTR
)
10797 return (value_from_longest
10799 do_op (value_as_long (arg1
), value_as_long (arg2
))));
10800 /* Preserve the original type for use by the range case below.
10801 We cannot cast the result to a reference type, so if ARG1 is
10802 a reference type, find its underlying type. */
10803 struct type
*type
= arg1
->type ();
10804 while (type
->code () == TYPE_CODE_REF
)
10805 type
= type
->target_type ();
10806 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10807 arg1
= value_binop (arg1
, arg2
, std::get
<0> (m_storage
));
10808 /* We need to special-case the result with a range.
10809 This is done for the benefit of "ptype". gdb's Ada support
10810 historically used the LHS to set the result type here, so
10811 preserve this behavior. */
10812 if (type
->code () == TYPE_CODE_RANGE
)
10813 arg1
= value_cast (type
, arg1
);
10818 ada_unop_atr_operation::evaluate (struct type
*expect_type
,
10819 struct expression
*exp
,
10820 enum noside noside
)
10822 struct type
*type_arg
= nullptr;
10823 value
*val
= nullptr;
10825 if (std::get
<0> (m_storage
)->opcode () == OP_TYPE
)
10827 value
*tem
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
,
10828 EVAL_AVOID_SIDE_EFFECTS
);
10829 type_arg
= tem
->type ();
10832 val
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
10834 return ada_unop_atr (exp
, noside
, std::get
<1> (m_storage
),
10835 val
, type_arg
, std::get
<2> (m_storage
));
10839 ada_var_msym_value_operation::evaluate_for_cast (struct type
*expect_type
,
10840 struct expression
*exp
,
10841 enum noside noside
)
10843 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10844 return value_zero (expect_type
, not_lval
);
10846 const bound_minimal_symbol
&b
= std::get
<0> (m_storage
);
10847 value
*val
= evaluate_var_msym_value (noside
, b
.objfile
, b
.minsym
);
10849 val
= ada_value_cast (expect_type
, val
);
10851 /* Follow the Ada language semantics that do not allow taking
10852 an address of the result of a cast (view conversion in Ada). */
10853 if (VALUE_LVAL (val
) == lval_memory
)
10855 if (value_lazy (val
))
10856 value_fetch_lazy (val
);
10857 VALUE_LVAL (val
) = not_lval
;
10863 ada_var_value_operation::evaluate_for_cast (struct type
*expect_type
,
10864 struct expression
*exp
,
10865 enum noside noside
)
10867 value
*val
= evaluate_var_value (noside
,
10868 std::get
<0> (m_storage
).block
,
10869 std::get
<0> (m_storage
).symbol
);
10871 val
= ada_value_cast (expect_type
, val
);
10873 /* Follow the Ada language semantics that do not allow taking
10874 an address of the result of a cast (view conversion in Ada). */
10875 if (VALUE_LVAL (val
) == lval_memory
)
10877 if (value_lazy (val
))
10878 value_fetch_lazy (val
);
10879 VALUE_LVAL (val
) = not_lval
;
10885 ada_var_value_operation::evaluate (struct type
*expect_type
,
10886 struct expression
*exp
,
10887 enum noside noside
)
10889 symbol
*sym
= std::get
<0> (m_storage
).symbol
;
10891 if (sym
->domain () == UNDEF_DOMAIN
)
10892 /* Only encountered when an unresolved symbol occurs in a
10893 context other than a function call, in which case, it is
10895 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10896 sym
->print_name ());
10898 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10900 struct type
*type
= static_unwrap_type (sym
->type ());
10901 /* Check to see if this is a tagged type. We also need to handle
10902 the case where the type is a reference to a tagged type, but
10903 we have to be careful to exclude pointers to tagged types.
10904 The latter should be shown as usual (as a pointer), whereas
10905 a reference should mostly be transparent to the user. */
10906 if (ada_is_tagged_type (type
, 0)
10907 || (type
->code () == TYPE_CODE_REF
10908 && ada_is_tagged_type (type
->target_type (), 0)))
10910 /* Tagged types are a little special in the fact that the real
10911 type is dynamic and can only be determined by inspecting the
10912 object's tag. This means that we need to get the object's
10913 value first (EVAL_NORMAL) and then extract the actual object
10916 Note that we cannot skip the final step where we extract
10917 the object type from its tag, because the EVAL_NORMAL phase
10918 results in dynamic components being resolved into fixed ones.
10919 This can cause problems when trying to print the type
10920 description of tagged types whose parent has a dynamic size:
10921 We use the type name of the "_parent" component in order
10922 to print the name of the ancestor type in the type description.
10923 If that component had a dynamic size, the resolution into
10924 a fixed type would result in the loss of that type name,
10925 thus preventing us from printing the name of the ancestor
10926 type in the type description. */
10927 value
*arg1
= evaluate (nullptr, exp
, EVAL_NORMAL
);
10929 if (type
->code () != TYPE_CODE_REF
)
10931 struct type
*actual_type
;
10933 actual_type
= type_from_tag (ada_value_tag (arg1
));
10934 if (actual_type
== NULL
)
10935 /* If, for some reason, we were unable to determine
10936 the actual type from the tag, then use the static
10937 approximation that we just computed as a fallback.
10938 This can happen if the debugging information is
10939 incomplete, for instance. */
10940 actual_type
= type
;
10941 return value_zero (actual_type
, not_lval
);
10945 /* In the case of a ref, ada_coerce_ref takes care
10946 of determining the actual type. But the evaluation
10947 should return a ref as it should be valid to ask
10948 for its address; so rebuild a ref after coerce. */
10949 arg1
= ada_coerce_ref (arg1
);
10950 return value_ref (arg1
, TYPE_CODE_REF
);
10954 /* Records and unions for which GNAT encodings have been
10955 generated need to be statically fixed as well.
10956 Otherwise, non-static fixing produces a type where
10957 all dynamic properties are removed, which prevents "ptype"
10958 from being able to completely describe the type.
10959 For instance, a case statement in a variant record would be
10960 replaced by the relevant components based on the actual
10961 value of the discriminants. */
10962 if ((type
->code () == TYPE_CODE_STRUCT
10963 && dynamic_template_type (type
) != NULL
)
10964 || (type
->code () == TYPE_CODE_UNION
10965 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10966 return value_zero (to_static_fixed_type (type
), not_lval
);
10969 value
*arg1
= var_value_operation::evaluate (expect_type
, exp
, noside
);
10970 return ada_to_fixed_value (arg1
);
10974 ada_var_value_operation::resolve (struct expression
*exp
,
10975 bool deprocedure_p
,
10976 bool parse_completion
,
10977 innermost_block_tracker
*tracker
,
10978 struct type
*context_type
)
10980 symbol
*sym
= std::get
<0> (m_storage
).symbol
;
10981 if (sym
->domain () == UNDEF_DOMAIN
)
10983 block_symbol resolved
10984 = ada_resolve_variable (sym
, std::get
<0> (m_storage
).block
,
10985 context_type
, parse_completion
,
10986 deprocedure_p
, tracker
);
10987 std::get
<0> (m_storage
) = resolved
;
10991 && (std::get
<0> (m_storage
).symbol
->type ()->code ()
10992 == TYPE_CODE_FUNC
))
10999 ada_atr_val_operation::evaluate (struct type
*expect_type
,
11000 struct expression
*exp
,
11001 enum noside noside
)
11003 value
*arg
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
11004 return ada_val_atr (noside
, std::get
<0> (m_storage
), arg
);
11008 ada_unop_ind_operation::evaluate (struct type
*expect_type
,
11009 struct expression
*exp
,
11010 enum noside noside
)
11012 value
*arg1
= std::get
<0> (m_storage
)->evaluate (expect_type
, exp
, noside
);
11014 struct type
*type
= ada_check_typedef (arg1
->type ());
11015 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11017 if (ada_is_array_descriptor_type (type
))
11018 /* GDB allows dereferencing GNAT array descriptors. */
11020 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11022 if (arrType
== NULL
)
11023 error (_("Attempt to dereference null array pointer."));
11024 return value_at_lazy (arrType
, 0);
11026 else if (type
->code () == TYPE_CODE_PTR
11027 || type
->code () == TYPE_CODE_REF
11028 /* In C you can dereference an array to get the 1st elt. */
11029 || type
->code () == TYPE_CODE_ARRAY
)
11031 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11032 only be determined by inspecting the object's tag.
11033 This means that we need to evaluate completely the
11034 expression in order to get its type. */
11036 if ((type
->code () == TYPE_CODE_REF
11037 || type
->code () == TYPE_CODE_PTR
)
11038 && ada_is_tagged_type (type
->target_type (), 0))
11040 arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
,
11042 type
= ada_value_ind (arg1
)->type ();
11046 type
= to_static_fixed_type
11048 (ada_check_typedef (type
->target_type ())));
11050 return value_zero (type
, lval_memory
);
11052 else if (type
->code () == TYPE_CODE_INT
)
11054 /* GDB allows dereferencing an int. */
11055 if (expect_type
== NULL
)
11056 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11061 to_static_fixed_type (ada_aligned_type (expect_type
));
11062 return value_zero (expect_type
, lval_memory
);
11066 error (_("Attempt to take contents of a non-pointer value."));
11068 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11069 type
= ada_check_typedef (arg1
->type ());
11071 if (type
->code () == TYPE_CODE_INT
)
11072 /* GDB allows dereferencing an int. If we were given
11073 the expect_type, then use that as the target type.
11074 Otherwise, assume that the target type is an int. */
11076 if (expect_type
!= NULL
)
11077 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11080 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11081 (CORE_ADDR
) value_as_address (arg1
));
11084 if (ada_is_array_descriptor_type (type
))
11085 /* GDB allows dereferencing GNAT array descriptors. */
11086 return ada_coerce_to_simple_array (arg1
);
11088 return ada_value_ind (arg1
);
11092 ada_structop_operation::evaluate (struct type
*expect_type
,
11093 struct expression
*exp
,
11094 enum noside noside
)
11096 value
*arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
11097 const char *str
= std::get
<1> (m_storage
).c_str ();
11098 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11101 struct type
*type1
= arg1
->type ();
11103 if (ada_is_tagged_type (type1
, 1))
11105 type
= ada_lookup_struct_elt_type (type1
, str
, 1, 1);
11107 /* If the field is not found, check if it exists in the
11108 extension of this object's type. This means that we
11109 need to evaluate completely the expression. */
11113 arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
,
11115 arg1
= ada_value_struct_elt (arg1
, str
, 0);
11116 arg1
= unwrap_value (arg1
);
11117 type
= ada_to_fixed_value (arg1
)->type ();
11121 type
= ada_lookup_struct_elt_type (type1
, str
, 1, 0);
11123 return value_zero (ada_aligned_type (type
), lval_memory
);
11127 arg1
= ada_value_struct_elt (arg1
, str
, 0);
11128 arg1
= unwrap_value (arg1
);
11129 return ada_to_fixed_value (arg1
);
11134 ada_funcall_operation::evaluate (struct type
*expect_type
,
11135 struct expression
*exp
,
11136 enum noside noside
)
11138 const std::vector
<operation_up
> &args_up
= std::get
<1> (m_storage
);
11139 int nargs
= args_up
.size ();
11140 std::vector
<value
*> argvec (nargs
);
11141 operation_up
&callee_op
= std::get
<0> (m_storage
);
11143 ada_var_value_operation
*avv
11144 = dynamic_cast<ada_var_value_operation
*> (callee_op
.get ());
11146 && avv
->get_symbol ()->domain () == UNDEF_DOMAIN
)
11147 error (_("Unexpected unresolved symbol, %s, during evaluation"),
11148 avv
->get_symbol ()->print_name ());
11150 value
*callee
= callee_op
->evaluate (nullptr, exp
, noside
);
11151 for (int i
= 0; i
< args_up
.size (); ++i
)
11152 argvec
[i
] = args_up
[i
]->evaluate (nullptr, exp
, noside
);
11154 if (ada_is_constrained_packed_array_type
11155 (desc_base_type (callee
->type ())))
11156 callee
= ada_coerce_to_simple_array (callee
);
11157 else if (callee
->type ()->code () == TYPE_CODE_ARRAY
11158 && TYPE_FIELD_BITSIZE (callee
->type (), 0) != 0)
11159 /* This is a packed array that has already been fixed, and
11160 therefore already coerced to a simple array. Nothing further
11163 else if (callee
->type ()->code () == TYPE_CODE_REF
)
11165 /* Make sure we dereference references so that all the code below
11166 feels like it's really handling the referenced value. Wrapping
11167 types (for alignment) may be there, so make sure we strip them as
11169 callee
= ada_to_fixed_value (coerce_ref (callee
));
11171 else if (callee
->type ()->code () == TYPE_CODE_ARRAY
11172 && VALUE_LVAL (callee
) == lval_memory
)
11173 callee
= value_addr (callee
);
11175 struct type
*type
= ada_check_typedef (callee
->type ());
11177 /* Ada allows us to implicitly dereference arrays when subscripting
11178 them. So, if this is an array typedef (encoding use for array
11179 access types encoded as fat pointers), strip it now. */
11180 if (type
->code () == TYPE_CODE_TYPEDEF
)
11181 type
= ada_typedef_target_type (type
);
11183 if (type
->code () == TYPE_CODE_PTR
)
11185 switch (ada_check_typedef (type
->target_type ())->code ())
11187 case TYPE_CODE_FUNC
:
11188 type
= ada_check_typedef (type
->target_type ());
11190 case TYPE_CODE_ARRAY
:
11192 case TYPE_CODE_STRUCT
:
11193 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
11194 callee
= ada_value_ind (callee
);
11195 type
= ada_check_typedef (type
->target_type ());
11198 error (_("cannot subscript or call something of type `%s'"),
11199 ada_type_name (callee
->type ()));
11204 switch (type
->code ())
11206 case TYPE_CODE_FUNC
:
11207 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11209 if (type
->target_type () == NULL
)
11210 error_call_unknown_return_type (NULL
);
11211 return allocate_value (type
->target_type ());
11213 return call_function_by_hand (callee
, NULL
, argvec
);
11214 case TYPE_CODE_INTERNAL_FUNCTION
:
11215 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11216 /* We don't know anything about what the internal
11217 function might return, but we have to return
11219 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11222 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
11226 case TYPE_CODE_STRUCT
:
11230 arity
= ada_array_arity (type
);
11231 type
= ada_array_element_type (type
, nargs
);
11233 error (_("cannot subscript or call a record"));
11234 if (arity
!= nargs
)
11235 error (_("wrong number of subscripts; expecting %d"), arity
);
11236 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11237 return value_zero (ada_aligned_type (type
), lval_memory
);
11239 unwrap_value (ada_value_subscript
11240 (callee
, nargs
, argvec
.data ()));
11242 case TYPE_CODE_ARRAY
:
11243 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11245 type
= ada_array_element_type (type
, nargs
);
11247 error (_("element type of array unknown"));
11249 return value_zero (ada_aligned_type (type
), lval_memory
);
11252 unwrap_value (ada_value_subscript
11253 (ada_coerce_to_simple_array (callee
),
11254 nargs
, argvec
.data ()));
11255 case TYPE_CODE_PTR
: /* Pointer to array */
11256 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11258 type
= to_fixed_array_type (type
->target_type (), NULL
, 1);
11259 type
= ada_array_element_type (type
, nargs
);
11261 error (_("element type of array unknown"));
11263 return value_zero (ada_aligned_type (type
), lval_memory
);
11266 unwrap_value (ada_value_ptr_subscript (callee
, nargs
,
11270 error (_("Attempt to index or call something other than an "
11271 "array or function"));
11276 ada_funcall_operation::resolve (struct expression
*exp
,
11277 bool deprocedure_p
,
11278 bool parse_completion
,
11279 innermost_block_tracker
*tracker
,
11280 struct type
*context_type
)
11282 operation_up
&callee_op
= std::get
<0> (m_storage
);
11284 ada_var_value_operation
*avv
11285 = dynamic_cast<ada_var_value_operation
*> (callee_op
.get ());
11286 if (avv
== nullptr)
11289 symbol
*sym
= avv
->get_symbol ();
11290 if (sym
->domain () != UNDEF_DOMAIN
)
11293 const std::vector
<operation_up
> &args_up
= std::get
<1> (m_storage
);
11294 int nargs
= args_up
.size ();
11295 std::vector
<value
*> argvec (nargs
);
11297 for (int i
= 0; i
< args_up
.size (); ++i
)
11298 argvec
[i
] = args_up
[i
]->evaluate (nullptr, exp
, EVAL_AVOID_SIDE_EFFECTS
);
11300 const block
*block
= avv
->get_block ();
11301 block_symbol resolved
11302 = ada_resolve_funcall (sym
, block
,
11303 context_type
, parse_completion
,
11304 nargs
, argvec
.data (),
11307 std::get
<0> (m_storage
)
11308 = make_operation
<ada_var_value_operation
> (resolved
);
11313 ada_ternop_slice_operation::resolve (struct expression
*exp
,
11314 bool deprocedure_p
,
11315 bool parse_completion
,
11316 innermost_block_tracker
*tracker
,
11317 struct type
*context_type
)
11319 /* Historically this check was done during resolution, so we
11320 continue that here. */
11321 value
*v
= std::get
<0> (m_storage
)->evaluate (context_type
, exp
,
11322 EVAL_AVOID_SIDE_EFFECTS
);
11323 if (ada_is_any_packed_array_type (v
->type ()))
11324 error (_("cannot slice a packed array"));
11332 /* Return non-zero iff TYPE represents a System.Address type. */
11335 ada_is_system_address_type (struct type
*type
)
11337 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11344 /* Scan STR beginning at position K for a discriminant name, and
11345 return the value of that discriminant field of DVAL in *PX. If
11346 PNEW_K is not null, put the position of the character beyond the
11347 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11348 not alter *PX and *PNEW_K if unsuccessful. */
11351 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11354 static std::string storage
;
11355 const char *pstart
, *pend
, *bound
;
11356 struct value
*bound_val
;
11358 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11362 pend
= strstr (pstart
, "__");
11366 k
+= strlen (bound
);
11370 int len
= pend
- pstart
;
11372 /* Strip __ and beyond. */
11373 storage
= std::string (pstart
, len
);
11374 bound
= storage
.c_str ();
11378 bound_val
= ada_search_struct_field (bound
, dval
, 0, dval
->type ());
11379 if (bound_val
== NULL
)
11382 *px
= value_as_long (bound_val
);
11383 if (pnew_k
!= NULL
)
11388 /* Value of variable named NAME. Only exact matches are considered.
11389 If no such variable found, then if ERR_MSG is null, returns 0, and
11390 otherwise causes an error with message ERR_MSG. */
11392 static struct value
*
11393 get_var_value (const char *name
, const char *err_msg
)
11395 std::string quoted_name
= add_angle_brackets (name
);
11397 lookup_name_info
lookup_name (quoted_name
, symbol_name_match_type::FULL
);
11399 std::vector
<struct block_symbol
> syms
11400 = ada_lookup_symbol_list_worker (lookup_name
,
11401 get_selected_block (0),
11404 if (syms
.size () != 1)
11406 if (err_msg
== NULL
)
11409 error (("%s"), err_msg
);
11412 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11415 /* Value of integer variable named NAME in the current environment.
11416 If no such variable is found, returns false. Otherwise, sets VALUE
11417 to the variable's value and returns true. */
11420 get_int_var_value (const char *name
, LONGEST
&value
)
11422 struct value
*var_val
= get_var_value (name
, 0);
11427 value
= value_as_long (var_val
);
11432 /* Return a range type whose base type is that of the range type named
11433 NAME in the current environment, and whose bounds are calculated
11434 from NAME according to the GNAT range encoding conventions.
11435 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11436 corresponding range type from debug information; fall back to using it
11437 if symbol lookup fails. If a new type must be created, allocate it
11438 like ORIG_TYPE was. The bounds information, in general, is encoded
11439 in NAME, the base type given in the named range type. */
11441 static struct type
*
11442 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11445 struct type
*base_type
;
11446 const char *subtype_info
;
11448 gdb_assert (raw_type
!= NULL
);
11449 gdb_assert (raw_type
->name () != NULL
);
11451 if (raw_type
->code () == TYPE_CODE_RANGE
)
11452 base_type
= raw_type
->target_type ();
11454 base_type
= raw_type
;
11456 name
= raw_type
->name ();
11457 subtype_info
= strstr (name
, "___XD");
11458 if (subtype_info
== NULL
)
11460 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11461 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11463 if (L
< INT_MIN
|| U
> INT_MAX
)
11466 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11471 int prefix_len
= subtype_info
- name
;
11474 const char *bounds_str
;
11478 bounds_str
= strchr (subtype_info
, '_');
11481 if (*subtype_info
== 'L')
11483 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11484 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11486 if (bounds_str
[n
] == '_')
11488 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11494 std::string name_buf
= std::string (name
, prefix_len
) + "___L";
11495 if (!get_int_var_value (name_buf
.c_str (), L
))
11497 lim_warning (_("Unknown lower bound, using 1."));
11502 if (*subtype_info
== 'U')
11504 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11505 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11510 std::string name_buf
= std::string (name
, prefix_len
) + "___U";
11511 if (!get_int_var_value (name_buf
.c_str (), U
))
11513 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11518 type
= create_static_range_type (alloc_type_copy (raw_type
),
11520 /* create_static_range_type alters the resulting type's length
11521 to match the size of the base_type, which is not what we want.
11522 Set it back to the original range type's length. */
11523 type
->set_length (raw_type
->length ());
11524 type
->set_name (name
);
11529 /* True iff NAME is the name of a range type. */
11532 ada_is_range_type_name (const char *name
)
11534 return (name
!= NULL
&& strstr (name
, "___XD"));
11538 /* Modular types */
11540 /* True iff TYPE is an Ada modular type. */
11543 ada_is_modular_type (struct type
*type
)
11545 struct type
*subranged_type
= get_base_type (type
);
11547 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11548 && subranged_type
->code () == TYPE_CODE_INT
11549 && subranged_type
->is_unsigned ());
11552 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11555 ada_modulus (struct type
*type
)
11557 const dynamic_prop
&high
= type
->bounds ()->high
;
11559 if (high
.kind () == PROP_CONST
)
11560 return (ULONGEST
) high
.const_val () + 1;
11562 /* If TYPE is unresolved, the high bound might be a location list. Return
11563 0, for lack of a better value to return. */
11568 /* Ada exception catchpoint support:
11569 ---------------------------------
11571 We support 3 kinds of exception catchpoints:
11572 . catchpoints on Ada exceptions
11573 . catchpoints on unhandled Ada exceptions
11574 . catchpoints on failed assertions
11576 Exceptions raised during failed assertions, or unhandled exceptions
11577 could perfectly be caught with the general catchpoint on Ada exceptions.
11578 However, we can easily differentiate these two special cases, and having
11579 the option to distinguish these two cases from the rest can be useful
11580 to zero-in on certain situations.
11582 Exception catchpoints are a specialized form of breakpoint,
11583 since they rely on inserting breakpoints inside known routines
11584 of the GNAT runtime. The implementation therefore uses a standard
11585 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11588 Support in the runtime for exception catchpoints have been changed
11589 a few times already, and these changes affect the implementation
11590 of these catchpoints. In order to be able to support several
11591 variants of the runtime, we use a sniffer that will determine
11592 the runtime variant used by the program being debugged. */
11594 /* Ada's standard exceptions.
11596 The Ada 83 standard also defined Numeric_Error. But there so many
11597 situations where it was unclear from the Ada 83 Reference Manual
11598 (RM) whether Constraint_Error or Numeric_Error should be raised,
11599 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11600 Interpretation saying that anytime the RM says that Numeric_Error
11601 should be raised, the implementation may raise Constraint_Error.
11602 Ada 95 went one step further and pretty much removed Numeric_Error
11603 from the list of standard exceptions (it made it a renaming of
11604 Constraint_Error, to help preserve compatibility when compiling
11605 an Ada83 compiler). As such, we do not include Numeric_Error from
11606 this list of standard exceptions. */
11608 static const char * const standard_exc
[] = {
11609 "constraint_error",
11615 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11617 /* A structure that describes how to support exception catchpoints
11618 for a given executable. */
11620 struct exception_support_info
11622 /* The name of the symbol to break on in order to insert
11623 a catchpoint on exceptions. */
11624 const char *catch_exception_sym
;
11626 /* The name of the symbol to break on in order to insert
11627 a catchpoint on unhandled exceptions. */
11628 const char *catch_exception_unhandled_sym
;
11630 /* The name of the symbol to break on in order to insert
11631 a catchpoint on failed assertions. */
11632 const char *catch_assert_sym
;
11634 /* The name of the symbol to break on in order to insert
11635 a catchpoint on exception handling. */
11636 const char *catch_handlers_sym
;
11638 /* Assuming that the inferior just triggered an unhandled exception
11639 catchpoint, this function is responsible for returning the address
11640 in inferior memory where the name of that exception is stored.
11641 Return zero if the address could not be computed. */
11642 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11645 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11646 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11648 /* The following exception support info structure describes how to
11649 implement exception catchpoints with the latest version of the
11650 Ada runtime (as of 2019-08-??). */
11652 static const struct exception_support_info default_exception_support_info
=
11654 "__gnat_debug_raise_exception", /* catch_exception_sym */
11655 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11656 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11657 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11658 ada_unhandled_exception_name_addr
11661 /* The following exception support info structure describes how to
11662 implement exception catchpoints with an earlier version of the
11663 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11665 static const struct exception_support_info exception_support_info_v0
=
11667 "__gnat_debug_raise_exception", /* catch_exception_sym */
11668 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11669 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11670 "__gnat_begin_handler", /* catch_handlers_sym */
11671 ada_unhandled_exception_name_addr
11674 /* The following exception support info structure describes how to
11675 implement exception catchpoints with a slightly older version
11676 of the Ada runtime. */
11678 static const struct exception_support_info exception_support_info_fallback
=
11680 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11681 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11682 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11683 "__gnat_begin_handler", /* catch_handlers_sym */
11684 ada_unhandled_exception_name_addr_from_raise
11687 /* Return nonzero if we can detect the exception support routines
11688 described in EINFO.
11690 This function errors out if an abnormal situation is detected
11691 (for instance, if we find the exception support routines, but
11692 that support is found to be incomplete). */
11695 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11697 struct symbol
*sym
;
11699 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11700 that should be compiled with debugging information. As a result, we
11701 expect to find that symbol in the symtabs. */
11703 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11706 /* Perhaps we did not find our symbol because the Ada runtime was
11707 compiled without debugging info, or simply stripped of it.
11708 It happens on some GNU/Linux distributions for instance, where
11709 users have to install a separate debug package in order to get
11710 the runtime's debugging info. In that situation, let the user
11711 know why we cannot insert an Ada exception catchpoint.
11713 Note: Just for the purpose of inserting our Ada exception
11714 catchpoint, we could rely purely on the associated minimal symbol.
11715 But we would be operating in degraded mode anyway, since we are
11716 still lacking the debugging info needed later on to extract
11717 the name of the exception being raised (this name is printed in
11718 the catchpoint message, and is also used when trying to catch
11719 a specific exception). We do not handle this case for now. */
11720 struct bound_minimal_symbol msym
11721 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11723 if (msym
.minsym
&& msym
.minsym
->type () != mst_solib_trampoline
)
11724 error (_("Your Ada runtime appears to be missing some debugging "
11725 "information.\nCannot insert Ada exception catchpoint "
11726 "in this configuration."));
11731 /* Make sure that the symbol we found corresponds to a function. */
11733 if (sym
->aclass () != LOC_BLOCK
)
11735 error (_("Symbol \"%s\" is not a function (class = %d)"),
11736 sym
->linkage_name (), sym
->aclass ());
11740 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11743 struct bound_minimal_symbol msym
11744 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11746 if (msym
.minsym
&& msym
.minsym
->type () != mst_solib_trampoline
)
11747 error (_("Your Ada runtime appears to be missing some debugging "
11748 "information.\nCannot insert Ada exception catchpoint "
11749 "in this configuration."));
11754 /* Make sure that the symbol we found corresponds to a function. */
11756 if (sym
->aclass () != LOC_BLOCK
)
11758 error (_("Symbol \"%s\" is not a function (class = %d)"),
11759 sym
->linkage_name (), sym
->aclass ());
11766 /* Inspect the Ada runtime and determine which exception info structure
11767 should be used to provide support for exception catchpoints.
11769 This function will always set the per-inferior exception_info,
11770 or raise an error. */
11773 ada_exception_support_info_sniffer (void)
11775 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11777 /* If the exception info is already known, then no need to recompute it. */
11778 if (data
->exception_info
!= NULL
)
11781 /* Check the latest (default) exception support info. */
11782 if (ada_has_this_exception_support (&default_exception_support_info
))
11784 data
->exception_info
= &default_exception_support_info
;
11788 /* Try the v0 exception suport info. */
11789 if (ada_has_this_exception_support (&exception_support_info_v0
))
11791 data
->exception_info
= &exception_support_info_v0
;
11795 /* Try our fallback exception suport info. */
11796 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11798 data
->exception_info
= &exception_support_info_fallback
;
11802 /* Sometimes, it is normal for us to not be able to find the routine
11803 we are looking for. This happens when the program is linked with
11804 the shared version of the GNAT runtime, and the program has not been
11805 started yet. Inform the user of these two possible causes if
11808 if (ada_update_initial_language (language_unknown
) != language_ada
)
11809 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11811 /* If the symbol does not exist, then check that the program is
11812 already started, to make sure that shared libraries have been
11813 loaded. If it is not started, this may mean that the symbol is
11814 in a shared library. */
11816 if (inferior_ptid
.pid () == 0)
11817 error (_("Unable to insert catchpoint. Try to start the program first."));
11819 /* At this point, we know that we are debugging an Ada program and
11820 that the inferior has been started, but we still are not able to
11821 find the run-time symbols. That can mean that we are in
11822 configurable run time mode, or that a-except as been optimized
11823 out by the linker... In any case, at this point it is not worth
11824 supporting this feature. */
11826 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11829 /* True iff FRAME is very likely to be that of a function that is
11830 part of the runtime system. This is all very heuristic, but is
11831 intended to be used as advice as to what frames are uninteresting
11835 is_known_support_routine (frame_info_ptr frame
)
11837 enum language func_lang
;
11839 const char *fullname
;
11841 /* If this code does not have any debugging information (no symtab),
11842 This cannot be any user code. */
11844 symtab_and_line sal
= find_frame_sal (frame
);
11845 if (sal
.symtab
== NULL
)
11848 /* If there is a symtab, but the associated source file cannot be
11849 located, then assume this is not user code: Selecting a frame
11850 for which we cannot display the code would not be very helpful
11851 for the user. This should also take care of case such as VxWorks
11852 where the kernel has some debugging info provided for a few units. */
11854 fullname
= symtab_to_fullname (sal
.symtab
);
11855 if (access (fullname
, R_OK
) != 0)
11858 /* Check the unit filename against the Ada runtime file naming.
11859 We also check the name of the objfile against the name of some
11860 known system libraries that sometimes come with debugging info
11863 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11865 re_comp (known_runtime_file_name_patterns
[i
]);
11866 if (re_exec (lbasename (sal
.symtab
->filename
)))
11868 if (sal
.symtab
->compunit ()->objfile () != NULL
11869 && re_exec (objfile_name (sal
.symtab
->compunit ()->objfile ())))
11873 /* Check whether the function is a GNAT-generated entity. */
11875 gdb::unique_xmalloc_ptr
<char> func_name
11876 = find_frame_funname (frame
, &func_lang
, NULL
);
11877 if (func_name
== NULL
)
11880 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11882 re_comp (known_auxiliary_function_name_patterns
[i
]);
11883 if (re_exec (func_name
.get ()))
11890 /* Find the first frame that contains debugging information and that is not
11891 part of the Ada run-time, starting from FI and moving upward. */
11894 ada_find_printable_frame (frame_info_ptr fi
)
11896 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11898 if (!is_known_support_routine (fi
))
11907 /* Assuming that the inferior just triggered an unhandled exception
11908 catchpoint, return the address in inferior memory where the name
11909 of the exception is stored.
11911 Return zero if the address could not be computed. */
11914 ada_unhandled_exception_name_addr (void)
11916 return parse_and_eval_address ("e.full_name");
11919 /* Same as ada_unhandled_exception_name_addr, except that this function
11920 should be used when the inferior uses an older version of the runtime,
11921 where the exception name needs to be extracted from a specific frame
11922 several frames up in the callstack. */
11925 ada_unhandled_exception_name_addr_from_raise (void)
11929 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11931 /* To determine the name of this exception, we need to select
11932 the frame corresponding to RAISE_SYM_NAME. This frame is
11933 at least 3 levels up, so we simply skip the first 3 frames
11934 without checking the name of their associated function. */
11935 fi
= get_current_frame ();
11936 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11938 fi
= get_prev_frame (fi
);
11942 enum language func_lang
;
11944 gdb::unique_xmalloc_ptr
<char> func_name
11945 = find_frame_funname (fi
, &func_lang
, NULL
);
11946 if (func_name
!= NULL
)
11948 if (strcmp (func_name
.get (),
11949 data
->exception_info
->catch_exception_sym
) == 0)
11950 break; /* We found the frame we were looking for... */
11952 fi
= get_prev_frame (fi
);
11959 return parse_and_eval_address ("id.full_name");
11962 /* Assuming the inferior just triggered an Ada exception catchpoint
11963 (of any type), return the address in inferior memory where the name
11964 of the exception is stored, if applicable.
11966 Assumes the selected frame is the current frame.
11968 Return zero if the address could not be computed, or if not relevant. */
11971 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
)
11973 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11977 case ada_catch_exception
:
11978 return (parse_and_eval_address ("e.full_name"));
11981 case ada_catch_exception_unhandled
:
11982 return data
->exception_info
->unhandled_exception_name_addr ();
11985 case ada_catch_handlers
:
11986 return 0; /* The runtimes does not provide access to the exception
11990 case ada_catch_assert
:
11991 return 0; /* Exception name is not relevant in this case. */
11995 internal_error (_("unexpected catchpoint type"));
11999 return 0; /* Should never be reached. */
12002 /* Assuming the inferior is stopped at an exception catchpoint,
12003 return the message which was associated to the exception, if
12004 available. Return NULL if the message could not be retrieved.
12006 Note: The exception message can be associated to an exception
12007 either through the use of the Raise_Exception function, or
12008 more simply (Ada 2005 and later), via:
12010 raise Exception_Name with "exception message";
12014 static gdb::unique_xmalloc_ptr
<char>
12015 ada_exception_message_1 (void)
12017 struct value
*e_msg_val
;
12020 /* For runtimes that support this feature, the exception message
12021 is passed as an unbounded string argument called "message". */
12022 e_msg_val
= parse_and_eval ("message");
12023 if (e_msg_val
== NULL
)
12024 return NULL
; /* Exception message not supported. */
12026 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12027 gdb_assert (e_msg_val
!= NULL
);
12028 e_msg_len
= e_msg_val
->type ()->length ();
12030 /* If the message string is empty, then treat it as if there was
12031 no exception message. */
12032 if (e_msg_len
<= 0)
12035 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12036 read_memory (value_address (e_msg_val
), (gdb_byte
*) e_msg
.get (),
12038 e_msg
.get ()[e_msg_len
] = '\0';
12043 /* Same as ada_exception_message_1, except that all exceptions are
12044 contained here (returning NULL instead). */
12046 static gdb::unique_xmalloc_ptr
<char>
12047 ada_exception_message (void)
12049 gdb::unique_xmalloc_ptr
<char> e_msg
;
12053 e_msg
= ada_exception_message_1 ();
12055 catch (const gdb_exception_error
&e
)
12057 e_msg
.reset (nullptr);
12063 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12064 any error that ada_exception_name_addr_1 might cause to be thrown.
12065 When an error is intercepted, a warning with the error message is printed,
12066 and zero is returned. */
12069 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
)
12071 CORE_ADDR result
= 0;
12075 result
= ada_exception_name_addr_1 (ex
);
12078 catch (const gdb_exception_error
&e
)
12080 warning (_("failed to get exception name: %s"), e
.what ());
12087 static std::string ada_exception_catchpoint_cond_string
12088 (const char *excep_string
,
12089 enum ada_exception_catchpoint_kind ex
);
12091 /* Ada catchpoints.
12093 In the case of catchpoints on Ada exceptions, the catchpoint will
12094 stop the target on every exception the program throws. When a user
12095 specifies the name of a specific exception, we translate this
12096 request into a condition expression (in text form), and then parse
12097 it into an expression stored in each of the catchpoint's locations.
12098 We then use this condition to check whether the exception that was
12099 raised is the one the user is interested in. If not, then the
12100 target is resumed again. We store the name of the requested
12101 exception, in order to be able to re-set the condition expression
12102 when symbols change. */
12104 /* An instance of this type is used to represent an Ada catchpoint. */
12106 struct ada_catchpoint
: public code_breakpoint
12108 ada_catchpoint (struct gdbarch
*gdbarch_
,
12109 enum ada_exception_catchpoint_kind kind
,
12110 struct symtab_and_line sal
,
12111 const char *addr_string_
,
12115 : code_breakpoint (gdbarch_
, bp_catchpoint
),
12118 add_location (sal
);
12120 /* Unlike most code_breakpoint types, Ada catchpoints are
12121 pspace-specific. */
12122 gdb_assert (sal
.pspace
!= nullptr);
12123 this->pspace
= sal
.pspace
;
12127 struct gdbarch
*loc_gdbarch
= get_sal_arch (sal
);
12129 loc_gdbarch
= gdbarch
;
12131 describe_other_breakpoints (loc_gdbarch
,
12132 sal
.pspace
, sal
.pc
, sal
.section
, -1);
12133 /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12134 version for exception catchpoints, because two catchpoints
12135 used for different exception names will use the same address.
12136 In this case, a "breakpoint ... also set at..." warning is
12137 unproductive. Besides, the warning phrasing is also a bit
12138 inappropriate, we should use the word catchpoint, and tell
12139 the user what type of catchpoint it is. The above is good
12140 enough for now, though. */
12143 enable_state
= enabled
? bp_enabled
: bp_disabled
;
12144 disposition
= tempflag
? disp_del
: disp_donttouch
;
12145 locspec
= string_to_location_spec (&addr_string_
,
12146 language_def (language_ada
));
12147 language
= language_ada
;
12150 struct bp_location
*allocate_location () override
;
12151 void re_set () override
;
12152 void check_status (struct bpstat
*bs
) override
;
12153 enum print_stop_action
print_it (const bpstat
*bs
) const override
;
12154 bool print_one (bp_location
**) const override
;
12155 void print_mention () const override
;
12156 void print_recreate (struct ui_file
*fp
) const override
;
12158 /* The name of the specific exception the user specified. */
12159 std::string excep_string
;
12161 /* What kind of catchpoint this is. */
12162 enum ada_exception_catchpoint_kind m_kind
;
12165 /* An instance of this type is used to represent an Ada catchpoint
12166 breakpoint location. */
12168 class ada_catchpoint_location
: public bp_location
12171 explicit ada_catchpoint_location (ada_catchpoint
*owner
)
12172 : bp_location (owner
, bp_loc_software_breakpoint
)
12175 /* The condition that checks whether the exception that was raised
12176 is the specific exception the user specified on catchpoint
12178 expression_up excep_cond_expr
;
12181 /* Parse the exception condition string in the context of each of the
12182 catchpoint's locations, and store them for later evaluation. */
12185 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12186 enum ada_exception_catchpoint_kind ex
)
12188 /* Nothing to do if there's no specific exception to catch. */
12189 if (c
->excep_string
.empty ())
12192 /* Same if there are no locations... */
12193 if (c
->loc
== NULL
)
12196 /* Compute the condition expression in text form, from the specific
12197 expection we want to catch. */
12198 std::string cond_string
12199 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12201 /* Iterate over all the catchpoint's locations, and parse an
12202 expression for each. */
12203 for (bp_location
*bl
: c
->locations ())
12205 struct ada_catchpoint_location
*ada_loc
12206 = (struct ada_catchpoint_location
*) bl
;
12209 if (!bl
->shlib_disabled
)
12213 s
= cond_string
.c_str ();
12216 exp
= parse_exp_1 (&s
, bl
->address
,
12217 block_for_pc (bl
->address
),
12220 catch (const gdb_exception_error
&e
)
12222 warning (_("failed to reevaluate internal exception condition "
12223 "for catchpoint %d: %s"),
12224 c
->number
, e
.what ());
12228 ada_loc
->excep_cond_expr
= std::move (exp
);
12232 /* Implement the ALLOCATE_LOCATION method in the structure for all
12233 exception catchpoint kinds. */
12235 struct bp_location
*
12236 ada_catchpoint::allocate_location ()
12238 return new ada_catchpoint_location (this);
12241 /* Implement the RE_SET method in the structure for all exception
12242 catchpoint kinds. */
12245 ada_catchpoint::re_set ()
12247 /* Call the base class's method. This updates the catchpoint's
12249 this->code_breakpoint::re_set ();
12251 /* Reparse the exception conditional expressions. One for each
12253 create_excep_cond_exprs (this, m_kind
);
12256 /* Returns true if we should stop for this breakpoint hit. If the
12257 user specified a specific exception, we only want to cause a stop
12258 if the program thrown that exception. */
12261 should_stop_exception (const struct bp_location
*bl
)
12263 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12264 const struct ada_catchpoint_location
*ada_loc
12265 = (const struct ada_catchpoint_location
*) bl
;
12268 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12269 if (c
->m_kind
== ada_catch_assert
)
12270 clear_internalvar (var
);
12277 if (c
->m_kind
== ada_catch_handlers
)
12278 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12279 ".all.occurrence.id");
12283 struct value
*exc
= parse_and_eval (expr
);
12284 set_internalvar (var
, exc
);
12286 catch (const gdb_exception_error
&ex
)
12288 clear_internalvar (var
);
12292 /* With no specific exception, should always stop. */
12293 if (c
->excep_string
.empty ())
12296 if (ada_loc
->excep_cond_expr
== NULL
)
12298 /* We will have a NULL expression if back when we were creating
12299 the expressions, this location's had failed to parse. */
12306 scoped_value_mark mark
;
12307 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12309 catch (const gdb_exception
&ex
)
12311 exception_fprintf (gdb_stderr
, ex
,
12312 _("Error in testing exception condition:\n"));
12318 /* Implement the CHECK_STATUS method in the structure for all
12319 exception catchpoint kinds. */
12322 ada_catchpoint::check_status (bpstat
*bs
)
12324 bs
->stop
= should_stop_exception (bs
->bp_location_at
.get ());
12327 /* Implement the PRINT_IT method in the structure for all exception
12328 catchpoint kinds. */
12330 enum print_stop_action
12331 ada_catchpoint::print_it (const bpstat
*bs
) const
12333 struct ui_out
*uiout
= current_uiout
;
12335 annotate_catchpoint (number
);
12337 if (uiout
->is_mi_like_p ())
12339 uiout
->field_string ("reason",
12340 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12341 uiout
->field_string ("disp", bpdisp_text (disposition
));
12344 uiout
->text (disposition
== disp_del
12345 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12346 print_num_locno (bs
, uiout
);
12347 uiout
->text (", ");
12349 /* ada_exception_name_addr relies on the selected frame being the
12350 current frame. Need to do this here because this function may be
12351 called more than once when printing a stop, and below, we'll
12352 select the first frame past the Ada run-time (see
12353 ada_find_printable_frame). */
12354 select_frame (get_current_frame ());
12358 case ada_catch_exception
:
12359 case ada_catch_exception_unhandled
:
12360 case ada_catch_handlers
:
12362 const CORE_ADDR addr
= ada_exception_name_addr (m_kind
);
12363 char exception_name
[256];
12367 read_memory (addr
, (gdb_byte
*) exception_name
,
12368 sizeof (exception_name
) - 1);
12369 exception_name
[sizeof (exception_name
) - 1] = '\0';
12373 /* For some reason, we were unable to read the exception
12374 name. This could happen if the Runtime was compiled
12375 without debugging info, for instance. In that case,
12376 just replace the exception name by the generic string
12377 "exception" - it will read as "an exception" in the
12378 notification we are about to print. */
12379 memcpy (exception_name
, "exception", sizeof ("exception"));
12381 /* In the case of unhandled exception breakpoints, we print
12382 the exception name as "unhandled EXCEPTION_NAME", to make
12383 it clearer to the user which kind of catchpoint just got
12384 hit. We used ui_out_text to make sure that this extra
12385 info does not pollute the exception name in the MI case. */
12386 if (m_kind
== ada_catch_exception_unhandled
)
12387 uiout
->text ("unhandled ");
12388 uiout
->field_string ("exception-name", exception_name
);
12391 case ada_catch_assert
:
12392 /* In this case, the name of the exception is not really
12393 important. Just print "failed assertion" to make it clearer
12394 that his program just hit an assertion-failure catchpoint.
12395 We used ui_out_text because this info does not belong in
12397 uiout
->text ("failed assertion");
12401 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12402 if (exception_message
!= NULL
)
12404 uiout
->text (" (");
12405 uiout
->field_string ("exception-message", exception_message
.get ());
12409 uiout
->text (" at ");
12410 ada_find_printable_frame (get_current_frame ());
12412 return PRINT_SRC_AND_LOC
;
12415 /* Implement the PRINT_ONE method in the structure for all exception
12416 catchpoint kinds. */
12419 ada_catchpoint::print_one (bp_location
**last_loc
) const
12421 struct ui_out
*uiout
= current_uiout
;
12422 struct value_print_options opts
;
12424 get_user_print_options (&opts
);
12426 if (opts
.addressprint
)
12427 uiout
->field_skip ("addr");
12429 annotate_field (5);
12432 case ada_catch_exception
:
12433 if (!excep_string
.empty ())
12435 std::string msg
= string_printf (_("`%s' Ada exception"),
12436 excep_string
.c_str ());
12438 uiout
->field_string ("what", msg
);
12441 uiout
->field_string ("what", "all Ada exceptions");
12445 case ada_catch_exception_unhandled
:
12446 uiout
->field_string ("what", "unhandled Ada exceptions");
12449 case ada_catch_handlers
:
12450 if (!excep_string
.empty ())
12452 uiout
->field_fmt ("what",
12453 _("`%s' Ada exception handlers"),
12454 excep_string
.c_str ());
12457 uiout
->field_string ("what", "all Ada exceptions handlers");
12460 case ada_catch_assert
:
12461 uiout
->field_string ("what", "failed Ada assertions");
12465 internal_error (_("unexpected catchpoint type"));
12472 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12473 for all exception catchpoint kinds. */
12476 ada_catchpoint::print_mention () const
12478 struct ui_out
*uiout
= current_uiout
;
12480 uiout
->text (disposition
== disp_del
? _("Temporary catchpoint ")
12481 : _("Catchpoint "));
12482 uiout
->field_signed ("bkptno", number
);
12483 uiout
->text (": ");
12487 case ada_catch_exception
:
12488 if (!excep_string
.empty ())
12490 std::string info
= string_printf (_("`%s' Ada exception"),
12491 excep_string
.c_str ());
12492 uiout
->text (info
);
12495 uiout
->text (_("all Ada exceptions"));
12498 case ada_catch_exception_unhandled
:
12499 uiout
->text (_("unhandled Ada exceptions"));
12502 case ada_catch_handlers
:
12503 if (!excep_string
.empty ())
12506 = string_printf (_("`%s' Ada exception handlers"),
12507 excep_string
.c_str ());
12508 uiout
->text (info
);
12511 uiout
->text (_("all Ada exceptions handlers"));
12514 case ada_catch_assert
:
12515 uiout
->text (_("failed Ada assertions"));
12519 internal_error (_("unexpected catchpoint type"));
12524 /* Implement the PRINT_RECREATE method in the structure for all
12525 exception catchpoint kinds. */
12528 ada_catchpoint::print_recreate (struct ui_file
*fp
) const
12532 case ada_catch_exception
:
12533 gdb_printf (fp
, "catch exception");
12534 if (!excep_string
.empty ())
12535 gdb_printf (fp
, " %s", excep_string
.c_str ());
12538 case ada_catch_exception_unhandled
:
12539 gdb_printf (fp
, "catch exception unhandled");
12542 case ada_catch_handlers
:
12543 gdb_printf (fp
, "catch handlers");
12546 case ada_catch_assert
:
12547 gdb_printf (fp
, "catch assert");
12551 internal_error (_("unexpected catchpoint type"));
12553 print_recreate_thread (fp
);
12556 /* See ada-lang.h. */
12559 is_ada_exception_catchpoint (breakpoint
*bp
)
12561 return dynamic_cast<ada_catchpoint
*> (bp
) != nullptr;
12564 /* Split the arguments specified in a "catch exception" command.
12565 Set EX to the appropriate catchpoint type.
12566 Set EXCEP_STRING to the name of the specific exception if
12567 specified by the user.
12568 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12569 "catch handlers" command. False otherwise.
12570 If a condition is found at the end of the arguments, the condition
12571 expression is stored in COND_STRING (memory must be deallocated
12572 after use). Otherwise COND_STRING is set to NULL. */
12575 catch_ada_exception_command_split (const char *args
,
12576 bool is_catch_handlers_cmd
,
12577 enum ada_exception_catchpoint_kind
*ex
,
12578 std::string
*excep_string
,
12579 std::string
*cond_string
)
12581 std::string exception_name
;
12583 exception_name
= extract_arg (&args
);
12584 if (exception_name
== "if")
12586 /* This is not an exception name; this is the start of a condition
12587 expression for a catchpoint on all exceptions. So, "un-get"
12588 this token, and set exception_name to NULL. */
12589 exception_name
.clear ();
12593 /* Check to see if we have a condition. */
12595 args
= skip_spaces (args
);
12596 if (startswith (args
, "if")
12597 && (isspace (args
[2]) || args
[2] == '\0'))
12600 args
= skip_spaces (args
);
12602 if (args
[0] == '\0')
12603 error (_("Condition missing after `if' keyword"));
12604 *cond_string
= args
;
12606 args
+= strlen (args
);
12609 /* Check that we do not have any more arguments. Anything else
12612 if (args
[0] != '\0')
12613 error (_("Junk at end of expression"));
12615 if (is_catch_handlers_cmd
)
12617 /* Catch handling of exceptions. */
12618 *ex
= ada_catch_handlers
;
12619 *excep_string
= exception_name
;
12621 else if (exception_name
.empty ())
12623 /* Catch all exceptions. */
12624 *ex
= ada_catch_exception
;
12625 excep_string
->clear ();
12627 else if (exception_name
== "unhandled")
12629 /* Catch unhandled exceptions. */
12630 *ex
= ada_catch_exception_unhandled
;
12631 excep_string
->clear ();
12635 /* Catch a specific exception. */
12636 *ex
= ada_catch_exception
;
12637 *excep_string
= exception_name
;
12641 /* Return the name of the symbol on which we should break in order to
12642 implement a catchpoint of the EX kind. */
12644 static const char *
12645 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12647 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12649 gdb_assert (data
->exception_info
!= NULL
);
12653 case ada_catch_exception
:
12654 return (data
->exception_info
->catch_exception_sym
);
12656 case ada_catch_exception_unhandled
:
12657 return (data
->exception_info
->catch_exception_unhandled_sym
);
12659 case ada_catch_assert
:
12660 return (data
->exception_info
->catch_assert_sym
);
12662 case ada_catch_handlers
:
12663 return (data
->exception_info
->catch_handlers_sym
);
12666 internal_error (_("unexpected catchpoint kind (%d)"), ex
);
12670 /* Return the condition that will be used to match the current exception
12671 being raised with the exception that the user wants to catch. This
12672 assumes that this condition is used when the inferior just triggered
12673 an exception catchpoint.
12674 EX: the type of catchpoints used for catching Ada exceptions. */
12677 ada_exception_catchpoint_cond_string (const char *excep_string
,
12678 enum ada_exception_catchpoint_kind ex
)
12680 bool is_standard_exc
= false;
12681 std::string result
;
12683 if (ex
== ada_catch_handlers
)
12685 /* For exception handlers catchpoints, the condition string does
12686 not use the same parameter as for the other exceptions. */
12687 result
= ("long_integer (GNAT_GCC_exception_Access"
12688 "(gcc_exception).all.occurrence.id)");
12691 result
= "long_integer (e)";
12693 /* The standard exceptions are a special case. They are defined in
12694 runtime units that have been compiled without debugging info; if
12695 EXCEP_STRING is the not-fully-qualified name of a standard
12696 exception (e.g. "constraint_error") then, during the evaluation
12697 of the condition expression, the symbol lookup on this name would
12698 *not* return this standard exception. The catchpoint condition
12699 may then be set only on user-defined exceptions which have the
12700 same not-fully-qualified name (e.g. my_package.constraint_error).
12702 To avoid this unexcepted behavior, these standard exceptions are
12703 systematically prefixed by "standard". This means that "catch
12704 exception constraint_error" is rewritten into "catch exception
12705 standard.constraint_error".
12707 If an exception named constraint_error is defined in another package of
12708 the inferior program, then the only way to specify this exception as a
12709 breakpoint condition is to use its fully-qualified named:
12710 e.g. my_package.constraint_error. */
12712 for (const char *name
: standard_exc
)
12714 if (strcmp (name
, excep_string
) == 0)
12716 is_standard_exc
= true;
12723 if (is_standard_exc
)
12724 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12726 string_appendf (result
, "long_integer (&%s)", excep_string
);
12731 /* Return the symtab_and_line that should be used to insert an exception
12732 catchpoint of the TYPE kind.
12734 ADDR_STRING returns the name of the function where the real
12735 breakpoint that implements the catchpoints is set, depending on the
12736 type of catchpoint we need to create. */
12738 static struct symtab_and_line
12739 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12740 std::string
*addr_string
)
12742 const char *sym_name
;
12743 struct symbol
*sym
;
12745 /* First, find out which exception support info to use. */
12746 ada_exception_support_info_sniffer ();
12748 /* Then lookup the function on which we will break in order to catch
12749 the Ada exceptions requested by the user. */
12750 sym_name
= ada_exception_sym_name (ex
);
12751 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12754 error (_("Catchpoint symbol not found: %s"), sym_name
);
12756 if (sym
->aclass () != LOC_BLOCK
)
12757 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12759 /* Set ADDR_STRING. */
12760 *addr_string
= sym_name
;
12762 return find_function_start_sal (sym
, 1);
12765 /* Create an Ada exception catchpoint.
12767 EX_KIND is the kind of exception catchpoint to be created.
12769 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12770 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12771 of the exception to which this catchpoint applies.
12773 COND_STRING, if not empty, is the catchpoint condition.
12775 TEMPFLAG, if nonzero, means that the underlying breakpoint
12776 should be temporary.
12778 FROM_TTY is the usual argument passed to all commands implementations. */
12781 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12782 enum ada_exception_catchpoint_kind ex_kind
,
12783 const std::string
&excep_string
,
12784 const std::string
&cond_string
,
12789 std::string addr_string
;
12790 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
);
12792 std::unique_ptr
<ada_catchpoint
> c
12793 (new ada_catchpoint (gdbarch
, ex_kind
, sal
, addr_string
.c_str (),
12794 tempflag
, disabled
, from_tty
));
12795 c
->excep_string
= excep_string
;
12796 create_excep_cond_exprs (c
.get (), ex_kind
);
12797 if (!cond_string
.empty ())
12798 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
, false);
12799 install_breakpoint (0, std::move (c
), 1);
12802 /* Implement the "catch exception" command. */
12805 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12806 struct cmd_list_element
*command
)
12808 const char *arg
= arg_entry
;
12809 struct gdbarch
*gdbarch
= get_current_arch ();
12811 enum ada_exception_catchpoint_kind ex_kind
;
12812 std::string excep_string
;
12813 std::string cond_string
;
12815 tempflag
= command
->context () == CATCH_TEMPORARY
;
12819 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12821 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12822 excep_string
, cond_string
,
12823 tempflag
, 1 /* enabled */,
12827 /* Implement the "catch handlers" command. */
12830 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12831 struct cmd_list_element
*command
)
12833 const char *arg
= arg_entry
;
12834 struct gdbarch
*gdbarch
= get_current_arch ();
12836 enum ada_exception_catchpoint_kind ex_kind
;
12837 std::string excep_string
;
12838 std::string cond_string
;
12840 tempflag
= command
->context () == CATCH_TEMPORARY
;
12844 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12846 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12847 excep_string
, cond_string
,
12848 tempflag
, 1 /* enabled */,
12852 /* Completion function for the Ada "catch" commands. */
12855 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12856 const char *text
, const char *word
)
12858 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12860 for (const ada_exc_info
&info
: exceptions
)
12862 if (startswith (info
.name
, word
))
12863 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12867 /* Split the arguments specified in a "catch assert" command.
12869 ARGS contains the command's arguments (or the empty string if
12870 no arguments were passed).
12872 If ARGS contains a condition, set COND_STRING to that condition
12873 (the memory needs to be deallocated after use). */
12876 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12878 args
= skip_spaces (args
);
12880 /* Check whether a condition was provided. */
12881 if (startswith (args
, "if")
12882 && (isspace (args
[2]) || args
[2] == '\0'))
12885 args
= skip_spaces (args
);
12886 if (args
[0] == '\0')
12887 error (_("condition missing after `if' keyword"));
12888 cond_string
.assign (args
);
12891 /* Otherwise, there should be no other argument at the end of
12893 else if (args
[0] != '\0')
12894 error (_("Junk at end of arguments."));
12897 /* Implement the "catch assert" command. */
12900 catch_assert_command (const char *arg_entry
, int from_tty
,
12901 struct cmd_list_element
*command
)
12903 const char *arg
= arg_entry
;
12904 struct gdbarch
*gdbarch
= get_current_arch ();
12906 std::string cond_string
;
12908 tempflag
= command
->context () == CATCH_TEMPORARY
;
12912 catch_ada_assert_command_split (arg
, cond_string
);
12913 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12915 tempflag
, 1 /* enabled */,
12919 /* Return non-zero if the symbol SYM is an Ada exception object. */
12922 ada_is_exception_sym (struct symbol
*sym
)
12924 const char *type_name
= sym
->type ()->name ();
12926 return (sym
->aclass () != LOC_TYPEDEF
12927 && sym
->aclass () != LOC_BLOCK
12928 && sym
->aclass () != LOC_CONST
12929 && sym
->aclass () != LOC_UNRESOLVED
12930 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12933 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12934 Ada exception object. This matches all exceptions except the ones
12935 defined by the Ada language. */
12938 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12940 if (!ada_is_exception_sym (sym
))
12943 for (const char *name
: standard_exc
)
12944 if (strcmp (sym
->linkage_name (), name
) == 0)
12945 return 0; /* A standard exception. */
12947 /* Numeric_Error is also a standard exception, so exclude it.
12948 See the STANDARD_EXC description for more details as to why
12949 this exception is not listed in that array. */
12950 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12956 /* A helper function for std::sort, comparing two struct ada_exc_info
12959 The comparison is determined first by exception name, and then
12960 by exception address. */
12963 ada_exc_info::operator< (const ada_exc_info
&other
) const
12967 result
= strcmp (name
, other
.name
);
12970 if (result
== 0 && addr
< other
.addr
)
12976 ada_exc_info::operator== (const ada_exc_info
&other
) const
12978 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12981 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12982 routine, but keeping the first SKIP elements untouched.
12984 All duplicates are also removed. */
12987 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12990 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12991 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12992 exceptions
->end ());
12995 /* Add all exceptions defined by the Ada standard whose name match
12996 a regular expression.
12998 If PREG is not NULL, then this regexp_t object is used to
12999 perform the symbol name matching. Otherwise, no name-based
13000 filtering is performed.
13002 EXCEPTIONS is a vector of exceptions to which matching exceptions
13006 ada_add_standard_exceptions (compiled_regex
*preg
,
13007 std::vector
<ada_exc_info
> *exceptions
)
13009 for (const char *name
: standard_exc
)
13011 if (preg
== NULL
|| preg
->exec (name
, 0, NULL
, 0) == 0)
13013 symbol_name_match_type match_type
= name_match_type_from_name (name
);
13014 lookup_name_info
lookup_name (name
, match_type
);
13016 symbol_name_matcher_ftype
*match_name
13017 = ada_get_symbol_name_matcher (lookup_name
);
13019 /* Iterate over all objfiles irrespective of scope or linker
13020 namespaces so we get all exceptions anywhere in the
13022 for (objfile
*objfile
: current_program_space
->objfiles ())
13024 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13026 if (match_name (msymbol
->linkage_name (), lookup_name
,
13028 && msymbol
->type () != mst_solib_trampoline
)
13031 = {name
, msymbol
->value_address (objfile
)};
13033 exceptions
->push_back (info
);
13041 /* Add all Ada exceptions defined locally and accessible from the given
13044 If PREG is not NULL, then this regexp_t object is used to
13045 perform the symbol name matching. Otherwise, no name-based
13046 filtering is performed.
13048 EXCEPTIONS is a vector of exceptions to which matching exceptions
13052 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13053 frame_info_ptr frame
,
13054 std::vector
<ada_exc_info
> *exceptions
)
13056 const struct block
*block
= get_frame_block (frame
, 0);
13060 struct block_iterator iter
;
13061 struct symbol
*sym
;
13063 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13065 switch (sym
->aclass ())
13072 if (ada_is_exception_sym (sym
))
13074 struct ada_exc_info info
= {sym
->print_name (),
13075 sym
->value_address ()};
13077 exceptions
->push_back (info
);
13081 if (block
->function () != NULL
)
13083 block
= block
->superblock ();
13087 /* Return true if NAME matches PREG or if PREG is NULL. */
13090 name_matches_regex (const char *name
, compiled_regex
*preg
)
13092 return (preg
== NULL
13093 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13096 /* Add all exceptions defined globally whose name name match
13097 a regular expression, excluding standard exceptions.
13099 The reason we exclude standard exceptions is that they need
13100 to be handled separately: Standard exceptions are defined inside
13101 a runtime unit which is normally not compiled with debugging info,
13102 and thus usually do not show up in our symbol search. However,
13103 if the unit was in fact built with debugging info, we need to
13104 exclude them because they would duplicate the entry we found
13105 during the special loop that specifically searches for those
13106 standard exceptions.
13108 If PREG is not NULL, then this regexp_t object is used to
13109 perform the symbol name matching. Otherwise, no name-based
13110 filtering is performed.
13112 EXCEPTIONS is a vector of exceptions to which matching exceptions
13116 ada_add_global_exceptions (compiled_regex
*preg
,
13117 std::vector
<ada_exc_info
> *exceptions
)
13119 /* In Ada, the symbol "search name" is a linkage name, whereas the
13120 regular expression used to do the matching refers to the natural
13121 name. So match against the decoded name. */
13122 expand_symtabs_matching (NULL
,
13123 lookup_name_info::match_any (),
13124 [&] (const char *search_name
)
13126 std::string decoded
= ada_decode (search_name
);
13127 return name_matches_regex (decoded
.c_str (), preg
);
13130 SEARCH_GLOBAL_BLOCK
| SEARCH_STATIC_BLOCK
,
13133 /* Iterate over all objfiles irrespective of scope or linker namespaces
13134 so we get all exceptions anywhere in the progspace. */
13135 for (objfile
*objfile
: current_program_space
->objfiles ())
13137 for (compunit_symtab
*s
: objfile
->compunits ())
13139 const struct blockvector
*bv
= s
->blockvector ();
13142 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13144 const struct block
*b
= bv
->block (i
);
13145 struct block_iterator iter
;
13146 struct symbol
*sym
;
13148 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13149 if (ada_is_non_standard_exception_sym (sym
)
13150 && name_matches_regex (sym
->natural_name (), preg
))
13152 struct ada_exc_info info
13153 = {sym
->print_name (), sym
->value_address ()};
13155 exceptions
->push_back (info
);
13162 /* Implements ada_exceptions_list with the regular expression passed
13163 as a regex_t, rather than a string.
13165 If not NULL, PREG is used to filter out exceptions whose names
13166 do not match. Otherwise, all exceptions are listed. */
13168 static std::vector
<ada_exc_info
>
13169 ada_exceptions_list_1 (compiled_regex
*preg
)
13171 std::vector
<ada_exc_info
> result
;
13174 /* First, list the known standard exceptions. These exceptions
13175 need to be handled separately, as they are usually defined in
13176 runtime units that have been compiled without debugging info. */
13178 ada_add_standard_exceptions (preg
, &result
);
13180 /* Next, find all exceptions whose scope is local and accessible
13181 from the currently selected frame. */
13183 if (has_stack_frames ())
13185 prev_len
= result
.size ();
13186 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13188 if (result
.size () > prev_len
)
13189 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13192 /* Add all exceptions whose scope is global. */
13194 prev_len
= result
.size ();
13195 ada_add_global_exceptions (preg
, &result
);
13196 if (result
.size () > prev_len
)
13197 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13202 /* Return a vector of ada_exc_info.
13204 If REGEXP is NULL, all exceptions are included in the result.
13205 Otherwise, it should contain a valid regular expression,
13206 and only the exceptions whose names match that regular expression
13207 are included in the result.
13209 The exceptions are sorted in the following order:
13210 - Standard exceptions (defined by the Ada language), in
13211 alphabetical order;
13212 - Exceptions only visible from the current frame, in
13213 alphabetical order;
13214 - Exceptions whose scope is global, in alphabetical order. */
13216 std::vector
<ada_exc_info
>
13217 ada_exceptions_list (const char *regexp
)
13219 if (regexp
== NULL
)
13220 return ada_exceptions_list_1 (NULL
);
13222 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13223 return ada_exceptions_list_1 (®
);
13226 /* Implement the "info exceptions" command. */
13229 info_exceptions_command (const char *regexp
, int from_tty
)
13231 struct gdbarch
*gdbarch
= get_current_arch ();
13233 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13235 if (regexp
!= NULL
)
13237 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13239 gdb_printf (_("All defined Ada exceptions:\n"));
13241 for (const ada_exc_info
&info
: exceptions
)
13242 gdb_printf ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13246 /* Language vector */
13248 /* symbol_name_matcher_ftype adapter for wild_match. */
13251 do_wild_match (const char *symbol_search_name
,
13252 const lookup_name_info
&lookup_name
,
13253 completion_match_result
*comp_match_res
)
13255 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13258 /* symbol_name_matcher_ftype adapter for full_match. */
13261 do_full_match (const char *symbol_search_name
,
13262 const lookup_name_info
&lookup_name
,
13263 completion_match_result
*comp_match_res
)
13265 const char *lname
= lookup_name
.ada ().lookup_name ().c_str ();
13267 /* If both symbols start with "_ada_", just let the loop below
13268 handle the comparison. However, if only the symbol name starts
13269 with "_ada_", skip the prefix and let the match proceed as
13271 if (startswith (symbol_search_name
, "_ada_")
13272 && !startswith (lname
, "_ada"))
13273 symbol_search_name
+= 5;
13274 /* Likewise for ghost entities. */
13275 if (startswith (symbol_search_name
, "___ghost_")
13276 && !startswith (lname
, "___ghost_"))
13277 symbol_search_name
+= 9;
13279 int uscore_count
= 0;
13280 while (*lname
!= '\0')
13282 if (*symbol_search_name
!= *lname
)
13284 if (*symbol_search_name
== 'B' && uscore_count
== 2
13285 && symbol_search_name
[1] == '_')
13287 symbol_search_name
+= 2;
13288 while (isdigit (*symbol_search_name
))
13289 ++symbol_search_name
;
13290 if (symbol_search_name
[0] == '_'
13291 && symbol_search_name
[1] == '_')
13293 symbol_search_name
+= 2;
13300 if (*symbol_search_name
== '_')
13305 ++symbol_search_name
;
13309 return is_name_suffix (symbol_search_name
);
13312 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13315 do_exact_match (const char *symbol_search_name
,
13316 const lookup_name_info
&lookup_name
,
13317 completion_match_result
*comp_match_res
)
13319 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13322 /* Build the Ada lookup name for LOOKUP_NAME. */
13324 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13326 gdb::string_view user_name
= lookup_name
.name ();
13328 if (!user_name
.empty () && user_name
[0] == '<')
13330 if (user_name
.back () == '>')
13332 = gdb::to_string (user_name
.substr (1, user_name
.size () - 2));
13335 = gdb::to_string (user_name
.substr (1, user_name
.size () - 1));
13336 m_encoded_p
= true;
13337 m_verbatim_p
= true;
13338 m_wild_match_p
= false;
13339 m_standard_p
= false;
13343 m_verbatim_p
= false;
13345 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13349 const char *folded
= ada_fold_name (user_name
);
13350 m_encoded_name
= ada_encode_1 (folded
, false);
13351 if (m_encoded_name
.empty ())
13352 m_encoded_name
= gdb::to_string (user_name
);
13355 m_encoded_name
= gdb::to_string (user_name
);
13357 /* Handle the 'package Standard' special case. See description
13358 of m_standard_p. */
13359 if (startswith (m_encoded_name
.c_str (), "standard__"))
13361 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13362 m_standard_p
= true;
13365 m_standard_p
= false;
13367 /* If the name contains a ".", then the user is entering a fully
13368 qualified entity name, and the match must not be done in wild
13369 mode. Similarly, if the user wants to complete what looks
13370 like an encoded name, the match must not be done in wild
13371 mode. Also, in the standard__ special case always do
13372 non-wild matching. */
13374 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13377 && user_name
.find ('.') == std::string::npos
);
13381 /* symbol_name_matcher_ftype method for Ada. This only handles
13382 completion mode. */
13385 ada_symbol_name_matches (const char *symbol_search_name
,
13386 const lookup_name_info
&lookup_name
,
13387 completion_match_result
*comp_match_res
)
13389 return lookup_name
.ada ().matches (symbol_search_name
,
13390 lookup_name
.match_type (),
13394 /* A name matcher that matches the symbol name exactly, with
13398 literal_symbol_name_matcher (const char *symbol_search_name
,
13399 const lookup_name_info
&lookup_name
,
13400 completion_match_result
*comp_match_res
)
13402 gdb::string_view name_view
= lookup_name
.name ();
13404 if (lookup_name
.completion_mode ()
13405 ? (strncmp (symbol_search_name
, name_view
.data (),
13406 name_view
.size ()) == 0)
13407 : symbol_search_name
== name_view
)
13409 if (comp_match_res
!= NULL
)
13410 comp_match_res
->set_match (symbol_search_name
);
13417 /* Implement the "get_symbol_name_matcher" language_defn method for
13420 static symbol_name_matcher_ftype
*
13421 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13423 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13424 return literal_symbol_name_matcher
;
13426 if (lookup_name
.completion_mode ())
13427 return ada_symbol_name_matches
;
13430 if (lookup_name
.ada ().wild_match_p ())
13431 return do_wild_match
;
13432 else if (lookup_name
.ada ().verbatim_p ())
13433 return do_exact_match
;
13435 return do_full_match
;
13439 /* Class representing the Ada language. */
13441 class ada_language
: public language_defn
13445 : language_defn (language_ada
)
13448 /* See language.h. */
13450 const char *name () const override
13453 /* See language.h. */
13455 const char *natural_name () const override
13458 /* See language.h. */
13460 const std::vector
<const char *> &filename_extensions () const override
13462 static const std::vector
<const char *> extensions
13463 = { ".adb", ".ads", ".a", ".ada", ".dg" };
13467 /* Print an array element index using the Ada syntax. */
13469 void print_array_index (struct type
*index_type
,
13471 struct ui_file
*stream
,
13472 const value_print_options
*options
) const override
13474 struct value
*index_value
= val_atr (index_type
, index
);
13476 value_print (index_value
, stream
, options
);
13477 gdb_printf (stream
, " => ");
13480 /* Implement the "read_var_value" language_defn method for Ada. */
13482 struct value
*read_var_value (struct symbol
*var
,
13483 const struct block
*var_block
,
13484 frame_info_ptr frame
) const override
13486 /* The only case where default_read_var_value is not sufficient
13487 is when VAR is a renaming... */
13488 if (frame
!= nullptr)
13490 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13491 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13492 return ada_read_renaming_var_value (var
, frame_block
);
13495 /* This is a typical case where we expect the default_read_var_value
13496 function to work. */
13497 return language_defn::read_var_value (var
, var_block
, frame
);
13500 /* See language.h. */
13501 bool symbol_printing_suppressed (struct symbol
*symbol
) const override
13503 return symbol
->is_artificial ();
13506 /* See language.h. */
13507 void language_arch_info (struct gdbarch
*gdbarch
,
13508 struct language_arch_info
*lai
) const override
13510 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13512 /* Helper function to allow shorter lines below. */
13513 auto add
= [&] (struct type
*t
)
13515 lai
->add_primitive_type (t
);
13518 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13520 add (arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13521 0, "long_integer"));
13522 add (arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13523 0, "short_integer"));
13524 struct type
*char_type
= arch_character_type (gdbarch
, TARGET_CHAR_BIT
,
13526 lai
->set_string_char_type (char_type
);
13528 add (arch_character_type (gdbarch
, 16, 1, "wide_character"));
13529 add (arch_character_type (gdbarch
, 32, 1, "wide_wide_character"));
13530 add (arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13531 "float", gdbarch_float_format (gdbarch
)));
13532 add (arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13533 "long_float", gdbarch_double_format (gdbarch
)));
13534 add (arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13535 0, "long_long_integer"));
13536 add (arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13538 gdbarch_long_double_format (gdbarch
)));
13539 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13541 add (arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13543 add (builtin
->builtin_void
);
13545 struct type
*system_addr_ptr
13546 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13548 system_addr_ptr
->set_name ("system__address");
13549 add (system_addr_ptr
);
13551 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13552 type. This is a signed integral type whose size is the same as
13553 the size of addresses. */
13554 unsigned int addr_length
= system_addr_ptr
->length ();
13555 add (arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13556 "storage_offset"));
13558 lai
->set_bool_type (builtin
->builtin_bool
);
13561 /* See language.h. */
13563 bool iterate_over_symbols
13564 (const struct block
*block
, const lookup_name_info
&name
,
13565 domain_enum domain
,
13566 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13568 std::vector
<struct block_symbol
> results
13569 = ada_lookup_symbol_list_worker (name
, block
, domain
, 0);
13570 for (block_symbol
&sym
: results
)
13572 if (!callback (&sym
))
13579 /* See language.h. */
13580 bool sniff_from_mangled_name
13581 (const char *mangled
,
13582 gdb::unique_xmalloc_ptr
<char> *out
) const override
13584 std::string demangled
= ada_decode (mangled
);
13588 if (demangled
!= mangled
&& demangled
[0] != '<')
13590 /* Set the gsymbol language to Ada, but still return 0.
13591 Two reasons for that:
13593 1. For Ada, we prefer computing the symbol's decoded name
13594 on the fly rather than pre-compute it, in order to save
13595 memory (Ada projects are typically very large).
13597 2. There are some areas in the definition of the GNAT
13598 encoding where, with a bit of bad luck, we might be able
13599 to decode a non-Ada symbol, generating an incorrect
13600 demangled name (Eg: names ending with "TB" for instance
13601 are identified as task bodies and so stripped from
13602 the decoded name returned).
13604 Returning true, here, but not setting *DEMANGLED, helps us get
13605 a little bit of the best of both worlds. Because we're last,
13606 we should not affect any of the other languages that were
13607 able to demangle the symbol before us; we get to correctly
13608 tag Ada symbols as such; and even if we incorrectly tagged a
13609 non-Ada symbol, which should be rare, any routing through the
13610 Ada language should be transparent (Ada tries to behave much
13611 like C/C++ with non-Ada symbols). */
13618 /* See language.h. */
13620 gdb::unique_xmalloc_ptr
<char> demangle_symbol (const char *mangled
,
13621 int options
) const override
13623 return make_unique_xstrdup (ada_decode (mangled
).c_str ());
13626 /* See language.h. */
13628 void print_type (struct type
*type
, const char *varstring
,
13629 struct ui_file
*stream
, int show
, int level
,
13630 const struct type_print_options
*flags
) const override
13632 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13635 /* See language.h. */
13637 const char *word_break_characters (void) const override
13639 return ada_completer_word_break_characters
;
13642 /* See language.h. */
13644 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13645 complete_symbol_mode mode
,
13646 symbol_name_match_type name_match_type
,
13647 const char *text
, const char *word
,
13648 enum type_code code
) const override
13650 struct symbol
*sym
;
13651 const struct block
*b
, *surrounding_static_block
= 0;
13652 struct block_iterator iter
;
13654 gdb_assert (code
== TYPE_CODE_UNDEF
);
13656 lookup_name_info
lookup_name (text
, name_match_type
, true);
13658 /* First, look at the partial symtab symbols. */
13659 expand_symtabs_matching (NULL
,
13663 SEARCH_GLOBAL_BLOCK
| SEARCH_STATIC_BLOCK
,
13666 /* At this point scan through the misc symbol vectors and add each
13667 symbol you find to the list. Eventually we want to ignore
13668 anything that isn't a text symbol (everything else will be
13669 handled by the psymtab code above). */
13671 for (objfile
*objfile
: current_program_space
->objfiles ())
13673 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13677 if (completion_skip_symbol (mode
, msymbol
))
13680 language symbol_language
= msymbol
->language ();
13682 /* Ada minimal symbols won't have their language set to Ada. If
13683 we let completion_list_add_name compare using the
13684 default/C-like matcher, then when completing e.g., symbols in a
13685 package named "pck", we'd match internal Ada symbols like
13686 "pckS", which are invalid in an Ada expression, unless you wrap
13687 them in '<' '>' to request a verbatim match.
13689 Unfortunately, some Ada encoded names successfully demangle as
13690 C++ symbols (using an old mangling scheme), such as "name__2Xn"
13691 -> "Xn::name(void)" and thus some Ada minimal symbols end up
13692 with the wrong language set. Paper over that issue here. */
13693 if (symbol_language
== language_auto
13694 || symbol_language
== language_cplus
)
13695 symbol_language
= language_ada
;
13697 completion_list_add_name (tracker
,
13699 msymbol
->linkage_name (),
13700 lookup_name
, text
, word
);
13704 /* Search upwards from currently selected frame (so that we can
13705 complete on local vars. */
13707 for (b
= get_selected_block (0); b
!= NULL
; b
= b
->superblock ())
13709 if (!b
->superblock ())
13710 surrounding_static_block
= b
; /* For elmin of dups */
13712 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13714 if (completion_skip_symbol (mode
, sym
))
13717 completion_list_add_name (tracker
,
13719 sym
->linkage_name (),
13720 lookup_name
, text
, word
);
13724 /* Go through the symtabs and check the externs and statics for
13725 symbols which match. */
13727 for (objfile
*objfile
: current_program_space
->objfiles ())
13729 for (compunit_symtab
*s
: objfile
->compunits ())
13732 b
= s
->blockvector ()->global_block ();
13733 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13735 if (completion_skip_symbol (mode
, sym
))
13738 completion_list_add_name (tracker
,
13740 sym
->linkage_name (),
13741 lookup_name
, text
, word
);
13746 for (objfile
*objfile
: current_program_space
->objfiles ())
13748 for (compunit_symtab
*s
: objfile
->compunits ())
13751 b
= s
->blockvector ()->static_block ();
13752 /* Don't do this block twice. */
13753 if (b
== surrounding_static_block
)
13755 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13757 if (completion_skip_symbol (mode
, sym
))
13760 completion_list_add_name (tracker
,
13762 sym
->linkage_name (),
13763 lookup_name
, text
, word
);
13769 /* See language.h. */
13771 gdb::unique_xmalloc_ptr
<char> watch_location_expression
13772 (struct type
*type
, CORE_ADDR addr
) const override
13774 type
= check_typedef (check_typedef (type
)->target_type ());
13775 std::string name
= type_to_string (type
);
13776 return xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
));
13779 /* See language.h. */
13781 void value_print (struct value
*val
, struct ui_file
*stream
,
13782 const struct value_print_options
*options
) const override
13784 return ada_value_print (val
, stream
, options
);
13787 /* See language.h. */
13789 void value_print_inner
13790 (struct value
*val
, struct ui_file
*stream
, int recurse
,
13791 const struct value_print_options
*options
) const override
13793 return ada_value_print_inner (val
, stream
, recurse
, options
);
13796 /* See language.h. */
13798 struct block_symbol lookup_symbol_nonlocal
13799 (const char *name
, const struct block
*block
,
13800 const domain_enum domain
) const override
13802 struct block_symbol sym
;
13804 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
13805 if (sym
.symbol
!= NULL
)
13808 /* If we haven't found a match at this point, try the primitive
13809 types. In other languages, this search is performed before
13810 searching for global symbols in order to short-circuit that
13811 global-symbol search if it happens that the name corresponds
13812 to a primitive type. But we cannot do the same in Ada, because
13813 it is perfectly legitimate for a program to declare a type which
13814 has the same name as a standard type. If looking up a type in
13815 that situation, we have traditionally ignored the primitive type
13816 in favor of user-defined types. This is why, unlike most other
13817 languages, we search the primitive types this late and only after
13818 having searched the global symbols without success. */
13820 if (domain
== VAR_DOMAIN
)
13822 struct gdbarch
*gdbarch
;
13825 gdbarch
= target_gdbarch ();
13827 gdbarch
= block_gdbarch (block
);
13829 = language_lookup_primitive_type_as_symbol (this, gdbarch
, name
);
13830 if (sym
.symbol
!= NULL
)
13837 /* See language.h. */
13839 int parser (struct parser_state
*ps
) const override
13841 warnings_issued
= 0;
13842 return ada_parse (ps
);
13845 /* See language.h. */
13847 void emitchar (int ch
, struct type
*chtype
,
13848 struct ui_file
*stream
, int quoter
) const override
13850 ada_emit_char (ch
, chtype
, stream
, quoter
, 1);
13853 /* See language.h. */
13855 void printchar (int ch
, struct type
*chtype
,
13856 struct ui_file
*stream
) const override
13858 ada_printchar (ch
, chtype
, stream
);
13861 /* See language.h. */
13863 void printstr (struct ui_file
*stream
, struct type
*elttype
,
13864 const gdb_byte
*string
, unsigned int length
,
13865 const char *encoding
, int force_ellipses
,
13866 const struct value_print_options
*options
) const override
13868 ada_printstr (stream
, elttype
, string
, length
, encoding
,
13869 force_ellipses
, options
);
13872 /* See language.h. */
13874 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
13875 struct ui_file
*stream
) const override
13877 ada_print_typedef (type
, new_symbol
, stream
);
13880 /* See language.h. */
13882 bool is_string_type_p (struct type
*type
) const override
13884 return ada_is_string_type (type
);
13887 /* See language.h. */
13889 const char *struct_too_deep_ellipsis () const override
13890 { return "(...)"; }
13892 /* See language.h. */
13894 bool c_style_arrays_p () const override
13897 /* See language.h. */
13899 bool store_sym_names_in_linkage_form_p () const override
13902 /* See language.h. */
13904 const struct lang_varobj_ops
*varobj_ops () const override
13905 { return &ada_varobj_ops
; }
13908 /* See language.h. */
13910 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
13911 (const lookup_name_info
&lookup_name
) const override
13913 return ada_get_symbol_name_matcher (lookup_name
);
13917 /* Single instance of the Ada language class. */
13919 static ada_language ada_language_defn
;
13921 /* Command-list for the "set/show ada" prefix command. */
13922 static struct cmd_list_element
*set_ada_list
;
13923 static struct cmd_list_element
*show_ada_list
;
13925 /* This module's 'new_objfile' observer. */
13928 ada_new_objfile_observer (struct objfile
*objfile
)
13930 ada_clear_symbol_cache ();
13933 /* This module's 'free_objfile' observer. */
13936 ada_free_objfile_observer (struct objfile
*objfile
)
13938 ada_clear_symbol_cache ();
13941 /* Charsets known to GNAT. */
13942 static const char * const gnat_source_charsets
[] =
13944 /* Note that code below assumes that the default comes first.
13945 Latin-1 is the default here, because that is also GNAT's
13955 /* Note that this value is special-cased in the encoder and
13961 void _initialize_ada_language ();
13963 _initialize_ada_language ()
13965 add_setshow_prefix_cmd
13967 _("Prefix command for changing Ada-specific settings."),
13968 _("Generic command for showing Ada-specific settings."),
13969 &set_ada_list
, &show_ada_list
,
13970 &setlist
, &showlist
);
13972 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
13973 &trust_pad_over_xvs
, _("\
13974 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13975 Show whether an optimization trusting PAD types over XVS types is activated."),
13977 This is related to the encoding used by the GNAT compiler. The debugger\n\
13978 should normally trust the contents of PAD types, but certain older versions\n\
13979 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13980 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13981 work around this bug. It is always safe to turn this option \"off\", but\n\
13982 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13983 this option to \"off\" unless necessary."),
13984 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
13986 add_setshow_boolean_cmd ("print-signatures", class_vars
,
13987 &print_signatures
, _("\
13988 Enable or disable the output of formal and return types for functions in the \
13989 overloads selection menu."), _("\
13990 Show whether the output of formal and return types for functions in the \
13991 overloads selection menu is activated."),
13992 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
13994 ada_source_charset
= gnat_source_charsets
[0];
13995 add_setshow_enum_cmd ("source-charset", class_files
,
13996 gnat_source_charsets
,
13997 &ada_source_charset
, _("\
13998 Set the Ada source character set."), _("\
13999 Show the Ada source character set."), _("\
14000 The character set used for Ada source files.\n\
14001 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14003 &set_ada_list
, &show_ada_list
);
14005 add_catch_command ("exception", _("\
14006 Catch Ada exceptions, when raised.\n\
14007 Usage: catch exception [ARG] [if CONDITION]\n\
14008 Without any argument, stop when any Ada exception is raised.\n\
14009 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14010 being raised does not have a handler (and will therefore lead to the task's\n\
14012 Otherwise, the catchpoint only stops when the name of the exception being\n\
14013 raised is the same as ARG.\n\
14014 CONDITION is a boolean expression that is evaluated to see whether the\n\
14015 exception should cause a stop."),
14016 catch_ada_exception_command
,
14017 catch_ada_completer
,
14021 add_catch_command ("handlers", _("\
14022 Catch Ada exceptions, when handled.\n\
14023 Usage: catch handlers [ARG] [if CONDITION]\n\
14024 Without any argument, stop when any Ada exception is handled.\n\
14025 With an argument, catch only exceptions with the given name.\n\
14026 CONDITION is a boolean expression that is evaluated to see whether the\n\
14027 exception should cause a stop."),
14028 catch_ada_handlers_command
,
14029 catch_ada_completer
,
14032 add_catch_command ("assert", _("\
14033 Catch failed Ada assertions, when raised.\n\
14034 Usage: catch assert [if CONDITION]\n\
14035 CONDITION is a boolean expression that is evaluated to see whether the\n\
14036 exception should cause a stop."),
14037 catch_assert_command
,
14042 add_info ("exceptions", info_exceptions_command
,
14044 List all Ada exception names.\n\
14045 Usage: info exceptions [REGEXP]\n\
14046 If a regular expression is passed as an argument, only those matching\n\
14047 the regular expression are listed."));
14049 add_setshow_prefix_cmd ("ada", class_maintenance
,
14050 _("Set Ada maintenance-related variables."),
14051 _("Show Ada maintenance-related variables."),
14052 &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
,
14053 &maintenance_set_cmdlist
, &maintenance_show_cmdlist
);
14055 add_setshow_boolean_cmd
14056 ("ignore-descriptive-types", class_maintenance
,
14057 &ada_ignore_descriptive_types_p
,
14058 _("Set whether descriptive types generated by GNAT should be ignored."),
14059 _("Show whether descriptive types generated by GNAT should be ignored."),
14061 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14062 DWARF attribute."),
14063 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14065 decoded_names_store
= htab_create_alloc (256, htab_hash_string
,
14067 NULL
, xcalloc
, xfree
);
14069 /* The ada-lang observers. */
14070 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
, "ada-lang");
14071 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
, "ada-lang");
14072 gdb::observers::inferior_exit
.attach (ada_inferior_exit
, "ada-lang");