1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2020 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 #include "gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdb_obstack.h"
40 #include "completer.h"
47 #include "observable.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 static struct type
*desc_base_type (struct type
*);
71 static struct type
*desc_bounds_type (struct type
*);
73 static struct value
*desc_bounds (struct value
*);
75 static int fat_pntr_bounds_bitpos (struct type
*);
77 static int fat_pntr_bounds_bitsize (struct type
*);
79 static struct type
*desc_data_target_type (struct type
*);
81 static struct value
*desc_data (struct value
*);
83 static int fat_pntr_data_bitpos (struct type
*);
85 static int fat_pntr_data_bitsize (struct type
*);
87 static struct value
*desc_one_bound (struct value
*, int, int);
89 static int desc_bound_bitpos (struct type
*, int, int);
91 static int desc_bound_bitsize (struct type
*, int, int);
93 static struct type
*desc_index_type (struct type
*, int);
95 static int desc_arity (struct type
*);
97 static int ada_type_match (struct type
*, struct type
*, int);
99 static int ada_args_match (struct symbol
*, struct value
**, int);
101 static struct value
*make_array_descriptor (struct type
*, struct value
*);
103 static void ada_add_block_symbols (struct obstack
*,
104 const struct block
*,
105 const lookup_name_info
&lookup_name
,
106 domain_enum
, struct objfile
*);
108 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
109 const lookup_name_info
&lookup_name
,
110 domain_enum
, int, int *);
112 static int is_nonfunction (struct block_symbol
*, int);
114 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
115 const struct block
*);
117 static int num_defns_collected (struct obstack
*);
119 static struct block_symbol
*defns_collected (struct obstack
*, int);
121 static struct value
*resolve_subexp (expression_up
*, int *, int,
123 innermost_block_tracker
*);
125 static void replace_operator_with_call (expression_up
*, int, int, int,
126 struct symbol
*, const struct block
*);
128 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
130 static const char *ada_op_name (enum exp_opcode
);
132 static const char *ada_decoded_op_name (enum exp_opcode
);
134 static int numeric_type_p (struct type
*);
136 static int integer_type_p (struct type
*);
138 static int scalar_type_p (struct type
*);
140 static int discrete_type_p (struct type
*);
142 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
145 static struct value
*evaluate_subexp_type (struct expression
*, int *);
147 static struct type
*ada_find_parallel_type_with_name (struct type
*,
150 static int is_dynamic_field (struct type
*, int);
152 static struct type
*to_fixed_variant_branch_type (struct type
*,
154 CORE_ADDR
, struct value
*);
156 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
158 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
160 static struct type
*to_static_fixed_type (struct type
*);
161 static struct type
*static_unwrap_type (struct type
*type
);
163 static struct value
*unwrap_value (struct value
*);
165 static struct type
*constrained_packed_array_type (struct type
*, long *);
167 static struct type
*decode_constrained_packed_array_type (struct type
*);
169 static long decode_packed_array_bitsize (struct type
*);
171 static struct value
*decode_constrained_packed_array (struct value
*);
173 static int ada_is_packed_array_type (struct type
*);
175 static int ada_is_unconstrained_packed_array_type (struct type
*);
177 static struct value
*value_subscript_packed (struct value
*, int,
180 static struct value
*coerce_unspec_val_to_type (struct value
*,
183 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
185 static int equiv_types (struct type
*, struct type
*);
187 static int is_name_suffix (const char *);
189 static int advance_wild_match (const char **, const char *, int);
191 static bool wild_match (const char *name
, const char *patn
);
193 static struct value
*ada_coerce_ref (struct value
*);
195 static LONGEST
pos_atr (struct value
*);
197 static struct value
*value_pos_atr (struct type
*, struct value
*);
199 static struct value
*val_atr (struct type
*, LONGEST
);
201 static struct value
*value_val_atr (struct type
*, struct value
*);
203 static struct symbol
*standard_lookup (const char *, const struct block
*,
206 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
209 static int find_struct_field (const char *, struct type
*, int,
210 struct type
**, int *, int *, int *, int *);
212 static int ada_resolve_function (struct block_symbol
*, int,
213 struct value
**, int, const char *,
216 static int ada_is_direct_array_type (struct type
*);
218 static struct value
*ada_index_struct_field (int, struct value
*, int,
221 static struct value
*assign_aggregate (struct value
*, struct value
*,
225 static void aggregate_assign_from_choices (struct value
*, struct value
*,
227 int *, LONGEST
*, int *,
228 int, LONGEST
, LONGEST
);
230 static void aggregate_assign_positional (struct value
*, struct value
*,
232 int *, LONGEST
*, int *, int,
236 static void aggregate_assign_others (struct value
*, struct value
*,
238 int *, LONGEST
*, int, LONGEST
, LONGEST
);
241 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
244 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
247 static void ada_forward_operator_length (struct expression
*, int, int *,
250 static struct type
*ada_find_any_type (const char *name
);
252 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
253 (const lookup_name_info
&lookup_name
);
257 /* The result of a symbol lookup to be stored in our symbol cache. */
261 /* The name used to perform the lookup. */
263 /* The namespace used during the lookup. */
265 /* The symbol returned by the lookup, or NULL if no matching symbol
268 /* The block where the symbol was found, or NULL if no matching
270 const struct block
*block
;
271 /* A pointer to the next entry with the same hash. */
272 struct cache_entry
*next
;
275 /* The Ada symbol cache, used to store the result of Ada-mode symbol
276 lookups in the course of executing the user's commands.
278 The cache is implemented using a simple, fixed-sized hash.
279 The size is fixed on the grounds that there are not likely to be
280 all that many symbols looked up during any given session, regardless
281 of the size of the symbol table. If we decide to go to a resizable
282 table, let's just use the stuff from libiberty instead. */
284 #define HASH_SIZE 1009
286 struct ada_symbol_cache
288 /* An obstack used to store the entries in our cache. */
289 struct obstack cache_space
;
291 /* The root of the hash table used to implement our symbol cache. */
292 struct cache_entry
*root
[HASH_SIZE
];
295 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
297 /* Maximum-sized dynamic type. */
298 static unsigned int varsize_limit
;
300 static const char ada_completer_word_break_characters
[] =
302 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
304 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
307 /* The name of the symbol to use to get the name of the main subprogram. */
308 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
309 = "__gnat_ada_main_program_name";
311 /* Limit on the number of warnings to raise per expression evaluation. */
312 static int warning_limit
= 2;
314 /* Number of warning messages issued; reset to 0 by cleanups after
315 expression evaluation. */
316 static int warnings_issued
= 0;
318 static const char *known_runtime_file_name_patterns
[] = {
319 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
322 static const char *known_auxiliary_function_name_patterns
[] = {
323 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
326 /* Maintenance-related settings for this module. */
328 static struct cmd_list_element
*maint_set_ada_cmdlist
;
329 static struct cmd_list_element
*maint_show_ada_cmdlist
;
331 /* The "maintenance ada set/show ignore-descriptive-type" value. */
333 static bool ada_ignore_descriptive_types_p
= false;
335 /* Inferior-specific data. */
337 /* Per-inferior data for this module. */
339 struct ada_inferior_data
341 /* The ada__tags__type_specific_data type, which is used when decoding
342 tagged types. With older versions of GNAT, this type was directly
343 accessible through a component ("tsd") in the object tag. But this
344 is no longer the case, so we cache it for each inferior. */
345 struct type
*tsd_type
= nullptr;
347 /* The exception_support_info data. This data is used to determine
348 how to implement support for Ada exception catchpoints in a given
350 const struct exception_support_info
*exception_info
= nullptr;
353 /* Our key to this module's inferior data. */
354 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
356 /* Return our inferior data for the given inferior (INF).
358 This function always returns a valid pointer to an allocated
359 ada_inferior_data structure. If INF's inferior data has not
360 been previously set, this functions creates a new one with all
361 fields set to zero, sets INF's inferior to it, and then returns
362 a pointer to that newly allocated ada_inferior_data. */
364 static struct ada_inferior_data
*
365 get_ada_inferior_data (struct inferior
*inf
)
367 struct ada_inferior_data
*data
;
369 data
= ada_inferior_data
.get (inf
);
371 data
= ada_inferior_data
.emplace (inf
);
376 /* Perform all necessary cleanups regarding our module's inferior data
377 that is required after the inferior INF just exited. */
380 ada_inferior_exit (struct inferior
*inf
)
382 ada_inferior_data
.clear (inf
);
386 /* program-space-specific data. */
388 /* This module's per-program-space data. */
389 struct ada_pspace_data
393 if (sym_cache
!= NULL
)
394 ada_free_symbol_cache (sym_cache
);
397 /* The Ada symbol cache. */
398 struct ada_symbol_cache
*sym_cache
= nullptr;
401 /* Key to our per-program-space data. */
402 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
404 /* Return this module's data for the given program space (PSPACE).
405 If not is found, add a zero'ed one now.
407 This function always returns a valid object. */
409 static struct ada_pspace_data
*
410 get_ada_pspace_data (struct program_space
*pspace
)
412 struct ada_pspace_data
*data
;
414 data
= ada_pspace_data_handle
.get (pspace
);
416 data
= ada_pspace_data_handle
.emplace (pspace
);
423 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
424 all typedef layers have been peeled. Otherwise, return TYPE.
426 Normally, we really expect a typedef type to only have 1 typedef layer.
427 In other words, we really expect the target type of a typedef type to be
428 a non-typedef type. This is particularly true for Ada units, because
429 the language does not have a typedef vs not-typedef distinction.
430 In that respect, the Ada compiler has been trying to eliminate as many
431 typedef definitions in the debugging information, since they generally
432 do not bring any extra information (we still use typedef under certain
433 circumstances related mostly to the GNAT encoding).
435 Unfortunately, we have seen situations where the debugging information
436 generated by the compiler leads to such multiple typedef layers. For
437 instance, consider the following example with stabs:
439 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
440 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
442 This is an error in the debugging information which causes type
443 pck__float_array___XUP to be defined twice, and the second time,
444 it is defined as a typedef of a typedef.
446 This is on the fringe of legality as far as debugging information is
447 concerned, and certainly unexpected. But it is easy to handle these
448 situations correctly, so we can afford to be lenient in this case. */
451 ada_typedef_target_type (struct type
*type
)
453 while (type
->code () == TYPE_CODE_TYPEDEF
)
454 type
= TYPE_TARGET_TYPE (type
);
458 /* Given DECODED_NAME a string holding a symbol name in its
459 decoded form (ie using the Ada dotted notation), returns
460 its unqualified name. */
463 ada_unqualified_name (const char *decoded_name
)
467 /* If the decoded name starts with '<', it means that the encoded
468 name does not follow standard naming conventions, and thus that
469 it is not your typical Ada symbol name. Trying to unqualify it
470 is therefore pointless and possibly erroneous. */
471 if (decoded_name
[0] == '<')
474 result
= strrchr (decoded_name
, '.');
476 result
++; /* Skip the dot... */
478 result
= decoded_name
;
483 /* Return a string starting with '<', followed by STR, and '>'. */
486 add_angle_brackets (const char *str
)
488 return string_printf ("<%s>", str
);
492 ada_get_gdb_completer_word_break_characters (void)
494 return ada_completer_word_break_characters
;
497 /* la_watch_location_expression for Ada. */
499 static gdb::unique_xmalloc_ptr
<char>
500 ada_watch_location_expression (struct type
*type
, CORE_ADDR addr
)
502 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
503 std::string name
= type_to_string (type
);
504 return gdb::unique_xmalloc_ptr
<char>
505 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
508 /* Assuming V points to an array of S objects, make sure that it contains at
509 least M objects, updating V and S as necessary. */
511 #define GROW_VECT(v, s, m) \
512 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
514 /* Assuming VECT points to an array of *SIZE objects of size
515 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
516 updating *SIZE as necessary and returning the (new) array. */
519 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
521 if (*size
< min_size
)
524 if (*size
< min_size
)
526 vect
= xrealloc (vect
, *size
* element_size
);
531 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
532 suffix of FIELD_NAME beginning "___". */
535 field_name_match (const char *field_name
, const char *target
)
537 int len
= strlen (target
);
540 (strncmp (field_name
, target
, len
) == 0
541 && (field_name
[len
] == '\0'
542 || (startswith (field_name
+ len
, "___")
543 && strcmp (field_name
+ strlen (field_name
) - 6,
548 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
549 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
550 and return its index. This function also handles fields whose name
551 have ___ suffixes because the compiler sometimes alters their name
552 by adding such a suffix to represent fields with certain constraints.
553 If the field could not be found, return a negative number if
554 MAYBE_MISSING is set. Otherwise raise an error. */
557 ada_get_field_index (const struct type
*type
, const char *field_name
,
561 struct type
*struct_type
= check_typedef ((struct type
*) type
);
563 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
564 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
568 error (_("Unable to find field %s in struct %s. Aborting"),
569 field_name
, struct_type
->name ());
574 /* The length of the prefix of NAME prior to any "___" suffix. */
577 ada_name_prefix_len (const char *name
)
583 const char *p
= strstr (name
, "___");
586 return strlen (name
);
592 /* Return non-zero if SUFFIX is a suffix of STR.
593 Return zero if STR is null. */
596 is_suffix (const char *str
, const char *suffix
)
603 len2
= strlen (suffix
);
604 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
607 /* The contents of value VAL, treated as a value of type TYPE. The
608 result is an lval in memory if VAL is. */
610 static struct value
*
611 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
613 type
= ada_check_typedef (type
);
614 if (value_type (val
) == type
)
618 struct value
*result
;
620 /* Make sure that the object size is not unreasonable before
621 trying to allocate some memory for it. */
622 ada_ensure_varsize_limit (type
);
625 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
626 result
= allocate_value_lazy (type
);
629 result
= allocate_value (type
);
630 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
632 set_value_component_location (result
, val
);
633 set_value_bitsize (result
, value_bitsize (val
));
634 set_value_bitpos (result
, value_bitpos (val
));
635 if (VALUE_LVAL (result
) == lval_memory
)
636 set_value_address (result
, value_address (val
));
641 static const gdb_byte
*
642 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
647 return valaddr
+ offset
;
651 cond_offset_target (CORE_ADDR address
, long offset
)
656 return address
+ offset
;
659 /* Issue a warning (as for the definition of warning in utils.c, but
660 with exactly one argument rather than ...), unless the limit on the
661 number of warnings has passed during the evaluation of the current
664 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
665 provided by "complaint". */
666 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
669 lim_warning (const char *format
, ...)
673 va_start (args
, format
);
674 warnings_issued
+= 1;
675 if (warnings_issued
<= warning_limit
)
676 vwarning (format
, args
);
681 /* Issue an error if the size of an object of type T is unreasonable,
682 i.e. if it would be a bad idea to allocate a value of this type in
686 ada_ensure_varsize_limit (const struct type
*type
)
688 if (TYPE_LENGTH (type
) > varsize_limit
)
689 error (_("object size is larger than varsize-limit"));
692 /* Maximum value of a SIZE-byte signed integer type. */
694 max_of_size (int size
)
696 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
698 return top_bit
| (top_bit
- 1);
701 /* Minimum value of a SIZE-byte signed integer type. */
703 min_of_size (int size
)
705 return -max_of_size (size
) - 1;
708 /* Maximum value of a SIZE-byte unsigned integer type. */
710 umax_of_size (int size
)
712 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
714 return top_bit
| (top_bit
- 1);
717 /* Maximum value of integral type T, as a signed quantity. */
719 max_of_type (struct type
*t
)
721 if (TYPE_UNSIGNED (t
))
722 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
724 return max_of_size (TYPE_LENGTH (t
));
727 /* Minimum value of integral type T, as a signed quantity. */
729 min_of_type (struct type
*t
)
731 if (TYPE_UNSIGNED (t
))
734 return min_of_size (TYPE_LENGTH (t
));
737 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
739 ada_discrete_type_high_bound (struct type
*type
)
741 type
= resolve_dynamic_type (type
, {}, 0);
742 switch (type
->code ())
744 case TYPE_CODE_RANGE
:
745 return TYPE_HIGH_BOUND (type
);
747 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
752 return max_of_type (type
);
754 error (_("Unexpected type in ada_discrete_type_high_bound."));
758 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
760 ada_discrete_type_low_bound (struct type
*type
)
762 type
= resolve_dynamic_type (type
, {}, 0);
763 switch (type
->code ())
765 case TYPE_CODE_RANGE
:
766 return TYPE_LOW_BOUND (type
);
768 return TYPE_FIELD_ENUMVAL (type
, 0);
773 return min_of_type (type
);
775 error (_("Unexpected type in ada_discrete_type_low_bound."));
779 /* The identity on non-range types. For range types, the underlying
780 non-range scalar type. */
783 get_base_type (struct type
*type
)
785 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
787 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
789 type
= TYPE_TARGET_TYPE (type
);
794 /* Return a decoded version of the given VALUE. This means returning
795 a value whose type is obtained by applying all the GNAT-specific
796 encodings, making the resulting type a static but standard description
797 of the initial type. */
800 ada_get_decoded_value (struct value
*value
)
802 struct type
*type
= ada_check_typedef (value_type (value
));
804 if (ada_is_array_descriptor_type (type
)
805 || (ada_is_constrained_packed_array_type (type
)
806 && type
->code () != TYPE_CODE_PTR
))
808 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
809 value
= ada_coerce_to_simple_array_ptr (value
);
811 value
= ada_coerce_to_simple_array (value
);
814 value
= ada_to_fixed_value (value
);
819 /* Same as ada_get_decoded_value, but with the given TYPE.
820 Because there is no associated actual value for this type,
821 the resulting type might be a best-effort approximation in
822 the case of dynamic types. */
825 ada_get_decoded_type (struct type
*type
)
827 type
= to_static_fixed_type (type
);
828 if (ada_is_constrained_packed_array_type (type
))
829 type
= ada_coerce_to_simple_array_type (type
);
835 /* Language Selection */
837 /* If the main program is in Ada, return language_ada, otherwise return LANG
838 (the main program is in Ada iif the adainit symbol is found). */
841 ada_update_initial_language (enum language lang
)
843 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
849 /* If the main procedure is written in Ada, then return its name.
850 The result is good until the next call. Return NULL if the main
851 procedure doesn't appear to be in Ada. */
856 struct bound_minimal_symbol msym
;
857 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
859 /* For Ada, the name of the main procedure is stored in a specific
860 string constant, generated by the binder. Look for that symbol,
861 extract its address, and then read that string. If we didn't find
862 that string, then most probably the main procedure is not written
864 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
866 if (msym
.minsym
!= NULL
)
868 CORE_ADDR main_program_name_addr
;
871 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
872 if (main_program_name_addr
== 0)
873 error (_("Invalid address for Ada main program name."));
875 target_read_string (main_program_name_addr
, &main_program_name
,
880 return main_program_name
.get ();
883 /* The main procedure doesn't seem to be in Ada. */
889 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
892 const struct ada_opname_map ada_opname_table
[] = {
893 {"Oadd", "\"+\"", BINOP_ADD
},
894 {"Osubtract", "\"-\"", BINOP_SUB
},
895 {"Omultiply", "\"*\"", BINOP_MUL
},
896 {"Odivide", "\"/\"", BINOP_DIV
},
897 {"Omod", "\"mod\"", BINOP_MOD
},
898 {"Orem", "\"rem\"", BINOP_REM
},
899 {"Oexpon", "\"**\"", BINOP_EXP
},
900 {"Olt", "\"<\"", BINOP_LESS
},
901 {"Ole", "\"<=\"", BINOP_LEQ
},
902 {"Ogt", "\">\"", BINOP_GTR
},
903 {"Oge", "\">=\"", BINOP_GEQ
},
904 {"Oeq", "\"=\"", BINOP_EQUAL
},
905 {"One", "\"/=\"", BINOP_NOTEQUAL
},
906 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
907 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
908 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
909 {"Oconcat", "\"&\"", BINOP_CONCAT
},
910 {"Oabs", "\"abs\"", UNOP_ABS
},
911 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
912 {"Oadd", "\"+\"", UNOP_PLUS
},
913 {"Osubtract", "\"-\"", UNOP_NEG
},
917 /* The "encoded" form of DECODED, according to GNAT conventions. The
918 result is valid until the next call to ada_encode. If
919 THROW_ERRORS, throw an error if invalid operator name is found.
920 Otherwise, return NULL in that case. */
923 ada_encode_1 (const char *decoded
, bool throw_errors
)
925 static char *encoding_buffer
= NULL
;
926 static size_t encoding_buffer_size
= 0;
933 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
934 2 * strlen (decoded
) + 10);
937 for (p
= decoded
; *p
!= '\0'; p
+= 1)
941 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
946 const struct ada_opname_map
*mapping
;
948 for (mapping
= ada_opname_table
;
949 mapping
->encoded
!= NULL
950 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
952 if (mapping
->encoded
== NULL
)
955 error (_("invalid Ada operator name: %s"), p
);
959 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
960 k
+= strlen (mapping
->encoded
);
965 encoding_buffer
[k
] = *p
;
970 encoding_buffer
[k
] = '\0';
971 return encoding_buffer
;
974 /* The "encoded" form of DECODED, according to GNAT conventions.
975 The result is valid until the next call to ada_encode. */
978 ada_encode (const char *decoded
)
980 return ada_encode_1 (decoded
, true);
983 /* Return NAME folded to lower case, or, if surrounded by single
984 quotes, unfolded, but with the quotes stripped away. Result good
988 ada_fold_name (gdb::string_view name
)
990 static char *fold_buffer
= NULL
;
991 static size_t fold_buffer_size
= 0;
993 int len
= name
.size ();
994 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
998 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
999 fold_buffer
[len
- 2] = '\000';
1005 for (i
= 0; i
<= len
; i
+= 1)
1006 fold_buffer
[i
] = tolower (name
[i
]);
1012 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1015 is_lower_alphanum (const char c
)
1017 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1020 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1021 This function saves in LEN the length of that same symbol name but
1022 without either of these suffixes:
1028 These are suffixes introduced by the compiler for entities such as
1029 nested subprogram for instance, in order to avoid name clashes.
1030 They do not serve any purpose for the debugger. */
1033 ada_remove_trailing_digits (const char *encoded
, int *len
)
1035 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1039 while (i
> 0 && isdigit (encoded
[i
]))
1041 if (i
>= 0 && encoded
[i
] == '.')
1043 else if (i
>= 0 && encoded
[i
] == '$')
1045 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1047 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1052 /* Remove the suffix introduced by the compiler for protected object
1056 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1058 /* Remove trailing N. */
1060 /* Protected entry subprograms are broken into two
1061 separate subprograms: The first one is unprotected, and has
1062 a 'N' suffix; the second is the protected version, and has
1063 the 'P' suffix. The second calls the first one after handling
1064 the protection. Since the P subprograms are internally generated,
1065 we leave these names undecoded, giving the user a clue that this
1066 entity is internal. */
1069 && encoded
[*len
- 1] == 'N'
1070 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1074 /* If ENCODED follows the GNAT entity encoding conventions, then return
1075 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1076 replaced by ENCODED. */
1079 ada_decode (const char *encoded
)
1085 std::string decoded
;
1087 /* With function descriptors on PPC64, the value of a symbol named
1088 ".FN", if it exists, is the entry point of the function "FN". */
1089 if (encoded
[0] == '.')
1092 /* The name of the Ada main procedure starts with "_ada_".
1093 This prefix is not part of the decoded name, so skip this part
1094 if we see this prefix. */
1095 if (startswith (encoded
, "_ada_"))
1098 /* If the name starts with '_', then it is not a properly encoded
1099 name, so do not attempt to decode it. Similarly, if the name
1100 starts with '<', the name should not be decoded. */
1101 if (encoded
[0] == '_' || encoded
[0] == '<')
1104 len0
= strlen (encoded
);
1106 ada_remove_trailing_digits (encoded
, &len0
);
1107 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1109 /* Remove the ___X.* suffix if present. Do not forget to verify that
1110 the suffix is located before the current "end" of ENCODED. We want
1111 to avoid re-matching parts of ENCODED that have previously been
1112 marked as discarded (by decrementing LEN0). */
1113 p
= strstr (encoded
, "___");
1114 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1122 /* Remove any trailing TKB suffix. It tells us that this symbol
1123 is for the body of a task, but that information does not actually
1124 appear in the decoded name. */
1126 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1129 /* Remove any trailing TB suffix. The TB suffix is slightly different
1130 from the TKB suffix because it is used for non-anonymous task
1133 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1136 /* Remove trailing "B" suffixes. */
1137 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1139 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1142 /* Make decoded big enough for possible expansion by operator name. */
1144 decoded
.resize (2 * len0
+ 1, 'X');
1146 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1148 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1151 while ((i
>= 0 && isdigit (encoded
[i
]))
1152 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1154 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1156 else if (encoded
[i
] == '$')
1160 /* The first few characters that are not alphabetic are not part
1161 of any encoding we use, so we can copy them over verbatim. */
1163 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1164 decoded
[j
] = encoded
[i
];
1169 /* Is this a symbol function? */
1170 if (at_start_name
&& encoded
[i
] == 'O')
1174 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1176 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1177 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1179 && !isalnum (encoded
[i
+ op_len
]))
1181 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1184 j
+= strlen (ada_opname_table
[k
].decoded
);
1188 if (ada_opname_table
[k
].encoded
!= NULL
)
1193 /* Replace "TK__" with "__", which will eventually be translated
1194 into "." (just below). */
1196 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1199 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1200 be translated into "." (just below). These are internal names
1201 generated for anonymous blocks inside which our symbol is nested. */
1203 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1204 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1205 && isdigit (encoded
[i
+4]))
1209 while (k
< len0
&& isdigit (encoded
[k
]))
1210 k
++; /* Skip any extra digit. */
1212 /* Double-check that the "__B_{DIGITS}+" sequence we found
1213 is indeed followed by "__". */
1214 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1218 /* Remove _E{DIGITS}+[sb] */
1220 /* Just as for protected object subprograms, there are 2 categories
1221 of subprograms created by the compiler for each entry. The first
1222 one implements the actual entry code, and has a suffix following
1223 the convention above; the second one implements the barrier and
1224 uses the same convention as above, except that the 'E' is replaced
1227 Just as above, we do not decode the name of barrier functions
1228 to give the user a clue that the code he is debugging has been
1229 internally generated. */
1231 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1232 && isdigit (encoded
[i
+2]))
1236 while (k
< len0
&& isdigit (encoded
[k
]))
1240 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1243 /* Just as an extra precaution, make sure that if this
1244 suffix is followed by anything else, it is a '_'.
1245 Otherwise, we matched this sequence by accident. */
1247 || (k
< len0
&& encoded
[k
] == '_'))
1252 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1253 the GNAT front-end in protected object subprograms. */
1256 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1258 /* Backtrack a bit up until we reach either the begining of
1259 the encoded name, or "__". Make sure that we only find
1260 digits or lowercase characters. */
1261 const char *ptr
= encoded
+ i
- 1;
1263 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1266 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1270 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1272 /* This is a X[bn]* sequence not separated from the previous
1273 part of the name with a non-alpha-numeric character (in other
1274 words, immediately following an alpha-numeric character), then
1275 verify that it is placed at the end of the encoded name. If
1276 not, then the encoding is not valid and we should abort the
1277 decoding. Otherwise, just skip it, it is used in body-nested
1281 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1285 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1287 /* Replace '__' by '.'. */
1295 /* It's a character part of the decoded name, so just copy it
1297 decoded
[j
] = encoded
[i
];
1304 /* Decoded names should never contain any uppercase character.
1305 Double-check this, and abort the decoding if we find one. */
1307 for (i
= 0; i
< decoded
.length(); ++i
)
1308 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1314 if (encoded
[0] == '<')
1317 decoded
= '<' + std::string(encoded
) + '>';
1322 /* Table for keeping permanent unique copies of decoded names. Once
1323 allocated, names in this table are never released. While this is a
1324 storage leak, it should not be significant unless there are massive
1325 changes in the set of decoded names in successive versions of a
1326 symbol table loaded during a single session. */
1327 static struct htab
*decoded_names_store
;
1329 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1330 in the language-specific part of GSYMBOL, if it has not been
1331 previously computed. Tries to save the decoded name in the same
1332 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1333 in any case, the decoded symbol has a lifetime at least that of
1335 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1336 const, but nevertheless modified to a semantically equivalent form
1337 when a decoded name is cached in it. */
1340 ada_decode_symbol (const struct general_symbol_info
*arg
)
1342 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1343 const char **resultp
=
1344 &gsymbol
->language_specific
.demangled_name
;
1346 if (!gsymbol
->ada_mangled
)
1348 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1349 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1351 gsymbol
->ada_mangled
= 1;
1353 if (obstack
!= NULL
)
1354 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1357 /* Sometimes, we can't find a corresponding objfile, in
1358 which case, we put the result on the heap. Since we only
1359 decode when needed, we hope this usually does not cause a
1360 significant memory leak (FIXME). */
1362 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1363 decoded
.c_str (), INSERT
);
1366 *slot
= xstrdup (decoded
.c_str ());
1375 ada_la_decode (const char *encoded
, int options
)
1377 return xstrdup (ada_decode (encoded
).c_str ());
1380 /* Implement la_sniff_from_mangled_name for Ada. */
1383 ada_sniff_from_mangled_name (const char *mangled
, char **out
)
1385 std::string demangled
= ada_decode (mangled
);
1389 if (demangled
!= mangled
&& demangled
[0] != '<')
1391 /* Set the gsymbol language to Ada, but still return 0.
1392 Two reasons for that:
1394 1. For Ada, we prefer computing the symbol's decoded name
1395 on the fly rather than pre-compute it, in order to save
1396 memory (Ada projects are typically very large).
1398 2. There are some areas in the definition of the GNAT
1399 encoding where, with a bit of bad luck, we might be able
1400 to decode a non-Ada symbol, generating an incorrect
1401 demangled name (Eg: names ending with "TB" for instance
1402 are identified as task bodies and so stripped from
1403 the decoded name returned).
1405 Returning 1, here, but not setting *DEMANGLED, helps us get a
1406 little bit of the best of both worlds. Because we're last,
1407 we should not affect any of the other languages that were
1408 able to demangle the symbol before us; we get to correctly
1409 tag Ada symbols as such; and even if we incorrectly tagged a
1410 non-Ada symbol, which should be rare, any routing through the
1411 Ada language should be transparent (Ada tries to behave much
1412 like C/C++ with non-Ada symbols). */
1423 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1424 generated by the GNAT compiler to describe the index type used
1425 for each dimension of an array, check whether it follows the latest
1426 known encoding. If not, fix it up to conform to the latest encoding.
1427 Otherwise, do nothing. This function also does nothing if
1428 INDEX_DESC_TYPE is NULL.
1430 The GNAT encoding used to describe the array index type evolved a bit.
1431 Initially, the information would be provided through the name of each
1432 field of the structure type only, while the type of these fields was
1433 described as unspecified and irrelevant. The debugger was then expected
1434 to perform a global type lookup using the name of that field in order
1435 to get access to the full index type description. Because these global
1436 lookups can be very expensive, the encoding was later enhanced to make
1437 the global lookup unnecessary by defining the field type as being
1438 the full index type description.
1440 The purpose of this routine is to allow us to support older versions
1441 of the compiler by detecting the use of the older encoding, and by
1442 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1443 we essentially replace each field's meaningless type by the associated
1447 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1451 if (index_desc_type
== NULL
)
1453 gdb_assert (index_desc_type
->num_fields () > 0);
1455 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1456 to check one field only, no need to check them all). If not, return
1459 If our INDEX_DESC_TYPE was generated using the older encoding,
1460 the field type should be a meaningless integer type whose name
1461 is not equal to the field name. */
1462 if (TYPE_FIELD_TYPE (index_desc_type
, 0)->name () != NULL
1463 && strcmp (TYPE_FIELD_TYPE (index_desc_type
, 0)->name (),
1464 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1467 /* Fixup each field of INDEX_DESC_TYPE. */
1468 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1470 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1471 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1474 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1478 /* The desc_* routines return primitive portions of array descriptors
1481 /* The descriptor or array type, if any, indicated by TYPE; removes
1482 level of indirection, if needed. */
1484 static struct type
*
1485 desc_base_type (struct type
*type
)
1489 type
= ada_check_typedef (type
);
1490 if (type
->code () == TYPE_CODE_TYPEDEF
)
1491 type
= ada_typedef_target_type (type
);
1494 && (type
->code () == TYPE_CODE_PTR
1495 || type
->code () == TYPE_CODE_REF
))
1496 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1501 /* True iff TYPE indicates a "thin" array pointer type. */
1504 is_thin_pntr (struct type
*type
)
1507 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1508 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1511 /* The descriptor type for thin pointer type TYPE. */
1513 static struct type
*
1514 thin_descriptor_type (struct type
*type
)
1516 struct type
*base_type
= desc_base_type (type
);
1518 if (base_type
== NULL
)
1520 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1524 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1526 if (alt_type
== NULL
)
1533 /* A pointer to the array data for thin-pointer value VAL. */
1535 static struct value
*
1536 thin_data_pntr (struct value
*val
)
1538 struct type
*type
= ada_check_typedef (value_type (val
));
1539 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1541 data_type
= lookup_pointer_type (data_type
);
1543 if (type
->code () == TYPE_CODE_PTR
)
1544 return value_cast (data_type
, value_copy (val
));
1546 return value_from_longest (data_type
, value_address (val
));
1549 /* True iff TYPE indicates a "thick" array pointer type. */
1552 is_thick_pntr (struct type
*type
)
1554 type
= desc_base_type (type
);
1555 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1556 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1559 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1560 pointer to one, the type of its bounds data; otherwise, NULL. */
1562 static struct type
*
1563 desc_bounds_type (struct type
*type
)
1567 type
= desc_base_type (type
);
1571 else if (is_thin_pntr (type
))
1573 type
= thin_descriptor_type (type
);
1576 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1578 return ada_check_typedef (r
);
1580 else if (type
->code () == TYPE_CODE_STRUCT
)
1582 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1584 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1589 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1590 one, a pointer to its bounds data. Otherwise NULL. */
1592 static struct value
*
1593 desc_bounds (struct value
*arr
)
1595 struct type
*type
= ada_check_typedef (value_type (arr
));
1597 if (is_thin_pntr (type
))
1599 struct type
*bounds_type
=
1600 desc_bounds_type (thin_descriptor_type (type
));
1603 if (bounds_type
== NULL
)
1604 error (_("Bad GNAT array descriptor"));
1606 /* NOTE: The following calculation is not really kosher, but
1607 since desc_type is an XVE-encoded type (and shouldn't be),
1608 the correct calculation is a real pain. FIXME (and fix GCC). */
1609 if (type
->code () == TYPE_CODE_PTR
)
1610 addr
= value_as_long (arr
);
1612 addr
= value_address (arr
);
1615 value_from_longest (lookup_pointer_type (bounds_type
),
1616 addr
- TYPE_LENGTH (bounds_type
));
1619 else if (is_thick_pntr (type
))
1621 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1622 _("Bad GNAT array descriptor"));
1623 struct type
*p_bounds_type
= value_type (p_bounds
);
1626 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1628 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1630 if (TYPE_STUB (target_type
))
1631 p_bounds
= value_cast (lookup_pointer_type
1632 (ada_check_typedef (target_type
)),
1636 error (_("Bad GNAT array descriptor"));
1644 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1645 position of the field containing the address of the bounds data. */
1648 fat_pntr_bounds_bitpos (struct type
*type
)
1650 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1653 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1654 size of the field containing the address of the bounds data. */
1657 fat_pntr_bounds_bitsize (struct type
*type
)
1659 type
= desc_base_type (type
);
1661 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1662 return TYPE_FIELD_BITSIZE (type
, 1);
1664 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1667 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1668 pointer to one, the type of its array data (a array-with-no-bounds type);
1669 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1672 static struct type
*
1673 desc_data_target_type (struct type
*type
)
1675 type
= desc_base_type (type
);
1677 /* NOTE: The following is bogus; see comment in desc_bounds. */
1678 if (is_thin_pntr (type
))
1679 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1680 else if (is_thick_pntr (type
))
1682 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1685 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1686 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1692 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1695 static struct value
*
1696 desc_data (struct value
*arr
)
1698 struct type
*type
= value_type (arr
);
1700 if (is_thin_pntr (type
))
1701 return thin_data_pntr (arr
);
1702 else if (is_thick_pntr (type
))
1703 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1704 _("Bad GNAT array descriptor"));
1710 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1711 position of the field containing the address of the data. */
1714 fat_pntr_data_bitpos (struct type
*type
)
1716 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1719 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1720 size of the field containing the address of the data. */
1723 fat_pntr_data_bitsize (struct type
*type
)
1725 type
= desc_base_type (type
);
1727 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1728 return TYPE_FIELD_BITSIZE (type
, 0);
1730 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1733 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1734 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1735 bound, if WHICH is 1. The first bound is I=1. */
1737 static struct value
*
1738 desc_one_bound (struct value
*bounds
, int i
, int which
)
1740 char bound_name
[20];
1741 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1742 which
? 'U' : 'L', i
- 1);
1743 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1744 _("Bad GNAT array descriptor bounds"));
1747 /* If BOUNDS is an array-bounds structure type, return the bit position
1748 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1749 bound, if WHICH is 1. The first bound is I=1. */
1752 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1754 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1757 /* If BOUNDS is an array-bounds structure type, return the bit field size
1758 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1759 bound, if WHICH is 1. The first bound is I=1. */
1762 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1764 type
= desc_base_type (type
);
1766 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1767 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1769 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1772 /* If TYPE is the type of an array-bounds structure, the type of its
1773 Ith bound (numbering from 1). Otherwise, NULL. */
1775 static struct type
*
1776 desc_index_type (struct type
*type
, int i
)
1778 type
= desc_base_type (type
);
1780 if (type
->code () == TYPE_CODE_STRUCT
)
1782 char bound_name
[20];
1783 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1784 return lookup_struct_elt_type (type
, bound_name
, 1);
1790 /* The number of index positions in the array-bounds type TYPE.
1791 Return 0 if TYPE is NULL. */
1794 desc_arity (struct type
*type
)
1796 type
= desc_base_type (type
);
1799 return type
->num_fields () / 2;
1803 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1804 an array descriptor type (representing an unconstrained array
1808 ada_is_direct_array_type (struct type
*type
)
1812 type
= ada_check_typedef (type
);
1813 return (type
->code () == TYPE_CODE_ARRAY
1814 || ada_is_array_descriptor_type (type
));
1817 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1821 ada_is_array_type (struct type
*type
)
1824 && (type
->code () == TYPE_CODE_PTR
1825 || type
->code () == TYPE_CODE_REF
))
1826 type
= TYPE_TARGET_TYPE (type
);
1827 return ada_is_direct_array_type (type
);
1830 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1833 ada_is_simple_array_type (struct type
*type
)
1837 type
= ada_check_typedef (type
);
1838 return (type
->code () == TYPE_CODE_ARRAY
1839 || (type
->code () == TYPE_CODE_PTR
1840 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1841 == TYPE_CODE_ARRAY
)));
1844 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1847 ada_is_array_descriptor_type (struct type
*type
)
1849 struct type
*data_type
= desc_data_target_type (type
);
1853 type
= ada_check_typedef (type
);
1854 return (data_type
!= NULL
1855 && data_type
->code () == TYPE_CODE_ARRAY
1856 && desc_arity (desc_bounds_type (type
)) > 0);
1859 /* Non-zero iff type is a partially mal-formed GNAT array
1860 descriptor. FIXME: This is to compensate for some problems with
1861 debugging output from GNAT. Re-examine periodically to see if it
1865 ada_is_bogus_array_descriptor (struct type
*type
)
1869 && type
->code () == TYPE_CODE_STRUCT
1870 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1871 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1872 && !ada_is_array_descriptor_type (type
);
1876 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1877 (fat pointer) returns the type of the array data described---specifically,
1878 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1879 in from the descriptor; otherwise, they are left unspecified. If
1880 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1881 returns NULL. The result is simply the type of ARR if ARR is not
1884 static struct type
*
1885 ada_type_of_array (struct value
*arr
, int bounds
)
1887 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1888 return decode_constrained_packed_array_type (value_type (arr
));
1890 if (!ada_is_array_descriptor_type (value_type (arr
)))
1891 return value_type (arr
);
1895 struct type
*array_type
=
1896 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1898 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1899 TYPE_FIELD_BITSIZE (array_type
, 0) =
1900 decode_packed_array_bitsize (value_type (arr
));
1906 struct type
*elt_type
;
1908 struct value
*descriptor
;
1910 elt_type
= ada_array_element_type (value_type (arr
), -1);
1911 arity
= ada_array_arity (value_type (arr
));
1913 if (elt_type
== NULL
|| arity
== 0)
1914 return ada_check_typedef (value_type (arr
));
1916 descriptor
= desc_bounds (arr
);
1917 if (value_as_long (descriptor
) == 0)
1921 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1922 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1923 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1924 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1927 create_static_range_type (range_type
, value_type (low
),
1928 longest_to_int (value_as_long (low
)),
1929 longest_to_int (value_as_long (high
)));
1930 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1932 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1934 /* We need to store the element packed bitsize, as well as
1935 recompute the array size, because it was previously
1936 computed based on the unpacked element size. */
1937 LONGEST lo
= value_as_long (low
);
1938 LONGEST hi
= value_as_long (high
);
1940 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1941 decode_packed_array_bitsize (value_type (arr
));
1942 /* If the array has no element, then the size is already
1943 zero, and does not need to be recomputed. */
1947 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1949 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1954 return lookup_pointer_type (elt_type
);
1958 /* If ARR does not represent an array, returns ARR unchanged.
1959 Otherwise, returns either a standard GDB array with bounds set
1960 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1961 GDB array. Returns NULL if ARR is a null fat pointer. */
1964 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1966 if (ada_is_array_descriptor_type (value_type (arr
)))
1968 struct type
*arrType
= ada_type_of_array (arr
, 1);
1970 if (arrType
== NULL
)
1972 return value_cast (arrType
, value_copy (desc_data (arr
)));
1974 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1975 return decode_constrained_packed_array (arr
);
1980 /* If ARR does not represent an array, returns ARR unchanged.
1981 Otherwise, returns a standard GDB array describing ARR (which may
1982 be ARR itself if it already is in the proper form). */
1985 ada_coerce_to_simple_array (struct value
*arr
)
1987 if (ada_is_array_descriptor_type (value_type (arr
)))
1989 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1992 error (_("Bounds unavailable for null array pointer."));
1993 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1994 return value_ind (arrVal
);
1996 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1997 return decode_constrained_packed_array (arr
);
2002 /* If TYPE represents a GNAT array type, return it translated to an
2003 ordinary GDB array type (possibly with BITSIZE fields indicating
2004 packing). For other types, is the identity. */
2007 ada_coerce_to_simple_array_type (struct type
*type
)
2009 if (ada_is_constrained_packed_array_type (type
))
2010 return decode_constrained_packed_array_type (type
);
2012 if (ada_is_array_descriptor_type (type
))
2013 return ada_check_typedef (desc_data_target_type (type
));
2018 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2021 ada_is_packed_array_type (struct type
*type
)
2025 type
= desc_base_type (type
);
2026 type
= ada_check_typedef (type
);
2028 ada_type_name (type
) != NULL
2029 && strstr (ada_type_name (type
), "___XP") != NULL
;
2032 /* Non-zero iff TYPE represents a standard GNAT constrained
2033 packed-array type. */
2036 ada_is_constrained_packed_array_type (struct type
*type
)
2038 return ada_is_packed_array_type (type
)
2039 && !ada_is_array_descriptor_type (type
);
2042 /* Non-zero iff TYPE represents an array descriptor for a
2043 unconstrained packed-array type. */
2046 ada_is_unconstrained_packed_array_type (struct type
*type
)
2048 return ada_is_packed_array_type (type
)
2049 && ada_is_array_descriptor_type (type
);
2052 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2053 return the size of its elements in bits. */
2056 decode_packed_array_bitsize (struct type
*type
)
2058 const char *raw_name
;
2062 /* Access to arrays implemented as fat pointers are encoded as a typedef
2063 of the fat pointer type. We need the name of the fat pointer type
2064 to do the decoding, so strip the typedef layer. */
2065 if (type
->code () == TYPE_CODE_TYPEDEF
)
2066 type
= ada_typedef_target_type (type
);
2068 raw_name
= ada_type_name (ada_check_typedef (type
));
2070 raw_name
= ada_type_name (desc_base_type (type
));
2075 tail
= strstr (raw_name
, "___XP");
2076 gdb_assert (tail
!= NULL
);
2078 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2081 (_("could not understand bit size information on packed array"));
2088 /* Given that TYPE is a standard GDB array type with all bounds filled
2089 in, and that the element size of its ultimate scalar constituents
2090 (that is, either its elements, or, if it is an array of arrays, its
2091 elements' elements, etc.) is *ELT_BITS, return an identical type,
2092 but with the bit sizes of its elements (and those of any
2093 constituent arrays) recorded in the BITSIZE components of its
2094 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2097 Note that, for arrays whose index type has an XA encoding where
2098 a bound references a record discriminant, getting that discriminant,
2099 and therefore the actual value of that bound, is not possible
2100 because none of the given parameters gives us access to the record.
2101 This function assumes that it is OK in the context where it is being
2102 used to return an array whose bounds are still dynamic and where
2103 the length is arbitrary. */
2105 static struct type
*
2106 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2108 struct type
*new_elt_type
;
2109 struct type
*new_type
;
2110 struct type
*index_type_desc
;
2111 struct type
*index_type
;
2112 LONGEST low_bound
, high_bound
;
2114 type
= ada_check_typedef (type
);
2115 if (type
->code () != TYPE_CODE_ARRAY
)
2118 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2119 if (index_type_desc
)
2120 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2123 index_type
= TYPE_INDEX_TYPE (type
);
2125 new_type
= alloc_type_copy (type
);
2127 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2129 create_array_type (new_type
, new_elt_type
, index_type
);
2130 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2131 new_type
->set_name (ada_type_name (type
));
2133 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2134 && is_dynamic_type (check_typedef (index_type
)))
2135 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2136 low_bound
= high_bound
= 0;
2137 if (high_bound
< low_bound
)
2138 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2141 *elt_bits
*= (high_bound
- low_bound
+ 1);
2142 TYPE_LENGTH (new_type
) =
2143 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2146 TYPE_FIXED_INSTANCE (new_type
) = 1;
2150 /* The array type encoded by TYPE, where
2151 ada_is_constrained_packed_array_type (TYPE). */
2153 static struct type
*
2154 decode_constrained_packed_array_type (struct type
*type
)
2156 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2159 struct type
*shadow_type
;
2163 raw_name
= ada_type_name (desc_base_type (type
));
2168 name
= (char *) alloca (strlen (raw_name
) + 1);
2169 tail
= strstr (raw_name
, "___XP");
2170 type
= desc_base_type (type
);
2172 memcpy (name
, raw_name
, tail
- raw_name
);
2173 name
[tail
- raw_name
] = '\000';
2175 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2177 if (shadow_type
== NULL
)
2179 lim_warning (_("could not find bounds information on packed array"));
2182 shadow_type
= check_typedef (shadow_type
);
2184 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2186 lim_warning (_("could not understand bounds "
2187 "information on packed array"));
2191 bits
= decode_packed_array_bitsize (type
);
2192 return constrained_packed_array_type (shadow_type
, &bits
);
2195 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2196 array, returns a simple array that denotes that array. Its type is a
2197 standard GDB array type except that the BITSIZEs of the array
2198 target types are set to the number of bits in each element, and the
2199 type length is set appropriately. */
2201 static struct value
*
2202 decode_constrained_packed_array (struct value
*arr
)
2206 /* If our value is a pointer, then dereference it. Likewise if
2207 the value is a reference. Make sure that this operation does not
2208 cause the target type to be fixed, as this would indirectly cause
2209 this array to be decoded. The rest of the routine assumes that
2210 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2211 and "value_ind" routines to perform the dereferencing, as opposed
2212 to using "ada_coerce_ref" or "ada_value_ind". */
2213 arr
= coerce_ref (arr
);
2214 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2215 arr
= value_ind (arr
);
2217 type
= decode_constrained_packed_array_type (value_type (arr
));
2220 error (_("can't unpack array"));
2224 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2225 && ada_is_modular_type (value_type (arr
)))
2227 /* This is a (right-justified) modular type representing a packed
2228 array with no wrapper. In order to interpret the value through
2229 the (left-justified) packed array type we just built, we must
2230 first left-justify it. */
2231 int bit_size
, bit_pos
;
2234 mod
= ada_modulus (value_type (arr
)) - 1;
2241 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2242 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2243 bit_pos
/ HOST_CHAR_BIT
,
2244 bit_pos
% HOST_CHAR_BIT
,
2249 return coerce_unspec_val_to_type (arr
, type
);
2253 /* The value of the element of packed array ARR at the ARITY indices
2254 given in IND. ARR must be a simple array. */
2256 static struct value
*
2257 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2260 int bits
, elt_off
, bit_off
;
2261 long elt_total_bit_offset
;
2262 struct type
*elt_type
;
2266 elt_total_bit_offset
= 0;
2267 elt_type
= ada_check_typedef (value_type (arr
));
2268 for (i
= 0; i
< arity
; i
+= 1)
2270 if (elt_type
->code () != TYPE_CODE_ARRAY
2271 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2273 (_("attempt to do packed indexing of "
2274 "something other than a packed array"));
2277 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2278 LONGEST lowerbound
, upperbound
;
2281 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2283 lim_warning (_("don't know bounds of array"));
2284 lowerbound
= upperbound
= 0;
2287 idx
= pos_atr (ind
[i
]);
2288 if (idx
< lowerbound
|| idx
> upperbound
)
2289 lim_warning (_("packed array index %ld out of bounds"),
2291 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2292 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2293 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2296 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2297 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2299 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2304 /* Non-zero iff TYPE includes negative integer values. */
2307 has_negatives (struct type
*type
)
2309 switch (type
->code ())
2314 return !TYPE_UNSIGNED (type
);
2315 case TYPE_CODE_RANGE
:
2316 return TYPE_LOW_BOUND (type
) - TYPE_RANGE_DATA (type
)->bias
< 0;
2320 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2321 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2322 the unpacked buffer.
2324 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2325 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2327 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2330 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2332 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2335 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2336 gdb_byte
*unpacked
, int unpacked_len
,
2337 int is_big_endian
, int is_signed_type
,
2340 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2341 int src_idx
; /* Index into the source area */
2342 int src_bytes_left
; /* Number of source bytes left to process. */
2343 int srcBitsLeft
; /* Number of source bits left to move */
2344 int unusedLS
; /* Number of bits in next significant
2345 byte of source that are unused */
2347 int unpacked_idx
; /* Index into the unpacked buffer */
2348 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2350 unsigned long accum
; /* Staging area for bits being transferred */
2351 int accumSize
; /* Number of meaningful bits in accum */
2354 /* Transmit bytes from least to most significant; delta is the direction
2355 the indices move. */
2356 int delta
= is_big_endian
? -1 : 1;
2358 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2360 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2361 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2362 bit_size
, unpacked_len
);
2364 srcBitsLeft
= bit_size
;
2365 src_bytes_left
= src_len
;
2366 unpacked_bytes_left
= unpacked_len
;
2371 src_idx
= src_len
- 1;
2373 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2377 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2383 unpacked_idx
= unpacked_len
- 1;
2387 /* Non-scalar values must be aligned at a byte boundary... */
2389 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2390 /* ... And are placed at the beginning (most-significant) bytes
2392 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2393 unpacked_bytes_left
= unpacked_idx
+ 1;
2398 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2400 src_idx
= unpacked_idx
= 0;
2401 unusedLS
= bit_offset
;
2404 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2409 while (src_bytes_left
> 0)
2411 /* Mask for removing bits of the next source byte that are not
2412 part of the value. */
2413 unsigned int unusedMSMask
=
2414 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2416 /* Sign-extend bits for this byte. */
2417 unsigned int signMask
= sign
& ~unusedMSMask
;
2420 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2421 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2422 if (accumSize
>= HOST_CHAR_BIT
)
2424 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2425 accumSize
-= HOST_CHAR_BIT
;
2426 accum
>>= HOST_CHAR_BIT
;
2427 unpacked_bytes_left
-= 1;
2428 unpacked_idx
+= delta
;
2430 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2432 src_bytes_left
-= 1;
2435 while (unpacked_bytes_left
> 0)
2437 accum
|= sign
<< accumSize
;
2438 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2439 accumSize
-= HOST_CHAR_BIT
;
2442 accum
>>= HOST_CHAR_BIT
;
2443 unpacked_bytes_left
-= 1;
2444 unpacked_idx
+= delta
;
2448 /* Create a new value of type TYPE from the contents of OBJ starting
2449 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2450 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2451 assigning through the result will set the field fetched from.
2452 VALADDR is ignored unless OBJ is NULL, in which case,
2453 VALADDR+OFFSET must address the start of storage containing the
2454 packed value. The value returned in this case is never an lval.
2455 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2458 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2459 long offset
, int bit_offset
, int bit_size
,
2463 const gdb_byte
*src
; /* First byte containing data to unpack */
2465 const int is_scalar
= is_scalar_type (type
);
2466 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2467 gdb::byte_vector staging
;
2469 type
= ada_check_typedef (type
);
2472 src
= valaddr
+ offset
;
2474 src
= value_contents (obj
) + offset
;
2476 if (is_dynamic_type (type
))
2478 /* The length of TYPE might by dynamic, so we need to resolve
2479 TYPE in order to know its actual size, which we then use
2480 to create the contents buffer of the value we return.
2481 The difficulty is that the data containing our object is
2482 packed, and therefore maybe not at a byte boundary. So, what
2483 we do, is unpack the data into a byte-aligned buffer, and then
2484 use that buffer as our object's value for resolving the type. */
2485 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2486 staging
.resize (staging_len
);
2488 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2489 staging
.data (), staging
.size (),
2490 is_big_endian
, has_negatives (type
),
2492 type
= resolve_dynamic_type (type
, staging
, 0);
2493 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2495 /* This happens when the length of the object is dynamic,
2496 and is actually smaller than the space reserved for it.
2497 For instance, in an array of variant records, the bit_size
2498 we're given is the array stride, which is constant and
2499 normally equal to the maximum size of its element.
2500 But, in reality, each element only actually spans a portion
2502 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2508 v
= allocate_value (type
);
2509 src
= valaddr
+ offset
;
2511 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2513 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2516 v
= value_at (type
, value_address (obj
) + offset
);
2517 buf
= (gdb_byte
*) alloca (src_len
);
2518 read_memory (value_address (v
), buf
, src_len
);
2523 v
= allocate_value (type
);
2524 src
= value_contents (obj
) + offset
;
2529 long new_offset
= offset
;
2531 set_value_component_location (v
, obj
);
2532 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2533 set_value_bitsize (v
, bit_size
);
2534 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2537 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2539 set_value_offset (v
, new_offset
);
2541 /* Also set the parent value. This is needed when trying to
2542 assign a new value (in inferior memory). */
2543 set_value_parent (v
, obj
);
2546 set_value_bitsize (v
, bit_size
);
2547 unpacked
= value_contents_writeable (v
);
2551 memset (unpacked
, 0, TYPE_LENGTH (type
));
2555 if (staging
.size () == TYPE_LENGTH (type
))
2557 /* Small short-cut: If we've unpacked the data into a buffer
2558 of the same size as TYPE's length, then we can reuse that,
2559 instead of doing the unpacking again. */
2560 memcpy (unpacked
, staging
.data (), staging
.size ());
2563 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2564 unpacked
, TYPE_LENGTH (type
),
2565 is_big_endian
, has_negatives (type
), is_scalar
);
2570 /* Store the contents of FROMVAL into the location of TOVAL.
2571 Return a new value with the location of TOVAL and contents of
2572 FROMVAL. Handles assignment into packed fields that have
2573 floating-point or non-scalar types. */
2575 static struct value
*
2576 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2578 struct type
*type
= value_type (toval
);
2579 int bits
= value_bitsize (toval
);
2581 toval
= ada_coerce_ref (toval
);
2582 fromval
= ada_coerce_ref (fromval
);
2584 if (ada_is_direct_array_type (value_type (toval
)))
2585 toval
= ada_coerce_to_simple_array (toval
);
2586 if (ada_is_direct_array_type (value_type (fromval
)))
2587 fromval
= ada_coerce_to_simple_array (fromval
);
2589 if (!deprecated_value_modifiable (toval
))
2590 error (_("Left operand of assignment is not a modifiable lvalue."));
2592 if (VALUE_LVAL (toval
) == lval_memory
2594 && (type
->code () == TYPE_CODE_FLT
2595 || type
->code () == TYPE_CODE_STRUCT
))
2597 int len
= (value_bitpos (toval
)
2598 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2600 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2602 CORE_ADDR to_addr
= value_address (toval
);
2604 if (type
->code () == TYPE_CODE_FLT
)
2605 fromval
= value_cast (type
, fromval
);
2607 read_memory (to_addr
, buffer
, len
);
2608 from_size
= value_bitsize (fromval
);
2610 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2612 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2613 ULONGEST from_offset
= 0;
2614 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2615 from_offset
= from_size
- bits
;
2616 copy_bitwise (buffer
, value_bitpos (toval
),
2617 value_contents (fromval
), from_offset
,
2618 bits
, is_big_endian
);
2619 write_memory_with_notification (to_addr
, buffer
, len
);
2621 val
= value_copy (toval
);
2622 memcpy (value_contents_raw (val
), value_contents (fromval
),
2623 TYPE_LENGTH (type
));
2624 deprecated_set_value_type (val
, type
);
2629 return value_assign (toval
, fromval
);
2633 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2634 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2635 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2636 COMPONENT, and not the inferior's memory. The current contents
2637 of COMPONENT are ignored.
2639 Although not part of the initial design, this function also works
2640 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2641 had a null address, and COMPONENT had an address which is equal to
2642 its offset inside CONTAINER. */
2645 value_assign_to_component (struct value
*container
, struct value
*component
,
2648 LONGEST offset_in_container
=
2649 (LONGEST
) (value_address (component
) - value_address (container
));
2650 int bit_offset_in_container
=
2651 value_bitpos (component
) - value_bitpos (container
);
2654 val
= value_cast (value_type (component
), val
);
2656 if (value_bitsize (component
) == 0)
2657 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2659 bits
= value_bitsize (component
);
2661 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2665 if (is_scalar_type (check_typedef (value_type (component
))))
2667 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2670 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2671 value_bitpos (container
) + bit_offset_in_container
,
2672 value_contents (val
), src_offset
, bits
, 1);
2675 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2676 value_bitpos (container
) + bit_offset_in_container
,
2677 value_contents (val
), 0, bits
, 0);
2680 /* Determine if TYPE is an access to an unconstrained array. */
2683 ada_is_access_to_unconstrained_array (struct type
*type
)
2685 return (type
->code () == TYPE_CODE_TYPEDEF
2686 && is_thick_pntr (ada_typedef_target_type (type
)));
2689 /* The value of the element of array ARR at the ARITY indices given in IND.
2690 ARR may be either a simple array, GNAT array descriptor, or pointer
2694 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2698 struct type
*elt_type
;
2700 elt
= ada_coerce_to_simple_array (arr
);
2702 elt_type
= ada_check_typedef (value_type (elt
));
2703 if (elt_type
->code () == TYPE_CODE_ARRAY
2704 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2705 return value_subscript_packed (elt
, arity
, ind
);
2707 for (k
= 0; k
< arity
; k
+= 1)
2709 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2711 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2712 error (_("too many subscripts (%d expected)"), k
);
2714 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2716 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2717 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2719 /* The element is a typedef to an unconstrained array,
2720 except that the value_subscript call stripped the
2721 typedef layer. The typedef layer is GNAT's way to
2722 specify that the element is, at the source level, an
2723 access to the unconstrained array, rather than the
2724 unconstrained array. So, we need to restore that
2725 typedef layer, which we can do by forcing the element's
2726 type back to its original type. Otherwise, the returned
2727 value is going to be printed as the array, rather
2728 than as an access. Another symptom of the same issue
2729 would be that an expression trying to dereference the
2730 element would also be improperly rejected. */
2731 deprecated_set_value_type (elt
, saved_elt_type
);
2734 elt_type
= ada_check_typedef (value_type (elt
));
2740 /* Assuming ARR is a pointer to a GDB array, the value of the element
2741 of *ARR at the ARITY indices given in IND.
2742 Does not read the entire array into memory.
2744 Note: Unlike what one would expect, this function is used instead of
2745 ada_value_subscript for basically all non-packed array types. The reason
2746 for this is that a side effect of doing our own pointer arithmetics instead
2747 of relying on value_subscript is that there is no implicit typedef peeling.
2748 This is important for arrays of array accesses, where it allows us to
2749 preserve the fact that the array's element is an array access, where the
2750 access part os encoded in a typedef layer. */
2752 static struct value
*
2753 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2756 struct value
*array_ind
= ada_value_ind (arr
);
2758 = check_typedef (value_enclosing_type (array_ind
));
2760 if (type
->code () == TYPE_CODE_ARRAY
2761 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2762 return value_subscript_packed (array_ind
, arity
, ind
);
2764 for (k
= 0; k
< arity
; k
+= 1)
2768 if (type
->code () != TYPE_CODE_ARRAY
)
2769 error (_("too many subscripts (%d expected)"), k
);
2770 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2772 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2773 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2774 type
= TYPE_TARGET_TYPE (type
);
2777 return value_ind (arr
);
2780 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2781 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2782 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2783 this array is LOW, as per Ada rules. */
2784 static struct value
*
2785 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2788 struct type
*type0
= ada_check_typedef (type
);
2789 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
));
2790 struct type
*index_type
2791 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2792 struct type
*slice_type
= create_array_type_with_stride
2793 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2794 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2795 TYPE_FIELD_BITSIZE (type0
, 0));
2796 int base_low
= ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
));
2797 LONGEST base_low_pos
, low_pos
;
2800 if (!discrete_position (base_index_type
, low
, &low_pos
)
2801 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2803 warning (_("unable to get positions in slice, use bounds instead"));
2805 base_low_pos
= base_low
;
2808 base
= value_as_address (array_ptr
)
2809 + ((low_pos
- base_low_pos
)
2810 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2811 return value_at_lazy (slice_type
, base
);
2815 static struct value
*
2816 ada_value_slice (struct value
*array
, int low
, int high
)
2818 struct type
*type
= ada_check_typedef (value_type (array
));
2819 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2820 struct type
*index_type
2821 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2822 struct type
*slice_type
= create_array_type_with_stride
2823 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2824 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2825 TYPE_FIELD_BITSIZE (type
, 0));
2826 LONGEST low_pos
, high_pos
;
2828 if (!discrete_position (base_index_type
, low
, &low_pos
)
2829 || !discrete_position (base_index_type
, high
, &high_pos
))
2831 warning (_("unable to get positions in slice, use bounds instead"));
2836 return value_cast (slice_type
,
2837 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2840 /* If type is a record type in the form of a standard GNAT array
2841 descriptor, returns the number of dimensions for type. If arr is a
2842 simple array, returns the number of "array of"s that prefix its
2843 type designation. Otherwise, returns 0. */
2846 ada_array_arity (struct type
*type
)
2853 type
= desc_base_type (type
);
2856 if (type
->code () == TYPE_CODE_STRUCT
)
2857 return desc_arity (desc_bounds_type (type
));
2859 while (type
->code () == TYPE_CODE_ARRAY
)
2862 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2868 /* If TYPE is a record type in the form of a standard GNAT array
2869 descriptor or a simple array type, returns the element type for
2870 TYPE after indexing by NINDICES indices, or by all indices if
2871 NINDICES is -1. Otherwise, returns NULL. */
2874 ada_array_element_type (struct type
*type
, int nindices
)
2876 type
= desc_base_type (type
);
2878 if (type
->code () == TYPE_CODE_STRUCT
)
2881 struct type
*p_array_type
;
2883 p_array_type
= desc_data_target_type (type
);
2885 k
= ada_array_arity (type
);
2889 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2890 if (nindices
>= 0 && k
> nindices
)
2892 while (k
> 0 && p_array_type
!= NULL
)
2894 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2897 return p_array_type
;
2899 else if (type
->code () == TYPE_CODE_ARRAY
)
2901 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2903 type
= TYPE_TARGET_TYPE (type
);
2912 /* The type of nth index in arrays of given type (n numbering from 1).
2913 Does not examine memory. Throws an error if N is invalid or TYPE
2914 is not an array type. NAME is the name of the Ada attribute being
2915 evaluated ('range, 'first, 'last, or 'length); it is used in building
2916 the error message. */
2918 static struct type
*
2919 ada_index_type (struct type
*type
, int n
, const char *name
)
2921 struct type
*result_type
;
2923 type
= desc_base_type (type
);
2925 if (n
< 0 || n
> ada_array_arity (type
))
2926 error (_("invalid dimension number to '%s"), name
);
2928 if (ada_is_simple_array_type (type
))
2932 for (i
= 1; i
< n
; i
+= 1)
2933 type
= TYPE_TARGET_TYPE (type
);
2934 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2935 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2936 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2937 perhaps stabsread.c would make more sense. */
2938 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2943 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2944 if (result_type
== NULL
)
2945 error (_("attempt to take bound of something that is not an array"));
2951 /* Given that arr is an array type, returns the lower bound of the
2952 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2953 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2954 array-descriptor type. It works for other arrays with bounds supplied
2955 by run-time quantities other than discriminants. */
2958 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2960 struct type
*type
, *index_type_desc
, *index_type
;
2963 gdb_assert (which
== 0 || which
== 1);
2965 if (ada_is_constrained_packed_array_type (arr_type
))
2966 arr_type
= decode_constrained_packed_array_type (arr_type
);
2968 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2969 return (LONGEST
) - which
;
2971 if (arr_type
->code () == TYPE_CODE_PTR
)
2972 type
= TYPE_TARGET_TYPE (arr_type
);
2976 if (TYPE_FIXED_INSTANCE (type
))
2978 /* The array has already been fixed, so we do not need to
2979 check the parallel ___XA type again. That encoding has
2980 already been applied, so ignore it now. */
2981 index_type_desc
= NULL
;
2985 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2986 ada_fixup_array_indexes_type (index_type_desc
);
2989 if (index_type_desc
!= NULL
)
2990 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2994 struct type
*elt_type
= check_typedef (type
);
2996 for (i
= 1; i
< n
; i
++)
2997 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2999 index_type
= TYPE_INDEX_TYPE (elt_type
);
3003 (LONGEST
) (which
== 0
3004 ? ada_discrete_type_low_bound (index_type
)
3005 : ada_discrete_type_high_bound (index_type
));
3008 /* Given that arr is an array value, returns the lower bound of the
3009 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3010 WHICH is 1. This routine will also work for arrays with bounds
3011 supplied by run-time quantities other than discriminants. */
3014 ada_array_bound (struct value
*arr
, int n
, int which
)
3016 struct type
*arr_type
;
3018 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3019 arr
= value_ind (arr
);
3020 arr_type
= value_enclosing_type (arr
);
3022 if (ada_is_constrained_packed_array_type (arr_type
))
3023 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3024 else if (ada_is_simple_array_type (arr_type
))
3025 return ada_array_bound_from_type (arr_type
, n
, which
);
3027 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3030 /* Given that arr is an array value, returns the length of the
3031 nth index. This routine will also work for arrays with bounds
3032 supplied by run-time quantities other than discriminants.
3033 Does not work for arrays indexed by enumeration types with representation
3034 clauses at the moment. */
3037 ada_array_length (struct value
*arr
, int n
)
3039 struct type
*arr_type
, *index_type
;
3042 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
3043 arr
= value_ind (arr
);
3044 arr_type
= value_enclosing_type (arr
);
3046 if (ada_is_constrained_packed_array_type (arr_type
))
3047 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3049 if (ada_is_simple_array_type (arr_type
))
3051 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3052 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3056 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3057 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3060 arr_type
= check_typedef (arr_type
);
3061 index_type
= ada_index_type (arr_type
, n
, "length");
3062 if (index_type
!= NULL
)
3064 struct type
*base_type
;
3065 if (index_type
->code () == TYPE_CODE_RANGE
)
3066 base_type
= TYPE_TARGET_TYPE (index_type
);
3068 base_type
= index_type
;
3070 low
= pos_atr (value_from_longest (base_type
, low
));
3071 high
= pos_atr (value_from_longest (base_type
, high
));
3073 return high
- low
+ 1;
3076 /* An array whose type is that of ARR_TYPE (an array type), with
3077 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3078 less than LOW, then LOW-1 is used. */
3080 static struct value
*
3081 empty_array (struct type
*arr_type
, int low
, int high
)
3083 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3084 struct type
*index_type
3085 = create_static_range_type
3086 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
,
3087 high
< low
? low
- 1 : high
);
3088 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3090 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3094 /* Name resolution */
3096 /* The "decoded" name for the user-definable Ada operator corresponding
3100 ada_decoded_op_name (enum exp_opcode op
)
3104 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3106 if (ada_opname_table
[i
].op
== op
)
3107 return ada_opname_table
[i
].decoded
;
3109 error (_("Could not find operator name for opcode"));
3112 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3113 in a listing of choices during disambiguation (see sort_choices, below).
3114 The idea is that overloadings of a subprogram name from the
3115 same package should sort in their source order. We settle for ordering
3116 such symbols by their trailing number (__N or $N). */
3119 encoded_ordered_before (const char *N0
, const char *N1
)
3123 else if (N0
== NULL
)
3129 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3131 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3133 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3134 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3139 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3142 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3144 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3145 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3147 return (strcmp (N0
, N1
) < 0);
3151 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3155 sort_choices (struct block_symbol syms
[], int nsyms
)
3159 for (i
= 1; i
< nsyms
; i
+= 1)
3161 struct block_symbol sym
= syms
[i
];
3164 for (j
= i
- 1; j
>= 0; j
-= 1)
3166 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3167 sym
.symbol
->linkage_name ()))
3169 syms
[j
+ 1] = syms
[j
];
3175 /* Whether GDB should display formals and return types for functions in the
3176 overloads selection menu. */
3177 static bool print_signatures
= true;
3179 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3180 all but functions, the signature is just the name of the symbol. For
3181 functions, this is the name of the function, the list of types for formals
3182 and the return type (if any). */
3185 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3186 const struct type_print_options
*flags
)
3188 struct type
*type
= SYMBOL_TYPE (sym
);
3190 fprintf_filtered (stream
, "%s", sym
->print_name ());
3191 if (!print_signatures
3193 || type
->code () != TYPE_CODE_FUNC
)
3196 if (type
->num_fields () > 0)
3200 fprintf_filtered (stream
, " (");
3201 for (i
= 0; i
< type
->num_fields (); ++i
)
3204 fprintf_filtered (stream
, "; ");
3205 ada_print_type (TYPE_FIELD_TYPE (type
, i
), NULL
, stream
, -1, 0,
3208 fprintf_filtered (stream
, ")");
3210 if (TYPE_TARGET_TYPE (type
) != NULL
3211 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3213 fprintf_filtered (stream
, " return ");
3214 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3218 /* Read and validate a set of numeric choices from the user in the
3219 range 0 .. N_CHOICES-1. Place the results in increasing
3220 order in CHOICES[0 .. N-1], and return N.
3222 The user types choices as a sequence of numbers on one line
3223 separated by blanks, encoding them as follows:
3225 + A choice of 0 means to cancel the selection, throwing an error.
3226 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3227 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3229 The user is not allowed to choose more than MAX_RESULTS values.
3231 ANNOTATION_SUFFIX, if present, is used to annotate the input
3232 prompts (for use with the -f switch). */
3235 get_selections (int *choices
, int n_choices
, int max_results
,
3236 int is_all_choice
, const char *annotation_suffix
)
3241 int first_choice
= is_all_choice
? 2 : 1;
3243 prompt
= getenv ("PS2");
3247 args
= command_line_input (prompt
, annotation_suffix
);
3250 error_no_arg (_("one or more choice numbers"));
3254 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3255 order, as given in args. Choices are validated. */
3261 args
= skip_spaces (args
);
3262 if (*args
== '\0' && n_chosen
== 0)
3263 error_no_arg (_("one or more choice numbers"));
3264 else if (*args
== '\0')
3267 choice
= strtol (args
, &args2
, 10);
3268 if (args
== args2
|| choice
< 0
3269 || choice
> n_choices
+ first_choice
- 1)
3270 error (_("Argument must be choice number"));
3274 error (_("cancelled"));
3276 if (choice
< first_choice
)
3278 n_chosen
= n_choices
;
3279 for (j
= 0; j
< n_choices
; j
+= 1)
3283 choice
-= first_choice
;
3285 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3289 if (j
< 0 || choice
!= choices
[j
])
3293 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3294 choices
[k
+ 1] = choices
[k
];
3295 choices
[j
+ 1] = choice
;
3300 if (n_chosen
> max_results
)
3301 error (_("Select no more than %d of the above"), max_results
);
3306 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3307 by asking the user (if necessary), returning the number selected,
3308 and setting the first elements of SYMS items. Error if no symbols
3311 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3312 to be re-integrated one of these days. */
3315 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3318 int *chosen
= XALLOCAVEC (int , nsyms
);
3320 int first_choice
= (max_results
== 1) ? 1 : 2;
3321 const char *select_mode
= multiple_symbols_select_mode ();
3323 if (max_results
< 1)
3324 error (_("Request to select 0 symbols!"));
3328 if (select_mode
== multiple_symbols_cancel
)
3330 canceled because the command is ambiguous\n\
3331 See set/show multiple-symbol."));
3333 /* If select_mode is "all", then return all possible symbols.
3334 Only do that if more than one symbol can be selected, of course.
3335 Otherwise, display the menu as usual. */
3336 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3339 printf_filtered (_("[0] cancel\n"));
3340 if (max_results
> 1)
3341 printf_filtered (_("[1] all\n"));
3343 sort_choices (syms
, nsyms
);
3345 for (i
= 0; i
< nsyms
; i
+= 1)
3347 if (syms
[i
].symbol
== NULL
)
3350 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3352 struct symtab_and_line sal
=
3353 find_function_start_sal (syms
[i
].symbol
, 1);
3355 printf_filtered ("[%d] ", i
+ first_choice
);
3356 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3357 &type_print_raw_options
);
3358 if (sal
.symtab
== NULL
)
3359 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3360 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3364 styled_string (file_name_style
.style (),
3365 symtab_to_filename_for_display (sal
.symtab
)),
3372 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3373 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3374 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3375 struct symtab
*symtab
= NULL
;
3377 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3378 symtab
= symbol_symtab (syms
[i
].symbol
);
3380 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3382 printf_filtered ("[%d] ", i
+ first_choice
);
3383 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3384 &type_print_raw_options
);
3385 printf_filtered (_(" at %s:%d\n"),
3386 symtab_to_filename_for_display (symtab
),
3387 SYMBOL_LINE (syms
[i
].symbol
));
3389 else if (is_enumeral
3390 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3392 printf_filtered (("[%d] "), i
+ first_choice
);
3393 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3394 gdb_stdout
, -1, 0, &type_print_raw_options
);
3395 printf_filtered (_("'(%s) (enumeral)\n"),
3396 syms
[i
].symbol
->print_name ());
3400 printf_filtered ("[%d] ", i
+ first_choice
);
3401 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3402 &type_print_raw_options
);
3405 printf_filtered (is_enumeral
3406 ? _(" in %s (enumeral)\n")
3408 symtab_to_filename_for_display (symtab
));
3410 printf_filtered (is_enumeral
3411 ? _(" (enumeral)\n")
3417 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3420 for (i
= 0; i
< n_chosen
; i
+= 1)
3421 syms
[i
] = syms
[chosen
[i
]];
3426 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3427 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3428 undefined namespace) and converts operators that are
3429 user-defined into appropriate function calls. If CONTEXT_TYPE is
3430 non-null, it provides a preferred result type [at the moment, only
3431 type void has any effect---causing procedures to be preferred over
3432 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3433 return type is preferred. May change (expand) *EXP. */
3436 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3437 innermost_block_tracker
*tracker
)
3439 struct type
*context_type
= NULL
;
3443 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3445 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3448 /* Resolve the operator of the subexpression beginning at
3449 position *POS of *EXPP. "Resolving" consists of replacing
3450 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3451 with their resolutions, replacing built-in operators with
3452 function calls to user-defined operators, where appropriate, and,
3453 when DEPROCEDURE_P is non-zero, converting function-valued variables
3454 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3455 are as in ada_resolve, above. */
3457 static struct value
*
3458 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3459 struct type
*context_type
, int parse_completion
,
3460 innermost_block_tracker
*tracker
)
3464 struct expression
*exp
; /* Convenience: == *expp. */
3465 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3466 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3467 int nargs
; /* Number of operands. */
3474 /* Pass one: resolve operands, saving their types and updating *pos,
3479 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3480 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3485 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3487 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3492 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3497 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3498 parse_completion
, tracker
);
3501 case OP_ATR_MODULUS
:
3511 case TERNOP_IN_RANGE
:
3512 case BINOP_IN_BOUNDS
:
3518 case OP_DISCRETE_RANGE
:
3520 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3529 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3531 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3533 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3551 case BINOP_LOGICAL_AND
:
3552 case BINOP_LOGICAL_OR
:
3553 case BINOP_BITWISE_AND
:
3554 case BINOP_BITWISE_IOR
:
3555 case BINOP_BITWISE_XOR
:
3558 case BINOP_NOTEQUAL
:
3565 case BINOP_SUBSCRIPT
:
3573 case UNOP_LOGICAL_NOT
:
3583 case OP_VAR_MSYM_VALUE
:
3590 case OP_INTERNALVAR
:
3600 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3603 case STRUCTOP_STRUCT
:
3604 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3617 error (_("Unexpected operator during name resolution"));
3620 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3621 for (i
= 0; i
< nargs
; i
+= 1)
3622 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3627 /* Pass two: perform any resolution on principal operator. */
3634 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3636 std::vector
<struct block_symbol
> candidates
;
3640 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3641 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3644 if (n_candidates
> 1)
3646 /* Types tend to get re-introduced locally, so if there
3647 are any local symbols that are not types, first filter
3650 for (j
= 0; j
< n_candidates
; j
+= 1)
3651 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3656 case LOC_REGPARM_ADDR
:
3664 if (j
< n_candidates
)
3667 while (j
< n_candidates
)
3669 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3671 candidates
[j
] = candidates
[n_candidates
- 1];
3680 if (n_candidates
== 0)
3681 error (_("No definition found for %s"),
3682 exp
->elts
[pc
+ 2].symbol
->print_name ());
3683 else if (n_candidates
== 1)
3685 else if (deprocedure_p
3686 && !is_nonfunction (candidates
.data (), n_candidates
))
3688 i
= ada_resolve_function
3689 (candidates
.data (), n_candidates
, NULL
, 0,
3690 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3691 context_type
, parse_completion
);
3693 error (_("Could not find a match for %s"),
3694 exp
->elts
[pc
+ 2].symbol
->print_name ());
3698 printf_filtered (_("Multiple matches for %s\n"),
3699 exp
->elts
[pc
+ 2].symbol
->print_name ());
3700 user_select_syms (candidates
.data (), n_candidates
, 1);
3704 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3705 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3706 tracker
->update (candidates
[i
]);
3710 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3713 replace_operator_with_call (expp
, pc
, 0, 4,
3714 exp
->elts
[pc
+ 2].symbol
,
3715 exp
->elts
[pc
+ 1].block
);
3722 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3723 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3725 std::vector
<struct block_symbol
> candidates
;
3729 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3730 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3733 if (n_candidates
== 1)
3737 i
= ada_resolve_function
3738 (candidates
.data (), n_candidates
,
3740 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3741 context_type
, parse_completion
);
3743 error (_("Could not find a match for %s"),
3744 exp
->elts
[pc
+ 5].symbol
->print_name ());
3747 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3748 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3749 tracker
->update (candidates
[i
]);
3760 case BINOP_BITWISE_AND
:
3761 case BINOP_BITWISE_IOR
:
3762 case BINOP_BITWISE_XOR
:
3764 case BINOP_NOTEQUAL
:
3772 case UNOP_LOGICAL_NOT
:
3774 if (possible_user_operator_p (op
, argvec
))
3776 std::vector
<struct block_symbol
> candidates
;
3780 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3784 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3785 nargs
, ada_decoded_op_name (op
), NULL
,
3790 replace_operator_with_call (expp
, pc
, nargs
, 1,
3791 candidates
[i
].symbol
,
3792 candidates
[i
].block
);
3803 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3804 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3805 exp
->elts
[pc
+ 1].objfile
,
3806 exp
->elts
[pc
+ 2].msymbol
);
3808 return evaluate_subexp_type (exp
, pos
);
3811 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3812 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3814 /* The term "match" here is rather loose. The match is heuristic and
3818 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3820 ftype
= ada_check_typedef (ftype
);
3821 atype
= ada_check_typedef (atype
);
3823 if (ftype
->code () == TYPE_CODE_REF
)
3824 ftype
= TYPE_TARGET_TYPE (ftype
);
3825 if (atype
->code () == TYPE_CODE_REF
)
3826 atype
= TYPE_TARGET_TYPE (atype
);
3828 switch (ftype
->code ())
3831 return ftype
->code () == atype
->code ();
3833 if (atype
->code () == TYPE_CODE_PTR
)
3834 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3835 TYPE_TARGET_TYPE (atype
), 0);
3838 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3840 case TYPE_CODE_ENUM
:
3841 case TYPE_CODE_RANGE
:
3842 switch (atype
->code ())
3845 case TYPE_CODE_ENUM
:
3846 case TYPE_CODE_RANGE
:
3852 case TYPE_CODE_ARRAY
:
3853 return (atype
->code () == TYPE_CODE_ARRAY
3854 || ada_is_array_descriptor_type (atype
));
3856 case TYPE_CODE_STRUCT
:
3857 if (ada_is_array_descriptor_type (ftype
))
3858 return (atype
->code () == TYPE_CODE_ARRAY
3859 || ada_is_array_descriptor_type (atype
));
3861 return (atype
->code () == TYPE_CODE_STRUCT
3862 && !ada_is_array_descriptor_type (atype
));
3864 case TYPE_CODE_UNION
:
3866 return (atype
->code () == ftype
->code ());
3870 /* Return non-zero if the formals of FUNC "sufficiently match" the
3871 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3872 may also be an enumeral, in which case it is treated as a 0-
3873 argument function. */
3876 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3879 struct type
*func_type
= SYMBOL_TYPE (func
);
3881 if (SYMBOL_CLASS (func
) == LOC_CONST
3882 && func_type
->code () == TYPE_CODE_ENUM
)
3883 return (n_actuals
== 0);
3884 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3887 if (func_type
->num_fields () != n_actuals
)
3890 for (i
= 0; i
< n_actuals
; i
+= 1)
3892 if (actuals
[i
] == NULL
)
3896 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3898 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3900 if (!ada_type_match (ftype
, atype
, 1))
3907 /* False iff function type FUNC_TYPE definitely does not produce a value
3908 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3909 FUNC_TYPE is not a valid function type with a non-null return type
3910 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3913 return_match (struct type
*func_type
, struct type
*context_type
)
3915 struct type
*return_type
;
3917 if (func_type
== NULL
)
3920 if (func_type
->code () == TYPE_CODE_FUNC
)
3921 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3923 return_type
= get_base_type (func_type
);
3924 if (return_type
== NULL
)
3927 context_type
= get_base_type (context_type
);
3929 if (return_type
->code () == TYPE_CODE_ENUM
)
3930 return context_type
== NULL
|| return_type
== context_type
;
3931 else if (context_type
== NULL
)
3932 return return_type
->code () != TYPE_CODE_VOID
;
3934 return return_type
->code () == context_type
->code ();
3938 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3939 function (if any) that matches the types of the NARGS arguments in
3940 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3941 that returns that type, then eliminate matches that don't. If
3942 CONTEXT_TYPE is void and there is at least one match that does not
3943 return void, eliminate all matches that do.
3945 Asks the user if there is more than one match remaining. Returns -1
3946 if there is no such symbol or none is selected. NAME is used
3947 solely for messages. May re-arrange and modify SYMS in
3948 the process; the index returned is for the modified vector. */
3951 ada_resolve_function (struct block_symbol syms
[],
3952 int nsyms
, struct value
**args
, int nargs
,
3953 const char *name
, struct type
*context_type
,
3954 int parse_completion
)
3958 int m
; /* Number of hits */
3961 /* In the first pass of the loop, we only accept functions matching
3962 context_type. If none are found, we add a second pass of the loop
3963 where every function is accepted. */
3964 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3966 for (k
= 0; k
< nsyms
; k
+= 1)
3968 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3970 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3971 && (fallback
|| return_match (type
, context_type
)))
3979 /* If we got multiple matches, ask the user which one to use. Don't do this
3980 interactive thing during completion, though, as the purpose of the
3981 completion is providing a list of all possible matches. Prompting the
3982 user to filter it down would be completely unexpected in this case. */
3985 else if (m
> 1 && !parse_completion
)
3987 printf_filtered (_("Multiple matches for %s\n"), name
);
3988 user_select_syms (syms
, m
, 1);
3994 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3995 on the function identified by SYM and BLOCK, and taking NARGS
3996 arguments. Update *EXPP as needed to hold more space. */
3999 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4000 int oplen
, struct symbol
*sym
,
4001 const struct block
*block
)
4003 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4004 symbol, -oplen for operator being replaced). */
4005 struct expression
*newexp
= (struct expression
*)
4006 xzalloc (sizeof (struct expression
)
4007 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
4008 struct expression
*exp
= expp
->get ();
4010 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
4011 newexp
->language_defn
= exp
->language_defn
;
4012 newexp
->gdbarch
= exp
->gdbarch
;
4013 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
4014 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4015 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
4017 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4018 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4020 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4021 newexp
->elts
[pc
+ 4].block
= block
;
4022 newexp
->elts
[pc
+ 5].symbol
= sym
;
4024 expp
->reset (newexp
);
4027 /* Type-class predicates */
4029 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4033 numeric_type_p (struct type
*type
)
4039 switch (type
->code ())
4044 case TYPE_CODE_RANGE
:
4045 return (type
== TYPE_TARGET_TYPE (type
)
4046 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4053 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4056 integer_type_p (struct type
*type
)
4062 switch (type
->code ())
4066 case TYPE_CODE_RANGE
:
4067 return (type
== TYPE_TARGET_TYPE (type
)
4068 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4075 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4078 scalar_type_p (struct type
*type
)
4084 switch (type
->code ())
4087 case TYPE_CODE_RANGE
:
4088 case TYPE_CODE_ENUM
:
4097 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4100 discrete_type_p (struct type
*type
)
4106 switch (type
->code ())
4109 case TYPE_CODE_RANGE
:
4110 case TYPE_CODE_ENUM
:
4111 case TYPE_CODE_BOOL
:
4119 /* Returns non-zero if OP with operands in the vector ARGS could be
4120 a user-defined function. Errs on the side of pre-defined operators
4121 (i.e., result 0). */
4124 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4126 struct type
*type0
=
4127 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4128 struct type
*type1
=
4129 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4143 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4147 case BINOP_BITWISE_AND
:
4148 case BINOP_BITWISE_IOR
:
4149 case BINOP_BITWISE_XOR
:
4150 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4153 case BINOP_NOTEQUAL
:
4158 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4161 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4164 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4168 case UNOP_LOGICAL_NOT
:
4170 return (!numeric_type_p (type0
));
4179 1. In the following, we assume that a renaming type's name may
4180 have an ___XD suffix. It would be nice if this went away at some
4182 2. We handle both the (old) purely type-based representation of
4183 renamings and the (new) variable-based encoding. At some point,
4184 it is devoutly to be hoped that the former goes away
4185 (FIXME: hilfinger-2007-07-09).
4186 3. Subprogram renamings are not implemented, although the XRS
4187 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4189 /* If SYM encodes a renaming,
4191 <renaming> renames <renamed entity>,
4193 sets *LEN to the length of the renamed entity's name,
4194 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4195 the string describing the subcomponent selected from the renamed
4196 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4197 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4198 are undefined). Otherwise, returns a value indicating the category
4199 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4200 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4201 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4202 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4203 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4204 may be NULL, in which case they are not assigned.
4206 [Currently, however, GCC does not generate subprogram renamings.] */
4208 enum ada_renaming_category
4209 ada_parse_renaming (struct symbol
*sym
,
4210 const char **renamed_entity
, int *len
,
4211 const char **renaming_expr
)
4213 enum ada_renaming_category kind
;
4218 return ADA_NOT_RENAMING
;
4219 switch (SYMBOL_CLASS (sym
))
4222 return ADA_NOT_RENAMING
;
4226 case LOC_OPTIMIZED_OUT
:
4227 info
= strstr (sym
->linkage_name (), "___XR");
4229 return ADA_NOT_RENAMING
;
4233 kind
= ADA_OBJECT_RENAMING
;
4237 kind
= ADA_EXCEPTION_RENAMING
;
4241 kind
= ADA_PACKAGE_RENAMING
;
4245 kind
= ADA_SUBPROGRAM_RENAMING
;
4249 return ADA_NOT_RENAMING
;
4253 if (renamed_entity
!= NULL
)
4254 *renamed_entity
= info
;
4255 suffix
= strstr (info
, "___XE");
4256 if (suffix
== NULL
|| suffix
== info
)
4257 return ADA_NOT_RENAMING
;
4259 *len
= strlen (info
) - strlen (suffix
);
4261 if (renaming_expr
!= NULL
)
4262 *renaming_expr
= suffix
;
4266 /* Compute the value of the given RENAMING_SYM, which is expected to
4267 be a symbol encoding a renaming expression. BLOCK is the block
4268 used to evaluate the renaming. */
4270 static struct value
*
4271 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4272 const struct block
*block
)
4274 const char *sym_name
;
4276 sym_name
= renaming_sym
->linkage_name ();
4277 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4278 return evaluate_expression (expr
.get ());
4282 /* Evaluation: Function Calls */
4284 /* Return an lvalue containing the value VAL. This is the identity on
4285 lvalues, and otherwise has the side-effect of allocating memory
4286 in the inferior where a copy of the value contents is copied. */
4288 static struct value
*
4289 ensure_lval (struct value
*val
)
4291 if (VALUE_LVAL (val
) == not_lval
4292 || VALUE_LVAL (val
) == lval_internalvar
)
4294 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4295 const CORE_ADDR addr
=
4296 value_as_long (value_allocate_space_in_inferior (len
));
4298 VALUE_LVAL (val
) = lval_memory
;
4299 set_value_address (val
, addr
);
4300 write_memory (addr
, value_contents (val
), len
);
4306 /* Given ARG, a value of type (pointer or reference to a)*
4307 structure/union, extract the component named NAME from the ultimate
4308 target structure/union and return it as a value with its
4311 The routine searches for NAME among all members of the structure itself
4312 and (recursively) among all members of any wrapper members
4315 If NO_ERR, then simply return NULL in case of error, rather than
4318 static struct value
*
4319 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4321 struct type
*t
, *t1
;
4326 t1
= t
= ada_check_typedef (value_type (arg
));
4327 if (t
->code () == TYPE_CODE_REF
)
4329 t1
= TYPE_TARGET_TYPE (t
);
4332 t1
= ada_check_typedef (t1
);
4333 if (t1
->code () == TYPE_CODE_PTR
)
4335 arg
= coerce_ref (arg
);
4340 while (t
->code () == TYPE_CODE_PTR
)
4342 t1
= TYPE_TARGET_TYPE (t
);
4345 t1
= ada_check_typedef (t1
);
4346 if (t1
->code () == TYPE_CODE_PTR
)
4348 arg
= value_ind (arg
);
4355 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4359 v
= ada_search_struct_field (name
, arg
, 0, t
);
4362 int bit_offset
, bit_size
, byte_offset
;
4363 struct type
*field_type
;
4366 if (t
->code () == TYPE_CODE_PTR
)
4367 address
= value_address (ada_value_ind (arg
));
4369 address
= value_address (ada_coerce_ref (arg
));
4371 /* Check to see if this is a tagged type. We also need to handle
4372 the case where the type is a reference to a tagged type, but
4373 we have to be careful to exclude pointers to tagged types.
4374 The latter should be shown as usual (as a pointer), whereas
4375 a reference should mostly be transparent to the user. */
4377 if (ada_is_tagged_type (t1
, 0)
4378 || (t1
->code () == TYPE_CODE_REF
4379 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4381 /* We first try to find the searched field in the current type.
4382 If not found then let's look in the fixed type. */
4384 if (!find_struct_field (name
, t1
, 0,
4385 &field_type
, &byte_offset
, &bit_offset
,
4394 /* Convert to fixed type in all cases, so that we have proper
4395 offsets to each field in unconstrained record types. */
4396 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4397 address
, NULL
, check_tag
);
4399 if (find_struct_field (name
, t1
, 0,
4400 &field_type
, &byte_offset
, &bit_offset
,
4405 if (t
->code () == TYPE_CODE_REF
)
4406 arg
= ada_coerce_ref (arg
);
4408 arg
= ada_value_ind (arg
);
4409 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4410 bit_offset
, bit_size
,
4414 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4418 if (v
!= NULL
|| no_err
)
4421 error (_("There is no member named %s."), name
);
4427 error (_("Attempt to extract a component of "
4428 "a value that is not a record."));
4431 /* Return the value ACTUAL, converted to be an appropriate value for a
4432 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4433 allocating any necessary descriptors (fat pointers), or copies of
4434 values not residing in memory, updating it as needed. */
4437 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4439 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4440 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4441 struct type
*formal_target
=
4442 formal_type
->code () == TYPE_CODE_PTR
4443 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4444 struct type
*actual_target
=
4445 actual_type
->code () == TYPE_CODE_PTR
4446 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4448 if (ada_is_array_descriptor_type (formal_target
)
4449 && actual_target
->code () == TYPE_CODE_ARRAY
)
4450 return make_array_descriptor (formal_type
, actual
);
4451 else if (formal_type
->code () == TYPE_CODE_PTR
4452 || formal_type
->code () == TYPE_CODE_REF
)
4454 struct value
*result
;
4456 if (formal_target
->code () == TYPE_CODE_ARRAY
4457 && ada_is_array_descriptor_type (actual_target
))
4458 result
= desc_data (actual
);
4459 else if (formal_type
->code () != TYPE_CODE_PTR
)
4461 if (VALUE_LVAL (actual
) != lval_memory
)
4465 actual_type
= ada_check_typedef (value_type (actual
));
4466 val
= allocate_value (actual_type
);
4467 memcpy ((char *) value_contents_raw (val
),
4468 (char *) value_contents (actual
),
4469 TYPE_LENGTH (actual_type
));
4470 actual
= ensure_lval (val
);
4472 result
= value_addr (actual
);
4476 return value_cast_pointers (formal_type
, result
, 0);
4478 else if (actual_type
->code () == TYPE_CODE_PTR
)
4479 return ada_value_ind (actual
);
4480 else if (ada_is_aligner_type (formal_type
))
4482 /* We need to turn this parameter into an aligner type
4484 struct value
*aligner
= allocate_value (formal_type
);
4485 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4487 value_assign_to_component (aligner
, component
, actual
);
4494 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4495 type TYPE. This is usually an inefficient no-op except on some targets
4496 (such as AVR) where the representation of a pointer and an address
4500 value_pointer (struct value
*value
, struct type
*type
)
4502 struct gdbarch
*gdbarch
= get_type_arch (type
);
4503 unsigned len
= TYPE_LENGTH (type
);
4504 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4507 addr
= value_address (value
);
4508 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4509 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4514 /* Push a descriptor of type TYPE for array value ARR on the stack at
4515 *SP, updating *SP to reflect the new descriptor. Return either
4516 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4517 to-descriptor type rather than a descriptor type), a struct value *
4518 representing a pointer to this descriptor. */
4520 static struct value
*
4521 make_array_descriptor (struct type
*type
, struct value
*arr
)
4523 struct type
*bounds_type
= desc_bounds_type (type
);
4524 struct type
*desc_type
= desc_base_type (type
);
4525 struct value
*descriptor
= allocate_value (desc_type
);
4526 struct value
*bounds
= allocate_value (bounds_type
);
4529 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4532 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4533 ada_array_bound (arr
, i
, 0),
4534 desc_bound_bitpos (bounds_type
, i
, 0),
4535 desc_bound_bitsize (bounds_type
, i
, 0));
4536 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4537 ada_array_bound (arr
, i
, 1),
4538 desc_bound_bitpos (bounds_type
, i
, 1),
4539 desc_bound_bitsize (bounds_type
, i
, 1));
4542 bounds
= ensure_lval (bounds
);
4544 modify_field (value_type (descriptor
),
4545 value_contents_writeable (descriptor
),
4546 value_pointer (ensure_lval (arr
),
4547 TYPE_FIELD_TYPE (desc_type
, 0)),
4548 fat_pntr_data_bitpos (desc_type
),
4549 fat_pntr_data_bitsize (desc_type
));
4551 modify_field (value_type (descriptor
),
4552 value_contents_writeable (descriptor
),
4553 value_pointer (bounds
,
4554 TYPE_FIELD_TYPE (desc_type
, 1)),
4555 fat_pntr_bounds_bitpos (desc_type
),
4556 fat_pntr_bounds_bitsize (desc_type
));
4558 descriptor
= ensure_lval (descriptor
);
4560 if (type
->code () == TYPE_CODE_PTR
)
4561 return value_addr (descriptor
);
4566 /* Symbol Cache Module */
4568 /* Performance measurements made as of 2010-01-15 indicate that
4569 this cache does bring some noticeable improvements. Depending
4570 on the type of entity being printed, the cache can make it as much
4571 as an order of magnitude faster than without it.
4573 The descriptive type DWARF extension has significantly reduced
4574 the need for this cache, at least when DWARF is being used. However,
4575 even in this case, some expensive name-based symbol searches are still
4576 sometimes necessary - to find an XVZ variable, mostly. */
4578 /* Initialize the contents of SYM_CACHE. */
4581 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4583 obstack_init (&sym_cache
->cache_space
);
4584 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4587 /* Free the memory used by SYM_CACHE. */
4590 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4592 obstack_free (&sym_cache
->cache_space
, NULL
);
4596 /* Return the symbol cache associated to the given program space PSPACE.
4597 If not allocated for this PSPACE yet, allocate and initialize one. */
4599 static struct ada_symbol_cache
*
4600 ada_get_symbol_cache (struct program_space
*pspace
)
4602 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4604 if (pspace_data
->sym_cache
== NULL
)
4606 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4607 ada_init_symbol_cache (pspace_data
->sym_cache
);
4610 return pspace_data
->sym_cache
;
4613 /* Clear all entries from the symbol cache. */
4616 ada_clear_symbol_cache (void)
4618 struct ada_symbol_cache
*sym_cache
4619 = ada_get_symbol_cache (current_program_space
);
4621 obstack_free (&sym_cache
->cache_space
, NULL
);
4622 ada_init_symbol_cache (sym_cache
);
4625 /* Search our cache for an entry matching NAME and DOMAIN.
4626 Return it if found, or NULL otherwise. */
4628 static struct cache_entry
**
4629 find_entry (const char *name
, domain_enum domain
)
4631 struct ada_symbol_cache
*sym_cache
4632 = ada_get_symbol_cache (current_program_space
);
4633 int h
= msymbol_hash (name
) % HASH_SIZE
;
4634 struct cache_entry
**e
;
4636 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4638 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4644 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4645 Return 1 if found, 0 otherwise.
4647 If an entry was found and SYM is not NULL, set *SYM to the entry's
4648 SYM. Same principle for BLOCK if not NULL. */
4651 lookup_cached_symbol (const char *name
, domain_enum domain
,
4652 struct symbol
**sym
, const struct block
**block
)
4654 struct cache_entry
**e
= find_entry (name
, domain
);
4661 *block
= (*e
)->block
;
4665 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4666 in domain DOMAIN, save this result in our symbol cache. */
4669 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4670 const struct block
*block
)
4672 struct ada_symbol_cache
*sym_cache
4673 = ada_get_symbol_cache (current_program_space
);
4675 struct cache_entry
*e
;
4677 /* Symbols for builtin types don't have a block.
4678 For now don't cache such symbols. */
4679 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4682 /* If the symbol is a local symbol, then do not cache it, as a search
4683 for that symbol depends on the context. To determine whether
4684 the symbol is local or not, we check the block where we found it
4685 against the global and static blocks of its associated symtab. */
4687 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4688 GLOBAL_BLOCK
) != block
4689 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4690 STATIC_BLOCK
) != block
)
4693 h
= msymbol_hash (name
) % HASH_SIZE
;
4694 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4695 e
->next
= sym_cache
->root
[h
];
4696 sym_cache
->root
[h
] = e
;
4697 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4705 /* Return the symbol name match type that should be used used when
4706 searching for all symbols matching LOOKUP_NAME.
4708 LOOKUP_NAME is expected to be a symbol name after transformation
4711 static symbol_name_match_type
4712 name_match_type_from_name (const char *lookup_name
)
4714 return (strstr (lookup_name
, "__") == NULL
4715 ? symbol_name_match_type::WILD
4716 : symbol_name_match_type::FULL
);
4719 /* Return the result of a standard (literal, C-like) lookup of NAME in
4720 given DOMAIN, visible from lexical block BLOCK. */
4722 static struct symbol
*
4723 standard_lookup (const char *name
, const struct block
*block
,
4726 /* Initialize it just to avoid a GCC false warning. */
4727 struct block_symbol sym
= {};
4729 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4731 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4732 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4737 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4738 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4739 since they contend in overloading in the same way. */
4741 is_nonfunction (struct block_symbol syms
[], int n
)
4745 for (i
= 0; i
< n
; i
+= 1)
4746 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4747 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4748 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4754 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4755 struct types. Otherwise, they may not. */
4758 equiv_types (struct type
*type0
, struct type
*type1
)
4762 if (type0
== NULL
|| type1
== NULL
4763 || type0
->code () != type1
->code ())
4765 if ((type0
->code () == TYPE_CODE_STRUCT
4766 || type0
->code () == TYPE_CODE_ENUM
)
4767 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4768 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4774 /* True iff SYM0 represents the same entity as SYM1, or one that is
4775 no more defined than that of SYM1. */
4778 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4782 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4783 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4786 switch (SYMBOL_CLASS (sym0
))
4792 struct type
*type0
= SYMBOL_TYPE (sym0
);
4793 struct type
*type1
= SYMBOL_TYPE (sym1
);
4794 const char *name0
= sym0
->linkage_name ();
4795 const char *name1
= sym1
->linkage_name ();
4796 int len0
= strlen (name0
);
4799 type0
->code () == type1
->code ()
4800 && (equiv_types (type0
, type1
)
4801 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4802 && startswith (name1
+ len0
, "___XV")));
4805 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4806 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4810 const char *name0
= sym0
->linkage_name ();
4811 const char *name1
= sym1
->linkage_name ();
4812 return (strcmp (name0
, name1
) == 0
4813 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4821 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4822 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4825 add_defn_to_vec (struct obstack
*obstackp
,
4827 const struct block
*block
)
4830 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4832 /* Do not try to complete stub types, as the debugger is probably
4833 already scanning all symbols matching a certain name at the
4834 time when this function is called. Trying to replace the stub
4835 type by its associated full type will cause us to restart a scan
4836 which may lead to an infinite recursion. Instead, the client
4837 collecting the matching symbols will end up collecting several
4838 matches, with at least one of them complete. It can then filter
4839 out the stub ones if needed. */
4841 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4843 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4845 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4847 prevDefns
[i
].symbol
= sym
;
4848 prevDefns
[i
].block
= block
;
4854 struct block_symbol info
;
4858 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4862 /* Number of block_symbol structures currently collected in current vector in
4866 num_defns_collected (struct obstack
*obstackp
)
4868 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4871 /* Vector of block_symbol structures currently collected in current vector in
4872 OBSTACKP. If FINISH, close off the vector and return its final address. */
4874 static struct block_symbol
*
4875 defns_collected (struct obstack
*obstackp
, int finish
)
4878 return (struct block_symbol
*) obstack_finish (obstackp
);
4880 return (struct block_symbol
*) obstack_base (obstackp
);
4883 /* Return a bound minimal symbol matching NAME according to Ada
4884 decoding rules. Returns an invalid symbol if there is no such
4885 minimal symbol. Names prefixed with "standard__" are handled
4886 specially: "standard__" is first stripped off, and only static and
4887 global symbols are searched. */
4889 struct bound_minimal_symbol
4890 ada_lookup_simple_minsym (const char *name
)
4892 struct bound_minimal_symbol result
;
4894 memset (&result
, 0, sizeof (result
));
4896 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4897 lookup_name_info
lookup_name (name
, match_type
);
4899 symbol_name_matcher_ftype
*match_name
4900 = ada_get_symbol_name_matcher (lookup_name
);
4902 for (objfile
*objfile
: current_program_space
->objfiles ())
4904 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4906 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4907 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4909 result
.minsym
= msymbol
;
4910 result
.objfile
= objfile
;
4919 /* For all subprograms that statically enclose the subprogram of the
4920 selected frame, add symbols matching identifier NAME in DOMAIN
4921 and their blocks to the list of data in OBSTACKP, as for
4922 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4923 with a wildcard prefix. */
4926 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4927 const lookup_name_info
&lookup_name
,
4932 /* True if TYPE is definitely an artificial type supplied to a symbol
4933 for which no debugging information was given in the symbol file. */
4936 is_nondebugging_type (struct type
*type
)
4938 const char *name
= ada_type_name (type
);
4940 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4943 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4944 that are deemed "identical" for practical purposes.
4946 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4947 types and that their number of enumerals is identical (in other
4948 words, type1->num_fields () == type2->num_fields ()). */
4951 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4955 /* The heuristic we use here is fairly conservative. We consider
4956 that 2 enumerate types are identical if they have the same
4957 number of enumerals and that all enumerals have the same
4958 underlying value and name. */
4960 /* All enums in the type should have an identical underlying value. */
4961 for (i
= 0; i
< type1
->num_fields (); i
++)
4962 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4965 /* All enumerals should also have the same name (modulo any numerical
4967 for (i
= 0; i
< type1
->num_fields (); i
++)
4969 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4970 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4971 int len_1
= strlen (name_1
);
4972 int len_2
= strlen (name_2
);
4974 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4975 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4977 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4978 TYPE_FIELD_NAME (type2
, i
),
4986 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4987 that are deemed "identical" for practical purposes. Sometimes,
4988 enumerals are not strictly identical, but their types are so similar
4989 that they can be considered identical.
4991 For instance, consider the following code:
4993 type Color is (Black, Red, Green, Blue, White);
4994 type RGB_Color is new Color range Red .. Blue;
4996 Type RGB_Color is a subrange of an implicit type which is a copy
4997 of type Color. If we call that implicit type RGB_ColorB ("B" is
4998 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4999 As a result, when an expression references any of the enumeral
5000 by name (Eg. "print green"), the expression is technically
5001 ambiguous and the user should be asked to disambiguate. But
5002 doing so would only hinder the user, since it wouldn't matter
5003 what choice he makes, the outcome would always be the same.
5004 So, for practical purposes, we consider them as the same. */
5007 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5011 /* Before performing a thorough comparison check of each type,
5012 we perform a series of inexpensive checks. We expect that these
5013 checks will quickly fail in the vast majority of cases, and thus
5014 help prevent the unnecessary use of a more expensive comparison.
5015 Said comparison also expects us to make some of these checks
5016 (see ada_identical_enum_types_p). */
5018 /* Quick check: All symbols should have an enum type. */
5019 for (i
= 0; i
< syms
.size (); i
++)
5020 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
5023 /* Quick check: They should all have the same value. */
5024 for (i
= 1; i
< syms
.size (); i
++)
5025 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5028 /* Quick check: They should all have the same number of enumerals. */
5029 for (i
= 1; i
< syms
.size (); i
++)
5030 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
5031 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
5034 /* All the sanity checks passed, so we might have a set of
5035 identical enumeration types. Perform a more complete
5036 comparison of the type of each symbol. */
5037 for (i
= 1; i
< syms
.size (); i
++)
5038 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5039 SYMBOL_TYPE (syms
[0].symbol
)))
5045 /* Remove any non-debugging symbols in SYMS that definitely
5046 duplicate other symbols in the list (The only case I know of where
5047 this happens is when object files containing stabs-in-ecoff are
5048 linked with files containing ordinary ecoff debugging symbols (or no
5049 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5050 Returns the number of items in the modified list. */
5053 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5057 /* We should never be called with less than 2 symbols, as there
5058 cannot be any extra symbol in that case. But it's easy to
5059 handle, since we have nothing to do in that case. */
5060 if (syms
->size () < 2)
5061 return syms
->size ();
5064 while (i
< syms
->size ())
5068 /* If two symbols have the same name and one of them is a stub type,
5069 the get rid of the stub. */
5071 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
5072 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5074 for (j
= 0; j
< syms
->size (); j
++)
5077 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
5078 && (*syms
)[j
].symbol
->linkage_name () != NULL
5079 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5080 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5085 /* Two symbols with the same name, same class and same address
5086 should be identical. */
5088 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5089 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5090 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5092 for (j
= 0; j
< syms
->size (); j
+= 1)
5095 && (*syms
)[j
].symbol
->linkage_name () != NULL
5096 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5097 (*syms
)[j
].symbol
->linkage_name ()) == 0
5098 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5099 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5100 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5101 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5107 syms
->erase (syms
->begin () + i
);
5112 /* If all the remaining symbols are identical enumerals, then
5113 just keep the first one and discard the rest.
5115 Unlike what we did previously, we do not discard any entry
5116 unless they are ALL identical. This is because the symbol
5117 comparison is not a strict comparison, but rather a practical
5118 comparison. If all symbols are considered identical, then
5119 we can just go ahead and use the first one and discard the rest.
5120 But if we cannot reduce the list to a single element, we have
5121 to ask the user to disambiguate anyways. And if we have to
5122 present a multiple-choice menu, it's less confusing if the list
5123 isn't missing some choices that were identical and yet distinct. */
5124 if (symbols_are_identical_enums (*syms
))
5127 return syms
->size ();
5130 /* Given a type that corresponds to a renaming entity, use the type name
5131 to extract the scope (package name or function name, fully qualified,
5132 and following the GNAT encoding convention) where this renaming has been
5136 xget_renaming_scope (struct type
*renaming_type
)
5138 /* The renaming types adhere to the following convention:
5139 <scope>__<rename>___<XR extension>.
5140 So, to extract the scope, we search for the "___XR" extension,
5141 and then backtrack until we find the first "__". */
5143 const char *name
= renaming_type
->name ();
5144 const char *suffix
= strstr (name
, "___XR");
5147 /* Now, backtrack a bit until we find the first "__". Start looking
5148 at suffix - 3, as the <rename> part is at least one character long. */
5150 for (last
= suffix
- 3; last
> name
; last
--)
5151 if (last
[0] == '_' && last
[1] == '_')
5154 /* Make a copy of scope and return it. */
5155 return std::string (name
, last
);
5158 /* Return nonzero if NAME corresponds to a package name. */
5161 is_package_name (const char *name
)
5163 /* Here, We take advantage of the fact that no symbols are generated
5164 for packages, while symbols are generated for each function.
5165 So the condition for NAME represent a package becomes equivalent
5166 to NAME not existing in our list of symbols. There is only one
5167 small complication with library-level functions (see below). */
5169 /* If it is a function that has not been defined at library level,
5170 then we should be able to look it up in the symbols. */
5171 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5174 /* Library-level function names start with "_ada_". See if function
5175 "_ada_" followed by NAME can be found. */
5177 /* Do a quick check that NAME does not contain "__", since library-level
5178 functions names cannot contain "__" in them. */
5179 if (strstr (name
, "__") != NULL
)
5182 std::string fun_name
= string_printf ("_ada_%s", name
);
5184 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5187 /* Return nonzero if SYM corresponds to a renaming entity that is
5188 not visible from FUNCTION_NAME. */
5191 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5193 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5196 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5198 /* If the rename has been defined in a package, then it is visible. */
5199 if (is_package_name (scope
.c_str ()))
5202 /* Check that the rename is in the current function scope by checking
5203 that its name starts with SCOPE. */
5205 /* If the function name starts with "_ada_", it means that it is
5206 a library-level function. Strip this prefix before doing the
5207 comparison, as the encoding for the renaming does not contain
5209 if (startswith (function_name
, "_ada_"))
5212 return !startswith (function_name
, scope
.c_str ());
5215 /* Remove entries from SYMS that corresponds to a renaming entity that
5216 is not visible from the function associated with CURRENT_BLOCK or
5217 that is superfluous due to the presence of more specific renaming
5218 information. Places surviving symbols in the initial entries of
5219 SYMS and returns the number of surviving symbols.
5222 First, in cases where an object renaming is implemented as a
5223 reference variable, GNAT may produce both the actual reference
5224 variable and the renaming encoding. In this case, we discard the
5227 Second, GNAT emits a type following a specified encoding for each renaming
5228 entity. Unfortunately, STABS currently does not support the definition
5229 of types that are local to a given lexical block, so all renamings types
5230 are emitted at library level. As a consequence, if an application
5231 contains two renaming entities using the same name, and a user tries to
5232 print the value of one of these entities, the result of the ada symbol
5233 lookup will also contain the wrong renaming type.
5235 This function partially covers for this limitation by attempting to
5236 remove from the SYMS list renaming symbols that should be visible
5237 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5238 method with the current information available. The implementation
5239 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5241 - When the user tries to print a rename in a function while there
5242 is another rename entity defined in a package: Normally, the
5243 rename in the function has precedence over the rename in the
5244 package, so the latter should be removed from the list. This is
5245 currently not the case.
5247 - This function will incorrectly remove valid renames if
5248 the CURRENT_BLOCK corresponds to a function which symbol name
5249 has been changed by an "Export" pragma. As a consequence,
5250 the user will be unable to print such rename entities. */
5253 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5254 const struct block
*current_block
)
5256 struct symbol
*current_function
;
5257 const char *current_function_name
;
5259 int is_new_style_renaming
;
5261 /* If there is both a renaming foo___XR... encoded as a variable and
5262 a simple variable foo in the same block, discard the latter.
5263 First, zero out such symbols, then compress. */
5264 is_new_style_renaming
= 0;
5265 for (i
= 0; i
< syms
->size (); i
+= 1)
5267 struct symbol
*sym
= (*syms
)[i
].symbol
;
5268 const struct block
*block
= (*syms
)[i
].block
;
5272 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5274 name
= sym
->linkage_name ();
5275 suffix
= strstr (name
, "___XR");
5279 int name_len
= suffix
- name
;
5282 is_new_style_renaming
= 1;
5283 for (j
= 0; j
< syms
->size (); j
+= 1)
5284 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5285 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5287 && block
== (*syms
)[j
].block
)
5288 (*syms
)[j
].symbol
= NULL
;
5291 if (is_new_style_renaming
)
5295 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5296 if ((*syms
)[j
].symbol
!= NULL
)
5298 (*syms
)[k
] = (*syms
)[j
];
5304 /* Extract the function name associated to CURRENT_BLOCK.
5305 Abort if unable to do so. */
5307 if (current_block
== NULL
)
5308 return syms
->size ();
5310 current_function
= block_linkage_function (current_block
);
5311 if (current_function
== NULL
)
5312 return syms
->size ();
5314 current_function_name
= current_function
->linkage_name ();
5315 if (current_function_name
== NULL
)
5316 return syms
->size ();
5318 /* Check each of the symbols, and remove it from the list if it is
5319 a type corresponding to a renaming that is out of the scope of
5320 the current block. */
5323 while (i
< syms
->size ())
5325 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5326 == ADA_OBJECT_RENAMING
5327 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5328 current_function_name
))
5329 syms
->erase (syms
->begin () + i
);
5334 return syms
->size ();
5337 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5338 whose name and domain match NAME and DOMAIN respectively.
5339 If no match was found, then extend the search to "enclosing"
5340 routines (in other words, if we're inside a nested function,
5341 search the symbols defined inside the enclosing functions).
5342 If WILD_MATCH_P is nonzero, perform the naming matching in
5343 "wild" mode (see function "wild_match" for more info).
5345 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5348 ada_add_local_symbols (struct obstack
*obstackp
,
5349 const lookup_name_info
&lookup_name
,
5350 const struct block
*block
, domain_enum domain
)
5352 int block_depth
= 0;
5354 while (block
!= NULL
)
5357 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5359 /* If we found a non-function match, assume that's the one. */
5360 if (is_nonfunction (defns_collected (obstackp
, 0),
5361 num_defns_collected (obstackp
)))
5364 block
= BLOCK_SUPERBLOCK (block
);
5367 /* If no luck so far, try to find NAME as a local symbol in some lexically
5368 enclosing subprogram. */
5369 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5370 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5373 /* An object of this type is used as the user_data argument when
5374 calling the map_matching_symbols method. */
5378 struct objfile
*objfile
;
5379 struct obstack
*obstackp
;
5380 struct symbol
*arg_sym
;
5384 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5385 to a list of symbols. DATA is a pointer to a struct match_data *
5386 containing the obstack that collects the symbol list, the file that SYM
5387 must come from, a flag indicating whether a non-argument symbol has
5388 been found in the current block, and the last argument symbol
5389 passed in SYM within the current block (if any). When SYM is null,
5390 marking the end of a block, the argument symbol is added if no
5391 other has been found. */
5394 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5395 struct match_data
*data
)
5397 const struct block
*block
= bsym
->block
;
5398 struct symbol
*sym
= bsym
->symbol
;
5402 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5403 add_defn_to_vec (data
->obstackp
,
5404 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5406 data
->found_sym
= 0;
5407 data
->arg_sym
= NULL
;
5411 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5413 else if (SYMBOL_IS_ARGUMENT (sym
))
5414 data
->arg_sym
= sym
;
5417 data
->found_sym
= 1;
5418 add_defn_to_vec (data
->obstackp
,
5419 fixup_symbol_section (sym
, data
->objfile
),
5426 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5427 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5428 symbols to OBSTACKP. Return whether we found such symbols. */
5431 ada_add_block_renamings (struct obstack
*obstackp
,
5432 const struct block
*block
,
5433 const lookup_name_info
&lookup_name
,
5436 struct using_direct
*renaming
;
5437 int defns_mark
= num_defns_collected (obstackp
);
5439 symbol_name_matcher_ftype
*name_match
5440 = ada_get_symbol_name_matcher (lookup_name
);
5442 for (renaming
= block_using (block
);
5444 renaming
= renaming
->next
)
5448 /* Avoid infinite recursions: skip this renaming if we are actually
5449 already traversing it.
5451 Currently, symbol lookup in Ada don't use the namespace machinery from
5452 C++/Fortran support: skip namespace imports that use them. */
5453 if (renaming
->searched
5454 || (renaming
->import_src
!= NULL
5455 && renaming
->import_src
[0] != '\0')
5456 || (renaming
->import_dest
!= NULL
5457 && renaming
->import_dest
[0] != '\0'))
5459 renaming
->searched
= 1;
5461 /* TODO: here, we perform another name-based symbol lookup, which can
5462 pull its own multiple overloads. In theory, we should be able to do
5463 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5464 not a simple name. But in order to do this, we would need to enhance
5465 the DWARF reader to associate a symbol to this renaming, instead of a
5466 name. So, for now, we do something simpler: re-use the C++/Fortran
5467 namespace machinery. */
5468 r_name
= (renaming
->alias
!= NULL
5470 : renaming
->declaration
);
5471 if (name_match (r_name
, lookup_name
, NULL
))
5473 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5474 lookup_name
.match_type ());
5475 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5478 renaming
->searched
= 0;
5480 return num_defns_collected (obstackp
) != defns_mark
;
5483 /* Implements compare_names, but only applying the comparision using
5484 the given CASING. */
5487 compare_names_with_case (const char *string1
, const char *string2
,
5488 enum case_sensitivity casing
)
5490 while (*string1
!= '\0' && *string2
!= '\0')
5494 if (isspace (*string1
) || isspace (*string2
))
5495 return strcmp_iw_ordered (string1
, string2
);
5497 if (casing
== case_sensitive_off
)
5499 c1
= tolower (*string1
);
5500 c2
= tolower (*string2
);
5517 return strcmp_iw_ordered (string1
, string2
);
5519 if (*string2
== '\0')
5521 if (is_name_suffix (string1
))
5528 if (*string2
== '(')
5529 return strcmp_iw_ordered (string1
, string2
);
5532 if (casing
== case_sensitive_off
)
5533 return tolower (*string1
) - tolower (*string2
);
5535 return *string1
- *string2
;
5540 /* Compare STRING1 to STRING2, with results as for strcmp.
5541 Compatible with strcmp_iw_ordered in that...
5543 strcmp_iw_ordered (STRING1, STRING2) <= 0
5547 compare_names (STRING1, STRING2) <= 0
5549 (they may differ as to what symbols compare equal). */
5552 compare_names (const char *string1
, const char *string2
)
5556 /* Similar to what strcmp_iw_ordered does, we need to perform
5557 a case-insensitive comparison first, and only resort to
5558 a second, case-sensitive, comparison if the first one was
5559 not sufficient to differentiate the two strings. */
5561 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5563 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5568 /* Convenience function to get at the Ada encoded lookup name for
5569 LOOKUP_NAME, as a C string. */
5572 ada_lookup_name (const lookup_name_info
&lookup_name
)
5574 return lookup_name
.ada ().lookup_name ().c_str ();
5577 /* Add to OBSTACKP all non-local symbols whose name and domain match
5578 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5579 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5580 symbols otherwise. */
5583 add_nonlocal_symbols (struct obstack
*obstackp
,
5584 const lookup_name_info
&lookup_name
,
5585 domain_enum domain
, int global
)
5587 struct match_data data
;
5589 memset (&data
, 0, sizeof data
);
5590 data
.obstackp
= obstackp
;
5592 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5594 auto callback
= [&] (struct block_symbol
*bsym
)
5596 return aux_add_nonlocal_symbols (bsym
, &data
);
5599 for (objfile
*objfile
: current_program_space
->objfiles ())
5601 data
.objfile
= objfile
;
5603 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5604 domain
, global
, callback
,
5606 ? NULL
: compare_names
));
5608 for (compunit_symtab
*cu
: objfile
->compunits ())
5610 const struct block
*global_block
5611 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5613 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5619 if (num_defns_collected (obstackp
) == 0 && 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 ())
5627 data
.objfile
= objfile
;
5628 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5629 domain
, global
, callback
,
5635 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5636 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5637 returning the number of matches. Add these to OBSTACKP.
5639 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5640 symbol match within the nest of blocks whose innermost member is BLOCK,
5641 is the one match returned (no other matches in that or
5642 enclosing blocks is returned). If there are any matches in or
5643 surrounding BLOCK, then these alone are returned.
5645 Names prefixed with "standard__" are handled specially:
5646 "standard__" is first stripped off (by the lookup_name
5647 constructor), and only static and global symbols are searched.
5649 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5650 to lookup global symbols. */
5653 ada_add_all_symbols (struct obstack
*obstackp
,
5654 const struct block
*block
,
5655 const lookup_name_info
&lookup_name
,
5658 int *made_global_lookup_p
)
5662 if (made_global_lookup_p
)
5663 *made_global_lookup_p
= 0;
5665 /* Special case: If the user specifies a symbol name inside package
5666 Standard, do a non-wild matching of the symbol name without
5667 the "standard__" prefix. This was primarily introduced in order
5668 to allow the user to specifically access the standard exceptions
5669 using, for instance, Standard.Constraint_Error when Constraint_Error
5670 is ambiguous (due to the user defining its own Constraint_Error
5671 entity inside its program). */
5672 if (lookup_name
.ada ().standard_p ())
5675 /* Check the non-global symbols. If we have ANY match, then we're done. */
5680 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5683 /* In the !full_search case we're are being called by
5684 ada_iterate_over_symbols, and we don't want to search
5686 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5688 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5692 /* No non-global symbols found. Check our cache to see if we have
5693 already performed this search before. If we have, then return
5696 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5697 domain
, &sym
, &block
))
5700 add_defn_to_vec (obstackp
, sym
, block
);
5704 if (made_global_lookup_p
)
5705 *made_global_lookup_p
= 1;
5707 /* Search symbols from all global blocks. */
5709 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5711 /* Now add symbols from all per-file blocks if we've gotten no hits
5712 (not strictly correct, but perhaps better than an error). */
5714 if (num_defns_collected (obstackp
) == 0)
5715 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5718 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5719 is non-zero, enclosing scope and in global scopes, returning the number of
5721 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5722 found and the blocks and symbol tables (if any) in which they were
5725 When full_search is non-zero, any non-function/non-enumeral
5726 symbol match within the nest of blocks whose innermost member is BLOCK,
5727 is the one match returned (no other matches in that or
5728 enclosing blocks is returned). If there are any matches in or
5729 surrounding BLOCK, then these alone are returned.
5731 Names prefixed with "standard__" are handled specially: "standard__"
5732 is first stripped off, and only static and global symbols are searched. */
5735 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5736 const struct block
*block
,
5738 std::vector
<struct block_symbol
> *results
,
5741 int syms_from_global_search
;
5743 auto_obstack obstack
;
5745 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5746 domain
, full_search
, &syms_from_global_search
);
5748 ndefns
= num_defns_collected (&obstack
);
5750 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5751 for (int i
= 0; i
< ndefns
; ++i
)
5752 results
->push_back (base
[i
]);
5754 ndefns
= remove_extra_symbols (results
);
5756 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5757 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5759 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5760 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5761 (*results
)[0].symbol
, (*results
)[0].block
);
5763 ndefns
= remove_irrelevant_renamings (results
, block
);
5768 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5769 in global scopes, returning the number of matches, and filling *RESULTS
5770 with (SYM,BLOCK) tuples.
5772 See ada_lookup_symbol_list_worker for further details. */
5775 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5777 std::vector
<struct block_symbol
> *results
)
5779 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5780 lookup_name_info
lookup_name (name
, name_match_type
);
5782 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5785 /* Implementation of the la_iterate_over_symbols method. */
5788 ada_iterate_over_symbols
5789 (const struct block
*block
, const lookup_name_info
&name
,
5791 gdb::function_view
<symbol_found_callback_ftype
> callback
)
5794 std::vector
<struct block_symbol
> results
;
5796 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5798 for (i
= 0; i
< ndefs
; ++i
)
5800 if (!callback (&results
[i
]))
5807 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5808 to 1, but choosing the first symbol found if there are multiple
5811 The result is stored in *INFO, which must be non-NULL.
5812 If no match is found, INFO->SYM is set to NULL. */
5815 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5817 struct block_symbol
*info
)
5819 /* Since we already have an encoded name, wrap it in '<>' to force a
5820 verbatim match. Otherwise, if the name happens to not look like
5821 an encoded name (because it doesn't include a "__"),
5822 ada_lookup_name_info would re-encode/fold it again, and that
5823 would e.g., incorrectly lowercase object renaming names like
5824 "R28b" -> "r28b". */
5825 std::string verbatim
= std::string ("<") + name
+ '>';
5827 gdb_assert (info
!= NULL
);
5828 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5831 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5832 scope and in global scopes, or NULL if none. NAME is folded and
5833 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5834 choosing the first symbol if there are multiple choices. */
5837 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5840 std::vector
<struct block_symbol
> candidates
;
5843 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5845 if (n_candidates
== 0)
5848 block_symbol info
= candidates
[0];
5849 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5853 static struct block_symbol
5854 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5856 const struct block
*block
,
5857 const domain_enum domain
)
5859 struct block_symbol sym
;
5861 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
5862 if (sym
.symbol
!= NULL
)
5865 /* If we haven't found a match at this point, try the primitive
5866 types. In other languages, this search is performed before
5867 searching for global symbols in order to short-circuit that
5868 global-symbol search if it happens that the name corresponds
5869 to a primitive type. But we cannot do the same in Ada, because
5870 it is perfectly legitimate for a program to declare a type which
5871 has the same name as a standard type. If looking up a type in
5872 that situation, we have traditionally ignored the primitive type
5873 in favor of user-defined types. This is why, unlike most other
5874 languages, we search the primitive types this late and only after
5875 having searched the global symbols without success. */
5877 if (domain
== VAR_DOMAIN
)
5879 struct gdbarch
*gdbarch
;
5882 gdbarch
= target_gdbarch ();
5884 gdbarch
= block_gdbarch (block
);
5885 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5886 if (sym
.symbol
!= NULL
)
5894 /* True iff STR is a possible encoded suffix of a normal Ada name
5895 that is to be ignored for matching purposes. Suffixes of parallel
5896 names (e.g., XVE) are not included here. Currently, the possible suffixes
5897 are given by any of the regular expressions:
5899 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5900 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5901 TKB [subprogram suffix for task bodies]
5902 _E[0-9]+[bs]$ [protected object entry suffixes]
5903 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5905 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5906 match is performed. This sequence is used to differentiate homonyms,
5907 is an optional part of a valid name suffix. */
5910 is_name_suffix (const char *str
)
5913 const char *matching
;
5914 const int len
= strlen (str
);
5916 /* Skip optional leading __[0-9]+. */
5918 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5921 while (isdigit (str
[0]))
5927 if (str
[0] == '.' || str
[0] == '$')
5930 while (isdigit (matching
[0]))
5932 if (matching
[0] == '\0')
5938 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5941 while (isdigit (matching
[0]))
5943 if (matching
[0] == '\0')
5947 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5949 if (strcmp (str
, "TKB") == 0)
5953 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5954 with a N at the end. Unfortunately, the compiler uses the same
5955 convention for other internal types it creates. So treating
5956 all entity names that end with an "N" as a name suffix causes
5957 some regressions. For instance, consider the case of an enumerated
5958 type. To support the 'Image attribute, it creates an array whose
5960 Having a single character like this as a suffix carrying some
5961 information is a bit risky. Perhaps we should change the encoding
5962 to be something like "_N" instead. In the meantime, do not do
5963 the following check. */
5964 /* Protected Object Subprograms */
5965 if (len
== 1 && str
[0] == 'N')
5970 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5973 while (isdigit (matching
[0]))
5975 if ((matching
[0] == 'b' || matching
[0] == 's')
5976 && matching
[1] == '\0')
5980 /* ??? We should not modify STR directly, as we are doing below. This
5981 is fine in this case, but may become problematic later if we find
5982 that this alternative did not work, and want to try matching
5983 another one from the begining of STR. Since we modified it, we
5984 won't be able to find the begining of the string anymore! */
5988 while (str
[0] != '_' && str
[0] != '\0')
5990 if (str
[0] != 'n' && str
[0] != 'b')
5996 if (str
[0] == '\000')
6001 if (str
[1] != '_' || str
[2] == '\000')
6005 if (strcmp (str
+ 3, "JM") == 0)
6007 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6008 the LJM suffix in favor of the JM one. But we will
6009 still accept LJM as a valid suffix for a reasonable
6010 amount of time, just to allow ourselves to debug programs
6011 compiled using an older version of GNAT. */
6012 if (strcmp (str
+ 3, "LJM") == 0)
6016 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
6017 || str
[4] == 'U' || str
[4] == 'P')
6019 if (str
[4] == 'R' && str
[5] != 'T')
6023 if (!isdigit (str
[2]))
6025 for (k
= 3; str
[k
] != '\0'; k
+= 1)
6026 if (!isdigit (str
[k
]) && str
[k
] != '_')
6030 if (str
[0] == '$' && isdigit (str
[1]))
6032 for (k
= 2; str
[k
] != '\0'; k
+= 1)
6033 if (!isdigit (str
[k
]) && str
[k
] != '_')
6040 /* Return non-zero if the string starting at NAME and ending before
6041 NAME_END contains no capital letters. */
6044 is_valid_name_for_wild_match (const char *name0
)
6046 std::string decoded_name
= ada_decode (name0
);
6049 /* If the decoded name starts with an angle bracket, it means that
6050 NAME0 does not follow the GNAT encoding format. It should then
6051 not be allowed as a possible wild match. */
6052 if (decoded_name
[0] == '<')
6055 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6056 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6062 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6063 that could start a simple name. Assumes that *NAMEP points into
6064 the string beginning at NAME0. */
6067 advance_wild_match (const char **namep
, const char *name0
, int target0
)
6069 const char *name
= *namep
;
6079 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6082 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6087 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6088 || name
[2] == target0
))
6096 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6106 /* Return true iff NAME encodes a name of the form prefix.PATN.
6107 Ignores any informational suffixes of NAME (i.e., for which
6108 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6112 wild_match (const char *name
, const char *patn
)
6115 const char *name0
= name
;
6119 const char *match
= name
;
6123 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6126 if (*p
== '\0' && is_name_suffix (name
))
6127 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6129 if (name
[-1] == '_')
6132 if (!advance_wild_match (&name
, name0
, *patn
))
6137 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6138 any trailing suffixes that encode debugging information or leading
6139 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6140 information that is ignored). */
6143 full_match (const char *sym_name
, const char *search_name
)
6145 size_t search_name_len
= strlen (search_name
);
6147 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6148 && is_name_suffix (sym_name
+ search_name_len
))
6151 if (startswith (sym_name
, "_ada_")
6152 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6153 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6159 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6160 *defn_symbols, updating the list of symbols in OBSTACKP (if
6161 necessary). OBJFILE is the section containing BLOCK. */
6164 ada_add_block_symbols (struct obstack
*obstackp
,
6165 const struct block
*block
,
6166 const lookup_name_info
&lookup_name
,
6167 domain_enum domain
, struct objfile
*objfile
)
6169 struct block_iterator iter
;
6170 /* A matching argument symbol, if any. */
6171 struct symbol
*arg_sym
;
6172 /* Set true when we find a matching non-argument symbol. */
6178 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6180 sym
= block_iter_match_next (lookup_name
, &iter
))
6182 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6184 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6186 if (SYMBOL_IS_ARGUMENT (sym
))
6191 add_defn_to_vec (obstackp
,
6192 fixup_symbol_section (sym
, objfile
),
6199 /* Handle renamings. */
6201 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6204 if (!found_sym
&& arg_sym
!= NULL
)
6206 add_defn_to_vec (obstackp
,
6207 fixup_symbol_section (arg_sym
, objfile
),
6211 if (!lookup_name
.ada ().wild_match_p ())
6215 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6216 const char *name
= ada_lookup_name
.c_str ();
6217 size_t name_len
= ada_lookup_name
.size ();
6219 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6221 if (symbol_matches_domain (sym
->language (),
6222 SYMBOL_DOMAIN (sym
), domain
))
6226 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6229 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6231 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6236 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6238 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6240 if (SYMBOL_IS_ARGUMENT (sym
))
6245 add_defn_to_vec (obstackp
,
6246 fixup_symbol_section (sym
, objfile
),
6254 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6255 They aren't parameters, right? */
6256 if (!found_sym
&& arg_sym
!= NULL
)
6258 add_defn_to_vec (obstackp
,
6259 fixup_symbol_section (arg_sym
, objfile
),
6266 /* Symbol Completion */
6271 ada_lookup_name_info::matches
6272 (const char *sym_name
,
6273 symbol_name_match_type match_type
,
6274 completion_match_result
*comp_match_res
) const
6277 const char *text
= m_encoded_name
.c_str ();
6278 size_t text_len
= m_encoded_name
.size ();
6280 /* First, test against the fully qualified name of the symbol. */
6282 if (strncmp (sym_name
, text
, text_len
) == 0)
6285 std::string decoded_name
= ada_decode (sym_name
);
6286 if (match
&& !m_encoded_p
)
6288 /* One needed check before declaring a positive match is to verify
6289 that iff we are doing a verbatim match, the decoded version
6290 of the symbol name starts with '<'. Otherwise, this symbol name
6291 is not a suitable completion. */
6293 bool has_angle_bracket
= (decoded_name
[0] == '<');
6294 match
= (has_angle_bracket
== m_verbatim_p
);
6297 if (match
&& !m_verbatim_p
)
6299 /* When doing non-verbatim match, another check that needs to
6300 be done is to verify that the potentially matching symbol name
6301 does not include capital letters, because the ada-mode would
6302 not be able to understand these symbol names without the
6303 angle bracket notation. */
6306 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6311 /* Second: Try wild matching... */
6313 if (!match
&& m_wild_match_p
)
6315 /* Since we are doing wild matching, this means that TEXT
6316 may represent an unqualified symbol name. We therefore must
6317 also compare TEXT against the unqualified name of the symbol. */
6318 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6320 if (strncmp (sym_name
, text
, text_len
) == 0)
6324 /* Finally: If we found a match, prepare the result to return. */
6329 if (comp_match_res
!= NULL
)
6331 std::string
&match_str
= comp_match_res
->match
.storage ();
6334 match_str
= ada_decode (sym_name
);
6338 match_str
= add_angle_brackets (sym_name
);
6340 match_str
= sym_name
;
6344 comp_match_res
->set_match (match_str
.c_str ());
6350 /* Add the list of possible symbol names completing TEXT to TRACKER.
6351 WORD is the entire command on which completion is made. */
6354 ada_collect_symbol_completion_matches (completion_tracker
&tracker
,
6355 complete_symbol_mode mode
,
6356 symbol_name_match_type name_match_type
,
6357 const char *text
, const char *word
,
6358 enum type_code code
)
6361 const struct block
*b
, *surrounding_static_block
= 0;
6362 struct block_iterator iter
;
6364 gdb_assert (code
== TYPE_CODE_UNDEF
);
6366 lookup_name_info
lookup_name (text
, name_match_type
, true);
6368 /* First, look at the partial symtab symbols. */
6369 expand_symtabs_matching (NULL
,
6375 /* At this point scan through the misc symbol vectors and add each
6376 symbol you find to the list. Eventually we want to ignore
6377 anything that isn't a text symbol (everything else will be
6378 handled by the psymtab code above). */
6380 for (objfile
*objfile
: current_program_space
->objfiles ())
6382 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
6386 if (completion_skip_symbol (mode
, msymbol
))
6389 language symbol_language
= msymbol
->language ();
6391 /* Ada minimal symbols won't have their language set to Ada. If
6392 we let completion_list_add_name compare using the
6393 default/C-like matcher, then when completing e.g., symbols in a
6394 package named "pck", we'd match internal Ada symbols like
6395 "pckS", which are invalid in an Ada expression, unless you wrap
6396 them in '<' '>' to request a verbatim match.
6398 Unfortunately, some Ada encoded names successfully demangle as
6399 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6400 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6401 with the wrong language set. Paper over that issue here. */
6402 if (symbol_language
== language_auto
6403 || symbol_language
== language_cplus
)
6404 symbol_language
= language_ada
;
6406 completion_list_add_name (tracker
,
6408 msymbol
->linkage_name (),
6409 lookup_name
, text
, word
);
6413 /* Search upwards from currently selected frame (so that we can
6414 complete on local vars. */
6416 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6418 if (!BLOCK_SUPERBLOCK (b
))
6419 surrounding_static_block
= b
; /* For elmin of dups */
6421 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6423 if (completion_skip_symbol (mode
, sym
))
6426 completion_list_add_name (tracker
,
6428 sym
->linkage_name (),
6429 lookup_name
, text
, word
);
6433 /* Go through the symtabs and check the externs and statics for
6434 symbols which match. */
6436 for (objfile
*objfile
: current_program_space
->objfiles ())
6438 for (compunit_symtab
*s
: objfile
->compunits ())
6441 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6442 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6444 if (completion_skip_symbol (mode
, sym
))
6447 completion_list_add_name (tracker
,
6449 sym
->linkage_name (),
6450 lookup_name
, text
, word
);
6455 for (objfile
*objfile
: current_program_space
->objfiles ())
6457 for (compunit_symtab
*s
: objfile
->compunits ())
6460 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6461 /* Don't do this block twice. */
6462 if (b
== surrounding_static_block
)
6464 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6466 if (completion_skip_symbol (mode
, sym
))
6469 completion_list_add_name (tracker
,
6471 sym
->linkage_name (),
6472 lookup_name
, text
, word
);
6480 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6481 for tagged types. */
6484 ada_is_dispatch_table_ptr_type (struct type
*type
)
6488 if (type
->code () != TYPE_CODE_PTR
)
6491 name
= TYPE_TARGET_TYPE (type
)->name ();
6495 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6498 /* Return non-zero if TYPE is an interface tag. */
6501 ada_is_interface_tag (struct type
*type
)
6503 const char *name
= type
->name ();
6508 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6511 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6512 to be invisible to users. */
6515 ada_is_ignored_field (struct type
*type
, int field_num
)
6517 if (field_num
< 0 || field_num
> type
->num_fields ())
6520 /* Check the name of that field. */
6522 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6524 /* Anonymous field names should not be printed.
6525 brobecker/2007-02-20: I don't think this can actually happen
6526 but we don't want to print the value of anonymous fields anyway. */
6530 /* Normally, fields whose name start with an underscore ("_")
6531 are fields that have been internally generated by the compiler,
6532 and thus should not be printed. The "_parent" field is special,
6533 however: This is a field internally generated by the compiler
6534 for tagged types, and it contains the components inherited from
6535 the parent type. This field should not be printed as is, but
6536 should not be ignored either. */
6537 if (name
[0] == '_' && !startswith (name
, "_parent"))
6541 /* If this is the dispatch table of a tagged type or an interface tag,
6543 if (ada_is_tagged_type (type
, 1)
6544 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6545 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6548 /* Not a special field, so it should not be ignored. */
6552 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6553 pointer or reference type whose ultimate target has a tag field. */
6556 ada_is_tagged_type (struct type
*type
, int refok
)
6558 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6561 /* True iff TYPE represents the type of X'Tag */
6564 ada_is_tag_type (struct type
*type
)
6566 type
= ada_check_typedef (type
);
6568 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6572 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6574 return (name
!= NULL
6575 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6579 /* The type of the tag on VAL. */
6581 static struct type
*
6582 ada_tag_type (struct value
*val
)
6584 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6587 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6588 retired at Ada 05). */
6591 is_ada95_tag (struct value
*tag
)
6593 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6596 /* The value of the tag on VAL. */
6598 static struct value
*
6599 ada_value_tag (struct value
*val
)
6601 return ada_value_struct_elt (val
, "_tag", 0);
6604 /* The value of the tag on the object of type TYPE whose contents are
6605 saved at VALADDR, if it is non-null, or is at memory address
6608 static struct value
*
6609 value_tag_from_contents_and_address (struct type
*type
,
6610 const gdb_byte
*valaddr
,
6613 int tag_byte_offset
;
6614 struct type
*tag_type
;
6616 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6619 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6621 : valaddr
+ tag_byte_offset
);
6622 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6624 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6629 static struct type
*
6630 type_from_tag (struct value
*tag
)
6632 const char *type_name
= ada_tag_name (tag
);
6634 if (type_name
!= NULL
)
6635 return ada_find_any_type (ada_encode (type_name
));
6639 /* Given a value OBJ of a tagged type, return a value of this
6640 type at the base address of the object. The base address, as
6641 defined in Ada.Tags, it is the address of the primary tag of
6642 the object, and therefore where the field values of its full
6643 view can be fetched. */
6646 ada_tag_value_at_base_address (struct value
*obj
)
6649 LONGEST offset_to_top
= 0;
6650 struct type
*ptr_type
, *obj_type
;
6652 CORE_ADDR base_address
;
6654 obj_type
= value_type (obj
);
6656 /* It is the responsability of the caller to deref pointers. */
6658 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6661 tag
= ada_value_tag (obj
);
6665 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6667 if (is_ada95_tag (tag
))
6670 ptr_type
= language_lookup_primitive_type
6671 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6672 ptr_type
= lookup_pointer_type (ptr_type
);
6673 val
= value_cast (ptr_type
, tag
);
6677 /* It is perfectly possible that an exception be raised while
6678 trying to determine the base address, just like for the tag;
6679 see ada_tag_name for more details. We do not print the error
6680 message for the same reason. */
6684 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6687 catch (const gdb_exception_error
&e
)
6692 /* If offset is null, nothing to do. */
6694 if (offset_to_top
== 0)
6697 /* -1 is a special case in Ada.Tags; however, what should be done
6698 is not quite clear from the documentation. So do nothing for
6701 if (offset_to_top
== -1)
6704 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6705 from the base address. This was however incompatible with
6706 C++ dispatch table: C++ uses a *negative* value to *add*
6707 to the base address. Ada's convention has therefore been
6708 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6709 use the same convention. Here, we support both cases by
6710 checking the sign of OFFSET_TO_TOP. */
6712 if (offset_to_top
> 0)
6713 offset_to_top
= -offset_to_top
;
6715 base_address
= value_address (obj
) + offset_to_top
;
6716 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6718 /* Make sure that we have a proper tag at the new address.
6719 Otherwise, offset_to_top is bogus (which can happen when
6720 the object is not initialized yet). */
6725 obj_type
= type_from_tag (tag
);
6730 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6733 /* Return the "ada__tags__type_specific_data" type. */
6735 static struct type
*
6736 ada_get_tsd_type (struct inferior
*inf
)
6738 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6740 if (data
->tsd_type
== 0)
6741 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6742 return data
->tsd_type
;
6745 /* Return the TSD (type-specific data) associated to the given TAG.
6746 TAG is assumed to be the tag of a tagged-type entity.
6748 May return NULL if we are unable to get the TSD. */
6750 static struct value
*
6751 ada_get_tsd_from_tag (struct value
*tag
)
6756 /* First option: The TSD is simply stored as a field of our TAG.
6757 Only older versions of GNAT would use this format, but we have
6758 to test it first, because there are no visible markers for
6759 the current approach except the absence of that field. */
6761 val
= ada_value_struct_elt (tag
, "tsd", 1);
6765 /* Try the second representation for the dispatch table (in which
6766 there is no explicit 'tsd' field in the referent of the tag pointer,
6767 and instead the tsd pointer is stored just before the dispatch
6770 type
= ada_get_tsd_type (current_inferior());
6773 type
= lookup_pointer_type (lookup_pointer_type (type
));
6774 val
= value_cast (type
, tag
);
6777 return value_ind (value_ptradd (val
, -1));
6780 /* Given the TSD of a tag (type-specific data), return a string
6781 containing the name of the associated type.
6783 The returned value is good until the next call. May return NULL
6784 if we are unable to determine the tag name. */
6787 ada_tag_name_from_tsd (struct value
*tsd
)
6789 static char name
[1024];
6793 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6796 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6797 for (p
= name
; *p
!= '\0'; p
+= 1)
6803 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6806 Return NULL if the TAG is not an Ada tag, or if we were unable to
6807 determine the name of that tag. The result is good until the next
6811 ada_tag_name (struct value
*tag
)
6815 if (!ada_is_tag_type (value_type (tag
)))
6818 /* It is perfectly possible that an exception be raised while trying
6819 to determine the TAG's name, even under normal circumstances:
6820 The associated variable may be uninitialized or corrupted, for
6821 instance. We do not let any exception propagate past this point.
6822 instead we return NULL.
6824 We also do not print the error message either (which often is very
6825 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6826 the caller print a more meaningful message if necessary. */
6829 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6832 name
= ada_tag_name_from_tsd (tsd
);
6834 catch (const gdb_exception_error
&e
)
6841 /* The parent type of TYPE, or NULL if none. */
6844 ada_parent_type (struct type
*type
)
6848 type
= ada_check_typedef (type
);
6850 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6853 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6854 if (ada_is_parent_field (type
, i
))
6856 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6858 /* If the _parent field is a pointer, then dereference it. */
6859 if (parent_type
->code () == TYPE_CODE_PTR
)
6860 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6861 /* If there is a parallel XVS type, get the actual base type. */
6862 parent_type
= ada_get_base_type (parent_type
);
6864 return ada_check_typedef (parent_type
);
6870 /* True iff field number FIELD_NUM of structure type TYPE contains the
6871 parent-type (inherited) fields of a derived type. Assumes TYPE is
6872 a structure type with at least FIELD_NUM+1 fields. */
6875 ada_is_parent_field (struct type
*type
, int field_num
)
6877 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6879 return (name
!= NULL
6880 && (startswith (name
, "PARENT")
6881 || startswith (name
, "_parent")));
6884 /* True iff field number FIELD_NUM of structure type TYPE is a
6885 transparent wrapper field (which should be silently traversed when doing
6886 field selection and flattened when printing). Assumes TYPE is a
6887 structure type with at least FIELD_NUM+1 fields. Such fields are always
6891 ada_is_wrapper_field (struct type
*type
, int field_num
)
6893 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6895 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6897 /* This happens in functions with "out" or "in out" parameters
6898 which are passed by copy. For such functions, GNAT describes
6899 the function's return type as being a struct where the return
6900 value is in a field called RETVAL, and where the other "out"
6901 or "in out" parameters are fields of that struct. This is not
6906 return (name
!= NULL
6907 && (startswith (name
, "PARENT")
6908 || strcmp (name
, "REP") == 0
6909 || startswith (name
, "_parent")
6910 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6913 /* True iff field number FIELD_NUM of structure or union type TYPE
6914 is a variant wrapper. Assumes TYPE is a structure type with at least
6915 FIELD_NUM+1 fields. */
6918 ada_is_variant_part (struct type
*type
, int field_num
)
6920 /* Only Ada types are eligible. */
6921 if (!ADA_TYPE_P (type
))
6924 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6926 return (field_type
->code () == TYPE_CODE_UNION
6927 || (is_dynamic_field (type
, field_num
)
6928 && (TYPE_TARGET_TYPE (field_type
)->code ()
6929 == TYPE_CODE_UNION
)));
6932 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6933 whose discriminants are contained in the record type OUTER_TYPE,
6934 returns the type of the controlling discriminant for the variant.
6935 May return NULL if the type could not be found. */
6938 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6940 const char *name
= ada_variant_discrim_name (var_type
);
6942 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6945 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6946 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6947 represents a 'when others' clause; otherwise 0. */
6950 ada_is_others_clause (struct type
*type
, int field_num
)
6952 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6954 return (name
!= NULL
&& name
[0] == 'O');
6957 /* Assuming that TYPE0 is the type of the variant part of a record,
6958 returns the name of the discriminant controlling the variant.
6959 The value is valid until the next call to ada_variant_discrim_name. */
6962 ada_variant_discrim_name (struct type
*type0
)
6964 static char *result
= NULL
;
6965 static size_t result_len
= 0;
6968 const char *discrim_end
;
6969 const char *discrim_start
;
6971 if (type0
->code () == TYPE_CODE_PTR
)
6972 type
= TYPE_TARGET_TYPE (type0
);
6976 name
= ada_type_name (type
);
6978 if (name
== NULL
|| name
[0] == '\000')
6981 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6984 if (startswith (discrim_end
, "___XVN"))
6987 if (discrim_end
== name
)
6990 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6993 if (discrim_start
== name
+ 1)
6995 if ((discrim_start
> name
+ 3
6996 && startswith (discrim_start
- 3, "___"))
6997 || discrim_start
[-1] == '.')
7001 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
7002 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
7003 result
[discrim_end
- discrim_start
] = '\0';
7007 /* Scan STR for a subtype-encoded number, beginning at position K.
7008 Put the position of the character just past the number scanned in
7009 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7010 Return 1 if there was a valid number at the given position, and 0
7011 otherwise. A "subtype-encoded" number consists of the absolute value
7012 in decimal, followed by the letter 'm' to indicate a negative number.
7013 Assumes 0m does not occur. */
7016 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
7020 if (!isdigit (str
[k
]))
7023 /* Do it the hard way so as not to make any assumption about
7024 the relationship of unsigned long (%lu scan format code) and
7027 while (isdigit (str
[k
]))
7029 RU
= RU
* 10 + (str
[k
] - '0');
7036 *R
= (-(LONGEST
) (RU
- 1)) - 1;
7042 /* NOTE on the above: Technically, C does not say what the results of
7043 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7044 number representable as a LONGEST (although either would probably work
7045 in most implementations). When RU>0, the locution in the then branch
7046 above is always equivalent to the negative of RU. */
7053 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7054 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7055 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7058 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
7060 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
7074 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
7084 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
7085 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
7087 if (val
>= L
&& val
<= U
)
7099 /* FIXME: Lots of redundancy below. Try to consolidate. */
7101 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7102 ARG_TYPE, extract and return the value of one of its (non-static)
7103 fields. FIELDNO says which field. Differs from value_primitive_field
7104 only in that it can handle packed values of arbitrary type. */
7107 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
7108 struct type
*arg_type
)
7112 arg_type
= ada_check_typedef (arg_type
);
7113 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
7115 /* Handle packed fields. It might be that the field is not packed
7116 relative to its containing structure, but the structure itself is
7117 packed; in this case we must take the bit-field path. */
7118 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
7120 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
7121 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
7123 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
7124 offset
+ bit_pos
/ 8,
7125 bit_pos
% 8, bit_size
, type
);
7128 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
7131 /* Find field with name NAME in object of type TYPE. If found,
7132 set the following for each argument that is non-null:
7133 - *FIELD_TYPE_P to the field's type;
7134 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7135 an object of that type;
7136 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7137 - *BIT_SIZE_P to its size in bits if the field is packed, and
7139 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7140 fields up to but not including the desired field, or by the total
7141 number of fields if not found. A NULL value of NAME never
7142 matches; the function just counts visible fields in this case.
7144 Notice that we need to handle when a tagged record hierarchy
7145 has some components with the same name, like in this scenario:
7147 type Top_T is tagged record
7153 type Middle_T is new Top.Top_T with record
7154 N : Character := 'a';
7158 type Bottom_T is new Middle.Middle_T with record
7160 C : Character := '5';
7162 A : Character := 'J';
7165 Let's say we now have a variable declared and initialized as follow:
7167 TC : Top_A := new Bottom_T;
7169 And then we use this variable to call this function
7171 procedure Assign (Obj: in out Top_T; TV : Integer);
7175 Assign (Top_T (B), 12);
7177 Now, we're in the debugger, and we're inside that procedure
7178 then and we want to print the value of obj.c:
7180 Usually, the tagged record or one of the parent type owns the
7181 component to print and there's no issue but in this particular
7182 case, what does it mean to ask for Obj.C? Since the actual
7183 type for object is type Bottom_T, it could mean two things: type
7184 component C from the Middle_T view, but also component C from
7185 Bottom_T. So in that "undefined" case, when the component is
7186 not found in the non-resolved type (which includes all the
7187 components of the parent type), then resolve it and see if we
7188 get better luck once expanded.
7190 In the case of homonyms in the derived tagged type, we don't
7191 guaranty anything, and pick the one that's easiest for us
7194 Returns 1 if found, 0 otherwise. */
7197 find_struct_field (const char *name
, struct type
*type
, int offset
,
7198 struct type
**field_type_p
,
7199 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7203 int parent_offset
= -1;
7205 type
= ada_check_typedef (type
);
7207 if (field_type_p
!= NULL
)
7208 *field_type_p
= NULL
;
7209 if (byte_offset_p
!= NULL
)
7211 if (bit_offset_p
!= NULL
)
7213 if (bit_size_p
!= NULL
)
7216 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7218 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7219 int fld_offset
= offset
+ bit_pos
/ 8;
7220 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7222 if (t_field_name
== NULL
)
7225 else if (ada_is_parent_field (type
, i
))
7227 /* This is a field pointing us to the parent type of a tagged
7228 type. As hinted in this function's documentation, we give
7229 preference to fields in the current record first, so what
7230 we do here is just record the index of this field before
7231 we skip it. If it turns out we couldn't find our field
7232 in the current record, then we'll get back to it and search
7233 inside it whether the field might exist in the parent. */
7239 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7241 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7243 if (field_type_p
!= NULL
)
7244 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
7245 if (byte_offset_p
!= NULL
)
7246 *byte_offset_p
= fld_offset
;
7247 if (bit_offset_p
!= NULL
)
7248 *bit_offset_p
= bit_pos
% 8;
7249 if (bit_size_p
!= NULL
)
7250 *bit_size_p
= bit_size
;
7253 else if (ada_is_wrapper_field (type
, i
))
7255 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
7256 field_type_p
, byte_offset_p
, bit_offset_p
,
7257 bit_size_p
, index_p
))
7260 else if (ada_is_variant_part (type
, i
))
7262 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7265 struct type
*field_type
7266 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7268 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7270 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7272 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7273 field_type_p
, byte_offset_p
,
7274 bit_offset_p
, bit_size_p
, index_p
))
7278 else if (index_p
!= NULL
)
7282 /* Field not found so far. If this is a tagged type which
7283 has a parent, try finding that field in the parent now. */
7285 if (parent_offset
!= -1)
7287 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7288 int fld_offset
= offset
+ bit_pos
/ 8;
7290 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, parent_offset
),
7291 fld_offset
, field_type_p
, byte_offset_p
,
7292 bit_offset_p
, bit_size_p
, index_p
))
7299 /* Number of user-visible fields in record type TYPE. */
7302 num_visible_fields (struct type
*type
)
7307 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7311 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7312 and search in it assuming it has (class) type TYPE.
7313 If found, return value, else return NULL.
7315 Searches recursively through wrapper fields (e.g., '_parent').
7317 In the case of homonyms in the tagged types, please refer to the
7318 long explanation in find_struct_field's function documentation. */
7320 static struct value
*
7321 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7325 int parent_offset
= -1;
7327 type
= ada_check_typedef (type
);
7328 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7330 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7332 if (t_field_name
== NULL
)
7335 else if (ada_is_parent_field (type
, i
))
7337 /* This is a field pointing us to the parent type of a tagged
7338 type. As hinted in this function's documentation, we give
7339 preference to fields in the current record first, so what
7340 we do here is just record the index of this field before
7341 we skip it. If it turns out we couldn't find our field
7342 in the current record, then we'll get back to it and search
7343 inside it whether the field might exist in the parent. */
7349 else if (field_name_match (t_field_name
, name
))
7350 return ada_value_primitive_field (arg
, offset
, i
, type
);
7352 else if (ada_is_wrapper_field (type
, i
))
7354 struct value
*v
= /* Do not let indent join lines here. */
7355 ada_search_struct_field (name
, arg
,
7356 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7357 TYPE_FIELD_TYPE (type
, i
));
7363 else if (ada_is_variant_part (type
, i
))
7365 /* PNH: Do we ever get here? See find_struct_field. */
7367 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7369 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7371 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7373 struct value
*v
= ada_search_struct_field
/* Force line
7376 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7377 TYPE_FIELD_TYPE (field_type
, j
));
7385 /* Field not found so far. If this is a tagged type which
7386 has a parent, try finding that field in the parent now. */
7388 if (parent_offset
!= -1)
7390 struct value
*v
= ada_search_struct_field (
7391 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7392 TYPE_FIELD_TYPE (type
, parent_offset
));
7401 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7402 int, struct type
*);
7405 /* Return field #INDEX in ARG, where the index is that returned by
7406 * find_struct_field through its INDEX_P argument. Adjust the address
7407 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7408 * If found, return value, else return NULL. */
7410 static struct value
*
7411 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7414 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7418 /* Auxiliary function for ada_index_struct_field. Like
7419 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7422 static struct value
*
7423 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7427 type
= ada_check_typedef (type
);
7429 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7431 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7433 else if (ada_is_wrapper_field (type
, i
))
7435 struct value
*v
= /* Do not let indent join lines here. */
7436 ada_index_struct_field_1 (index_p
, arg
,
7437 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7438 TYPE_FIELD_TYPE (type
, i
));
7444 else if (ada_is_variant_part (type
, i
))
7446 /* PNH: Do we ever get here? See ada_search_struct_field,
7447 find_struct_field. */
7448 error (_("Cannot assign this kind of variant record"));
7450 else if (*index_p
== 0)
7451 return ada_value_primitive_field (arg
, offset
, i
, type
);
7458 /* Return a string representation of type TYPE. */
7461 type_as_string (struct type
*type
)
7463 string_file tmp_stream
;
7465 type_print (type
, "", &tmp_stream
, -1);
7467 return std::move (tmp_stream
.string ());
7470 /* Given a type TYPE, look up the type of the component of type named NAME.
7471 If DISPP is non-null, add its byte displacement from the beginning of a
7472 structure (pointed to by a value) of type TYPE to *DISPP (does not
7473 work for packed fields).
7475 Matches any field whose name has NAME as a prefix, possibly
7478 TYPE can be either a struct or union. If REFOK, TYPE may also
7479 be a (pointer or reference)+ to a struct or union, and the
7480 ultimate target type will be searched.
7482 Looks recursively into variant clauses and parent types.
7484 In the case of homonyms in the tagged types, please refer to the
7485 long explanation in find_struct_field's function documentation.
7487 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7488 TYPE is not a type of the right kind. */
7490 static struct type
*
7491 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7495 int parent_offset
= -1;
7500 if (refok
&& type
!= NULL
)
7503 type
= ada_check_typedef (type
);
7504 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7506 type
= TYPE_TARGET_TYPE (type
);
7510 || (type
->code () != TYPE_CODE_STRUCT
7511 && type
->code () != TYPE_CODE_UNION
))
7516 error (_("Type %s is not a structure or union type"),
7517 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7520 type
= to_static_fixed_type (type
);
7522 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7524 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7527 if (t_field_name
== NULL
)
7530 else if (ada_is_parent_field (type
, i
))
7532 /* This is a field pointing us to the parent type of a tagged
7533 type. As hinted in this function's documentation, we give
7534 preference to fields in the current record first, so what
7535 we do here is just record the index of this field before
7536 we skip it. If it turns out we couldn't find our field
7537 in the current record, then we'll get back to it and search
7538 inside it whether the field might exist in the parent. */
7544 else if (field_name_match (t_field_name
, name
))
7545 return TYPE_FIELD_TYPE (type
, i
);
7547 else if (ada_is_wrapper_field (type
, i
))
7549 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7555 else if (ada_is_variant_part (type
, i
))
7558 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7561 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7563 /* FIXME pnh 2008/01/26: We check for a field that is
7564 NOT wrapped in a struct, since the compiler sometimes
7565 generates these for unchecked variant types. Revisit
7566 if the compiler changes this practice. */
7567 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7569 if (v_field_name
!= NULL
7570 && field_name_match (v_field_name
, name
))
7571 t
= TYPE_FIELD_TYPE (field_type
, j
);
7573 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7584 /* Field not found so far. If this is a tagged type which
7585 has a parent, try finding that field in the parent now. */
7587 if (parent_offset
!= -1)
7591 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, parent_offset
),
7600 const char *name_str
= name
!= NULL
? name
: _("<null>");
7602 error (_("Type %s has no component named %s"),
7603 type_as_string (type
).c_str (), name_str
);
7609 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7610 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7611 represents an unchecked union (that is, the variant part of a
7612 record that is named in an Unchecked_Union pragma). */
7615 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7617 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7619 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7623 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7624 within OUTER, determine which variant clause (field number in VAR_TYPE,
7625 numbering from 0) is applicable. Returns -1 if none are. */
7628 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7632 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7633 struct value
*discrim
;
7634 LONGEST discrim_val
;
7636 /* Using plain value_from_contents_and_address here causes problems
7637 because we will end up trying to resolve a type that is currently
7638 being constructed. */
7639 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7640 if (discrim
== NULL
)
7642 discrim_val
= value_as_long (discrim
);
7645 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7647 if (ada_is_others_clause (var_type
, i
))
7649 else if (ada_in_variant (discrim_val
, var_type
, i
))
7653 return others_clause
;
7658 /* Dynamic-Sized Records */
7660 /* Strategy: The type ostensibly attached to a value with dynamic size
7661 (i.e., a size that is not statically recorded in the debugging
7662 data) does not accurately reflect the size or layout of the value.
7663 Our strategy is to convert these values to values with accurate,
7664 conventional types that are constructed on the fly. */
7666 /* There is a subtle and tricky problem here. In general, we cannot
7667 determine the size of dynamic records without its data. However,
7668 the 'struct value' data structure, which GDB uses to represent
7669 quantities in the inferior process (the target), requires the size
7670 of the type at the time of its allocation in order to reserve space
7671 for GDB's internal copy of the data. That's why the
7672 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7673 rather than struct value*s.
7675 However, GDB's internal history variables ($1, $2, etc.) are
7676 struct value*s containing internal copies of the data that are not, in
7677 general, the same as the data at their corresponding addresses in
7678 the target. Fortunately, the types we give to these values are all
7679 conventional, fixed-size types (as per the strategy described
7680 above), so that we don't usually have to perform the
7681 'to_fixed_xxx_type' conversions to look at their values.
7682 Unfortunately, there is one exception: if one of the internal
7683 history variables is an array whose elements are unconstrained
7684 records, then we will need to create distinct fixed types for each
7685 element selected. */
7687 /* The upshot of all of this is that many routines take a (type, host
7688 address, target address) triple as arguments to represent a value.
7689 The host address, if non-null, is supposed to contain an internal
7690 copy of the relevant data; otherwise, the program is to consult the
7691 target at the target address. */
7693 /* Assuming that VAL0 represents a pointer value, the result of
7694 dereferencing it. Differs from value_ind in its treatment of
7695 dynamic-sized types. */
7698 ada_value_ind (struct value
*val0
)
7700 struct value
*val
= value_ind (val0
);
7702 if (ada_is_tagged_type (value_type (val
), 0))
7703 val
= ada_tag_value_at_base_address (val
);
7705 return ada_to_fixed_value (val
);
7708 /* The value resulting from dereferencing any "reference to"
7709 qualifiers on VAL0. */
7711 static struct value
*
7712 ada_coerce_ref (struct value
*val0
)
7714 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7716 struct value
*val
= val0
;
7718 val
= coerce_ref (val
);
7720 if (ada_is_tagged_type (value_type (val
), 0))
7721 val
= ada_tag_value_at_base_address (val
);
7723 return ada_to_fixed_value (val
);
7729 /* Return the bit alignment required for field #F of template type TYPE. */
7732 field_alignment (struct type
*type
, int f
)
7734 const char *name
= TYPE_FIELD_NAME (type
, f
);
7738 /* The field name should never be null, unless the debugging information
7739 is somehow malformed. In this case, we assume the field does not
7740 require any alignment. */
7744 len
= strlen (name
);
7746 if (!isdigit (name
[len
- 1]))
7749 if (isdigit (name
[len
- 2]))
7750 align_offset
= len
- 2;
7752 align_offset
= len
- 1;
7754 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7755 return TARGET_CHAR_BIT
;
7757 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7760 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7762 static struct symbol
*
7763 ada_find_any_type_symbol (const char *name
)
7767 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7768 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7771 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7775 /* Find a type named NAME. Ignores ambiguity. This routine will look
7776 solely for types defined by debug info, it will not search the GDB
7779 static struct type
*
7780 ada_find_any_type (const char *name
)
7782 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7785 return SYMBOL_TYPE (sym
);
7790 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7791 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7792 symbol, in which case it is returned. Otherwise, this looks for
7793 symbols whose name is that of NAME_SYM suffixed with "___XR".
7794 Return symbol if found, and NULL otherwise. */
7797 ada_is_renaming_symbol (struct symbol
*name_sym
)
7799 const char *name
= name_sym
->linkage_name ();
7800 return strstr (name
, "___XR") != NULL
;
7803 /* Because of GNAT encoding conventions, several GDB symbols may match a
7804 given type name. If the type denoted by TYPE0 is to be preferred to
7805 that of TYPE1 for purposes of type printing, return non-zero;
7806 otherwise return 0. */
7809 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7813 else if (type0
== NULL
)
7815 else if (type1
->code () == TYPE_CODE_VOID
)
7817 else if (type0
->code () == TYPE_CODE_VOID
)
7819 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7821 else if (ada_is_constrained_packed_array_type (type0
))
7823 else if (ada_is_array_descriptor_type (type0
)
7824 && !ada_is_array_descriptor_type (type1
))
7828 const char *type0_name
= type0
->name ();
7829 const char *type1_name
= type1
->name ();
7831 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7832 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7838 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7842 ada_type_name (struct type
*type
)
7846 return type
->name ();
7849 /* Search the list of "descriptive" types associated to TYPE for a type
7850 whose name is NAME. */
7852 static struct type
*
7853 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7855 struct type
*result
, *tmp
;
7857 if (ada_ignore_descriptive_types_p
)
7860 /* If there no descriptive-type info, then there is no parallel type
7862 if (!HAVE_GNAT_AUX_INFO (type
))
7865 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7866 while (result
!= NULL
)
7868 const char *result_name
= ada_type_name (result
);
7870 if (result_name
== NULL
)
7872 warning (_("unexpected null name on descriptive type"));
7876 /* If the names match, stop. */
7877 if (strcmp (result_name
, name
) == 0)
7880 /* Otherwise, look at the next item on the list, if any. */
7881 if (HAVE_GNAT_AUX_INFO (result
))
7882 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7886 /* If not found either, try after having resolved the typedef. */
7891 result
= check_typedef (result
);
7892 if (HAVE_GNAT_AUX_INFO (result
))
7893 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7899 /* If we didn't find a match, see whether this is a packed array. With
7900 older compilers, the descriptive type information is either absent or
7901 irrelevant when it comes to packed arrays so the above lookup fails.
7902 Fall back to using a parallel lookup by name in this case. */
7903 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7904 return ada_find_any_type (name
);
7909 /* Find a parallel type to TYPE with the specified NAME, using the
7910 descriptive type taken from the debugging information, if available,
7911 and otherwise using the (slower) name-based method. */
7913 static struct type
*
7914 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7916 struct type
*result
= NULL
;
7918 if (HAVE_GNAT_AUX_INFO (type
))
7919 result
= find_parallel_type_by_descriptive_type (type
, name
);
7921 result
= ada_find_any_type (name
);
7926 /* Same as above, but specify the name of the parallel type by appending
7927 SUFFIX to the name of TYPE. */
7930 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7933 const char *type_name
= ada_type_name (type
);
7936 if (type_name
== NULL
)
7939 len
= strlen (type_name
);
7941 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7943 strcpy (name
, type_name
);
7944 strcpy (name
+ len
, suffix
);
7946 return ada_find_parallel_type_with_name (type
, name
);
7949 /* If TYPE is a variable-size record type, return the corresponding template
7950 type describing its fields. Otherwise, return NULL. */
7952 static struct type
*
7953 dynamic_template_type (struct type
*type
)
7955 type
= ada_check_typedef (type
);
7957 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7958 || ada_type_name (type
) == NULL
)
7962 int len
= strlen (ada_type_name (type
));
7964 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7967 return ada_find_parallel_type (type
, "___XVE");
7971 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7972 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7975 is_dynamic_field (struct type
*templ_type
, int field_num
)
7977 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7980 && TYPE_FIELD_TYPE (templ_type
, field_num
)->code () == TYPE_CODE_PTR
7981 && strstr (name
, "___XVL") != NULL
;
7984 /* The index of the variant field of TYPE, or -1 if TYPE does not
7985 represent a variant record type. */
7988 variant_field_index (struct type
*type
)
7992 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7995 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7997 if (ada_is_variant_part (type
, f
))
8003 /* A record type with no fields. */
8005 static struct type
*
8006 empty_record (struct type
*templ
)
8008 struct type
*type
= alloc_type_copy (templ
);
8010 type
->set_code (TYPE_CODE_STRUCT
);
8011 INIT_NONE_SPECIFIC (type
);
8012 type
->set_name ("<empty>");
8013 TYPE_LENGTH (type
) = 0;
8017 /* An ordinary record type (with fixed-length fields) that describes
8018 the value of type TYPE at VALADDR or ADDRESS (see comments at
8019 the beginning of this section) VAL according to GNAT conventions.
8020 DVAL0 should describe the (portion of a) record that contains any
8021 necessary discriminants. It should be NULL if value_type (VAL) is
8022 an outer-level type (i.e., as opposed to a branch of a variant.) A
8023 variant field (unless unchecked) is replaced by a particular branch
8026 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8027 length are not statically known are discarded. As a consequence,
8028 VALADDR, ADDRESS and DVAL0 are ignored.
8030 NOTE: Limitations: For now, we assume that dynamic fields and
8031 variants occupy whole numbers of bytes. However, they need not be
8035 ada_template_to_fixed_record_type_1 (struct type
*type
,
8036 const gdb_byte
*valaddr
,
8037 CORE_ADDR address
, struct value
*dval0
,
8038 int keep_dynamic_fields
)
8040 struct value
*mark
= value_mark ();
8043 int nfields
, bit_len
;
8049 /* Compute the number of fields in this record type that are going
8050 to be processed: unless keep_dynamic_fields, this includes only
8051 fields whose position and length are static will be processed. */
8052 if (keep_dynamic_fields
)
8053 nfields
= type
->num_fields ();
8057 while (nfields
< type
->num_fields ()
8058 && !ada_is_variant_part (type
, nfields
)
8059 && !is_dynamic_field (type
, nfields
))
8063 rtype
= alloc_type_copy (type
);
8064 rtype
->set_code (TYPE_CODE_STRUCT
);
8065 INIT_NONE_SPECIFIC (rtype
);
8066 rtype
->set_num_fields (nfields
);
8068 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
8069 rtype
->set_name (ada_type_name (type
));
8070 TYPE_FIXED_INSTANCE (rtype
) = 1;
8076 for (f
= 0; f
< nfields
; f
+= 1)
8078 off
= align_up (off
, field_alignment (type
, f
))
8079 + TYPE_FIELD_BITPOS (type
, f
);
8080 SET_FIELD_BITPOS (rtype
->field (f
), off
);
8081 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
8083 if (ada_is_variant_part (type
, f
))
8088 else if (is_dynamic_field (type
, f
))
8090 const gdb_byte
*field_valaddr
= valaddr
;
8091 CORE_ADDR field_address
= address
;
8092 struct type
*field_type
=
8093 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
8097 /* rtype's length is computed based on the run-time
8098 value of discriminants. If the discriminants are not
8099 initialized, the type size may be completely bogus and
8100 GDB may fail to allocate a value for it. So check the
8101 size first before creating the value. */
8102 ada_ensure_varsize_limit (rtype
);
8103 /* Using plain value_from_contents_and_address here
8104 causes problems because we will end up trying to
8105 resolve a type that is currently being
8107 dval
= value_from_contents_and_address_unresolved (rtype
,
8110 rtype
= value_type (dval
);
8115 /* If the type referenced by this field is an aligner type, we need
8116 to unwrap that aligner type, because its size might not be set.
8117 Keeping the aligner type would cause us to compute the wrong
8118 size for this field, impacting the offset of the all the fields
8119 that follow this one. */
8120 if (ada_is_aligner_type (field_type
))
8122 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
8124 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
8125 field_address
= cond_offset_target (field_address
, field_offset
);
8126 field_type
= ada_aligned_type (field_type
);
8129 field_valaddr
= cond_offset_host (field_valaddr
,
8130 off
/ TARGET_CHAR_BIT
);
8131 field_address
= cond_offset_target (field_address
,
8132 off
/ TARGET_CHAR_BIT
);
8134 /* Get the fixed type of the field. Note that, in this case,
8135 we do not want to get the real type out of the tag: if
8136 the current field is the parent part of a tagged record,
8137 we will get the tag of the object. Clearly wrong: the real
8138 type of the parent is not the real type of the child. We
8139 would end up in an infinite loop. */
8140 field_type
= ada_get_base_type (field_type
);
8141 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8142 field_address
, dval
, 0);
8143 /* If the field size is already larger than the maximum
8144 object size, then the record itself will necessarily
8145 be larger than the maximum object size. We need to make
8146 this check now, because the size might be so ridiculously
8147 large (due to an uninitialized variable in the inferior)
8148 that it would cause an overflow when adding it to the
8150 ada_ensure_varsize_limit (field_type
);
8152 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
8153 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8154 /* The multiplication can potentially overflow. But because
8155 the field length has been size-checked just above, and
8156 assuming that the maximum size is a reasonable value,
8157 an overflow should not happen in practice. So rather than
8158 adding overflow recovery code to this already complex code,
8159 we just assume that it's not going to happen. */
8161 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
8165 /* Note: If this field's type is a typedef, it is important
8166 to preserve the typedef layer.
8168 Otherwise, we might be transforming a typedef to a fat
8169 pointer (encoding a pointer to an unconstrained array),
8170 into a basic fat pointer (encoding an unconstrained
8171 array). As both types are implemented using the same
8172 structure, the typedef is the only clue which allows us
8173 to distinguish between the two options. Stripping it
8174 would prevent us from printing this field appropriately. */
8175 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
8176 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8177 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8179 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8182 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
8184 /* We need to be careful of typedefs when computing
8185 the length of our field. If this is a typedef,
8186 get the length of the target type, not the length
8188 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
8189 field_type
= ada_typedef_target_type (field_type
);
8192 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8195 if (off
+ fld_bit_len
> bit_len
)
8196 bit_len
= off
+ fld_bit_len
;
8198 TYPE_LENGTH (rtype
) =
8199 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8202 /* We handle the variant part, if any, at the end because of certain
8203 odd cases in which it is re-ordered so as NOT to be the last field of
8204 the record. This can happen in the presence of representation
8206 if (variant_field
>= 0)
8208 struct type
*branch_type
;
8210 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8214 /* Using plain value_from_contents_and_address here causes
8215 problems because we will end up trying to resolve a type
8216 that is currently being constructed. */
8217 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8219 rtype
= value_type (dval
);
8225 to_fixed_variant_branch_type
8226 (TYPE_FIELD_TYPE (type
, variant_field
),
8227 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8228 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8229 if (branch_type
== NULL
)
8231 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8232 rtype
->field (f
- 1) = rtype
->field (f
);
8233 rtype
->set_num_fields (rtype
->num_fields () - 1);
8237 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8238 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8240 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8242 if (off
+ fld_bit_len
> bit_len
)
8243 bit_len
= off
+ fld_bit_len
;
8244 TYPE_LENGTH (rtype
) =
8245 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8249 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8250 should contain the alignment of that record, which should be a strictly
8251 positive value. If null or negative, then something is wrong, most
8252 probably in the debug info. In that case, we don't round up the size
8253 of the resulting type. If this record is not part of another structure,
8254 the current RTYPE length might be good enough for our purposes. */
8255 if (TYPE_LENGTH (type
) <= 0)
8258 warning (_("Invalid type size for `%s' detected: %s."),
8259 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8261 warning (_("Invalid type size for <unnamed> detected: %s."),
8262 pulongest (TYPE_LENGTH (type
)));
8266 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8267 TYPE_LENGTH (type
));
8270 value_free_to_mark (mark
);
8271 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8272 error (_("record type with dynamic size is larger than varsize-limit"));
8276 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8279 static struct type
*
8280 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8281 CORE_ADDR address
, struct value
*dval0
)
8283 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8287 /* An ordinary record type in which ___XVL-convention fields and
8288 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8289 static approximations, containing all possible fields. Uses
8290 no runtime values. Useless for use in values, but that's OK,
8291 since the results are used only for type determinations. Works on both
8292 structs and unions. Representation note: to save space, we memorize
8293 the result of this function in the TYPE_TARGET_TYPE of the
8296 static struct type
*
8297 template_to_static_fixed_type (struct type
*type0
)
8303 /* No need no do anything if the input type is already fixed. */
8304 if (TYPE_FIXED_INSTANCE (type0
))
8307 /* Likewise if we already have computed the static approximation. */
8308 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8309 return TYPE_TARGET_TYPE (type0
);
8311 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8313 nfields
= type0
->num_fields ();
8315 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8316 recompute all over next time. */
8317 TYPE_TARGET_TYPE (type0
) = type
;
8319 for (f
= 0; f
< nfields
; f
+= 1)
8321 struct type
*field_type
= TYPE_FIELD_TYPE (type0
, f
);
8322 struct type
*new_type
;
8324 if (is_dynamic_field (type0
, f
))
8326 field_type
= ada_check_typedef (field_type
);
8327 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8330 new_type
= static_unwrap_type (field_type
);
8332 if (new_type
!= field_type
)
8334 /* Clone TYPE0 only the first time we get a new field type. */
8337 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8338 type
->set_code (type0
->code ());
8339 INIT_NONE_SPECIFIC (type
);
8340 type
->set_num_fields (nfields
);
8344 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8345 memcpy (fields
, type0
->fields (),
8346 sizeof (struct field
) * nfields
);
8347 type
->set_fields (fields
);
8349 type
->set_name (ada_type_name (type0
));
8350 TYPE_FIXED_INSTANCE (type
) = 1;
8351 TYPE_LENGTH (type
) = 0;
8353 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8354 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8361 /* Given an object of type TYPE whose contents are at VALADDR and
8362 whose address in memory is ADDRESS, returns a revision of TYPE,
8363 which should be a non-dynamic-sized record, in which the variant
8364 part, if any, is replaced with the appropriate branch. Looks
8365 for discriminant values in DVAL0, which can be NULL if the record
8366 contains the necessary discriminant values. */
8368 static struct type
*
8369 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8370 CORE_ADDR address
, struct value
*dval0
)
8372 struct value
*mark
= value_mark ();
8375 struct type
*branch_type
;
8376 int nfields
= type
->num_fields ();
8377 int variant_field
= variant_field_index (type
);
8379 if (variant_field
== -1)
8384 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8385 type
= value_type (dval
);
8390 rtype
= alloc_type_copy (type
);
8391 rtype
->set_code (TYPE_CODE_STRUCT
);
8392 INIT_NONE_SPECIFIC (rtype
);
8393 rtype
->set_num_fields (nfields
);
8396 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8397 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8398 rtype
->set_fields (fields
);
8400 rtype
->set_name (ada_type_name (type
));
8401 TYPE_FIXED_INSTANCE (rtype
) = 1;
8402 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8404 branch_type
= to_fixed_variant_branch_type
8405 (TYPE_FIELD_TYPE (type
, variant_field
),
8406 cond_offset_host (valaddr
,
8407 TYPE_FIELD_BITPOS (type
, variant_field
)
8409 cond_offset_target (address
,
8410 TYPE_FIELD_BITPOS (type
, variant_field
)
8411 / TARGET_CHAR_BIT
), dval
);
8412 if (branch_type
== NULL
)
8416 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8417 rtype
->field (f
- 1) = rtype
->field (f
);
8418 rtype
->set_num_fields (rtype
->num_fields () - 1);
8422 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8423 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8424 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8425 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8427 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8429 value_free_to_mark (mark
);
8433 /* An ordinary record type (with fixed-length fields) that describes
8434 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8435 beginning of this section]. Any necessary discriminants' values
8436 should be in DVAL, a record value; it may be NULL if the object
8437 at ADDR itself contains any necessary discriminant values.
8438 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8439 values from the record are needed. Except in the case that DVAL,
8440 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8441 unchecked) is replaced by a particular branch of the variant.
8443 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8444 is questionable and may be removed. It can arise during the
8445 processing of an unconstrained-array-of-record type where all the
8446 variant branches have exactly the same size. This is because in
8447 such cases, the compiler does not bother to use the XVS convention
8448 when encoding the record. I am currently dubious of this
8449 shortcut and suspect the compiler should be altered. FIXME. */
8451 static struct type
*
8452 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8453 CORE_ADDR address
, struct value
*dval
)
8455 struct type
*templ_type
;
8457 if (TYPE_FIXED_INSTANCE (type0
))
8460 templ_type
= dynamic_template_type (type0
);
8462 if (templ_type
!= NULL
)
8463 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8464 else if (variant_field_index (type0
) >= 0)
8466 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8468 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8473 TYPE_FIXED_INSTANCE (type0
) = 1;
8479 /* An ordinary record type (with fixed-length fields) that describes
8480 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8481 union type. Any necessary discriminants' values should be in DVAL,
8482 a record value. That is, this routine selects the appropriate
8483 branch of the union at ADDR according to the discriminant value
8484 indicated in the union's type name. Returns VAR_TYPE0 itself if
8485 it represents a variant subject to a pragma Unchecked_Union. */
8487 static struct type
*
8488 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8489 CORE_ADDR address
, struct value
*dval
)
8492 struct type
*templ_type
;
8493 struct type
*var_type
;
8495 if (var_type0
->code () == TYPE_CODE_PTR
)
8496 var_type
= TYPE_TARGET_TYPE (var_type0
);
8498 var_type
= var_type0
;
8500 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8502 if (templ_type
!= NULL
)
8503 var_type
= templ_type
;
8505 if (is_unchecked_variant (var_type
, value_type (dval
)))
8507 which
= ada_which_variant_applies (var_type
, dval
);
8510 return empty_record (var_type
);
8511 else if (is_dynamic_field (var_type
, which
))
8512 return to_fixed_record_type
8513 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8514 valaddr
, address
, dval
);
8515 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8517 to_fixed_record_type
8518 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8520 return TYPE_FIELD_TYPE (var_type
, which
);
8523 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8524 ENCODING_TYPE, a type following the GNAT conventions for discrete
8525 type encodings, only carries redundant information. */
8528 ada_is_redundant_range_encoding (struct type
*range_type
,
8529 struct type
*encoding_type
)
8531 const char *bounds_str
;
8535 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8537 if (get_base_type (range_type
)->code ()
8538 != get_base_type (encoding_type
)->code ())
8540 /* The compiler probably used a simple base type to describe
8541 the range type instead of the range's actual base type,
8542 expecting us to get the real base type from the encoding
8543 anyway. In this situation, the encoding cannot be ignored
8548 if (is_dynamic_type (range_type
))
8551 if (encoding_type
->name () == NULL
)
8554 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8555 if (bounds_str
== NULL
)
8558 n
= 8; /* Skip "___XDLU_". */
8559 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8561 if (TYPE_LOW_BOUND (range_type
) != lo
)
8564 n
+= 2; /* Skip the "__" separator between the two bounds. */
8565 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8567 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8573 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8574 a type following the GNAT encoding for describing array type
8575 indices, only carries redundant information. */
8578 ada_is_redundant_index_type_desc (struct type
*array_type
,
8579 struct type
*desc_type
)
8581 struct type
*this_layer
= check_typedef (array_type
);
8584 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8586 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer
),
8587 TYPE_FIELD_TYPE (desc_type
, i
)))
8589 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8595 /* Assuming that TYPE0 is an array type describing the type of a value
8596 at ADDR, and that DVAL describes a record containing any
8597 discriminants used in TYPE0, returns a type for the value that
8598 contains no dynamic components (that is, no components whose sizes
8599 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8600 true, gives an error message if the resulting type's size is over
8603 static struct type
*
8604 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8607 struct type
*index_type_desc
;
8608 struct type
*result
;
8609 int constrained_packed_array_p
;
8610 static const char *xa_suffix
= "___XA";
8612 type0
= ada_check_typedef (type0
);
8613 if (TYPE_FIXED_INSTANCE (type0
))
8616 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8617 if (constrained_packed_array_p
)
8618 type0
= decode_constrained_packed_array_type (type0
);
8620 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8622 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8623 encoding suffixed with 'P' may still be generated. If so,
8624 it should be used to find the XA type. */
8626 if (index_type_desc
== NULL
)
8628 const char *type_name
= ada_type_name (type0
);
8630 if (type_name
!= NULL
)
8632 const int len
= strlen (type_name
);
8633 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8635 if (type_name
[len
- 1] == 'P')
8637 strcpy (name
, type_name
);
8638 strcpy (name
+ len
- 1, xa_suffix
);
8639 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8644 ada_fixup_array_indexes_type (index_type_desc
);
8645 if (index_type_desc
!= NULL
8646 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8648 /* Ignore this ___XA parallel type, as it does not bring any
8649 useful information. This allows us to avoid creating fixed
8650 versions of the array's index types, which would be identical
8651 to the original ones. This, in turn, can also help avoid
8652 the creation of fixed versions of the array itself. */
8653 index_type_desc
= NULL
;
8656 if (index_type_desc
== NULL
)
8658 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8660 /* NOTE: elt_type---the fixed version of elt_type0---should never
8661 depend on the contents of the array in properly constructed
8663 /* Create a fixed version of the array element type.
8664 We're not providing the address of an element here,
8665 and thus the actual object value cannot be inspected to do
8666 the conversion. This should not be a problem, since arrays of
8667 unconstrained objects are not allowed. In particular, all
8668 the elements of an array of a tagged type should all be of
8669 the same type specified in the debugging info. No need to
8670 consult the object tag. */
8671 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8673 /* Make sure we always create a new array type when dealing with
8674 packed array types, since we're going to fix-up the array
8675 type length and element bitsize a little further down. */
8676 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8679 result
= create_array_type (alloc_type_copy (type0
),
8680 elt_type
, TYPE_INDEX_TYPE (type0
));
8685 struct type
*elt_type0
;
8688 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8689 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8691 /* NOTE: result---the fixed version of elt_type0---should never
8692 depend on the contents of the array in properly constructed
8694 /* Create a fixed version of the array element type.
8695 We're not providing the address of an element here,
8696 and thus the actual object value cannot be inspected to do
8697 the conversion. This should not be a problem, since arrays of
8698 unconstrained objects are not allowed. In particular, all
8699 the elements of an array of a tagged type should all be of
8700 the same type specified in the debugging info. No need to
8701 consult the object tag. */
8703 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8706 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8708 struct type
*range_type
=
8709 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8711 result
= create_array_type (alloc_type_copy (elt_type0
),
8712 result
, range_type
);
8713 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8715 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8716 error (_("array type with dynamic size is larger than varsize-limit"));
8719 /* We want to preserve the type name. This can be useful when
8720 trying to get the type name of a value that has already been
8721 printed (for instance, if the user did "print VAR; whatis $". */
8722 result
->set_name (type0
->name ());
8724 if (constrained_packed_array_p
)
8726 /* So far, the resulting type has been created as if the original
8727 type was a regular (non-packed) array type. As a result, the
8728 bitsize of the array elements needs to be set again, and the array
8729 length needs to be recomputed based on that bitsize. */
8730 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8731 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8733 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8734 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8735 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8736 TYPE_LENGTH (result
)++;
8739 TYPE_FIXED_INSTANCE (result
) = 1;
8744 /* A standard type (containing no dynamically sized components)
8745 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8746 DVAL describes a record containing any discriminants used in TYPE0,
8747 and may be NULL if there are none, or if the object of type TYPE at
8748 ADDRESS or in VALADDR contains these discriminants.
8750 If CHECK_TAG is not null, in the case of tagged types, this function
8751 attempts to locate the object's tag and use it to compute the actual
8752 type. However, when ADDRESS is null, we cannot use it to determine the
8753 location of the tag, and therefore compute the tagged type's actual type.
8754 So we return the tagged type without consulting the tag. */
8756 static struct type
*
8757 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8758 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8760 type
= ada_check_typedef (type
);
8762 /* Only un-fixed types need to be handled here. */
8763 if (!HAVE_GNAT_AUX_INFO (type
))
8766 switch (type
->code ())
8770 case TYPE_CODE_STRUCT
:
8772 struct type
*static_type
= to_static_fixed_type (type
);
8773 struct type
*fixed_record_type
=
8774 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8776 /* If STATIC_TYPE is a tagged type and we know the object's address,
8777 then we can determine its tag, and compute the object's actual
8778 type from there. Note that we have to use the fixed record
8779 type (the parent part of the record may have dynamic fields
8780 and the way the location of _tag is expressed may depend on
8783 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8786 value_tag_from_contents_and_address
8790 struct type
*real_type
= type_from_tag (tag
);
8792 value_from_contents_and_address (fixed_record_type
,
8795 fixed_record_type
= value_type (obj
);
8796 if (real_type
!= NULL
)
8797 return to_fixed_record_type
8799 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8802 /* Check to see if there is a parallel ___XVZ variable.
8803 If there is, then it provides the actual size of our type. */
8804 else if (ada_type_name (fixed_record_type
) != NULL
)
8806 const char *name
= ada_type_name (fixed_record_type
);
8808 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8809 bool xvz_found
= false;
8812 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8815 xvz_found
= get_int_var_value (xvz_name
, size
);
8817 catch (const gdb_exception_error
&except
)
8819 /* We found the variable, but somehow failed to read
8820 its value. Rethrow the same error, but with a little
8821 bit more information, to help the user understand
8822 what went wrong (Eg: the variable might have been
8824 throw_error (except
.error
,
8825 _("unable to read value of %s (%s)"),
8826 xvz_name
, except
.what ());
8829 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8831 fixed_record_type
= copy_type (fixed_record_type
);
8832 TYPE_LENGTH (fixed_record_type
) = size
;
8834 /* The FIXED_RECORD_TYPE may have be a stub. We have
8835 observed this when the debugging info is STABS, and
8836 apparently it is something that is hard to fix.
8838 In practice, we don't need the actual type definition
8839 at all, because the presence of the XVZ variable allows us
8840 to assume that there must be a XVS type as well, which we
8841 should be able to use later, when we need the actual type
8844 In the meantime, pretend that the "fixed" type we are
8845 returning is NOT a stub, because this can cause trouble
8846 when using this type to create new types targeting it.
8847 Indeed, the associated creation routines often check
8848 whether the target type is a stub and will try to replace
8849 it, thus using a type with the wrong size. This, in turn,
8850 might cause the new type to have the wrong size too.
8851 Consider the case of an array, for instance, where the size
8852 of the array is computed from the number of elements in
8853 our array multiplied by the size of its element. */
8854 TYPE_STUB (fixed_record_type
) = 0;
8857 return fixed_record_type
;
8859 case TYPE_CODE_ARRAY
:
8860 return to_fixed_array_type (type
, dval
, 1);
8861 case TYPE_CODE_UNION
:
8865 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8869 /* The same as ada_to_fixed_type_1, except that it preserves the type
8870 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8872 The typedef layer needs be preserved in order to differentiate between
8873 arrays and array pointers when both types are implemented using the same
8874 fat pointer. In the array pointer case, the pointer is encoded as
8875 a typedef of the pointer type. For instance, considering:
8877 type String_Access is access String;
8878 S1 : String_Access := null;
8880 To the debugger, S1 is defined as a typedef of type String. But
8881 to the user, it is a pointer. So if the user tries to print S1,
8882 we should not dereference the array, but print the array address
8885 If we didn't preserve the typedef layer, we would lose the fact that
8886 the type is to be presented as a pointer (needs de-reference before
8887 being printed). And we would also use the source-level type name. */
8890 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8891 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8894 struct type
*fixed_type
=
8895 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8897 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8898 then preserve the typedef layer.
8900 Implementation note: We can only check the main-type portion of
8901 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8902 from TYPE now returns a type that has the same instance flags
8903 as TYPE. For instance, if TYPE is a "typedef const", and its
8904 target type is a "struct", then the typedef elimination will return
8905 a "const" version of the target type. See check_typedef for more
8906 details about how the typedef layer elimination is done.
8908 brobecker/2010-11-19: It seems to me that the only case where it is
8909 useful to preserve the typedef layer is when dealing with fat pointers.
8910 Perhaps, we could add a check for that and preserve the typedef layer
8911 only in that situation. But this seems unnecessary so far, probably
8912 because we call check_typedef/ada_check_typedef pretty much everywhere.
8914 if (type
->code () == TYPE_CODE_TYPEDEF
8915 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8916 == TYPE_MAIN_TYPE (fixed_type
)))
8922 /* A standard (static-sized) type corresponding as well as possible to
8923 TYPE0, but based on no runtime data. */
8925 static struct type
*
8926 to_static_fixed_type (struct type
*type0
)
8933 if (TYPE_FIXED_INSTANCE (type0
))
8936 type0
= ada_check_typedef (type0
);
8938 switch (type0
->code ())
8942 case TYPE_CODE_STRUCT
:
8943 type
= dynamic_template_type (type0
);
8945 return template_to_static_fixed_type (type
);
8947 return template_to_static_fixed_type (type0
);
8948 case TYPE_CODE_UNION
:
8949 type
= ada_find_parallel_type (type0
, "___XVU");
8951 return template_to_static_fixed_type (type
);
8953 return template_to_static_fixed_type (type0
);
8957 /* A static approximation of TYPE with all type wrappers removed. */
8959 static struct type
*
8960 static_unwrap_type (struct type
*type
)
8962 if (ada_is_aligner_type (type
))
8964 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
8965 if (ada_type_name (type1
) == NULL
)
8966 type1
->set_name (ada_type_name (type
));
8968 return static_unwrap_type (type1
);
8972 struct type
*raw_real_type
= ada_get_base_type (type
);
8974 if (raw_real_type
== type
)
8977 return to_static_fixed_type (raw_real_type
);
8981 /* In some cases, incomplete and private types require
8982 cross-references that are not resolved as records (for example,
8984 type FooP is access Foo;
8986 type Foo is array ...;
8987 ). In these cases, since there is no mechanism for producing
8988 cross-references to such types, we instead substitute for FooP a
8989 stub enumeration type that is nowhere resolved, and whose tag is
8990 the name of the actual type. Call these types "non-record stubs". */
8992 /* A type equivalent to TYPE that is not a non-record stub, if one
8993 exists, otherwise TYPE. */
8996 ada_check_typedef (struct type
*type
)
9001 /* If our type is an access to an unconstrained array, which is encoded
9002 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9003 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9004 what allows us to distinguish between fat pointers that represent
9005 array types, and fat pointers that represent array access types
9006 (in both cases, the compiler implements them as fat pointers). */
9007 if (ada_is_access_to_unconstrained_array (type
))
9010 type
= check_typedef (type
);
9011 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
9012 || !TYPE_STUB (type
)
9013 || type
->name () == NULL
)
9017 const char *name
= type
->name ();
9018 struct type
*type1
= ada_find_any_type (name
);
9023 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9024 stubs pointing to arrays, as we don't create symbols for array
9025 types, only for the typedef-to-array types). If that's the case,
9026 strip the typedef layer. */
9027 if (type1
->code () == TYPE_CODE_TYPEDEF
)
9028 type1
= ada_check_typedef (type1
);
9034 /* A value representing the data at VALADDR/ADDRESS as described by
9035 type TYPE0, but with a standard (static-sized) type that correctly
9036 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9037 type, then return VAL0 [this feature is simply to avoid redundant
9038 creation of struct values]. */
9040 static struct value
*
9041 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
9044 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
9046 if (type
== type0
&& val0
!= NULL
)
9049 if (VALUE_LVAL (val0
) != lval_memory
)
9051 /* Our value does not live in memory; it could be a convenience
9052 variable, for instance. Create a not_lval value using val0's
9054 return value_from_contents (type
, value_contents (val0
));
9057 return value_from_contents_and_address (type
, 0, address
);
9060 /* A value representing VAL, but with a standard (static-sized) type
9061 that correctly describes it. Does not necessarily create a new
9065 ada_to_fixed_value (struct value
*val
)
9067 val
= unwrap_value (val
);
9068 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
9075 /* Table mapping attribute numbers to names.
9076 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9078 static const char *attribute_names
[] = {
9096 ada_attribute_name (enum exp_opcode n
)
9098 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
9099 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
9101 return attribute_names
[0];
9104 /* Evaluate the 'POS attribute applied to ARG. */
9107 pos_atr (struct value
*arg
)
9109 struct value
*val
= coerce_ref (arg
);
9110 struct type
*type
= value_type (val
);
9113 if (!discrete_type_p (type
))
9114 error (_("'POS only defined on discrete types"));
9116 if (!discrete_position (type
, value_as_long (val
), &result
))
9117 error (_("enumeration value is invalid: can't find 'POS"));
9122 static struct value
*
9123 value_pos_atr (struct type
*type
, struct value
*arg
)
9125 return value_from_longest (type
, pos_atr (arg
));
9128 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9130 static struct value
*
9131 val_atr (struct type
*type
, LONGEST val
)
9133 gdb_assert (discrete_type_p (type
));
9134 if (type
->code () == TYPE_CODE_RANGE
)
9135 type
= TYPE_TARGET_TYPE (type
);
9136 if (type
->code () == TYPE_CODE_ENUM
)
9138 if (val
< 0 || val
>= type
->num_fields ())
9139 error (_("argument to 'VAL out of range"));
9140 val
= TYPE_FIELD_ENUMVAL (type
, val
);
9142 return value_from_longest (type
, val
);
9145 static struct value
*
9146 value_val_atr (struct type
*type
, struct value
*arg
)
9148 if (!discrete_type_p (type
))
9149 error (_("'VAL only defined on discrete types"));
9150 if (!integer_type_p (value_type (arg
)))
9151 error (_("'VAL requires integral argument"));
9153 return val_atr (type
, value_as_long (arg
));
9159 /* True if TYPE appears to be an Ada character type.
9160 [At the moment, this is true only for Character and Wide_Character;
9161 It is a heuristic test that could stand improvement]. */
9164 ada_is_character_type (struct type
*type
)
9168 /* If the type code says it's a character, then assume it really is,
9169 and don't check any further. */
9170 if (type
->code () == TYPE_CODE_CHAR
)
9173 /* Otherwise, assume it's a character type iff it is a discrete type
9174 with a known character type name. */
9175 name
= ada_type_name (type
);
9176 return (name
!= NULL
9177 && (type
->code () == TYPE_CODE_INT
9178 || type
->code () == TYPE_CODE_RANGE
)
9179 && (strcmp (name
, "character") == 0
9180 || strcmp (name
, "wide_character") == 0
9181 || strcmp (name
, "wide_wide_character") == 0
9182 || strcmp (name
, "unsigned char") == 0));
9185 /* True if TYPE appears to be an Ada string type. */
9188 ada_is_string_type (struct type
*type
)
9190 type
= ada_check_typedef (type
);
9192 && type
->code () != TYPE_CODE_PTR
9193 && (ada_is_simple_array_type (type
)
9194 || ada_is_array_descriptor_type (type
))
9195 && ada_array_arity (type
) == 1)
9197 struct type
*elttype
= ada_array_element_type (type
, 1);
9199 return ada_is_character_type (elttype
);
9205 /* The compiler sometimes provides a parallel XVS type for a given
9206 PAD type. Normally, it is safe to follow the PAD type directly,
9207 but older versions of the compiler have a bug that causes the offset
9208 of its "F" field to be wrong. Following that field in that case
9209 would lead to incorrect results, but this can be worked around
9210 by ignoring the PAD type and using the associated XVS type instead.
9212 Set to True if the debugger should trust the contents of PAD types.
9213 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9214 static bool trust_pad_over_xvs
= true;
9216 /* True if TYPE is a struct type introduced by the compiler to force the
9217 alignment of a value. Such types have a single field with a
9218 distinctive name. */
9221 ada_is_aligner_type (struct type
*type
)
9223 type
= ada_check_typedef (type
);
9225 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9228 return (type
->code () == TYPE_CODE_STRUCT
9229 && type
->num_fields () == 1
9230 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9233 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9234 the parallel type. */
9237 ada_get_base_type (struct type
*raw_type
)
9239 struct type
*real_type_namer
;
9240 struct type
*raw_real_type
;
9242 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9245 if (ada_is_aligner_type (raw_type
))
9246 /* The encoding specifies that we should always use the aligner type.
9247 So, even if this aligner type has an associated XVS type, we should
9250 According to the compiler gurus, an XVS type parallel to an aligner
9251 type may exist because of a stabs limitation. In stabs, aligner
9252 types are empty because the field has a variable-sized type, and
9253 thus cannot actually be used as an aligner type. As a result,
9254 we need the associated parallel XVS type to decode the type.
9255 Since the policy in the compiler is to not change the internal
9256 representation based on the debugging info format, we sometimes
9257 end up having a redundant XVS type parallel to the aligner type. */
9260 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9261 if (real_type_namer
== NULL
9262 || real_type_namer
->code () != TYPE_CODE_STRUCT
9263 || real_type_namer
->num_fields () != 1)
9266 if (TYPE_FIELD_TYPE (real_type_namer
, 0)->code () != TYPE_CODE_REF
)
9268 /* This is an older encoding form where the base type needs to be
9269 looked up by name. We prefer the newer encoding because it is
9271 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9272 if (raw_real_type
== NULL
)
9275 return raw_real_type
;
9278 /* The field in our XVS type is a reference to the base type. */
9279 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
9282 /* The type of value designated by TYPE, with all aligners removed. */
9285 ada_aligned_type (struct type
*type
)
9287 if (ada_is_aligner_type (type
))
9288 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
9290 return ada_get_base_type (type
);
9294 /* The address of the aligned value in an object at address VALADDR
9295 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9298 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9300 if (ada_is_aligner_type (type
))
9301 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
9303 TYPE_FIELD_BITPOS (type
,
9304 0) / TARGET_CHAR_BIT
);
9311 /* The printed representation of an enumeration literal with encoded
9312 name NAME. The value is good to the next call of ada_enum_name. */
9314 ada_enum_name (const char *name
)
9316 static char *result
;
9317 static size_t result_len
= 0;
9320 /* First, unqualify the enumeration name:
9321 1. Search for the last '.' character. If we find one, then skip
9322 all the preceding characters, the unqualified name starts
9323 right after that dot.
9324 2. Otherwise, we may be debugging on a target where the compiler
9325 translates dots into "__". Search forward for double underscores,
9326 but stop searching when we hit an overloading suffix, which is
9327 of the form "__" followed by digits. */
9329 tmp
= strrchr (name
, '.');
9334 while ((tmp
= strstr (name
, "__")) != NULL
)
9336 if (isdigit (tmp
[2]))
9347 if (name
[1] == 'U' || name
[1] == 'W')
9349 if (sscanf (name
+ 2, "%x", &v
) != 1)
9352 else if (((name
[1] >= '0' && name
[1] <= '9')
9353 || (name
[1] >= 'a' && name
[1] <= 'z'))
9356 GROW_VECT (result
, result_len
, 4);
9357 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9363 GROW_VECT (result
, result_len
, 16);
9364 if (isascii (v
) && isprint (v
))
9365 xsnprintf (result
, result_len
, "'%c'", v
);
9366 else if (name
[1] == 'U')
9367 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9369 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9375 tmp
= strstr (name
, "__");
9377 tmp
= strstr (name
, "$");
9380 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9381 strncpy (result
, name
, tmp
- name
);
9382 result
[tmp
- name
] = '\0';
9390 /* Evaluate the subexpression of EXP starting at *POS as for
9391 evaluate_type, updating *POS to point just past the evaluated
9394 static struct value
*
9395 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9397 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9400 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9403 static struct value
*
9404 unwrap_value (struct value
*val
)
9406 struct type
*type
= ada_check_typedef (value_type (val
));
9408 if (ada_is_aligner_type (type
))
9410 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9411 struct type
*val_type
= ada_check_typedef (value_type (v
));
9413 if (ada_type_name (val_type
) == NULL
)
9414 val_type
->set_name (ada_type_name (type
));
9416 return unwrap_value (v
);
9420 struct type
*raw_real_type
=
9421 ada_check_typedef (ada_get_base_type (type
));
9423 /* If there is no parallel XVS or XVE type, then the value is
9424 already unwrapped. Return it without further modification. */
9425 if ((type
== raw_real_type
)
9426 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9430 coerce_unspec_val_to_type
9431 (val
, ada_to_fixed_type (raw_real_type
, 0,
9432 value_address (val
),
9437 static struct value
*
9438 cast_from_fixed (struct type
*type
, struct value
*arg
)
9440 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9441 arg
= value_cast (value_type (scale
), arg
);
9443 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9444 return value_cast (type
, arg
);
9447 static struct value
*
9448 cast_to_fixed (struct type
*type
, struct value
*arg
)
9450 if (type
== value_type (arg
))
9453 struct value
*scale
= ada_scaling_factor (type
);
9454 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9455 arg
= cast_from_fixed (value_type (scale
), arg
);
9457 arg
= value_cast (value_type (scale
), arg
);
9459 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9460 return value_cast (type
, arg
);
9463 /* Given two array types T1 and T2, return nonzero iff both arrays
9464 contain the same number of elements. */
9467 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9469 LONGEST lo1
, hi1
, lo2
, hi2
;
9471 /* Get the array bounds in order to verify that the size of
9472 the two arrays match. */
9473 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9474 || !get_array_bounds (t2
, &lo2
, &hi2
))
9475 error (_("unable to determine array bounds"));
9477 /* To make things easier for size comparison, normalize a bit
9478 the case of empty arrays by making sure that the difference
9479 between upper bound and lower bound is always -1. */
9485 return (hi1
- lo1
== hi2
- lo2
);
9488 /* Assuming that VAL is an array of integrals, and TYPE represents
9489 an array with the same number of elements, but with wider integral
9490 elements, return an array "casted" to TYPE. In practice, this
9491 means that the returned array is built by casting each element
9492 of the original array into TYPE's (wider) element type. */
9494 static struct value
*
9495 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9497 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9502 /* Verify that both val and type are arrays of scalars, and
9503 that the size of val's elements is smaller than the size
9504 of type's element. */
9505 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9506 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9507 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9508 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9509 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9510 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9512 if (!get_array_bounds (type
, &lo
, &hi
))
9513 error (_("unable to determine array bounds"));
9515 res
= allocate_value (type
);
9517 /* Promote each array element. */
9518 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9520 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9522 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9523 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9529 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9530 return the converted value. */
9532 static struct value
*
9533 coerce_for_assign (struct type
*type
, struct value
*val
)
9535 struct type
*type2
= value_type (val
);
9540 type2
= ada_check_typedef (type2
);
9541 type
= ada_check_typedef (type
);
9543 if (type2
->code () == TYPE_CODE_PTR
9544 && type
->code () == TYPE_CODE_ARRAY
)
9546 val
= ada_value_ind (val
);
9547 type2
= value_type (val
);
9550 if (type2
->code () == TYPE_CODE_ARRAY
9551 && type
->code () == TYPE_CODE_ARRAY
)
9553 if (!ada_same_array_size_p (type
, type2
))
9554 error (_("cannot assign arrays of different length"));
9556 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9557 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9558 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9559 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9561 /* Allow implicit promotion of the array elements to
9563 return ada_promote_array_of_integrals (type
, val
);
9566 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9567 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9568 error (_("Incompatible types in assignment"));
9569 deprecated_set_value_type (val
, type
);
9574 static struct value
*
9575 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9578 struct type
*type1
, *type2
;
9581 arg1
= coerce_ref (arg1
);
9582 arg2
= coerce_ref (arg2
);
9583 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9584 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9586 if (type1
->code () != TYPE_CODE_INT
9587 || type2
->code () != TYPE_CODE_INT
)
9588 return value_binop (arg1
, arg2
, op
);
9597 return value_binop (arg1
, arg2
, op
);
9600 v2
= value_as_long (arg2
);
9602 error (_("second operand of %s must not be zero."), op_string (op
));
9604 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9605 return value_binop (arg1
, arg2
, op
);
9607 v1
= value_as_long (arg1
);
9612 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9613 v
+= v
> 0 ? -1 : 1;
9621 /* Should not reach this point. */
9625 val
= allocate_value (type1
);
9626 store_unsigned_integer (value_contents_raw (val
),
9627 TYPE_LENGTH (value_type (val
)),
9628 type_byte_order (type1
), v
);
9633 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9635 if (ada_is_direct_array_type (value_type (arg1
))
9636 || ada_is_direct_array_type (value_type (arg2
)))
9638 struct type
*arg1_type
, *arg2_type
;
9640 /* Automatically dereference any array reference before
9641 we attempt to perform the comparison. */
9642 arg1
= ada_coerce_ref (arg1
);
9643 arg2
= ada_coerce_ref (arg2
);
9645 arg1
= ada_coerce_to_simple_array (arg1
);
9646 arg2
= ada_coerce_to_simple_array (arg2
);
9648 arg1_type
= ada_check_typedef (value_type (arg1
));
9649 arg2_type
= ada_check_typedef (value_type (arg2
));
9651 if (arg1_type
->code () != TYPE_CODE_ARRAY
9652 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9653 error (_("Attempt to compare array with non-array"));
9654 /* FIXME: The following works only for types whose
9655 representations use all bits (no padding or undefined bits)
9656 and do not have user-defined equality. */
9657 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9658 && memcmp (value_contents (arg1
), value_contents (arg2
),
9659 TYPE_LENGTH (arg1_type
)) == 0);
9661 return value_equal (arg1
, arg2
);
9664 /* Total number of component associations in the aggregate starting at
9665 index PC in EXP. Assumes that index PC is the start of an
9669 num_component_specs (struct expression
*exp
, int pc
)
9673 m
= exp
->elts
[pc
+ 1].longconst
;
9676 for (i
= 0; i
< m
; i
+= 1)
9678 switch (exp
->elts
[pc
].opcode
)
9684 n
+= exp
->elts
[pc
+ 1].longconst
;
9687 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9692 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9693 component of LHS (a simple array or a record), updating *POS past
9694 the expression, assuming that LHS is contained in CONTAINER. Does
9695 not modify the inferior's memory, nor does it modify LHS (unless
9696 LHS == CONTAINER). */
9699 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9700 struct expression
*exp
, int *pos
)
9702 struct value
*mark
= value_mark ();
9704 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9706 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9708 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9709 struct value
*index_val
= value_from_longest (index_type
, index
);
9711 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9715 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9716 elt
= ada_to_fixed_value (elt
);
9719 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9720 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9722 value_assign_to_component (container
, elt
,
9723 ada_evaluate_subexp (NULL
, exp
, pos
,
9726 value_free_to_mark (mark
);
9729 /* Assuming that LHS represents an lvalue having a record or array
9730 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9731 of that aggregate's value to LHS, advancing *POS past the
9732 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9733 lvalue containing LHS (possibly LHS itself). Does not modify
9734 the inferior's memory, nor does it modify the contents of
9735 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9737 static struct value
*
9738 assign_aggregate (struct value
*container
,
9739 struct value
*lhs
, struct expression
*exp
,
9740 int *pos
, enum noside noside
)
9742 struct type
*lhs_type
;
9743 int n
= exp
->elts
[*pos
+1].longconst
;
9744 LONGEST low_index
, high_index
;
9747 int max_indices
, num_indices
;
9751 if (noside
!= EVAL_NORMAL
)
9753 for (i
= 0; i
< n
; i
+= 1)
9754 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9758 container
= ada_coerce_ref (container
);
9759 if (ada_is_direct_array_type (value_type (container
)))
9760 container
= ada_coerce_to_simple_array (container
);
9761 lhs
= ada_coerce_ref (lhs
);
9762 if (!deprecated_value_modifiable (lhs
))
9763 error (_("Left operand of assignment is not a modifiable lvalue."));
9765 lhs_type
= check_typedef (value_type (lhs
));
9766 if (ada_is_direct_array_type (lhs_type
))
9768 lhs
= ada_coerce_to_simple_array (lhs
);
9769 lhs_type
= check_typedef (value_type (lhs
));
9770 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9771 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9773 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9776 high_index
= num_visible_fields (lhs_type
) - 1;
9779 error (_("Left-hand side must be array or record."));
9781 num_specs
= num_component_specs (exp
, *pos
- 3);
9782 max_indices
= 4 * num_specs
+ 4;
9783 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9784 indices
[0] = indices
[1] = low_index
- 1;
9785 indices
[2] = indices
[3] = high_index
+ 1;
9788 for (i
= 0; i
< n
; i
+= 1)
9790 switch (exp
->elts
[*pos
].opcode
)
9793 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9794 &num_indices
, max_indices
,
9795 low_index
, high_index
);
9798 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9799 &num_indices
, max_indices
,
9800 low_index
, high_index
);
9804 error (_("Misplaced 'others' clause"));
9805 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9806 num_indices
, low_index
, high_index
);
9809 error (_("Internal error: bad aggregate clause"));
9816 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9817 construct at *POS, updating *POS past the construct, given that
9818 the positions are relative to lower bound LOW, where HIGH is the
9819 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9820 updating *NUM_INDICES as needed. CONTAINER is as for
9821 assign_aggregate. */
9823 aggregate_assign_positional (struct value
*container
,
9824 struct value
*lhs
, struct expression
*exp
,
9825 int *pos
, LONGEST
*indices
, int *num_indices
,
9826 int max_indices
, LONGEST low
, LONGEST high
)
9828 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9830 if (ind
- 1 == high
)
9831 warning (_("Extra components in aggregate ignored."));
9834 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9836 assign_component (container
, lhs
, ind
, exp
, pos
);
9839 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9842 /* Assign into the components of LHS indexed by the OP_CHOICES
9843 construct at *POS, updating *POS past the construct, given that
9844 the allowable indices are LOW..HIGH. Record the indices assigned
9845 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9846 needed. CONTAINER is as for assign_aggregate. */
9848 aggregate_assign_from_choices (struct value
*container
,
9849 struct value
*lhs
, struct expression
*exp
,
9850 int *pos
, LONGEST
*indices
, int *num_indices
,
9851 int max_indices
, LONGEST low
, LONGEST high
)
9854 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9855 int choice_pos
, expr_pc
;
9856 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9858 choice_pos
= *pos
+= 3;
9860 for (j
= 0; j
< n_choices
; j
+= 1)
9861 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9863 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9865 for (j
= 0; j
< n_choices
; j
+= 1)
9867 LONGEST lower
, upper
;
9868 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9870 if (op
== OP_DISCRETE_RANGE
)
9873 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9875 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9880 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9892 name
= &exp
->elts
[choice_pos
+ 2].string
;
9895 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9898 error (_("Invalid record component association."));
9900 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9902 if (! find_struct_field (name
, value_type (lhs
), 0,
9903 NULL
, NULL
, NULL
, NULL
, &ind
))
9904 error (_("Unknown component name: %s."), name
);
9905 lower
= upper
= ind
;
9908 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9909 error (_("Index in component association out of bounds."));
9911 add_component_interval (lower
, upper
, indices
, num_indices
,
9913 while (lower
<= upper
)
9918 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9924 /* Assign the value of the expression in the OP_OTHERS construct in
9925 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9926 have not been previously assigned. The index intervals already assigned
9927 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9928 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9930 aggregate_assign_others (struct value
*container
,
9931 struct value
*lhs
, struct expression
*exp
,
9932 int *pos
, LONGEST
*indices
, int num_indices
,
9933 LONGEST low
, LONGEST high
)
9936 int expr_pc
= *pos
+ 1;
9938 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9942 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9947 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9950 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9953 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9954 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9955 modifying *SIZE as needed. It is an error if *SIZE exceeds
9956 MAX_SIZE. The resulting intervals do not overlap. */
9958 add_component_interval (LONGEST low
, LONGEST high
,
9959 LONGEST
* indices
, int *size
, int max_size
)
9963 for (i
= 0; i
< *size
; i
+= 2) {
9964 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9968 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9969 if (high
< indices
[kh
])
9971 if (low
< indices
[i
])
9973 indices
[i
+ 1] = indices
[kh
- 1];
9974 if (high
> indices
[i
+ 1])
9975 indices
[i
+ 1] = high
;
9976 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9977 *size
-= kh
- i
- 2;
9980 else if (high
< indices
[i
])
9984 if (*size
== max_size
)
9985 error (_("Internal error: miscounted aggregate components."));
9987 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9988 indices
[j
] = indices
[j
- 2];
9990 indices
[i
+ 1] = high
;
9993 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9996 static struct value
*
9997 ada_value_cast (struct type
*type
, struct value
*arg2
)
9999 if (type
== ada_check_typedef (value_type (arg2
)))
10002 if (ada_is_gnat_encoded_fixed_point_type (type
))
10003 return cast_to_fixed (type
, arg2
);
10005 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10006 return cast_from_fixed (type
, arg2
);
10008 return value_cast (type
, arg2
);
10011 /* Evaluating Ada expressions, and printing their result.
10012 ------------------------------------------------------
10017 We usually evaluate an Ada expression in order to print its value.
10018 We also evaluate an expression in order to print its type, which
10019 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10020 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10021 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10022 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10025 Evaluating expressions is a little more complicated for Ada entities
10026 than it is for entities in languages such as C. The main reason for
10027 this is that Ada provides types whose definition might be dynamic.
10028 One example of such types is variant records. Or another example
10029 would be an array whose bounds can only be known at run time.
10031 The following description is a general guide as to what should be
10032 done (and what should NOT be done) in order to evaluate an expression
10033 involving such types, and when. This does not cover how the semantic
10034 information is encoded by GNAT as this is covered separatly. For the
10035 document used as the reference for the GNAT encoding, see exp_dbug.ads
10036 in the GNAT sources.
10038 Ideally, we should embed each part of this description next to its
10039 associated code. Unfortunately, the amount of code is so vast right
10040 now that it's hard to see whether the code handling a particular
10041 situation might be duplicated or not. One day, when the code is
10042 cleaned up, this guide might become redundant with the comments
10043 inserted in the code, and we might want to remove it.
10045 2. ``Fixing'' an Entity, the Simple Case:
10046 -----------------------------------------
10048 When evaluating Ada expressions, the tricky issue is that they may
10049 reference entities whose type contents and size are not statically
10050 known. Consider for instance a variant record:
10052 type Rec (Empty : Boolean := True) is record
10055 when False => Value : Integer;
10058 Yes : Rec := (Empty => False, Value => 1);
10059 No : Rec := (empty => True);
10061 The size and contents of that record depends on the value of the
10062 descriminant (Rec.Empty). At this point, neither the debugging
10063 information nor the associated type structure in GDB are able to
10064 express such dynamic types. So what the debugger does is to create
10065 "fixed" versions of the type that applies to the specific object.
10066 We also informally refer to this operation as "fixing" an object,
10067 which means creating its associated fixed type.
10069 Example: when printing the value of variable "Yes" above, its fixed
10070 type would look like this:
10077 On the other hand, if we printed the value of "No", its fixed type
10084 Things become a little more complicated when trying to fix an entity
10085 with a dynamic type that directly contains another dynamic type,
10086 such as an array of variant records, for instance. There are
10087 two possible cases: Arrays, and records.
10089 3. ``Fixing'' Arrays:
10090 ---------------------
10092 The type structure in GDB describes an array in terms of its bounds,
10093 and the type of its elements. By design, all elements in the array
10094 have the same type and we cannot represent an array of variant elements
10095 using the current type structure in GDB. When fixing an array,
10096 we cannot fix the array element, as we would potentially need one
10097 fixed type per element of the array. As a result, the best we can do
10098 when fixing an array is to produce an array whose bounds and size
10099 are correct (allowing us to read it from memory), but without having
10100 touched its element type. Fixing each element will be done later,
10101 when (if) necessary.
10103 Arrays are a little simpler to handle than records, because the same
10104 amount of memory is allocated for each element of the array, even if
10105 the amount of space actually used by each element differs from element
10106 to element. Consider for instance the following array of type Rec:
10108 type Rec_Array is array (1 .. 2) of Rec;
10110 The actual amount of memory occupied by each element might be different
10111 from element to element, depending on the value of their discriminant.
10112 But the amount of space reserved for each element in the array remains
10113 fixed regardless. So we simply need to compute that size using
10114 the debugging information available, from which we can then determine
10115 the array size (we multiply the number of elements of the array by
10116 the size of each element).
10118 The simplest case is when we have an array of a constrained element
10119 type. For instance, consider the following type declarations:
10121 type Bounded_String (Max_Size : Integer) is
10123 Buffer : String (1 .. Max_Size);
10125 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10127 In this case, the compiler describes the array as an array of
10128 variable-size elements (identified by its XVS suffix) for which
10129 the size can be read in the parallel XVZ variable.
10131 In the case of an array of an unconstrained element type, the compiler
10132 wraps the array element inside a private PAD type. This type should not
10133 be shown to the user, and must be "unwrap"'ed before printing. Note
10134 that we also use the adjective "aligner" in our code to designate
10135 these wrapper types.
10137 In some cases, the size allocated for each element is statically
10138 known. In that case, the PAD type already has the correct size,
10139 and the array element should remain unfixed.
10141 But there are cases when this size is not statically known.
10142 For instance, assuming that "Five" is an integer variable:
10144 type Dynamic is array (1 .. Five) of Integer;
10145 type Wrapper (Has_Length : Boolean := False) is record
10148 when True => Length : Integer;
10149 when False => null;
10152 type Wrapper_Array is array (1 .. 2) of Wrapper;
10154 Hello : Wrapper_Array := (others => (Has_Length => True,
10155 Data => (others => 17),
10159 The debugging info would describe variable Hello as being an
10160 array of a PAD type. The size of that PAD type is not statically
10161 known, but can be determined using a parallel XVZ variable.
10162 In that case, a copy of the PAD type with the correct size should
10163 be used for the fixed array.
10165 3. ``Fixing'' record type objects:
10166 ----------------------------------
10168 Things are slightly different from arrays in the case of dynamic
10169 record types. In this case, in order to compute the associated
10170 fixed type, we need to determine the size and offset of each of
10171 its components. This, in turn, requires us to compute the fixed
10172 type of each of these components.
10174 Consider for instance the example:
10176 type Bounded_String (Max_Size : Natural) is record
10177 Str : String (1 .. Max_Size);
10180 My_String : Bounded_String (Max_Size => 10);
10182 In that case, the position of field "Length" depends on the size
10183 of field Str, which itself depends on the value of the Max_Size
10184 discriminant. In order to fix the type of variable My_String,
10185 we need to fix the type of field Str. Therefore, fixing a variant
10186 record requires us to fix each of its components.
10188 However, if a component does not have a dynamic size, the component
10189 should not be fixed. In particular, fields that use a PAD type
10190 should not fixed. Here is an example where this might happen
10191 (assuming type Rec above):
10193 type Container (Big : Boolean) is record
10197 when True => Another : Integer;
10198 when False => null;
10201 My_Container : Container := (Big => False,
10202 First => (Empty => True),
10205 In that example, the compiler creates a PAD type for component First,
10206 whose size is constant, and then positions the component After just
10207 right after it. The offset of component After is therefore constant
10210 The debugger computes the position of each field based on an algorithm
10211 that uses, among other things, the actual position and size of the field
10212 preceding it. Let's now imagine that the user is trying to print
10213 the value of My_Container. If the type fixing was recursive, we would
10214 end up computing the offset of field After based on the size of the
10215 fixed version of field First. And since in our example First has
10216 only one actual field, the size of the fixed type is actually smaller
10217 than the amount of space allocated to that field, and thus we would
10218 compute the wrong offset of field After.
10220 To make things more complicated, we need to watch out for dynamic
10221 components of variant records (identified by the ___XVL suffix in
10222 the component name). Even if the target type is a PAD type, the size
10223 of that type might not be statically known. So the PAD type needs
10224 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10225 we might end up with the wrong size for our component. This can be
10226 observed with the following type declarations:
10228 type Octal is new Integer range 0 .. 7;
10229 type Octal_Array is array (Positive range <>) of Octal;
10230 pragma Pack (Octal_Array);
10232 type Octal_Buffer (Size : Positive) is record
10233 Buffer : Octal_Array (1 .. Size);
10237 In that case, Buffer is a PAD type whose size is unset and needs
10238 to be computed by fixing the unwrapped type.
10240 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10241 ----------------------------------------------------------
10243 Lastly, when should the sub-elements of an entity that remained unfixed
10244 thus far, be actually fixed?
10246 The answer is: Only when referencing that element. For instance
10247 when selecting one component of a record, this specific component
10248 should be fixed at that point in time. Or when printing the value
10249 of a record, each component should be fixed before its value gets
10250 printed. Similarly for arrays, the element of the array should be
10251 fixed when printing each element of the array, or when extracting
10252 one element out of that array. On the other hand, fixing should
10253 not be performed on the elements when taking a slice of an array!
10255 Note that one of the side effects of miscomputing the offset and
10256 size of each field is that we end up also miscomputing the size
10257 of the containing type. This can have adverse results when computing
10258 the value of an entity. GDB fetches the value of an entity based
10259 on the size of its type, and thus a wrong size causes GDB to fetch
10260 the wrong amount of memory. In the case where the computed size is
10261 too small, GDB fetches too little data to print the value of our
10262 entity. Results in this case are unpredictable, as we usually read
10263 past the buffer containing the data =:-o. */
10265 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10266 for that subexpression cast to TO_TYPE. Advance *POS over the
10270 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10271 enum noside noside
, struct type
*to_type
)
10275 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10276 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10281 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10283 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10284 return value_zero (to_type
, not_lval
);
10286 val
= evaluate_var_msym_value (noside
,
10287 exp
->elts
[pc
+ 1].objfile
,
10288 exp
->elts
[pc
+ 2].msymbol
);
10291 val
= evaluate_var_value (noside
,
10292 exp
->elts
[pc
+ 1].block
,
10293 exp
->elts
[pc
+ 2].symbol
);
10295 if (noside
== EVAL_SKIP
)
10296 return eval_skip_value (exp
);
10298 val
= ada_value_cast (to_type
, val
);
10300 /* Follow the Ada language semantics that do not allow taking
10301 an address of the result of a cast (view conversion in Ada). */
10302 if (VALUE_LVAL (val
) == lval_memory
)
10304 if (value_lazy (val
))
10305 value_fetch_lazy (val
);
10306 VALUE_LVAL (val
) = not_lval
;
10311 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10312 if (noside
== EVAL_SKIP
)
10313 return eval_skip_value (exp
);
10314 return ada_value_cast (to_type
, val
);
10317 /* Implement the evaluate_exp routine in the exp_descriptor structure
10318 for the Ada language. */
10320 static struct value
*
10321 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10322 int *pos
, enum noside noside
)
10324 enum exp_opcode op
;
10328 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10331 struct value
**argvec
;
10335 op
= exp
->elts
[pc
].opcode
;
10341 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10343 if (noside
== EVAL_NORMAL
)
10344 arg1
= unwrap_value (arg1
);
10346 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10347 then we need to perform the conversion manually, because
10348 evaluate_subexp_standard doesn't do it. This conversion is
10349 necessary in Ada because the different kinds of float/fixed
10350 types in Ada have different representations.
10352 Similarly, we need to perform the conversion from OP_LONG
10354 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10355 arg1
= ada_value_cast (expect_type
, arg1
);
10361 struct value
*result
;
10364 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10365 /* The result type will have code OP_STRING, bashed there from
10366 OP_ARRAY. Bash it back. */
10367 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10368 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10374 type
= exp
->elts
[pc
+ 1].type
;
10375 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10379 type
= exp
->elts
[pc
+ 1].type
;
10380 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10383 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10384 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10386 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10387 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10389 return ada_value_assign (arg1
, arg1
);
10391 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10392 except if the lhs of our assignment is a convenience variable.
10393 In the case of assigning to a convenience variable, the lhs
10394 should be exactly the result of the evaluation of the rhs. */
10395 type
= value_type (arg1
);
10396 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10398 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10399 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10401 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10405 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10406 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10407 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10409 (_("Fixed-point values must be assigned to fixed-point variables"));
10411 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10412 return ada_value_assign (arg1
, arg2
);
10415 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10416 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10417 if (noside
== EVAL_SKIP
)
10419 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10420 return (value_from_longest
10421 (value_type (arg1
),
10422 value_as_long (arg1
) + value_as_long (arg2
)));
10423 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10424 return (value_from_longest
10425 (value_type (arg2
),
10426 value_as_long (arg1
) + value_as_long (arg2
)));
10427 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10428 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10429 && value_type (arg1
) != value_type (arg2
))
10430 error (_("Operands of fixed-point addition must have the same type"));
10431 /* Do the addition, and cast the result to the type of the first
10432 argument. We cannot cast the result to a reference type, so if
10433 ARG1 is a reference type, find its underlying type. */
10434 type
= value_type (arg1
);
10435 while (type
->code () == TYPE_CODE_REF
)
10436 type
= TYPE_TARGET_TYPE (type
);
10437 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10438 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10441 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10442 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10443 if (noside
== EVAL_SKIP
)
10445 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10446 return (value_from_longest
10447 (value_type (arg1
),
10448 value_as_long (arg1
) - value_as_long (arg2
)));
10449 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10450 return (value_from_longest
10451 (value_type (arg2
),
10452 value_as_long (arg1
) - value_as_long (arg2
)));
10453 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10454 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10455 && value_type (arg1
) != value_type (arg2
))
10456 error (_("Operands of fixed-point subtraction "
10457 "must have the same type"));
10458 /* Do the substraction, and cast the result to the type of the first
10459 argument. We cannot cast the result to a reference type, so if
10460 ARG1 is a reference type, find its underlying type. */
10461 type
= value_type (arg1
);
10462 while (type
->code () == TYPE_CODE_REF
)
10463 type
= TYPE_TARGET_TYPE (type
);
10464 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10465 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10471 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10472 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10473 if (noside
== EVAL_SKIP
)
10475 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10477 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10478 return value_zero (value_type (arg1
), not_lval
);
10482 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10483 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10484 arg1
= cast_from_fixed (type
, arg1
);
10485 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10486 arg2
= cast_from_fixed (type
, arg2
);
10487 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10488 return ada_value_binop (arg1
, arg2
, op
);
10492 case BINOP_NOTEQUAL
:
10493 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10494 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10495 if (noside
== EVAL_SKIP
)
10497 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10501 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10502 tem
= ada_value_equal (arg1
, arg2
);
10504 if (op
== BINOP_NOTEQUAL
)
10506 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10507 return value_from_longest (type
, (LONGEST
) tem
);
10510 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10511 if (noside
== EVAL_SKIP
)
10513 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10514 return value_cast (value_type (arg1
), value_neg (arg1
));
10517 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10518 return value_neg (arg1
);
10521 case BINOP_LOGICAL_AND
:
10522 case BINOP_LOGICAL_OR
:
10523 case UNOP_LOGICAL_NOT
:
10528 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10529 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10530 return value_cast (type
, val
);
10533 case BINOP_BITWISE_AND
:
10534 case BINOP_BITWISE_IOR
:
10535 case BINOP_BITWISE_XOR
:
10539 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10541 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10543 return value_cast (value_type (arg1
), val
);
10549 if (noside
== EVAL_SKIP
)
10555 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10556 /* Only encountered when an unresolved symbol occurs in a
10557 context other than a function call, in which case, it is
10559 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10560 exp
->elts
[pc
+ 2].symbol
->print_name ());
10562 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10564 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10565 /* Check to see if this is a tagged type. We also need to handle
10566 the case where the type is a reference to a tagged type, but
10567 we have to be careful to exclude pointers to tagged types.
10568 The latter should be shown as usual (as a pointer), whereas
10569 a reference should mostly be transparent to the user. */
10570 if (ada_is_tagged_type (type
, 0)
10571 || (type
->code () == TYPE_CODE_REF
10572 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10574 /* Tagged types are a little special in the fact that the real
10575 type is dynamic and can only be determined by inspecting the
10576 object's tag. This means that we need to get the object's
10577 value first (EVAL_NORMAL) and then extract the actual object
10580 Note that we cannot skip the final step where we extract
10581 the object type from its tag, because the EVAL_NORMAL phase
10582 results in dynamic components being resolved into fixed ones.
10583 This can cause problems when trying to print the type
10584 description of tagged types whose parent has a dynamic size:
10585 We use the type name of the "_parent" component in order
10586 to print the name of the ancestor type in the type description.
10587 If that component had a dynamic size, the resolution into
10588 a fixed type would result in the loss of that type name,
10589 thus preventing us from printing the name of the ancestor
10590 type in the type description. */
10591 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10593 if (type
->code () != TYPE_CODE_REF
)
10595 struct type
*actual_type
;
10597 actual_type
= type_from_tag (ada_value_tag (arg1
));
10598 if (actual_type
== NULL
)
10599 /* If, for some reason, we were unable to determine
10600 the actual type from the tag, then use the static
10601 approximation that we just computed as a fallback.
10602 This can happen if the debugging information is
10603 incomplete, for instance. */
10604 actual_type
= type
;
10605 return value_zero (actual_type
, not_lval
);
10609 /* In the case of a ref, ada_coerce_ref takes care
10610 of determining the actual type. But the evaluation
10611 should return a ref as it should be valid to ask
10612 for its address; so rebuild a ref after coerce. */
10613 arg1
= ada_coerce_ref (arg1
);
10614 return value_ref (arg1
, TYPE_CODE_REF
);
10618 /* Records and unions for which GNAT encodings have been
10619 generated need to be statically fixed as well.
10620 Otherwise, non-static fixing produces a type where
10621 all dynamic properties are removed, which prevents "ptype"
10622 from being able to completely describe the type.
10623 For instance, a case statement in a variant record would be
10624 replaced by the relevant components based on the actual
10625 value of the discriminants. */
10626 if ((type
->code () == TYPE_CODE_STRUCT
10627 && dynamic_template_type (type
) != NULL
)
10628 || (type
->code () == TYPE_CODE_UNION
10629 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10632 return value_zero (to_static_fixed_type (type
), not_lval
);
10636 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10637 return ada_to_fixed_value (arg1
);
10642 /* Allocate arg vector, including space for the function to be
10643 called in argvec[0] and a terminating NULL. */
10644 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10645 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10647 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10648 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10649 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10650 exp
->elts
[pc
+ 5].symbol
->print_name ());
10653 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10654 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10657 if (noside
== EVAL_SKIP
)
10661 if (ada_is_constrained_packed_array_type
10662 (desc_base_type (value_type (argvec
[0]))))
10663 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10664 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10665 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10666 /* This is a packed array that has already been fixed, and
10667 therefore already coerced to a simple array. Nothing further
10670 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10672 /* Make sure we dereference references so that all the code below
10673 feels like it's really handling the referenced value. Wrapping
10674 types (for alignment) may be there, so make sure we strip them as
10676 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10678 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10679 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10680 argvec
[0] = value_addr (argvec
[0]);
10682 type
= ada_check_typedef (value_type (argvec
[0]));
10684 /* Ada allows us to implicitly dereference arrays when subscripting
10685 them. So, if this is an array typedef (encoding use for array
10686 access types encoded as fat pointers), strip it now. */
10687 if (type
->code () == TYPE_CODE_TYPEDEF
)
10688 type
= ada_typedef_target_type (type
);
10690 if (type
->code () == TYPE_CODE_PTR
)
10692 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10694 case TYPE_CODE_FUNC
:
10695 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10697 case TYPE_CODE_ARRAY
:
10699 case TYPE_CODE_STRUCT
:
10700 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10701 argvec
[0] = ada_value_ind (argvec
[0]);
10702 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10705 error (_("cannot subscript or call something of type `%s'"),
10706 ada_type_name (value_type (argvec
[0])));
10711 switch (type
->code ())
10713 case TYPE_CODE_FUNC
:
10714 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10716 if (TYPE_TARGET_TYPE (type
) == NULL
)
10717 error_call_unknown_return_type (NULL
);
10718 return allocate_value (TYPE_TARGET_TYPE (type
));
10720 return call_function_by_hand (argvec
[0], NULL
,
10721 gdb::make_array_view (argvec
+ 1,
10723 case TYPE_CODE_INTERNAL_FUNCTION
:
10724 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10725 /* We don't know anything about what the internal
10726 function might return, but we have to return
10728 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10731 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10732 argvec
[0], nargs
, argvec
+ 1);
10734 case TYPE_CODE_STRUCT
:
10738 arity
= ada_array_arity (type
);
10739 type
= ada_array_element_type (type
, nargs
);
10741 error (_("cannot subscript or call a record"));
10742 if (arity
!= nargs
)
10743 error (_("wrong number of subscripts; expecting %d"), arity
);
10744 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10745 return value_zero (ada_aligned_type (type
), lval_memory
);
10747 unwrap_value (ada_value_subscript
10748 (argvec
[0], nargs
, argvec
+ 1));
10750 case TYPE_CODE_ARRAY
:
10751 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10753 type
= ada_array_element_type (type
, nargs
);
10755 error (_("element type of array unknown"));
10757 return value_zero (ada_aligned_type (type
), lval_memory
);
10760 unwrap_value (ada_value_subscript
10761 (ada_coerce_to_simple_array (argvec
[0]),
10762 nargs
, argvec
+ 1));
10763 case TYPE_CODE_PTR
: /* Pointer to array */
10764 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10766 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10767 type
= ada_array_element_type (type
, nargs
);
10769 error (_("element type of array unknown"));
10771 return value_zero (ada_aligned_type (type
), lval_memory
);
10774 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10775 nargs
, argvec
+ 1));
10778 error (_("Attempt to index or call something other than an "
10779 "array or function"));
10784 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10785 struct value
*low_bound_val
=
10786 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10787 struct value
*high_bound_val
=
10788 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10790 LONGEST high_bound
;
10792 low_bound_val
= coerce_ref (low_bound_val
);
10793 high_bound_val
= coerce_ref (high_bound_val
);
10794 low_bound
= value_as_long (low_bound_val
);
10795 high_bound
= value_as_long (high_bound_val
);
10797 if (noside
== EVAL_SKIP
)
10800 /* If this is a reference to an aligner type, then remove all
10802 if (value_type (array
)->code () == TYPE_CODE_REF
10803 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10804 TYPE_TARGET_TYPE (value_type (array
)) =
10805 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10807 if (ada_is_constrained_packed_array_type (value_type (array
)))
10808 error (_("cannot slice a packed array"));
10810 /* If this is a reference to an array or an array lvalue,
10811 convert to a pointer. */
10812 if (value_type (array
)->code () == TYPE_CODE_REF
10813 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10814 && VALUE_LVAL (array
) == lval_memory
))
10815 array
= value_addr (array
);
10817 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10818 && ada_is_array_descriptor_type (ada_check_typedef
10819 (value_type (array
))))
10820 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10823 array
= ada_coerce_to_simple_array_ptr (array
);
10825 /* If we have more than one level of pointer indirection,
10826 dereference the value until we get only one level. */
10827 while (value_type (array
)->code () == TYPE_CODE_PTR
10828 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10830 array
= value_ind (array
);
10832 /* Make sure we really do have an array type before going further,
10833 to avoid a SEGV when trying to get the index type or the target
10834 type later down the road if the debug info generated by
10835 the compiler is incorrect or incomplete. */
10836 if (!ada_is_simple_array_type (value_type (array
)))
10837 error (_("cannot take slice of non-array"));
10839 if (ada_check_typedef (value_type (array
))->code ()
10842 struct type
*type0
= ada_check_typedef (value_type (array
));
10844 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10845 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10848 struct type
*arr_type0
=
10849 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10851 return ada_value_slice_from_ptr (array
, arr_type0
,
10852 longest_to_int (low_bound
),
10853 longest_to_int (high_bound
));
10856 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10858 else if (high_bound
< low_bound
)
10859 return empty_array (value_type (array
), low_bound
, high_bound
);
10861 return ada_value_slice (array
, longest_to_int (low_bound
),
10862 longest_to_int (high_bound
));
10865 case UNOP_IN_RANGE
:
10867 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10868 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10870 if (noside
== EVAL_SKIP
)
10873 switch (type
->code ())
10876 lim_warning (_("Membership test incompletely implemented; "
10877 "always returns true"));
10878 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10879 return value_from_longest (type
, (LONGEST
) 1);
10881 case TYPE_CODE_RANGE
:
10882 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10883 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10884 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10885 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10886 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10888 value_from_longest (type
,
10889 (value_less (arg1
, arg3
)
10890 || value_equal (arg1
, arg3
))
10891 && (value_less (arg2
, arg1
)
10892 || value_equal (arg2
, arg1
)));
10895 case BINOP_IN_BOUNDS
:
10897 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10898 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10900 if (noside
== EVAL_SKIP
)
10903 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10905 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10906 return value_zero (type
, not_lval
);
10909 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10911 type
= ada_index_type (value_type (arg2
), tem
, "range");
10913 type
= value_type (arg1
);
10915 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10916 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10918 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10919 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10920 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10922 value_from_longest (type
,
10923 (value_less (arg1
, arg3
)
10924 || value_equal (arg1
, arg3
))
10925 && (value_less (arg2
, arg1
)
10926 || value_equal (arg2
, arg1
)));
10928 case TERNOP_IN_RANGE
:
10929 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10930 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10931 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10933 if (noside
== EVAL_SKIP
)
10936 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10937 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10938 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10940 value_from_longest (type
,
10941 (value_less (arg1
, arg3
)
10942 || value_equal (arg1
, arg3
))
10943 && (value_less (arg2
, arg1
)
10944 || value_equal (arg2
, arg1
)));
10948 case OP_ATR_LENGTH
:
10950 struct type
*type_arg
;
10952 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10954 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10956 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10960 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10964 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10965 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10966 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10969 if (noside
== EVAL_SKIP
)
10971 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10973 if (type_arg
== NULL
)
10974 type_arg
= value_type (arg1
);
10976 if (ada_is_constrained_packed_array_type (type_arg
))
10977 type_arg
= decode_constrained_packed_array_type (type_arg
);
10979 if (!discrete_type_p (type_arg
))
10983 default: /* Should never happen. */
10984 error (_("unexpected attribute encountered"));
10987 type_arg
= ada_index_type (type_arg
, tem
,
10988 ada_attribute_name (op
));
10990 case OP_ATR_LENGTH
:
10991 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10996 return value_zero (type_arg
, not_lval
);
10998 else if (type_arg
== NULL
)
11000 arg1
= ada_coerce_ref (arg1
);
11002 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
11003 arg1
= ada_coerce_to_simple_array (arg1
);
11005 if (op
== OP_ATR_LENGTH
)
11006 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11009 type
= ada_index_type (value_type (arg1
), tem
,
11010 ada_attribute_name (op
));
11012 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11017 default: /* Should never happen. */
11018 error (_("unexpected attribute encountered"));
11020 return value_from_longest
11021 (type
, ada_array_bound (arg1
, tem
, 0));
11023 return value_from_longest
11024 (type
, ada_array_bound (arg1
, tem
, 1));
11025 case OP_ATR_LENGTH
:
11026 return value_from_longest
11027 (type
, ada_array_length (arg1
, tem
));
11030 else if (discrete_type_p (type_arg
))
11032 struct type
*range_type
;
11033 const char *name
= ada_type_name (type_arg
);
11036 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
11037 range_type
= to_fixed_range_type (type_arg
, NULL
);
11038 if (range_type
== NULL
)
11039 range_type
= type_arg
;
11043 error (_("unexpected attribute encountered"));
11045 return value_from_longest
11046 (range_type
, ada_discrete_type_low_bound (range_type
));
11048 return value_from_longest
11049 (range_type
, ada_discrete_type_high_bound (range_type
));
11050 case OP_ATR_LENGTH
:
11051 error (_("the 'length attribute applies only to array types"));
11054 else if (type_arg
->code () == TYPE_CODE_FLT
)
11055 error (_("unimplemented type attribute"));
11060 if (ada_is_constrained_packed_array_type (type_arg
))
11061 type_arg
= decode_constrained_packed_array_type (type_arg
);
11063 if (op
== OP_ATR_LENGTH
)
11064 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11067 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
11069 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11075 error (_("unexpected attribute encountered"));
11077 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11078 return value_from_longest (type
, low
);
11080 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11081 return value_from_longest (type
, high
);
11082 case OP_ATR_LENGTH
:
11083 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11084 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11085 return value_from_longest (type
, high
- low
+ 1);
11091 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11092 if (noside
== EVAL_SKIP
)
11095 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11096 return value_zero (ada_tag_type (arg1
), not_lval
);
11098 return ada_value_tag (arg1
);
11102 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11103 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11104 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11105 if (noside
== EVAL_SKIP
)
11107 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11108 return value_zero (value_type (arg1
), not_lval
);
11111 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11112 return value_binop (arg1
, arg2
,
11113 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
11116 case OP_ATR_MODULUS
:
11118 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11120 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11121 if (noside
== EVAL_SKIP
)
11124 if (!ada_is_modular_type (type_arg
))
11125 error (_("'modulus must be applied to modular type"));
11127 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
11128 ada_modulus (type_arg
));
11133 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11134 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11135 if (noside
== EVAL_SKIP
)
11137 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11138 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11139 return value_zero (type
, not_lval
);
11141 return value_pos_atr (type
, arg1
);
11144 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11145 type
= value_type (arg1
);
11147 /* If the argument is a reference, then dereference its type, since
11148 the user is really asking for the size of the actual object,
11149 not the size of the pointer. */
11150 if (type
->code () == TYPE_CODE_REF
)
11151 type
= TYPE_TARGET_TYPE (type
);
11153 if (noside
== EVAL_SKIP
)
11155 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11156 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
11158 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
11159 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
11162 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11163 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11164 type
= exp
->elts
[pc
+ 2].type
;
11165 if (noside
== EVAL_SKIP
)
11167 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11168 return value_zero (type
, not_lval
);
11170 return value_val_atr (type
, arg1
);
11173 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11174 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11175 if (noside
== EVAL_SKIP
)
11177 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11178 return value_zero (value_type (arg1
), not_lval
);
11181 /* For integer exponentiation operations,
11182 only promote the first argument. */
11183 if (is_integral_type (value_type (arg2
)))
11184 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11186 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11188 return value_binop (arg1
, arg2
, op
);
11192 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11193 if (noside
== EVAL_SKIP
)
11199 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11200 if (noside
== EVAL_SKIP
)
11202 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11203 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11204 return value_neg (arg1
);
11209 preeval_pos
= *pos
;
11210 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11211 if (noside
== EVAL_SKIP
)
11213 type
= ada_check_typedef (value_type (arg1
));
11214 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11216 if (ada_is_array_descriptor_type (type
))
11217 /* GDB allows dereferencing GNAT array descriptors. */
11219 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11221 if (arrType
== NULL
)
11222 error (_("Attempt to dereference null array pointer."));
11223 return value_at_lazy (arrType
, 0);
11225 else if (type
->code () == TYPE_CODE_PTR
11226 || type
->code () == TYPE_CODE_REF
11227 /* In C you can dereference an array to get the 1st elt. */
11228 || type
->code () == TYPE_CODE_ARRAY
)
11230 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11231 only be determined by inspecting the object's tag.
11232 This means that we need to evaluate completely the
11233 expression in order to get its type. */
11235 if ((type
->code () == TYPE_CODE_REF
11236 || type
->code () == TYPE_CODE_PTR
)
11237 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11239 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11241 type
= value_type (ada_value_ind (arg1
));
11245 type
= to_static_fixed_type
11247 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11249 ada_ensure_varsize_limit (type
);
11250 return value_zero (type
, lval_memory
);
11252 else if (type
->code () == TYPE_CODE_INT
)
11254 /* GDB allows dereferencing an int. */
11255 if (expect_type
== NULL
)
11256 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11261 to_static_fixed_type (ada_aligned_type (expect_type
));
11262 return value_zero (expect_type
, lval_memory
);
11266 error (_("Attempt to take contents of a non-pointer value."));
11268 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11269 type
= ada_check_typedef (value_type (arg1
));
11271 if (type
->code () == TYPE_CODE_INT
)
11272 /* GDB allows dereferencing an int. If we were given
11273 the expect_type, then use that as the target type.
11274 Otherwise, assume that the target type is an int. */
11276 if (expect_type
!= NULL
)
11277 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11280 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11281 (CORE_ADDR
) value_as_address (arg1
));
11284 if (ada_is_array_descriptor_type (type
))
11285 /* GDB allows dereferencing GNAT array descriptors. */
11286 return ada_coerce_to_simple_array (arg1
);
11288 return ada_value_ind (arg1
);
11290 case STRUCTOP_STRUCT
:
11291 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11292 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11293 preeval_pos
= *pos
;
11294 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11295 if (noside
== EVAL_SKIP
)
11297 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11299 struct type
*type1
= value_type (arg1
);
11301 if (ada_is_tagged_type (type1
, 1))
11303 type
= ada_lookup_struct_elt_type (type1
,
11304 &exp
->elts
[pc
+ 2].string
,
11307 /* If the field is not found, check if it exists in the
11308 extension of this object's type. This means that we
11309 need to evaluate completely the expression. */
11313 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11315 arg1
= ada_value_struct_elt (arg1
,
11316 &exp
->elts
[pc
+ 2].string
,
11318 arg1
= unwrap_value (arg1
);
11319 type
= value_type (ada_to_fixed_value (arg1
));
11324 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11327 return value_zero (ada_aligned_type (type
), lval_memory
);
11331 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11332 arg1
= unwrap_value (arg1
);
11333 return ada_to_fixed_value (arg1
);
11337 /* The value is not supposed to be used. This is here to make it
11338 easier to accommodate expressions that contain types. */
11340 if (noside
== EVAL_SKIP
)
11342 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11343 return allocate_value (exp
->elts
[pc
+ 1].type
);
11345 error (_("Attempt to use a type name as an expression"));
11350 case OP_DISCRETE_RANGE
:
11351 case OP_POSITIONAL
:
11353 if (noside
== EVAL_NORMAL
)
11357 error (_("Undefined name, ambiguous name, or renaming used in "
11358 "component association: %s."), &exp
->elts
[pc
+2].string
);
11360 error (_("Aggregates only allowed on the right of an assignment"));
11362 internal_error (__FILE__
, __LINE__
,
11363 _("aggregate apparently mangled"));
11366 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11368 for (tem
= 0; tem
< nargs
; tem
+= 1)
11369 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11374 return eval_skip_value (exp
);
11380 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11381 type name that encodes the 'small and 'delta information.
11382 Otherwise, return NULL. */
11384 static const char *
11385 gnat_encoded_fixed_type_info (struct type
*type
)
11387 const char *name
= ada_type_name (type
);
11388 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11390 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11392 const char *tail
= strstr (name
, "___XF_");
11399 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11400 return gnat_encoded_fixed_type_info (TYPE_TARGET_TYPE (type
));
11405 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11408 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11410 return gnat_encoded_fixed_type_info (type
) != NULL
;
11413 /* Return non-zero iff TYPE represents a System.Address type. */
11416 ada_is_system_address_type (struct type
*type
)
11418 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11421 /* Assuming that TYPE is the representation of an Ada fixed-point
11422 type, return the target floating-point type to be used to represent
11423 of this type during internal computation. */
11425 static struct type
*
11426 ada_scaling_type (struct type
*type
)
11428 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11431 /* Assuming that TYPE is the representation of an Ada fixed-point
11432 type, return its delta, or NULL if the type is malformed and the
11433 delta cannot be determined. */
11436 gnat_encoded_fixed_point_delta (struct type
*type
)
11438 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11439 struct type
*scale_type
= ada_scaling_type (type
);
11441 long long num
, den
;
11443 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11446 return value_binop (value_from_longest (scale_type
, num
),
11447 value_from_longest (scale_type
, den
), BINOP_DIV
);
11450 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11451 the scaling factor ('SMALL value) associated with the type. */
11454 ada_scaling_factor (struct type
*type
)
11456 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11457 struct type
*scale_type
= ada_scaling_type (type
);
11459 long long num0
, den0
, num1
, den1
;
11462 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11463 &num0
, &den0
, &num1
, &den1
);
11466 return value_from_longest (scale_type
, 1);
11468 return value_binop (value_from_longest (scale_type
, num1
),
11469 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11471 return value_binop (value_from_longest (scale_type
, num0
),
11472 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11479 /* Scan STR beginning at position K for a discriminant name, and
11480 return the value of that discriminant field of DVAL in *PX. If
11481 PNEW_K is not null, put the position of the character beyond the
11482 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11483 not alter *PX and *PNEW_K if unsuccessful. */
11486 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11489 static char *bound_buffer
= NULL
;
11490 static size_t bound_buffer_len
= 0;
11491 const char *pstart
, *pend
, *bound
;
11492 struct value
*bound_val
;
11494 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11498 pend
= strstr (pstart
, "__");
11502 k
+= strlen (bound
);
11506 int len
= pend
- pstart
;
11508 /* Strip __ and beyond. */
11509 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11510 strncpy (bound_buffer
, pstart
, len
);
11511 bound_buffer
[len
] = '\0';
11513 bound
= bound_buffer
;
11517 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11518 if (bound_val
== NULL
)
11521 *px
= value_as_long (bound_val
);
11522 if (pnew_k
!= NULL
)
11527 /* Value of variable named NAME in the current environment. If
11528 no such variable found, then if ERR_MSG is null, returns 0, and
11529 otherwise causes an error with message ERR_MSG. */
11531 static struct value
*
11532 get_var_value (const char *name
, const char *err_msg
)
11534 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11536 std::vector
<struct block_symbol
> syms
;
11537 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11538 get_selected_block (0),
11539 VAR_DOMAIN
, &syms
, 1);
11543 if (err_msg
== NULL
)
11546 error (("%s"), err_msg
);
11549 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11552 /* Value of integer variable named NAME in the current environment.
11553 If no such variable is found, returns false. Otherwise, sets VALUE
11554 to the variable's value and returns true. */
11557 get_int_var_value (const char *name
, LONGEST
&value
)
11559 struct value
*var_val
= get_var_value (name
, 0);
11564 value
= value_as_long (var_val
);
11569 /* Return a range type whose base type is that of the range type named
11570 NAME in the current environment, and whose bounds are calculated
11571 from NAME according to the GNAT range encoding conventions.
11572 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11573 corresponding range type from debug information; fall back to using it
11574 if symbol lookup fails. If a new type must be created, allocate it
11575 like ORIG_TYPE was. The bounds information, in general, is encoded
11576 in NAME, the base type given in the named range type. */
11578 static struct type
*
11579 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11582 struct type
*base_type
;
11583 const char *subtype_info
;
11585 gdb_assert (raw_type
!= NULL
);
11586 gdb_assert (raw_type
->name () != NULL
);
11588 if (raw_type
->code () == TYPE_CODE_RANGE
)
11589 base_type
= TYPE_TARGET_TYPE (raw_type
);
11591 base_type
= raw_type
;
11593 name
= raw_type
->name ();
11594 subtype_info
= strstr (name
, "___XD");
11595 if (subtype_info
== NULL
)
11597 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11598 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11600 if (L
< INT_MIN
|| U
> INT_MAX
)
11603 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11608 static char *name_buf
= NULL
;
11609 static size_t name_len
= 0;
11610 int prefix_len
= subtype_info
- name
;
11613 const char *bounds_str
;
11616 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11617 strncpy (name_buf
, name
, prefix_len
);
11618 name_buf
[prefix_len
] = '\0';
11621 bounds_str
= strchr (subtype_info
, '_');
11624 if (*subtype_info
== 'L')
11626 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11627 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11629 if (bounds_str
[n
] == '_')
11631 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11637 strcpy (name_buf
+ prefix_len
, "___L");
11638 if (!get_int_var_value (name_buf
, L
))
11640 lim_warning (_("Unknown lower bound, using 1."));
11645 if (*subtype_info
== 'U')
11647 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11648 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11653 strcpy (name_buf
+ prefix_len
, "___U");
11654 if (!get_int_var_value (name_buf
, U
))
11656 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11661 type
= create_static_range_type (alloc_type_copy (raw_type
),
11663 /* create_static_range_type alters the resulting type's length
11664 to match the size of the base_type, which is not what we want.
11665 Set it back to the original range type's length. */
11666 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11667 type
->set_name (name
);
11672 /* True iff NAME is the name of a range type. */
11675 ada_is_range_type_name (const char *name
)
11677 return (name
!= NULL
&& strstr (name
, "___XD"));
11681 /* Modular types */
11683 /* True iff TYPE is an Ada modular type. */
11686 ada_is_modular_type (struct type
*type
)
11688 struct type
*subranged_type
= get_base_type (type
);
11690 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11691 && subranged_type
->code () == TYPE_CODE_INT
11692 && TYPE_UNSIGNED (subranged_type
));
11695 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11698 ada_modulus (struct type
*type
)
11700 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11704 /* Ada exception catchpoint support:
11705 ---------------------------------
11707 We support 3 kinds of exception catchpoints:
11708 . catchpoints on Ada exceptions
11709 . catchpoints on unhandled Ada exceptions
11710 . catchpoints on failed assertions
11712 Exceptions raised during failed assertions, or unhandled exceptions
11713 could perfectly be caught with the general catchpoint on Ada exceptions.
11714 However, we can easily differentiate these two special cases, and having
11715 the option to distinguish these two cases from the rest can be useful
11716 to zero-in on certain situations.
11718 Exception catchpoints are a specialized form of breakpoint,
11719 since they rely on inserting breakpoints inside known routines
11720 of the GNAT runtime. The implementation therefore uses a standard
11721 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11724 Support in the runtime for exception catchpoints have been changed
11725 a few times already, and these changes affect the implementation
11726 of these catchpoints. In order to be able to support several
11727 variants of the runtime, we use a sniffer that will determine
11728 the runtime variant used by the program being debugged. */
11730 /* Ada's standard exceptions.
11732 The Ada 83 standard also defined Numeric_Error. But there so many
11733 situations where it was unclear from the Ada 83 Reference Manual
11734 (RM) whether Constraint_Error or Numeric_Error should be raised,
11735 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11736 Interpretation saying that anytime the RM says that Numeric_Error
11737 should be raised, the implementation may raise Constraint_Error.
11738 Ada 95 went one step further and pretty much removed Numeric_Error
11739 from the list of standard exceptions (it made it a renaming of
11740 Constraint_Error, to help preserve compatibility when compiling
11741 an Ada83 compiler). As such, we do not include Numeric_Error from
11742 this list of standard exceptions. */
11744 static const char *standard_exc
[] = {
11745 "constraint_error",
11751 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11753 /* A structure that describes how to support exception catchpoints
11754 for a given executable. */
11756 struct exception_support_info
11758 /* The name of the symbol to break on in order to insert
11759 a catchpoint on exceptions. */
11760 const char *catch_exception_sym
;
11762 /* The name of the symbol to break on in order to insert
11763 a catchpoint on unhandled exceptions. */
11764 const char *catch_exception_unhandled_sym
;
11766 /* The name of the symbol to break on in order to insert
11767 a catchpoint on failed assertions. */
11768 const char *catch_assert_sym
;
11770 /* The name of the symbol to break on in order to insert
11771 a catchpoint on exception handling. */
11772 const char *catch_handlers_sym
;
11774 /* Assuming that the inferior just triggered an unhandled exception
11775 catchpoint, this function is responsible for returning the address
11776 in inferior memory where the name of that exception is stored.
11777 Return zero if the address could not be computed. */
11778 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11781 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11782 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11784 /* The following exception support info structure describes how to
11785 implement exception catchpoints with the latest version of the
11786 Ada runtime (as of 2019-08-??). */
11788 static const struct exception_support_info default_exception_support_info
=
11790 "__gnat_debug_raise_exception", /* catch_exception_sym */
11791 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11792 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11793 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11794 ada_unhandled_exception_name_addr
11797 /* The following exception support info structure describes how to
11798 implement exception catchpoints with an earlier version of the
11799 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11801 static const struct exception_support_info exception_support_info_v0
=
11803 "__gnat_debug_raise_exception", /* catch_exception_sym */
11804 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11805 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11806 "__gnat_begin_handler", /* catch_handlers_sym */
11807 ada_unhandled_exception_name_addr
11810 /* The following exception support info structure describes how to
11811 implement exception catchpoints with a slightly older version
11812 of the Ada runtime. */
11814 static const struct exception_support_info exception_support_info_fallback
=
11816 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11817 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11818 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11819 "__gnat_begin_handler", /* catch_handlers_sym */
11820 ada_unhandled_exception_name_addr_from_raise
11823 /* Return nonzero if we can detect the exception support routines
11824 described in EINFO.
11826 This function errors out if an abnormal situation is detected
11827 (for instance, if we find the exception support routines, but
11828 that support is found to be incomplete). */
11831 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11833 struct symbol
*sym
;
11835 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11836 that should be compiled with debugging information. As a result, we
11837 expect to find that symbol in the symtabs. */
11839 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11842 /* Perhaps we did not find our symbol because the Ada runtime was
11843 compiled without debugging info, or simply stripped of it.
11844 It happens on some GNU/Linux distributions for instance, where
11845 users have to install a separate debug package in order to get
11846 the runtime's debugging info. In that situation, let the user
11847 know why we cannot insert an Ada exception catchpoint.
11849 Note: Just for the purpose of inserting our Ada exception
11850 catchpoint, we could rely purely on the associated minimal symbol.
11851 But we would be operating in degraded mode anyway, since we are
11852 still lacking the debugging info needed later on to extract
11853 the name of the exception being raised (this name is printed in
11854 the catchpoint message, and is also used when trying to catch
11855 a specific exception). We do not handle this case for now. */
11856 struct bound_minimal_symbol msym
11857 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11859 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11860 error (_("Your Ada runtime appears to be missing some debugging "
11861 "information.\nCannot insert Ada exception catchpoint "
11862 "in this configuration."));
11867 /* Make sure that the symbol we found corresponds to a function. */
11869 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11871 error (_("Symbol \"%s\" is not a function (class = %d)"),
11872 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11876 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11879 struct bound_minimal_symbol msym
11880 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11882 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11883 error (_("Your Ada runtime appears to be missing some debugging "
11884 "information.\nCannot insert Ada exception catchpoint "
11885 "in this configuration."));
11890 /* Make sure that the symbol we found corresponds to a function. */
11892 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11894 error (_("Symbol \"%s\" is not a function (class = %d)"),
11895 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11902 /* Inspect the Ada runtime and determine which exception info structure
11903 should be used to provide support for exception catchpoints.
11905 This function will always set the per-inferior exception_info,
11906 or raise an error. */
11909 ada_exception_support_info_sniffer (void)
11911 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11913 /* If the exception info is already known, then no need to recompute it. */
11914 if (data
->exception_info
!= NULL
)
11917 /* Check the latest (default) exception support info. */
11918 if (ada_has_this_exception_support (&default_exception_support_info
))
11920 data
->exception_info
= &default_exception_support_info
;
11924 /* Try the v0 exception suport info. */
11925 if (ada_has_this_exception_support (&exception_support_info_v0
))
11927 data
->exception_info
= &exception_support_info_v0
;
11931 /* Try our fallback exception suport info. */
11932 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11934 data
->exception_info
= &exception_support_info_fallback
;
11938 /* Sometimes, it is normal for us to not be able to find the routine
11939 we are looking for. This happens when the program is linked with
11940 the shared version of the GNAT runtime, and the program has not been
11941 started yet. Inform the user of these two possible causes if
11944 if (ada_update_initial_language (language_unknown
) != language_ada
)
11945 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11947 /* If the symbol does not exist, then check that the program is
11948 already started, to make sure that shared libraries have been
11949 loaded. If it is not started, this may mean that the symbol is
11950 in a shared library. */
11952 if (inferior_ptid
.pid () == 0)
11953 error (_("Unable to insert catchpoint. Try to start the program first."));
11955 /* At this point, we know that we are debugging an Ada program and
11956 that the inferior has been started, but we still are not able to
11957 find the run-time symbols. That can mean that we are in
11958 configurable run time mode, or that a-except as been optimized
11959 out by the linker... In any case, at this point it is not worth
11960 supporting this feature. */
11962 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11965 /* True iff FRAME is very likely to be that of a function that is
11966 part of the runtime system. This is all very heuristic, but is
11967 intended to be used as advice as to what frames are uninteresting
11971 is_known_support_routine (struct frame_info
*frame
)
11973 enum language func_lang
;
11975 const char *fullname
;
11977 /* If this code does not have any debugging information (no symtab),
11978 This cannot be any user code. */
11980 symtab_and_line sal
= find_frame_sal (frame
);
11981 if (sal
.symtab
== NULL
)
11984 /* If there is a symtab, but the associated source file cannot be
11985 located, then assume this is not user code: Selecting a frame
11986 for which we cannot display the code would not be very helpful
11987 for the user. This should also take care of case such as VxWorks
11988 where the kernel has some debugging info provided for a few units. */
11990 fullname
= symtab_to_fullname (sal
.symtab
);
11991 if (access (fullname
, R_OK
) != 0)
11994 /* Check the unit filename against the Ada runtime file naming.
11995 We also check the name of the objfile against the name of some
11996 known system libraries that sometimes come with debugging info
11999 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
12001 re_comp (known_runtime_file_name_patterns
[i
]);
12002 if (re_exec (lbasename (sal
.symtab
->filename
)))
12004 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
12005 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
12009 /* Check whether the function is a GNAT-generated entity. */
12011 gdb::unique_xmalloc_ptr
<char> func_name
12012 = find_frame_funname (frame
, &func_lang
, NULL
);
12013 if (func_name
== NULL
)
12016 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
12018 re_comp (known_auxiliary_function_name_patterns
[i
]);
12019 if (re_exec (func_name
.get ()))
12026 /* Find the first frame that contains debugging information and that is not
12027 part of the Ada run-time, starting from FI and moving upward. */
12030 ada_find_printable_frame (struct frame_info
*fi
)
12032 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
12034 if (!is_known_support_routine (fi
))
12043 /* Assuming that the inferior just triggered an unhandled exception
12044 catchpoint, return the address in inferior memory where the name
12045 of the exception is stored.
12047 Return zero if the address could not be computed. */
12050 ada_unhandled_exception_name_addr (void)
12052 return parse_and_eval_address ("e.full_name");
12055 /* Same as ada_unhandled_exception_name_addr, except that this function
12056 should be used when the inferior uses an older version of the runtime,
12057 where the exception name needs to be extracted from a specific frame
12058 several frames up in the callstack. */
12061 ada_unhandled_exception_name_addr_from_raise (void)
12064 struct frame_info
*fi
;
12065 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12067 /* To determine the name of this exception, we need to select
12068 the frame corresponding to RAISE_SYM_NAME. This frame is
12069 at least 3 levels up, so we simply skip the first 3 frames
12070 without checking the name of their associated function. */
12071 fi
= get_current_frame ();
12072 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
12074 fi
= get_prev_frame (fi
);
12078 enum language func_lang
;
12080 gdb::unique_xmalloc_ptr
<char> func_name
12081 = find_frame_funname (fi
, &func_lang
, NULL
);
12082 if (func_name
!= NULL
)
12084 if (strcmp (func_name
.get (),
12085 data
->exception_info
->catch_exception_sym
) == 0)
12086 break; /* We found the frame we were looking for... */
12088 fi
= get_prev_frame (fi
);
12095 return parse_and_eval_address ("id.full_name");
12098 /* Assuming the inferior just triggered an Ada exception catchpoint
12099 (of any type), return the address in inferior memory where the name
12100 of the exception is stored, if applicable.
12102 Assumes the selected frame is the current frame.
12104 Return zero if the address could not be computed, or if not relevant. */
12107 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
12108 struct breakpoint
*b
)
12110 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12114 case ada_catch_exception
:
12115 return (parse_and_eval_address ("e.full_name"));
12118 case ada_catch_exception_unhandled
:
12119 return data
->exception_info
->unhandled_exception_name_addr ();
12122 case ada_catch_handlers
:
12123 return 0; /* The runtimes does not provide access to the exception
12127 case ada_catch_assert
:
12128 return 0; /* Exception name is not relevant in this case. */
12132 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12136 return 0; /* Should never be reached. */
12139 /* Assuming the inferior is stopped at an exception catchpoint,
12140 return the message which was associated to the exception, if
12141 available. Return NULL if the message could not be retrieved.
12143 Note: The exception message can be associated to an exception
12144 either through the use of the Raise_Exception function, or
12145 more simply (Ada 2005 and later), via:
12147 raise Exception_Name with "exception message";
12151 static gdb::unique_xmalloc_ptr
<char>
12152 ada_exception_message_1 (void)
12154 struct value
*e_msg_val
;
12157 /* For runtimes that support this feature, the exception message
12158 is passed as an unbounded string argument called "message". */
12159 e_msg_val
= parse_and_eval ("message");
12160 if (e_msg_val
== NULL
)
12161 return NULL
; /* Exception message not supported. */
12163 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12164 gdb_assert (e_msg_val
!= NULL
);
12165 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12167 /* If the message string is empty, then treat it as if there was
12168 no exception message. */
12169 if (e_msg_len
<= 0)
12172 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12173 read_memory_string (value_address (e_msg_val
), e_msg
.get (), e_msg_len
+ 1);
12174 e_msg
.get ()[e_msg_len
] = '\0';
12179 /* Same as ada_exception_message_1, except that all exceptions are
12180 contained here (returning NULL instead). */
12182 static gdb::unique_xmalloc_ptr
<char>
12183 ada_exception_message (void)
12185 gdb::unique_xmalloc_ptr
<char> e_msg
;
12189 e_msg
= ada_exception_message_1 ();
12191 catch (const gdb_exception_error
&e
)
12193 e_msg
.reset (nullptr);
12199 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12200 any error that ada_exception_name_addr_1 might cause to be thrown.
12201 When an error is intercepted, a warning with the error message is printed,
12202 and zero is returned. */
12205 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12206 struct breakpoint
*b
)
12208 CORE_ADDR result
= 0;
12212 result
= ada_exception_name_addr_1 (ex
, b
);
12215 catch (const gdb_exception_error
&e
)
12217 warning (_("failed to get exception name: %s"), e
.what ());
12224 static std::string ada_exception_catchpoint_cond_string
12225 (const char *excep_string
,
12226 enum ada_exception_catchpoint_kind ex
);
12228 /* Ada catchpoints.
12230 In the case of catchpoints on Ada exceptions, the catchpoint will
12231 stop the target on every exception the program throws. When a user
12232 specifies the name of a specific exception, we translate this
12233 request into a condition expression (in text form), and then parse
12234 it into an expression stored in each of the catchpoint's locations.
12235 We then use this condition to check whether the exception that was
12236 raised is the one the user is interested in. If not, then the
12237 target is resumed again. We store the name of the requested
12238 exception, in order to be able to re-set the condition expression
12239 when symbols change. */
12241 /* An instance of this type is used to represent an Ada catchpoint
12242 breakpoint location. */
12244 class ada_catchpoint_location
: public bp_location
12247 ada_catchpoint_location (breakpoint
*owner
)
12248 : bp_location (owner
, bp_loc_software_breakpoint
)
12251 /* The condition that checks whether the exception that was raised
12252 is the specific exception the user specified on catchpoint
12254 expression_up excep_cond_expr
;
12257 /* An instance of this type is used to represent an Ada catchpoint. */
12259 struct ada_catchpoint
: public breakpoint
12261 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12266 /* The name of the specific exception the user specified. */
12267 std::string excep_string
;
12269 /* What kind of catchpoint this is. */
12270 enum ada_exception_catchpoint_kind m_kind
;
12273 /* Parse the exception condition string in the context of each of the
12274 catchpoint's locations, and store them for later evaluation. */
12277 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12278 enum ada_exception_catchpoint_kind ex
)
12280 struct bp_location
*bl
;
12282 /* Nothing to do if there's no specific exception to catch. */
12283 if (c
->excep_string
.empty ())
12286 /* Same if there are no locations... */
12287 if (c
->loc
== NULL
)
12290 /* Compute the condition expression in text form, from the specific
12291 expection we want to catch. */
12292 std::string cond_string
12293 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12295 /* Iterate over all the catchpoint's locations, and parse an
12296 expression for each. */
12297 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12299 struct ada_catchpoint_location
*ada_loc
12300 = (struct ada_catchpoint_location
*) bl
;
12303 if (!bl
->shlib_disabled
)
12307 s
= cond_string
.c_str ();
12310 exp
= parse_exp_1 (&s
, bl
->address
,
12311 block_for_pc (bl
->address
),
12314 catch (const gdb_exception_error
&e
)
12316 warning (_("failed to reevaluate internal exception condition "
12317 "for catchpoint %d: %s"),
12318 c
->number
, e
.what ());
12322 ada_loc
->excep_cond_expr
= std::move (exp
);
12326 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12327 structure for all exception catchpoint kinds. */
12329 static struct bp_location
*
12330 allocate_location_exception (struct breakpoint
*self
)
12332 return new ada_catchpoint_location (self
);
12335 /* Implement the RE_SET method in the breakpoint_ops structure for all
12336 exception catchpoint kinds. */
12339 re_set_exception (struct breakpoint
*b
)
12341 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12343 /* Call the base class's method. This updates the catchpoint's
12345 bkpt_breakpoint_ops
.re_set (b
);
12347 /* Reparse the exception conditional expressions. One for each
12349 create_excep_cond_exprs (c
, c
->m_kind
);
12352 /* Returns true if we should stop for this breakpoint hit. If the
12353 user specified a specific exception, we only want to cause a stop
12354 if the program thrown that exception. */
12357 should_stop_exception (const struct bp_location
*bl
)
12359 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12360 const struct ada_catchpoint_location
*ada_loc
12361 = (const struct ada_catchpoint_location
*) bl
;
12364 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12365 if (c
->m_kind
== ada_catch_assert
)
12366 clear_internalvar (var
);
12373 if (c
->m_kind
== ada_catch_handlers
)
12374 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12375 ".all.occurrence.id");
12379 struct value
*exc
= parse_and_eval (expr
);
12380 set_internalvar (var
, exc
);
12382 catch (const gdb_exception_error
&ex
)
12384 clear_internalvar (var
);
12388 /* With no specific exception, should always stop. */
12389 if (c
->excep_string
.empty ())
12392 if (ada_loc
->excep_cond_expr
== NULL
)
12394 /* We will have a NULL expression if back when we were creating
12395 the expressions, this location's had failed to parse. */
12402 struct value
*mark
;
12404 mark
= value_mark ();
12405 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12406 value_free_to_mark (mark
);
12408 catch (const gdb_exception
&ex
)
12410 exception_fprintf (gdb_stderr
, ex
,
12411 _("Error in testing exception condition:\n"));
12417 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12418 for all exception catchpoint kinds. */
12421 check_status_exception (bpstat bs
)
12423 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12426 /* Implement the PRINT_IT method in the breakpoint_ops structure
12427 for all exception catchpoint kinds. */
12429 static enum print_stop_action
12430 print_it_exception (bpstat bs
)
12432 struct ui_out
*uiout
= current_uiout
;
12433 struct breakpoint
*b
= bs
->breakpoint_at
;
12435 annotate_catchpoint (b
->number
);
12437 if (uiout
->is_mi_like_p ())
12439 uiout
->field_string ("reason",
12440 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12441 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12444 uiout
->text (b
->disposition
== disp_del
12445 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12446 uiout
->field_signed ("bkptno", b
->number
);
12447 uiout
->text (", ");
12449 /* ada_exception_name_addr relies on the selected frame being the
12450 current frame. Need to do this here because this function may be
12451 called more than once when printing a stop, and below, we'll
12452 select the first frame past the Ada run-time (see
12453 ada_find_printable_frame). */
12454 select_frame (get_current_frame ());
12456 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12459 case ada_catch_exception
:
12460 case ada_catch_exception_unhandled
:
12461 case ada_catch_handlers
:
12463 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12464 char exception_name
[256];
12468 read_memory (addr
, (gdb_byte
*) exception_name
,
12469 sizeof (exception_name
) - 1);
12470 exception_name
[sizeof (exception_name
) - 1] = '\0';
12474 /* For some reason, we were unable to read the exception
12475 name. This could happen if the Runtime was compiled
12476 without debugging info, for instance. In that case,
12477 just replace the exception name by the generic string
12478 "exception" - it will read as "an exception" in the
12479 notification we are about to print. */
12480 memcpy (exception_name
, "exception", sizeof ("exception"));
12482 /* In the case of unhandled exception breakpoints, we print
12483 the exception name as "unhandled EXCEPTION_NAME", to make
12484 it clearer to the user which kind of catchpoint just got
12485 hit. We used ui_out_text to make sure that this extra
12486 info does not pollute the exception name in the MI case. */
12487 if (c
->m_kind
== ada_catch_exception_unhandled
)
12488 uiout
->text ("unhandled ");
12489 uiout
->field_string ("exception-name", exception_name
);
12492 case ada_catch_assert
:
12493 /* In this case, the name of the exception is not really
12494 important. Just print "failed assertion" to make it clearer
12495 that his program just hit an assertion-failure catchpoint.
12496 We used ui_out_text because this info does not belong in
12498 uiout
->text ("failed assertion");
12502 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12503 if (exception_message
!= NULL
)
12505 uiout
->text (" (");
12506 uiout
->field_string ("exception-message", exception_message
.get ());
12510 uiout
->text (" at ");
12511 ada_find_printable_frame (get_current_frame ());
12513 return PRINT_SRC_AND_LOC
;
12516 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12517 for all exception catchpoint kinds. */
12520 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12522 struct ui_out
*uiout
= current_uiout
;
12523 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12524 struct value_print_options opts
;
12526 get_user_print_options (&opts
);
12528 if (opts
.addressprint
)
12529 uiout
->field_skip ("addr");
12531 annotate_field (5);
12534 case ada_catch_exception
:
12535 if (!c
->excep_string
.empty ())
12537 std::string msg
= string_printf (_("`%s' Ada exception"),
12538 c
->excep_string
.c_str ());
12540 uiout
->field_string ("what", msg
);
12543 uiout
->field_string ("what", "all Ada exceptions");
12547 case ada_catch_exception_unhandled
:
12548 uiout
->field_string ("what", "unhandled Ada exceptions");
12551 case ada_catch_handlers
:
12552 if (!c
->excep_string
.empty ())
12554 uiout
->field_fmt ("what",
12555 _("`%s' Ada exception handlers"),
12556 c
->excep_string
.c_str ());
12559 uiout
->field_string ("what", "all Ada exceptions handlers");
12562 case ada_catch_assert
:
12563 uiout
->field_string ("what", "failed Ada assertions");
12567 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12572 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12573 for all exception catchpoint kinds. */
12576 print_mention_exception (struct breakpoint
*b
)
12578 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12579 struct ui_out
*uiout
= current_uiout
;
12581 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12582 : _("Catchpoint "));
12583 uiout
->field_signed ("bkptno", b
->number
);
12584 uiout
->text (": ");
12588 case ada_catch_exception
:
12589 if (!c
->excep_string
.empty ())
12591 std::string info
= string_printf (_("`%s' Ada exception"),
12592 c
->excep_string
.c_str ());
12593 uiout
->text (info
.c_str ());
12596 uiout
->text (_("all Ada exceptions"));
12599 case ada_catch_exception_unhandled
:
12600 uiout
->text (_("unhandled Ada exceptions"));
12603 case ada_catch_handlers
:
12604 if (!c
->excep_string
.empty ())
12607 = string_printf (_("`%s' Ada exception handlers"),
12608 c
->excep_string
.c_str ());
12609 uiout
->text (info
.c_str ());
12612 uiout
->text (_("all Ada exceptions handlers"));
12615 case ada_catch_assert
:
12616 uiout
->text (_("failed Ada assertions"));
12620 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12625 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12626 for all exception catchpoint kinds. */
12629 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12631 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12635 case ada_catch_exception
:
12636 fprintf_filtered (fp
, "catch exception");
12637 if (!c
->excep_string
.empty ())
12638 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12641 case ada_catch_exception_unhandled
:
12642 fprintf_filtered (fp
, "catch exception unhandled");
12645 case ada_catch_handlers
:
12646 fprintf_filtered (fp
, "catch handlers");
12649 case ada_catch_assert
:
12650 fprintf_filtered (fp
, "catch assert");
12654 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12656 print_recreate_thread (b
, fp
);
12659 /* Virtual tables for various breakpoint types. */
12660 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12661 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12662 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12663 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12665 /* See ada-lang.h. */
12668 is_ada_exception_catchpoint (breakpoint
*bp
)
12670 return (bp
->ops
== &catch_exception_breakpoint_ops
12671 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12672 || bp
->ops
== &catch_assert_breakpoint_ops
12673 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12676 /* Split the arguments specified in a "catch exception" command.
12677 Set EX to the appropriate catchpoint type.
12678 Set EXCEP_STRING to the name of the specific exception if
12679 specified by the user.
12680 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12681 "catch handlers" command. False otherwise.
12682 If a condition is found at the end of the arguments, the condition
12683 expression is stored in COND_STRING (memory must be deallocated
12684 after use). Otherwise COND_STRING is set to NULL. */
12687 catch_ada_exception_command_split (const char *args
,
12688 bool is_catch_handlers_cmd
,
12689 enum ada_exception_catchpoint_kind
*ex
,
12690 std::string
*excep_string
,
12691 std::string
*cond_string
)
12693 std::string exception_name
;
12695 exception_name
= extract_arg (&args
);
12696 if (exception_name
== "if")
12698 /* This is not an exception name; this is the start of a condition
12699 expression for a catchpoint on all exceptions. So, "un-get"
12700 this token, and set exception_name to NULL. */
12701 exception_name
.clear ();
12705 /* Check to see if we have a condition. */
12707 args
= skip_spaces (args
);
12708 if (startswith (args
, "if")
12709 && (isspace (args
[2]) || args
[2] == '\0'))
12712 args
= skip_spaces (args
);
12714 if (args
[0] == '\0')
12715 error (_("Condition missing after `if' keyword"));
12716 *cond_string
= args
;
12718 args
+= strlen (args
);
12721 /* Check that we do not have any more arguments. Anything else
12724 if (args
[0] != '\0')
12725 error (_("Junk at end of expression"));
12727 if (is_catch_handlers_cmd
)
12729 /* Catch handling of exceptions. */
12730 *ex
= ada_catch_handlers
;
12731 *excep_string
= exception_name
;
12733 else if (exception_name
.empty ())
12735 /* Catch all exceptions. */
12736 *ex
= ada_catch_exception
;
12737 excep_string
->clear ();
12739 else if (exception_name
== "unhandled")
12741 /* Catch unhandled exceptions. */
12742 *ex
= ada_catch_exception_unhandled
;
12743 excep_string
->clear ();
12747 /* Catch a specific exception. */
12748 *ex
= ada_catch_exception
;
12749 *excep_string
= exception_name
;
12753 /* Return the name of the symbol on which we should break in order to
12754 implement a catchpoint of the EX kind. */
12756 static const char *
12757 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12759 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12761 gdb_assert (data
->exception_info
!= NULL
);
12765 case ada_catch_exception
:
12766 return (data
->exception_info
->catch_exception_sym
);
12768 case ada_catch_exception_unhandled
:
12769 return (data
->exception_info
->catch_exception_unhandled_sym
);
12771 case ada_catch_assert
:
12772 return (data
->exception_info
->catch_assert_sym
);
12774 case ada_catch_handlers
:
12775 return (data
->exception_info
->catch_handlers_sym
);
12778 internal_error (__FILE__
, __LINE__
,
12779 _("unexpected catchpoint kind (%d)"), ex
);
12783 /* Return the breakpoint ops "virtual table" used for catchpoints
12786 static const struct breakpoint_ops
*
12787 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12791 case ada_catch_exception
:
12792 return (&catch_exception_breakpoint_ops
);
12794 case ada_catch_exception_unhandled
:
12795 return (&catch_exception_unhandled_breakpoint_ops
);
12797 case ada_catch_assert
:
12798 return (&catch_assert_breakpoint_ops
);
12800 case ada_catch_handlers
:
12801 return (&catch_handlers_breakpoint_ops
);
12804 internal_error (__FILE__
, __LINE__
,
12805 _("unexpected catchpoint kind (%d)"), ex
);
12809 /* Return the condition that will be used to match the current exception
12810 being raised with the exception that the user wants to catch. This
12811 assumes that this condition is used when the inferior just triggered
12812 an exception catchpoint.
12813 EX: the type of catchpoints used for catching Ada exceptions. */
12816 ada_exception_catchpoint_cond_string (const char *excep_string
,
12817 enum ada_exception_catchpoint_kind ex
)
12820 bool is_standard_exc
= false;
12821 std::string result
;
12823 if (ex
== ada_catch_handlers
)
12825 /* For exception handlers catchpoints, the condition string does
12826 not use the same parameter as for the other exceptions. */
12827 result
= ("long_integer (GNAT_GCC_exception_Access"
12828 "(gcc_exception).all.occurrence.id)");
12831 result
= "long_integer (e)";
12833 /* The standard exceptions are a special case. They are defined in
12834 runtime units that have been compiled without debugging info; if
12835 EXCEP_STRING is the not-fully-qualified name of a standard
12836 exception (e.g. "constraint_error") then, during the evaluation
12837 of the condition expression, the symbol lookup on this name would
12838 *not* return this standard exception. The catchpoint condition
12839 may then be set only on user-defined exceptions which have the
12840 same not-fully-qualified name (e.g. my_package.constraint_error).
12842 To avoid this unexcepted behavior, these standard exceptions are
12843 systematically prefixed by "standard". This means that "catch
12844 exception constraint_error" is rewritten into "catch exception
12845 standard.constraint_error".
12847 If an exception named constraint_error is defined in another package of
12848 the inferior program, then the only way to specify this exception as a
12849 breakpoint condition is to use its fully-qualified named:
12850 e.g. my_package.constraint_error. */
12852 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12854 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12856 is_standard_exc
= true;
12863 if (is_standard_exc
)
12864 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12866 string_appendf (result
, "long_integer (&%s)", excep_string
);
12871 /* Return the symtab_and_line that should be used to insert an exception
12872 catchpoint of the TYPE kind.
12874 ADDR_STRING returns the name of the function where the real
12875 breakpoint that implements the catchpoints is set, depending on the
12876 type of catchpoint we need to create. */
12878 static struct symtab_and_line
12879 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12880 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12882 const char *sym_name
;
12883 struct symbol
*sym
;
12885 /* First, find out which exception support info to use. */
12886 ada_exception_support_info_sniffer ();
12888 /* Then lookup the function on which we will break in order to catch
12889 the Ada exceptions requested by the user. */
12890 sym_name
= ada_exception_sym_name (ex
);
12891 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12894 error (_("Catchpoint symbol not found: %s"), sym_name
);
12896 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12897 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12899 /* Set ADDR_STRING. */
12900 *addr_string
= sym_name
;
12903 *ops
= ada_exception_breakpoint_ops (ex
);
12905 return find_function_start_sal (sym
, 1);
12908 /* Create an Ada exception catchpoint.
12910 EX_KIND is the kind of exception catchpoint to be created.
12912 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12913 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12914 of the exception to which this catchpoint applies.
12916 COND_STRING, if not empty, is the catchpoint condition.
12918 TEMPFLAG, if nonzero, means that the underlying breakpoint
12919 should be temporary.
12921 FROM_TTY is the usual argument passed to all commands implementations. */
12924 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12925 enum ada_exception_catchpoint_kind ex_kind
,
12926 const std::string
&excep_string
,
12927 const std::string
&cond_string
,
12932 std::string addr_string
;
12933 const struct breakpoint_ops
*ops
= NULL
;
12934 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12936 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12937 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12938 ops
, tempflag
, disabled
, from_tty
);
12939 c
->excep_string
= excep_string
;
12940 create_excep_cond_exprs (c
.get (), ex_kind
);
12941 if (!cond_string
.empty ())
12942 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
12943 install_breakpoint (0, std::move (c
), 1);
12946 /* Implement the "catch exception" command. */
12949 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12950 struct cmd_list_element
*command
)
12952 const char *arg
= arg_entry
;
12953 struct gdbarch
*gdbarch
= get_current_arch ();
12955 enum ada_exception_catchpoint_kind ex_kind
;
12956 std::string excep_string
;
12957 std::string cond_string
;
12959 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12963 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12965 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12966 excep_string
, cond_string
,
12967 tempflag
, 1 /* enabled */,
12971 /* Implement the "catch handlers" command. */
12974 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12975 struct cmd_list_element
*command
)
12977 const char *arg
= arg_entry
;
12978 struct gdbarch
*gdbarch
= get_current_arch ();
12980 enum ada_exception_catchpoint_kind ex_kind
;
12981 std::string excep_string
;
12982 std::string cond_string
;
12984 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12988 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12990 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12991 excep_string
, cond_string
,
12992 tempflag
, 1 /* enabled */,
12996 /* Completion function for the Ada "catch" commands. */
12999 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
13000 const char *text
, const char *word
)
13002 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
13004 for (const ada_exc_info
&info
: exceptions
)
13006 if (startswith (info
.name
, word
))
13007 tracker
.add_completion (make_unique_xstrdup (info
.name
));
13011 /* Split the arguments specified in a "catch assert" command.
13013 ARGS contains the command's arguments (or the empty string if
13014 no arguments were passed).
13016 If ARGS contains a condition, set COND_STRING to that condition
13017 (the memory needs to be deallocated after use). */
13020 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
13022 args
= skip_spaces (args
);
13024 /* Check whether a condition was provided. */
13025 if (startswith (args
, "if")
13026 && (isspace (args
[2]) || args
[2] == '\0'))
13029 args
= skip_spaces (args
);
13030 if (args
[0] == '\0')
13031 error (_("condition missing after `if' keyword"));
13032 cond_string
.assign (args
);
13035 /* Otherwise, there should be no other argument at the end of
13037 else if (args
[0] != '\0')
13038 error (_("Junk at end of arguments."));
13041 /* Implement the "catch assert" command. */
13044 catch_assert_command (const char *arg_entry
, int from_tty
,
13045 struct cmd_list_element
*command
)
13047 const char *arg
= arg_entry
;
13048 struct gdbarch
*gdbarch
= get_current_arch ();
13050 std::string cond_string
;
13052 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13056 catch_ada_assert_command_split (arg
, cond_string
);
13057 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
13059 tempflag
, 1 /* enabled */,
13063 /* Return non-zero if the symbol SYM is an Ada exception object. */
13066 ada_is_exception_sym (struct symbol
*sym
)
13068 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
13070 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
13071 && SYMBOL_CLASS (sym
) != LOC_BLOCK
13072 && SYMBOL_CLASS (sym
) != LOC_CONST
13073 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
13074 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
13077 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13078 Ada exception object. This matches all exceptions except the ones
13079 defined by the Ada language. */
13082 ada_is_non_standard_exception_sym (struct symbol
*sym
)
13086 if (!ada_is_exception_sym (sym
))
13089 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13090 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
13091 return 0; /* A standard exception. */
13093 /* Numeric_Error is also a standard exception, so exclude it.
13094 See the STANDARD_EXC description for more details as to why
13095 this exception is not listed in that array. */
13096 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
13102 /* A helper function for std::sort, comparing two struct ada_exc_info
13105 The comparison is determined first by exception name, and then
13106 by exception address. */
13109 ada_exc_info::operator< (const ada_exc_info
&other
) const
13113 result
= strcmp (name
, other
.name
);
13116 if (result
== 0 && addr
< other
.addr
)
13122 ada_exc_info::operator== (const ada_exc_info
&other
) const
13124 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
13127 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13128 routine, but keeping the first SKIP elements untouched.
13130 All duplicates are also removed. */
13133 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
13136 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
13137 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
13138 exceptions
->end ());
13141 /* Add all exceptions defined by the Ada standard whose name match
13142 a regular expression.
13144 If PREG is not NULL, then this regexp_t object is used to
13145 perform the symbol name matching. Otherwise, no name-based
13146 filtering is performed.
13148 EXCEPTIONS is a vector of exceptions to which matching exceptions
13152 ada_add_standard_exceptions (compiled_regex
*preg
,
13153 std::vector
<ada_exc_info
> *exceptions
)
13157 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13160 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
13162 struct bound_minimal_symbol msymbol
13163 = ada_lookup_simple_minsym (standard_exc
[i
]);
13165 if (msymbol
.minsym
!= NULL
)
13167 struct ada_exc_info info
13168 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13170 exceptions
->push_back (info
);
13176 /* Add all Ada exceptions defined locally and accessible from the given
13179 If PREG is not NULL, then this regexp_t object is used to
13180 perform the symbol name matching. Otherwise, no name-based
13181 filtering is performed.
13183 EXCEPTIONS is a vector of exceptions to which matching exceptions
13187 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13188 struct frame_info
*frame
,
13189 std::vector
<ada_exc_info
> *exceptions
)
13191 const struct block
*block
= get_frame_block (frame
, 0);
13195 struct block_iterator iter
;
13196 struct symbol
*sym
;
13198 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13200 switch (SYMBOL_CLASS (sym
))
13207 if (ada_is_exception_sym (sym
))
13209 struct ada_exc_info info
= {sym
->print_name (),
13210 SYMBOL_VALUE_ADDRESS (sym
)};
13212 exceptions
->push_back (info
);
13216 if (BLOCK_FUNCTION (block
) != NULL
)
13218 block
= BLOCK_SUPERBLOCK (block
);
13222 /* Return true if NAME matches PREG or if PREG is NULL. */
13225 name_matches_regex (const char *name
, compiled_regex
*preg
)
13227 return (preg
== NULL
13228 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13231 /* Add all exceptions defined globally whose name name match
13232 a regular expression, excluding standard exceptions.
13234 The reason we exclude standard exceptions is that they need
13235 to be handled separately: Standard exceptions are defined inside
13236 a runtime unit which is normally not compiled with debugging info,
13237 and thus usually do not show up in our symbol search. However,
13238 if the unit was in fact built with debugging info, we need to
13239 exclude them because they would duplicate the entry we found
13240 during the special loop that specifically searches for those
13241 standard exceptions.
13243 If PREG is not NULL, then this regexp_t object is used to
13244 perform the symbol name matching. Otherwise, no name-based
13245 filtering is performed.
13247 EXCEPTIONS is a vector of exceptions to which matching exceptions
13251 ada_add_global_exceptions (compiled_regex
*preg
,
13252 std::vector
<ada_exc_info
> *exceptions
)
13254 /* In Ada, the symbol "search name" is a linkage name, whereas the
13255 regular expression used to do the matching refers to the natural
13256 name. So match against the decoded name. */
13257 expand_symtabs_matching (NULL
,
13258 lookup_name_info::match_any (),
13259 [&] (const char *search_name
)
13261 std::string decoded
= ada_decode (search_name
);
13262 return name_matches_regex (decoded
.c_str (), preg
);
13267 for (objfile
*objfile
: current_program_space
->objfiles ())
13269 for (compunit_symtab
*s
: objfile
->compunits ())
13271 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13274 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13276 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13277 struct block_iterator iter
;
13278 struct symbol
*sym
;
13280 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13281 if (ada_is_non_standard_exception_sym (sym
)
13282 && name_matches_regex (sym
->natural_name (), preg
))
13284 struct ada_exc_info info
13285 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13287 exceptions
->push_back (info
);
13294 /* Implements ada_exceptions_list with the regular expression passed
13295 as a regex_t, rather than a string.
13297 If not NULL, PREG is used to filter out exceptions whose names
13298 do not match. Otherwise, all exceptions are listed. */
13300 static std::vector
<ada_exc_info
>
13301 ada_exceptions_list_1 (compiled_regex
*preg
)
13303 std::vector
<ada_exc_info
> result
;
13306 /* First, list the known standard exceptions. These exceptions
13307 need to be handled separately, as they are usually defined in
13308 runtime units that have been compiled without debugging info. */
13310 ada_add_standard_exceptions (preg
, &result
);
13312 /* Next, find all exceptions whose scope is local and accessible
13313 from the currently selected frame. */
13315 if (has_stack_frames ())
13317 prev_len
= result
.size ();
13318 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13320 if (result
.size () > prev_len
)
13321 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13324 /* Add all exceptions whose scope is global. */
13326 prev_len
= result
.size ();
13327 ada_add_global_exceptions (preg
, &result
);
13328 if (result
.size () > prev_len
)
13329 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13334 /* Return a vector of ada_exc_info.
13336 If REGEXP is NULL, all exceptions are included in the result.
13337 Otherwise, it should contain a valid regular expression,
13338 and only the exceptions whose names match that regular expression
13339 are included in the result.
13341 The exceptions are sorted in the following order:
13342 - Standard exceptions (defined by the Ada language), in
13343 alphabetical order;
13344 - Exceptions only visible from the current frame, in
13345 alphabetical order;
13346 - Exceptions whose scope is global, in alphabetical order. */
13348 std::vector
<ada_exc_info
>
13349 ada_exceptions_list (const char *regexp
)
13351 if (regexp
== NULL
)
13352 return ada_exceptions_list_1 (NULL
);
13354 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13355 return ada_exceptions_list_1 (®
);
13358 /* Implement the "info exceptions" command. */
13361 info_exceptions_command (const char *regexp
, int from_tty
)
13363 struct gdbarch
*gdbarch
= get_current_arch ();
13365 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13367 if (regexp
!= NULL
)
13369 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13371 printf_filtered (_("All defined Ada exceptions:\n"));
13373 for (const ada_exc_info
&info
: exceptions
)
13374 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13378 /* Information about operators given special treatment in functions
13380 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13382 #define ADA_OPERATORS \
13383 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13384 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13385 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13386 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13387 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13388 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13389 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13390 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13391 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13392 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13393 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13394 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13395 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13396 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13397 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13398 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13399 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13400 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13401 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13404 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13407 switch (exp
->elts
[pc
- 1].opcode
)
13410 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13413 #define OP_DEFN(op, len, args, binop) \
13414 case op: *oplenp = len; *argsp = args; break;
13420 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13425 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13430 /* Implementation of the exp_descriptor method operator_check. */
13433 ada_operator_check (struct expression
*exp
, int pos
,
13434 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13437 const union exp_element
*const elts
= exp
->elts
;
13438 struct type
*type
= NULL
;
13440 switch (elts
[pos
].opcode
)
13442 case UNOP_IN_RANGE
:
13444 type
= elts
[pos
+ 1].type
;
13448 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13451 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13453 if (type
&& TYPE_OBJFILE (type
)
13454 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13460 static const char *
13461 ada_op_name (enum exp_opcode opcode
)
13466 return op_name_standard (opcode
);
13468 #define OP_DEFN(op, len, args, binop) case op: return #op;
13473 return "OP_AGGREGATE";
13475 return "OP_CHOICES";
13481 /* As for operator_length, but assumes PC is pointing at the first
13482 element of the operator, and gives meaningful results only for the
13483 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13486 ada_forward_operator_length (struct expression
*exp
, int pc
,
13487 int *oplenp
, int *argsp
)
13489 switch (exp
->elts
[pc
].opcode
)
13492 *oplenp
= *argsp
= 0;
13495 #define OP_DEFN(op, len, args, binop) \
13496 case op: *oplenp = len; *argsp = args; break;
13502 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13507 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13513 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13515 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13523 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13525 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13530 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13534 /* Ada attributes ('Foo). */
13537 case OP_ATR_LENGTH
:
13541 case OP_ATR_MODULUS
:
13548 case UNOP_IN_RANGE
:
13550 /* XXX: gdb_sprint_host_address, type_sprint */
13551 fprintf_filtered (stream
, _("Type @"));
13552 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13553 fprintf_filtered (stream
, " (");
13554 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13555 fprintf_filtered (stream
, ")");
13557 case BINOP_IN_BOUNDS
:
13558 fprintf_filtered (stream
, " (%d)",
13559 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13561 case TERNOP_IN_RANGE
:
13566 case OP_DISCRETE_RANGE
:
13567 case OP_POSITIONAL
:
13574 char *name
= &exp
->elts
[elt
+ 2].string
;
13575 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13577 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13582 return dump_subexp_body_standard (exp
, stream
, elt
);
13586 for (i
= 0; i
< nargs
; i
+= 1)
13587 elt
= dump_subexp (exp
, stream
, elt
);
13592 /* The Ada extension of print_subexp (q.v.). */
13595 ada_print_subexp (struct expression
*exp
, int *pos
,
13596 struct ui_file
*stream
, enum precedence prec
)
13598 int oplen
, nargs
, i
;
13600 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13602 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13609 print_subexp_standard (exp
, pos
, stream
, prec
);
13613 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13616 case BINOP_IN_BOUNDS
:
13617 /* XXX: sprint_subexp */
13618 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13619 fputs_filtered (" in ", stream
);
13620 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13621 fputs_filtered ("'range", stream
);
13622 if (exp
->elts
[pc
+ 1].longconst
> 1)
13623 fprintf_filtered (stream
, "(%ld)",
13624 (long) exp
->elts
[pc
+ 1].longconst
);
13627 case TERNOP_IN_RANGE
:
13628 if (prec
>= PREC_EQUAL
)
13629 fputs_filtered ("(", stream
);
13630 /* XXX: sprint_subexp */
13631 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13632 fputs_filtered (" in ", stream
);
13633 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13634 fputs_filtered (" .. ", stream
);
13635 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13636 if (prec
>= PREC_EQUAL
)
13637 fputs_filtered (")", stream
);
13642 case OP_ATR_LENGTH
:
13646 case OP_ATR_MODULUS
:
13651 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13653 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13654 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13655 &type_print_raw_options
);
13659 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13660 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13665 for (tem
= 1; tem
< nargs
; tem
+= 1)
13667 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13668 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13670 fputs_filtered (")", stream
);
13675 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13676 fputs_filtered ("'(", stream
);
13677 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13678 fputs_filtered (")", stream
);
13681 case UNOP_IN_RANGE
:
13682 /* XXX: sprint_subexp */
13683 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13684 fputs_filtered (" in ", stream
);
13685 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13686 &type_print_raw_options
);
13689 case OP_DISCRETE_RANGE
:
13690 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13691 fputs_filtered ("..", stream
);
13692 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13696 fputs_filtered ("others => ", stream
);
13697 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13701 for (i
= 0; i
< nargs
-1; i
+= 1)
13704 fputs_filtered ("|", stream
);
13705 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13707 fputs_filtered (" => ", stream
);
13708 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13711 case OP_POSITIONAL
:
13712 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13716 fputs_filtered ("(", stream
);
13717 for (i
= 0; i
< nargs
; i
+= 1)
13720 fputs_filtered (", ", stream
);
13721 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13723 fputs_filtered (")", stream
);
13728 /* Table mapping opcodes into strings for printing operators
13729 and precedences of the operators. */
13731 static const struct op_print ada_op_print_tab
[] = {
13732 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13733 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13734 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13735 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13736 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13737 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13738 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13739 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13740 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13741 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13742 {">", BINOP_GTR
, PREC_ORDER
, 0},
13743 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13744 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13745 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13746 {"+", BINOP_ADD
, PREC_ADD
, 0},
13747 {"-", BINOP_SUB
, PREC_ADD
, 0},
13748 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13749 {"*", BINOP_MUL
, PREC_MUL
, 0},
13750 {"/", BINOP_DIV
, PREC_MUL
, 0},
13751 {"rem", BINOP_REM
, PREC_MUL
, 0},
13752 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13753 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13754 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13755 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13756 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13757 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13758 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13759 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13760 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13761 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13762 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13763 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13766 enum ada_primitive_types
{
13767 ada_primitive_type_int
,
13768 ada_primitive_type_long
,
13769 ada_primitive_type_short
,
13770 ada_primitive_type_char
,
13771 ada_primitive_type_float
,
13772 ada_primitive_type_double
,
13773 ada_primitive_type_void
,
13774 ada_primitive_type_long_long
,
13775 ada_primitive_type_long_double
,
13776 ada_primitive_type_natural
,
13777 ada_primitive_type_positive
,
13778 ada_primitive_type_system_address
,
13779 ada_primitive_type_storage_offset
,
13780 nr_ada_primitive_types
13784 /* Language vector */
13786 /* Not really used, but needed in the ada_language_defn. */
13789 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13791 ada_emit_char (c
, type
, stream
, quoter
, 1);
13795 parse (struct parser_state
*ps
)
13797 warnings_issued
= 0;
13798 return ada_parse (ps
);
13801 static const struct exp_descriptor ada_exp_descriptor
= {
13803 ada_operator_length
,
13804 ada_operator_check
,
13806 ada_dump_subexp_body
,
13807 ada_evaluate_subexp
13810 /* symbol_name_matcher_ftype adapter for wild_match. */
13813 do_wild_match (const char *symbol_search_name
,
13814 const lookup_name_info
&lookup_name
,
13815 completion_match_result
*comp_match_res
)
13817 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13820 /* symbol_name_matcher_ftype adapter for full_match. */
13823 do_full_match (const char *symbol_search_name
,
13824 const lookup_name_info
&lookup_name
,
13825 completion_match_result
*comp_match_res
)
13827 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13830 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13833 do_exact_match (const char *symbol_search_name
,
13834 const lookup_name_info
&lookup_name
,
13835 completion_match_result
*comp_match_res
)
13837 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13840 /* Build the Ada lookup name for LOOKUP_NAME. */
13842 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13844 gdb::string_view user_name
= lookup_name
.name ();
13846 if (user_name
[0] == '<')
13848 if (user_name
.back () == '>')
13850 = user_name
.substr (1, user_name
.size () - 2).to_string ();
13853 = user_name
.substr (1, user_name
.size () - 1).to_string ();
13854 m_encoded_p
= true;
13855 m_verbatim_p
= true;
13856 m_wild_match_p
= false;
13857 m_standard_p
= false;
13861 m_verbatim_p
= false;
13863 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13867 const char *folded
= ada_fold_name (user_name
);
13868 const char *encoded
= ada_encode_1 (folded
, false);
13869 if (encoded
!= NULL
)
13870 m_encoded_name
= encoded
;
13872 m_encoded_name
= user_name
.to_string ();
13875 m_encoded_name
= user_name
.to_string ();
13877 /* Handle the 'package Standard' special case. See description
13878 of m_standard_p. */
13879 if (startswith (m_encoded_name
.c_str (), "standard__"))
13881 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13882 m_standard_p
= true;
13885 m_standard_p
= false;
13887 /* If the name contains a ".", then the user is entering a fully
13888 qualified entity name, and the match must not be done in wild
13889 mode. Similarly, if the user wants to complete what looks
13890 like an encoded name, the match must not be done in wild
13891 mode. Also, in the standard__ special case always do
13892 non-wild matching. */
13894 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13897 && user_name
.find ('.') == std::string::npos
);
13901 /* symbol_name_matcher_ftype method for Ada. This only handles
13902 completion mode. */
13905 ada_symbol_name_matches (const char *symbol_search_name
,
13906 const lookup_name_info
&lookup_name
,
13907 completion_match_result
*comp_match_res
)
13909 return lookup_name
.ada ().matches (symbol_search_name
,
13910 lookup_name
.match_type (),
13914 /* A name matcher that matches the symbol name exactly, with
13918 literal_symbol_name_matcher (const char *symbol_search_name
,
13919 const lookup_name_info
&lookup_name
,
13920 completion_match_result
*comp_match_res
)
13922 gdb::string_view name_view
= lookup_name
.name ();
13924 if (lookup_name
.completion_mode ()
13925 ? (strncmp (symbol_search_name
, name_view
.data (),
13926 name_view
.size ()) == 0)
13927 : symbol_search_name
== name_view
)
13929 if (comp_match_res
!= NULL
)
13930 comp_match_res
->set_match (symbol_search_name
);
13937 /* Implement the "la_get_symbol_name_matcher" language_defn method for
13940 static symbol_name_matcher_ftype
*
13941 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13943 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13944 return literal_symbol_name_matcher
;
13946 if (lookup_name
.completion_mode ())
13947 return ada_symbol_name_matches
;
13950 if (lookup_name
.ada ().wild_match_p ())
13951 return do_wild_match
;
13952 else if (lookup_name
.ada ().verbatim_p ())
13953 return do_exact_match
;
13955 return do_full_match
;
13959 static const char *ada_extensions
[] =
13961 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13964 /* Constant data that describes the Ada language. */
13966 extern const struct language_data ada_language_data
=
13968 "ada", /* Language name */
13972 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13973 that's not quite what this means. */
13975 macro_expansion_no
,
13977 &ada_exp_descriptor
,
13980 ada_printchar
, /* Print a character constant */
13981 ada_printstr
, /* Function to print string constant */
13982 emit_char
, /* Function to print single char (not used) */
13983 ada_print_type
, /* Print a type using appropriate syntax */
13984 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13985 ada_value_print_inner
, /* la_value_print_inner */
13986 ada_value_print
, /* Print a top-level value */
13987 NULL
, /* Language specific skip_trampoline */
13988 NULL
, /* name_of_this */
13989 true, /* la_store_sym_names_in_linkage_form_p */
13990 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13991 ada_la_decode
, /* Language specific symbol demangler */
13992 ada_sniff_from_mangled_name
,
13993 NULL
, /* Language specific
13994 class_name_from_physname */
13995 ada_op_print_tab
, /* expression operators for printing */
13996 0, /* c-style arrays */
13997 1, /* String lower bound */
13998 ada_get_gdb_completer_word_break_characters
,
13999 ada_collect_symbol_completion_matches
,
14000 ada_watch_location_expression
,
14001 ada_get_symbol_name_matcher
, /* la_get_symbol_name_matcher */
14002 ada_iterate_over_symbols
,
14003 default_search_name_hash
,
14007 ada_is_string_type
,
14008 "(...)" /* la_struct_too_deep_ellipsis */
14011 /* Class representing the Ada language. */
14013 class ada_language
: public language_defn
14017 : language_defn (language_ada
, ada_language_data
)
14020 /* Print an array element index using the Ada syntax. */
14022 void print_array_index (struct type
*index_type
,
14024 struct ui_file
*stream
,
14025 const value_print_options
*options
) const override
14027 struct value
*index_value
= val_atr (index_type
, index
);
14029 LA_VALUE_PRINT (index_value
, stream
, options
);
14030 fprintf_filtered (stream
, " => ");
14033 /* Implement the "read_var_value" language_defn method for Ada. */
14035 struct value
*read_var_value (struct symbol
*var
,
14036 const struct block
*var_block
,
14037 struct frame_info
*frame
) const override
14039 /* The only case where default_read_var_value is not sufficient
14040 is when VAR is a renaming... */
14041 if (frame
!= nullptr)
14043 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
14044 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
14045 return ada_read_renaming_var_value (var
, frame_block
);
14048 /* This is a typical case where we expect the default_read_var_value
14049 function to work. */
14050 return language_defn::read_var_value (var
, var_block
, frame
);
14053 /* See language.h. */
14054 void language_arch_info (struct gdbarch
*gdbarch
,
14055 struct language_arch_info
*lai
) const override
14057 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
14059 lai
->primitive_type_vector
14060 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
14063 lai
->primitive_type_vector
[ada_primitive_type_int
]
14064 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14066 lai
->primitive_type_vector
[ada_primitive_type_long
]
14067 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
14068 0, "long_integer");
14069 lai
->primitive_type_vector
[ada_primitive_type_short
]
14070 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
14071 0, "short_integer");
14072 lai
->string_char_type
14073 = lai
->primitive_type_vector
[ada_primitive_type_char
]
14074 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
14075 lai
->primitive_type_vector
[ada_primitive_type_float
]
14076 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
14077 "float", gdbarch_float_format (gdbarch
));
14078 lai
->primitive_type_vector
[ada_primitive_type_double
]
14079 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
14080 "long_float", gdbarch_double_format (gdbarch
));
14081 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
14082 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
14083 0, "long_long_integer");
14084 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
14085 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
14086 "long_long_float", gdbarch_long_double_format (gdbarch
));
14087 lai
->primitive_type_vector
[ada_primitive_type_natural
]
14088 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14090 lai
->primitive_type_vector
[ada_primitive_type_positive
]
14091 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14093 lai
->primitive_type_vector
[ada_primitive_type_void
]
14094 = builtin
->builtin_void
;
14096 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14097 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
14099 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14100 ->set_name ("system__address");
14102 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14103 type. This is a signed integral type whose size is the same as
14104 the size of addresses. */
14106 unsigned int addr_length
= TYPE_LENGTH
14107 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
14109 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
14110 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
14114 lai
->bool_type_symbol
= NULL
;
14115 lai
->bool_type_default
= builtin
->builtin_bool
;
14119 /* Single instance of the Ada language class. */
14121 static ada_language ada_language_defn
;
14123 /* Command-list for the "set/show ada" prefix command. */
14124 static struct cmd_list_element
*set_ada_list
;
14125 static struct cmd_list_element
*show_ada_list
;
14128 initialize_ada_catchpoint_ops (void)
14130 struct breakpoint_ops
*ops
;
14132 initialize_breakpoint_ops ();
14134 ops
= &catch_exception_breakpoint_ops
;
14135 *ops
= bkpt_breakpoint_ops
;
14136 ops
->allocate_location
= allocate_location_exception
;
14137 ops
->re_set
= re_set_exception
;
14138 ops
->check_status
= check_status_exception
;
14139 ops
->print_it
= print_it_exception
;
14140 ops
->print_one
= print_one_exception
;
14141 ops
->print_mention
= print_mention_exception
;
14142 ops
->print_recreate
= print_recreate_exception
;
14144 ops
= &catch_exception_unhandled_breakpoint_ops
;
14145 *ops
= bkpt_breakpoint_ops
;
14146 ops
->allocate_location
= allocate_location_exception
;
14147 ops
->re_set
= re_set_exception
;
14148 ops
->check_status
= check_status_exception
;
14149 ops
->print_it
= print_it_exception
;
14150 ops
->print_one
= print_one_exception
;
14151 ops
->print_mention
= print_mention_exception
;
14152 ops
->print_recreate
= print_recreate_exception
;
14154 ops
= &catch_assert_breakpoint_ops
;
14155 *ops
= bkpt_breakpoint_ops
;
14156 ops
->allocate_location
= allocate_location_exception
;
14157 ops
->re_set
= re_set_exception
;
14158 ops
->check_status
= check_status_exception
;
14159 ops
->print_it
= print_it_exception
;
14160 ops
->print_one
= print_one_exception
;
14161 ops
->print_mention
= print_mention_exception
;
14162 ops
->print_recreate
= print_recreate_exception
;
14164 ops
= &catch_handlers_breakpoint_ops
;
14165 *ops
= bkpt_breakpoint_ops
;
14166 ops
->allocate_location
= allocate_location_exception
;
14167 ops
->re_set
= re_set_exception
;
14168 ops
->check_status
= check_status_exception
;
14169 ops
->print_it
= print_it_exception
;
14170 ops
->print_one
= print_one_exception
;
14171 ops
->print_mention
= print_mention_exception
;
14172 ops
->print_recreate
= print_recreate_exception
;
14175 /* This module's 'new_objfile' observer. */
14178 ada_new_objfile_observer (struct objfile
*objfile
)
14180 ada_clear_symbol_cache ();
14183 /* This module's 'free_objfile' observer. */
14186 ada_free_objfile_observer (struct objfile
*objfile
)
14188 ada_clear_symbol_cache ();
14191 void _initialize_ada_language ();
14193 _initialize_ada_language ()
14195 initialize_ada_catchpoint_ops ();
14197 add_basic_prefix_cmd ("ada", no_class
,
14198 _("Prefix command for changing Ada-specific settings."),
14199 &set_ada_list
, "set ada ", 0, &setlist
);
14201 add_show_prefix_cmd ("ada", no_class
,
14202 _("Generic command for showing Ada-specific settings."),
14203 &show_ada_list
, "show ada ", 0, &showlist
);
14205 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14206 &trust_pad_over_xvs
, _("\
14207 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14208 Show whether an optimization trusting PAD types over XVS types is activated."),
14210 This is related to the encoding used by the GNAT compiler. The debugger\n\
14211 should normally trust the contents of PAD types, but certain older versions\n\
14212 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14213 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14214 work around this bug. It is always safe to turn this option \"off\", but\n\
14215 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14216 this option to \"off\" unless necessary."),
14217 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14219 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14220 &print_signatures
, _("\
14221 Enable or disable the output of formal and return types for functions in the \
14222 overloads selection menu."), _("\
14223 Show whether the output of formal and return types for functions in the \
14224 overloads selection menu is activated."),
14225 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14227 add_catch_command ("exception", _("\
14228 Catch Ada exceptions, when raised.\n\
14229 Usage: catch exception [ARG] [if CONDITION]\n\
14230 Without any argument, stop when any Ada exception is raised.\n\
14231 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14232 being raised does not have a handler (and will therefore lead to the task's\n\
14234 Otherwise, the catchpoint only stops when the name of the exception being\n\
14235 raised is the same as ARG.\n\
14236 CONDITION is a boolean expression that is evaluated to see whether the\n\
14237 exception should cause a stop."),
14238 catch_ada_exception_command
,
14239 catch_ada_completer
,
14243 add_catch_command ("handlers", _("\
14244 Catch Ada exceptions, when handled.\n\
14245 Usage: catch handlers [ARG] [if CONDITION]\n\
14246 Without any argument, stop when any Ada exception is handled.\n\
14247 With an argument, catch only exceptions with the given name.\n\
14248 CONDITION is a boolean expression that is evaluated to see whether the\n\
14249 exception should cause a stop."),
14250 catch_ada_handlers_command
,
14251 catch_ada_completer
,
14254 add_catch_command ("assert", _("\
14255 Catch failed Ada assertions, when raised.\n\
14256 Usage: catch assert [if CONDITION]\n\
14257 CONDITION is a boolean expression that is evaluated to see whether the\n\
14258 exception should cause a stop."),
14259 catch_assert_command
,
14264 varsize_limit
= 65536;
14265 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14266 &varsize_limit
, _("\
14267 Set the maximum number of bytes allowed in a variable-size object."), _("\
14268 Show the maximum number of bytes allowed in a variable-size object."), _("\
14269 Attempts to access an object whose size is not a compile-time constant\n\
14270 and exceeds this limit will cause an error."),
14271 NULL
, NULL
, &setlist
, &showlist
);
14273 add_info ("exceptions", info_exceptions_command
,
14275 List all Ada exception names.\n\
14276 Usage: info exceptions [REGEXP]\n\
14277 If a regular expression is passed as an argument, only those matching\n\
14278 the regular expression are listed."));
14280 add_basic_prefix_cmd ("ada", class_maintenance
,
14281 _("Set Ada maintenance-related variables."),
14282 &maint_set_ada_cmdlist
, "maintenance set ada ",
14283 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14285 add_show_prefix_cmd ("ada", class_maintenance
,
14286 _("Show Ada maintenance-related variables."),
14287 &maint_show_ada_cmdlist
, "maintenance show ada ",
14288 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14290 add_setshow_boolean_cmd
14291 ("ignore-descriptive-types", class_maintenance
,
14292 &ada_ignore_descriptive_types_p
,
14293 _("Set whether descriptive types generated by GNAT should be ignored."),
14294 _("Show whether descriptive types generated by GNAT should be ignored."),
14296 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14297 DWARF attribute."),
14298 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14300 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14301 NULL
, xcalloc
, xfree
);
14303 /* The ada-lang observers. */
14304 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14305 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14306 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);